diff --git a/MY_RUN/BENCH/CINES_MNH55X/004_Hector_128x128_MNH-55X/001_pgd1/PRE_PGD1.nam b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_128x128_MNH-55X/001_pgd1/PRE_PGD1.nam
new file mode 100644
index 0000000000000000000000000000000000000000..3ae48e8b0f44fc5ea746497eca9a0a0b2277c131
--- /dev/null
+++ b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_128x128_MNH-55X/001_pgd1/PRE_PGD1.nam
@@ -0,0 +1,13 @@
+&NAM_CONFZ
+ NB_PROCIO_W=1 ,
+ !MPI_BUFFER_SIZE=40
+/
+&NAM_PGDFILE CPGDFILE="PGD00128" /
+&NAM_PGD_SCHEMES CNATURE='ISBA', CSEA='SEAFLX', CTOWN='NONE', CWATER='NONE' /
+&NAM_CONF_PROJ XLAT0=-11.5, XLON0=130.7, XRPK=0., XBETA=0. /
+&NAM_CONF_PROJ_GRID XLATCEN=-11.5, XLONCEN=130.7, NIMAX=128, NJMAX=128,
+ XDX=1600.00000, XDY=1600.00000 /
+&NAM_COVER YCOVER='ECOCLIMAP_v2.0', YCOVERFILETYPE='DIRECT' /
+&NAM_ZS YZS='gtopo30', YZSFILETYPE='DIRECT' /
+&NAM_ISBA YCLAY='CLAY_HWSD_MOY', YCLAYFILETYPE='DIRECT',
+ YSAND='SAND_HWSD_MOY', YSANDFILETYPE='DIRECT' /
diff --git a/MY_RUN/BENCH/CINES_MNH55X/004_Hector_128x128_MNH-55X/001_pgd1/get_pgd_files b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_128x128_MNH-55X/001_pgd1/get_pgd_files
new file mode 100755
index 0000000000000000000000000000000000000000..56726933a0f7608e0c4918f42e80d5aea76b669d
--- /dev/null
+++ b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_128x128_MNH-55X/001_pgd1/get_pgd_files
@@ -0,0 +1,30 @@
+#
+# Modif
+# J.Escobar 11/04/2014 get PGD files from 'dir_open' directory ( without psswd )
+# J.Escobar 25/04/2013 get LICENCE files
+#
+PREP_PGD_FILES=${PREP_PGD_FILES:-"$HOME/PREP_PGD_FILES_WWW"} ; export PREP_PGD_FILES
+echo "!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!"
+echo "!!!! WARNING !!!!"
+echo "!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!"
+echo
+echo you need 3GO to download this files in
+echo
+echo PREP_PGD_FILES=$PREP_PGD_FILES
+echo
+echo if OK press ENTER else CTRL-C
+read RIEN
+set -x
+mkdir -p $PREP_PGD_FILES
+cd $PREP_PGD_FILES
+PGD_URL="http://mesonh.aero.obs-mip.fr/mesonh/dir_open/dir_PGDFILES"
+WGET="wget"
+export PGD_URL
+for file in LICENSE_ECOCLIMAP.txt LICENSE_soil_data.txt \
+ gtopo30.dir gtopo30.hdr \
+ SAND_HWSD_MOY.hdr SAND_HWSD_MOY.dir CLAY_HWSD_MOY.hdr CLAY_HWSD_MOY.dir \
+ ECOCLIMAP_v2.0.hdr ECOCLIMAP_v2.0.dir
+do
+[ -f $file ] || ( ${WGET} -c -nd $PGD_URL/$file.gz ; gunzip $file.gz ; )
+done
+
diff --git a/MY_RUN/BENCH/CINES_MNH55X/004_Hector_128x128_MNH-55X/001_pgd1/run_prep_pgd_xyz b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_128x128_MNH-55X/001_pgd1/run_prep_pgd_xyz
new file mode 100755
index 0000000000000000000000000000000000000000..5c34e67e3f8ec036121d636d3d9c8cc5fadf197e
--- /dev/null
+++ b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_128x128_MNH-55X/001_pgd1/run_prep_pgd_xyz
@@ -0,0 +1,35 @@
+#!/bin/bash
+
+export MPIRUN="Mpirun -np 4"
+
+
+PREP_PGD_FILES=${PREP_PGD_FILES:-"$HOME/PREP_PGD_FILES_WWW"} ; export PREP_PGD_FILES
+#
+if [ ! -d $PREP_PGD_FILES ]
+then
+cat << EOF
+
+Your directory PREP_PGD_FILES=$PREP_PGD_FILES
+
+containing the files gtopo30*, ECOCLIMAP_v2.0*
+doesn't exist ( or was not found !!! )
+use the script 'get_pgd_files' to download
+this files from the MESONH WEB PAGES !!!
+( or change the variable PREP_PGD_FILES ... )
+
+After fixing it , run this script again !!!
+
+EOF
+exit 1
+else
+set -x
+#
+rm -f OUTPUT_LISTING0 pipe_name
+rm -f gtopo30.??? sand_fao.??? clay_fao.???
+rm -f SAND_HWSD_MOY.??? ECOCLIMAP_v2.0.??? ecoclimats_v2.???
+rm -f PGD00128.*
+#
+ln -sf $PREP_PGD_FILES/*.dir $PREP_PGD_FILES/*.hdr .
+#
+time ${MPIRUN} PREP_PGD${XYZ}
+fi
diff --git a/MY_RUN/BENCH/CINES_MNH55X/004_Hector_128x128_MNH-55X/002_prep_ideal_case/PRE_IDEA1.nam b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_128x128_MNH-55X/002_prep_ideal_case/PRE_IDEA1.nam
new file mode 100644
index 0000000000000000000000000000000000000000..3baef58caeae016c444e5f7c447f821726afb861
--- /dev/null
+++ b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_128x128_MNH-55X/002_prep_ideal_case/PRE_IDEA1.nam
@@ -0,0 +1,226 @@
+&NAM_CONFZ
+ !NB_PROCIO_R=1 ,
+ !NB_PROCIO_W=1 ,
+ !MPI_BUFFER_SIZE=40
+/
+
+&NAM_REAL_PGD
+ CPGD_FILE ="PGD00128" ,
+ LREAD_ZS =.TRUE., LREAD_GROUND_PARAM =.TRUE.
+/
+&NAM_DIMn_PRE NIMAX=40, NJMAX=32 /
+&NAM_CONF_PRE LCARTESIAN=.FALSE.
+ CIDEAL='RSOU' CZS='FLAT'
+ NVERB=0 /
+&NAM_CONFn LUSERV= T /
+&NAM_LUNITn CINIFILE = "DA0128" , CINIFILEPGD = "PGD00128" /
+&NAM_DYNn_PRE
+ CPRESOPT= 'ZRESI' ,
+ NITR=4 XRELAX=1. /
+&NAM_LBCn_PRE CLBCX= 2*'OPEN' CLBCY= 2*'OPEN' /
+&NAM_VPROF_PRE CTYPELOC='IJGRID' NILOC=1 NJLOC=1
+ CFUNU='ZZZ' CFUNV='ZZZ'
+ LGEOSBAL=.FALSE. /
+&NAM_VER_GRID NKMAX=126, YZGRID_TYPE='FUNCTN',
+ ZDZGRD=40., ZDZTOP=210., ZZMAX_STRGRD=2500.,
+ ZSTRGRD=7., ZSTRTOP=7. /
+&NAM_GRn_PRE
+ CSURF='EXTE'
+ ! CSURF='NONE'
+ /
+&NAM_PREP_ISBA XTG_SURF= 311., XTG_ROOT= 303., XTG_DEEP= 302.,
+ XHUG_SURF= 0.16, XHUG_ROOT= 0.16, XHUG_DEEP= 0.16 /
+&NAM_PREP_SEAFLUX XSST_UNIF= 304. /
+ RSOU
+ 2005 11 30 0
+ 'PUVTHDMR'
+ 0.0000000E+00
+ 100300.0
+ 303.3000
+ 1.9630000E-02
+ 92
+ 100000.0 3.637668 -3.637668
+ 99900.00 2.572220 -4.455216
+ 99100.00 -4.612377 0.4035313
+ 96600.00 5.124864 -0.4483674
+ 93000.00 5.836996 -2.009839
+ 92800.00 5.801031 -2.111402
+ 92500.00 5.466062 -1.464627
+ 85000.00 0.1345103 -1.537459
+ 81400.00 -0.9020693 -1.849517
+ 71800.00 -2.797467 1.304481
+ 70000.00 -4.472232 1.198331
+ 60500.00 -3.289776 -1.464702
+ 59900.00 -3.208611 -1.634869
+ 56900.00 -2.329535 -2.025034
+ 55600.00 -2.105100 -2.257443
+ 50100.00 -0.5325915 -1.987659
+ 50000.00 -0.2679967 -1.519885
+ 49500.00 0.2507798 -2.042438
+ 46700.00 5.466062 1.464627
+ 45300.00 5.594935 2.608961
+ 44800.00 5.450725 2.898202
+ 43700.00 4.994327 3.628591
+ 42200.00 4.561049 4.891127
+ 41900.00 4.387573 5.047325
+ 41800.00 4.298817 5.123130
+ 40000.00 6.305391 5.290851
+ 39000.00 5.970908 4.027428
+ 38600.00 5.671552 3.543979
+ 38300.00 5.346259 3.086664
+ 35500.00 2.976104 3.546782
+ 32700.00 4.455215 2.572220
+ 31400.00 3.712562 4.270814
+ 30700.00 3.086664 5.346259
+ 30000.00 3.540875 5.056894
+ 28800.00 3.786532 4.205370
+ 26700.00 3.329551 2.419061
+ 25000.00 2.797467 1.304481
+ 24400.00 2.819808 1.255459
+ 23800.00 2.841289 1.206056
+ 21400.00 3.424857 1.112804
+ 20000.00 3.478403 0.9320353
+ 19300.00 3.383935 1.231651
+ 17400.00 3.411947 2.301387
+ 15000.00 2.950729 4.214078
+ 12700.00 2.167201 2.875973
+ 10200.00 1.322713 1.576348
+ 10000.00 0.4466614 2.533142
+ 9120.000 -3.306782 3.940869
+ 8700.000 -7.950636 2.130367
+ 8200.000 -8.712269 0.7622259
+ 8000.000 -9.224754 -0.8070621
+ 7600.000 -4.009694 -2.314998
+ 7300.000 -5.066284 -0.8933228
+ 7000.000 -4.196201 -1.956721
+ 6700.000 -1.013257 0.1786647
+ 6400.000 -2.107039 1.475365
+ 6340.000 -2.558960 1.726041
+ 5480.000 -13.17234 2.322640
+ 5300.000 -15.37459 1.345105
+ 5000.000 -12.81216 -1.120920
+ 4900.000 -12.66571 -2.233307
+ 4860.000 -12.25463 -1.504677
+ 4700.000 -10.76221 0.9415731
+ 4500.000 -11.37801 7.966970
+ 3800.000 -25.11183 2.197004
+ 3600.000 -22.54940 -1.972818
+ 3200.000 -22.72465 -4.417223
+ 3000.000 -22.36116 -5.991656
+ 2490.000 -21.48829 -2.258509
+ 2300.000 -21.07936 -0.7361050
+ 2200.000 -20.57776 -1.7989648E-06
+ 2080.000 -19.00834 -0.9961855
+ 2000.000 -17.93702 -1.569287
+ 1600.000 -14.74927 -10.32755
+ 1500.000 -13.52109 -6.304989
+ 1430.000 -16.89510 -4.527030
+ 1400.000 -18.23862 -3.215962
+ 1300.000 -15.46941 -5.630407
+ 1200.000 -5.594935 2.608962
+ 1190.000 -5.671552 3.543979
+ 1100.000 1.786646 10.13257
+ 1050.000 -3.736842 7.333968
+ 1020.000 -5.435582 4.725079
+ 1000.000 -5.594935 2.608962
+ 950.0000 -4.347303 8.176087
+ 900.0000 2.143975 12.15908
+ 889.9999 1.031246 11.78719
+ 800.0000 -4.728969 4.728969
+ 760.0000 2.890712 7.154763
+ 710.0000 8.644947 -3.318484
+ 700.0000 7.487652 -6.282886
+ 600.0000 -4.214078 -2.950729
+ 91
+ 100000.0 303.1000 1.8050000E-02
+ 99900.00 303.1000 1.8040001E-02
+ 99100.00 303.1000 1.7969999E-02
+ 96600.00 303.1000 1.7729999E-02
+ 93000.00 303.0000 1.7370002E-02
+ 92800.00 303.1000 1.6980000E-02
+ 92500.00 303.2000 1.6400000E-02
+ 85000.00 307.1000 1.1190000E-02
+ 81400.00 309.6000 6.6700005E-03
+ 71800.00 312.3000 6.5600001E-03
+ 70000.00 312.9000 6.5400004E-03
+ 60500.00 316.2000 6.1800000E-03
+ 59900.00 318.1000 5.3400006E-03
+ 56900.00 318.7000 4.9899998E-03
+ 55600.00 322.2000 3.3100001E-03
+ 50100.00 325.5000 2.6000000E-03
+ 50000.00 325.5000 2.5800001E-03
+ 49500.00 325.7000 3.1700002E-03
+ 46700.00 328.6000 1.4500001E-03
+ 45300.00 330.1000 9.4000006E-04
+ 44800.00 330.1000 1.9600000E-03
+ 43700.00 331.0000 2.1500003E-03
+ 42200.00 332.2000 1.9400001E-03
+ 41900.00 332.9000 9.6000003E-04
+ 41800.00 333.0000 9.7000005E-04
+ 40000.00 334.2000 1.1600000E-03
+ 39000.00 334.6000 1.0300000E-03
+ 38600.00 335.6000 6.5000000E-04
+ 38300.00 335.8000 6.0000003E-04
+ 35500.00 338.2000 2.5000001E-04
+ 32700.00 340.8000 9.0000009E-05
+ 31400.00 342.0000 5.0000002E-05
+ 30700.00 342.1000 4.0000003E-05
+ 30000.00 342.3000 4.0000003E-05
+ 28800.00 342.3000 1.2000000E-04
+ 26700.00 344.8000 1.0000001E-05
+ 25000.00 345.4000 1.0000001E-05
+ 24400.00 346.3000 2.0000001E-05
+ 23800.00 346.4000 9.0000009E-05
+ 21400.00 348.1000 1.0000001E-05
+ 20000.00 348.8000 1.0000001E-05
+ 19300.00 348.9000 2.0000001E-05
+ 17400.00 351.5000 1.0000001E-05
+ 15000.00 354.0000 7.1596442E-06
+ 12700.00 355.7000 4.4376361E-06
+ 10200.00 364.6000 1.4789329E-06
+ 10000.00 365.4000 1.2422363E-06
+ 9120.000 371.6000 1.2919259E-06
+ 8700.000 379.9000 1.5496893E-06
+ 8200.000 390.6000 1.8819877E-06
+ 8000.000 395.1000 2.0217396E-06
+ 7600.000 404.7000 2.3198761E-06
+ 7300.000 412.3000 2.4844724E-06
+ 7000.000 420.4000 2.4844724E-06
+ 6700.000 431.1000 2.4844724E-06
+ 6400.000 442.4000 2.4844724E-06
+ 6340.000 444.8000 2.4844724E-06
+ 5480.000 467.8000 2.4844724E-06
+ 5300.000 471.0000 2.4844724E-06
+ 5000.000 476.5000 2.4844724E-06
+ 4900.000 477.6000 2.4844724E-06
+ 4860.000 478.0000 2.4844724E-06
+ 4700.000 485.1000 2.4844724E-06
+ 4500.000 494.6000 2.4844724E-06
+ 3800.000 532.9000 2.4844724E-06
+ 3600.000 545.6000 2.4844724E-06
+ 3200.000 574.4000 2.4844724E-06
+ 3000.000 585.1000 2.4844724E-06
+ 2490.000 624.0000 2.4844724E-06
+ 2300.000 648.9000 2.4844724E-06
+ 2200.000 655.4000 2.4844724E-06
+ 2080.000 663.6000 2.4844724E-06
+ 2000.000 673.5000 2.4844724E-06
+ 1600.000 726.4000 2.4844724E-06
+ 1500.000 742.5000 2.4844724E-06
+ 1430.000 750.7000 2.4844724E-06
+ 1400.000 759.0000 2.4844724E-06
+ 1300.000 788.6000 2.4844724E-06
+ 1200.000 821.7000 2.4844724E-06
+ 1190.000 825.2000 2.4844724E-06
+ 1100.000 833.9000 2.4844724E-06
+ 1050.000 839.0000 2.4844724E-06
+ 1020.000 845.3000 2.4844724E-06
+ 1000.000 851.6000 2.4844724E-06
+ 950.0000 877.0000 2.4844724E-06
+ 900.0000 885.6000 2.4844724E-06
+ 889.9999 887.3000 2.4844724E-06
+ 800.0000 926.6000 2.4844724E-06
+ 760.0000 946.0000 2.4844724E-06
+ 710.0000 958.0000 2.4844724E-06
+ 700.0000 963.1000 2.4844724E-06
+ 600.0000 20.30000 2.4844724E-06
diff --git a/MY_RUN/BENCH/CINES_MNH55X/004_Hector_128x128_MNH-55X/002_prep_ideal_case/run_prep_ideal_xyz b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_128x128_MNH-55X/002_prep_ideal_case/run_prep_ideal_xyz
new file mode 100755
index 0000000000000000000000000000000000000000..cc04c8357ad94625ece1e7492b5d68fdb8caad26
--- /dev/null
+++ b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_128x128_MNH-55X/002_prep_ideal_case/run_prep_ideal_xyz
@@ -0,0 +1,20 @@
+#!/bin/bash
+
+NP=${NP:-16}
+NPS=${NPS:-4}
+
+export ACC_DEVICE_TYPE=HOST
+export MPIRUN="Mpirun -tag-output -report-bindings --mca mpi_cuda_support 0 -map-by ppr:${NPS}:socket -bind-to none -np ${NP} set_core_device_impair"
+
+#
+set -x
+set -e
+#
+rm -f OUTPUT_LISTING1 pipe_name file_for_xtransfer
+rm -f PGD00128.*
+rm -f DA0128.*
+#
+ln -sf ../001_pgd1/PGD00128.* .
+#
+time ${MPIRUN} PREP_IDEAL_CASE${XYZ}
+#
diff --git a/MY_RUN/BENCH/CINES_MNH55X/004_Hector_128x128_MNH-55X/003_mesonh_step1/EXSEG1.nam b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_128x128_MNH-55X/003_mesonh_step1/EXSEG1.nam
new file mode 100644
index 0000000000000000000000000000000000000000..cbfeca7d31195ad0c0dfbc8ba72acc279b1083f4
--- /dev/null
+++ b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_128x128_MNH-55X/003_mesonh_step1/EXSEG1.nam
@@ -0,0 +1,53 @@
+&NAM_CONFZ
+ ! NB_PROCIO_R=1 ,
+ ! NB_PROCIO_W=1 ,
+ ! LMNH_MPI_BSEND = T ,
+ ! MPI_BUFFER_SIZE = 40
+/
+
+&NAM_LUNITn CINIFILE = "DA0128" , CINIFILEPGD = "PGD00128" /
+&NAM_CONFn LUSERV = T, LUSERC = T, LUSERR = T, LUSERI = T,
+ LUSERS = T, LUSERG = T, LUSERH = F, LUSECI = T /
+&NAM_DYNn XTSTEP = 15.00000 ,
+ CPRESOPT = "ZRESI", NITR = 12
+ !CPRESOPT = "ZSOLV", NITR = 12
+ XRELAX = 1., LHORELAX_UVWTH = T, LHORELAX_RV = T, LVE_RELAX = T,
+ NRIMX = 6, NRIMY = 6, XRIMKMAX = 0.0005, XT4DIFU = 4000 /
+&NAM_ADVn CUVW_ADV_SCHEME = "WENO_K", CMET_ADV_SCHEME = "PPM_01",
+ CSV_ADV_SCHEME = "PPM_01" /
+&NAM_PARAMn CTURB = "TKEL" ! "NONE" ! "TKEL",
+ CRAD = "ECMW",
+ CCLOUD = "ICE3" ! "NONE" ! "ICE3",
+ CDCONV = "NONE", CSCONV = "NONE" /
+&NAM_PARAM_RADn XDTRAD = 1800., XDTRAD_CLONLY = 1800., LCLEAR_SKY = F,
+ NRAD_COLNBR = 500 /
+&NAM_PARAM_MFSHALLn XIMPL_MF = 1, CMF_UPDRAFT = "EDKF", CMF_CLOUD = "NONE",
+ LMIXUV = T, LMF_FLX = F /
+&NAM_LBCn CLBCX = 2*"OPEN", CLBCY = 2*"OPEN", XCPHASE = 20. /
+&NAM_TURBn XIMPL = 1., CTURBLEN = "DEAR", CTURBDIM = "3DIM",
+ LTURB_FLX = F, LTURB_DIAG = F, CSUBG_AUCV = "NONE", LSIGMAS = F,
+ LSIG_CONV = F, LSUBG_COND = F /
+&NAM_CH_MNHCn /
+&NAM_CONF CCONF = "START", LFLAT = F, CEQNSYS = "DUR",
+ LLG=F, NMODEL = 1, NVERB = 0, CEXP = "D0128",
+ CSEG = "DAR01", CSPLIT = "BSPLITTING"
+ NHALO=1
+ /
+&NAM_DYN XSEGLEN = 14400.0000 ! 150. ! 14400.0000 , LCORIO = T,
+ LNUMDIFU = F, LNUMDIFTH = F,
+ XALKTOP = 0.001, XALZBOT = 22000. /
+&NAM_BLANK /
+&NAM_NESTING /
+&NAM_BACKUP
+ XBAK_TIME(1,1) = 3600.00000 ! 150. ! 3600.00000
+ XBAK_TIME(1,2) = 7200.00000
+ XBAK_TIME(1,3) = 10800.0000
+ XBAK_TIME(1,4) = 14400.0000
+ XBAK_TIME(1,5) = 18000.0000
+ XBAK_TIME(1,6) = 21600.0000
+ /
+&NAM_ISBAn /
+&NAM_SEAFLUXn /
+&NAM_DIAG_SURFn LSURF_BUDGET=T /
+&NAM_DIAG_ISBAn /
+&NAM_DIAG_SURF_ATMn /
diff --git a/MY_RUN/BENCH/CINES_MNH55X/004_Hector_128x128_MNH-55X/003_mesonh_step1/parameters_mg.nam b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_128x128_MNH-55X/003_mesonh_step1/parameters_mg.nam
new file mode 100644
index 0000000000000000000000000000000000000000..5d76f4dff351b9c8873c37072d3f1f0747877d70
--- /dev/null
+++ b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_128x128_MNH-55X/003_mesonh_step1/parameters_mg.nam
@@ -0,0 +1,118 @@
+! *********************************************************************
+! *********************************************************************
+! ** **
+! ** Parameter file for geometric multigrid code **
+! ** **
+! *********************************************************************
+! *********************************************************************
+!
+! *********************************************************************
+! * General parameters
+! *********************************************************************
+¶meters_general
+ savefields = .F. ! Save fields to disk?
+/
+
+! *********************************************************************
+! * General solver parameters
+! *********************************************************************
+¶meters_solver
+ LUseO = F ,
+ LUseT = T ,
+ solvertype = 1, ! Solver type:
+ ! 1 : Richardson iteration
+ ! 2 : Conjugate gradient
+ resreduction = 1e-1 ! 1.0d-10 ! Required relative residual reduction
+ maxiter = 5 ! 50 ! Maximal number of iterations
+/
+
+! *********************************************************************
+! * Conjugate gradient parameters
+! *********************************************************************
+¶meters_conjugategradient
+ verbose = 10, ! Verbosity level
+ maxiter = 5, ! Maximal number of iterations
+ resreduction = 1.0e-1, ! Target residual reduction
+ n_prec = 1 ! Number of smoother applications in
+ ! preconditioner (N.B.: Using 0 is
+ ! inefficient, as the identity is used
+ ! for preconditioning, instead of using
+ ! unpreconditioned CG.)
+/
+
+! *********************************************************************
+! * Grid parameters
+! *********************************************************************
+¶meters_grid
+ n = 128 , ! 64, ! Number of horizontal grid cells
+ nz = 72, ! Number of vertical grid cells
+ L = 204800.0 ! 16000.0 metre * 256 pt grille ! 1.0, ! Size in horizontal direction
+ H = 19200.0 ! 150.0 metre * 128 niveaux ! 0.01, ! Size in vertical direction
+ vertbc = 2, ! Boundary conditions at top and bottom of the
+ ! atmosphere. 1 = DIRICHLET, 2 = NEUMANN
+ ! Note that Neumann boundary conditions only work
+ ! for coarsening in the horizontal only, as they are
+ ! not yet implemented in the prolongation operator.
+ graded = .F. ! Is the grid graded in the vertical direction?
+/
+
+! *********************************************************************
+! * Parallel communication parameters
+! *********************************************************************
+¶meters_communication
+ halo_size = 1 ! Size of halos (has to be 1 or 2)
+/
+
+! *********************************************************************
+! * Model parameters
+! *********************************************************************
+!
+! parameters of the Helmholtz operator
+!
+! -omega2*(d^2/dy^2 + d^2/dy^2 + lambda2*d^2/dz^2) u + delta u = RHS
+!
+¶meters_model
+ omega2 = 1.0,
+ lambda2 = 1.0 ! 100.0, ! Vertical coupling
+ delta = 0.0d0 ! Size of constant term
+/
+
+! *********************************************************************
+! * Smoother parameters
+! *********************************************************************
+!
+! parameters of the smoother
+!
+¶meters_smoother
+ smoother = 3, ! Smoother method
+ ! 3 = line SOR
+ ! 4 = line SSOR
+ ! 6 = line Jacobi
+ ordering = 2, ! Ordering of grid points (for smoother)
+
+ ! 1 = lexicographic
+ ! 2 = red-black ordering
+ !rho = 0.6666666666666666d0 ! Overrelaxation parameter
+ rho = 0.8d0 ! Overrelaxation parameter
+/
+
+! *********************************************************************
+! * Multigrid parameters
+! *********************************************************************
+¶meters_multigrid
+ verbose = 10, ! Verbosity level
+ n_lev = 8, ! Number of levels
+ lev_split = 3, ! First level where data is pulled together
+ n_presmooth = 1, ! Number of presmoothing steps
+ n_postsmooth = 1, ! Number of postsmoothing steps
+ n_coarsegridsmooth = 1, ! Number of smoothing steps on coarsest level
+ prolongation = 2 ! 2 best after modif !! ! Prologation method
+ ! 1 = constant interpolation
+ ! 2 = (tri-) linear interpolation
+ restriction = 1, ! Restriction method
+ ! 1 = cell average
+ ! 2 = Khalil
+ coarsegridsolver = 1 ! Solver on coarsest grid
+ ! 1 = use smoother
+ ! 2 = Conjugate gradient
+/
diff --git a/MY_RUN/BENCH/CINES_MNH55X/004_Hector_128x128_MNH-55X/003_mesonh_step1/run_mesonh_step1_xyz b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_128x128_MNH-55X/003_mesonh_step1/run_mesonh_step1_xyz
new file mode 100755
index 0000000000000000000000000000000000000000..d676734a931960542ae88ddc28a34cf7a11b509a
--- /dev/null
+++ b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_128x128_MNH-55X/003_mesonh_step1/run_mesonh_step1_xyz
@@ -0,0 +1,23 @@
+
+
+#export PGI_ACC_POOL_ALLOC=0
+export PGI_ACC_SYNCHRONOUS=1
+
+NP=${NP:-16}
+NPS=${NPS:-4}
+
+export MPIRUN=${MPIRUN:-"Mpirun -tag-output -bind-to none -map-by ppr:${NPS}:socket -x PGI_ACC_POOL_ALLOC -x PGI_ACC_SYNCHRONOUS -np ${NP} set_core_device_impair "}
+
+
+#
+set -x
+set -e
+#
+rm -f DA0128.*
+rm -f PGD00128.*
+rm -f D0128.1.DAR01.* OUTPUT_LISTING* pipe_name
+#
+ln -sf ../001_pgd1/PGD00128.{des,nc} .
+ln -sf ../002_prep_ideal_case/DA0128.{des,nc} .
+#
+time ${MPIRUN} MESONH${XYZ}
diff --git a/MY_RUN/BENCH/CINES_MNH55X/004_Hector_128x128_MNH-55X/004_mesonh_step2/EXSEG1.nam b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_128x128_MNH-55X/004_mesonh_step2/EXSEG1.nam
new file mode 100644
index 0000000000000000000000000000000000000000..f2dcd82899ee955178d92a7bf90d484ac6c78920
--- /dev/null
+++ b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_128x128_MNH-55X/004_mesonh_step2/EXSEG1.nam
@@ -0,0 +1,59 @@
+&NAM_CONFIO
+ LIO_ALLOW_NO_BACKUP = T , LIO_NO_WRITE = T
+/
+&NAM_CONFZ
+ ! NB_PROCIO_R=1 ,
+ ! NB_PROCIO_W=1 ,
+ LMNH_MPI_BSEND = F ,
+ ! MPI_BUFFER_SIZE = 40
+ !NZ_PROC=1
+/
+
+&NAM_LUNITn CINIFILE = "D0128.1.DAR01.004" , CINIFILEPGD = "PGD00128" /
+&NAM_CONFn LUSERV = T, LUSERC = T, LUSERR = T, LUSERI = T,
+ LUSERS = T, LUSERG = T, LUSERH = F, LUSECI = T /
+&NAM_DYNn XTSTEP = 15.00000 ,
+ CPRESOPT = "ZRESI",
+ !CPRESOPT = "ZSOLV",
+ NITR = 12,
+ XRELAX = 1., LHORELAX_UVWTH = T, LHORELAX_RV = T, LVE_RELAX = T,
+ NRIMX = 6, NRIMY = 6, XRIMKMAX = 0.0005, XT4DIFU = 4000 /
+&NAM_ADVn CUVW_ADV_SCHEME = "WENO_K", CMET_ADV_SCHEME = "PPM_01",
+ CSV_ADV_SCHEME = "PPM_01" /
+&NAM_PARAMn CTURB = "TKEL", ! "NONE" , ! "TKEL",
+ CRAD = "ECMWF",
+ CCLOUD = "ICE3", ! "NONE" , ! "ICE3",
+ CDCONV = "NONE", CSCONV = "NONE" /
+&NAM_PARAM_RADn XDTRAD = 1800., XDTRAD_CLONLY = 1800., LCLEAR_SKY = F,
+ NRAD_COLNBR = 500 /
+&NAM_PARAM_MFSHALLn XIMPL_MF = 1, CMF_UPDRAFT = "EDKF", CMF_CLOUD = "NONE",
+ LMIXUV = T, LMF_FLX = F /
+&NAM_LBCn CLBCX = 2*"OPEN", CLBCY = 2*"OPEN", XCPHASE = 20. /
+&NAM_TURBn XIMPL = 1., CTURBLEN = "DEAR", CTURBDIM = "3DIM",
+ LTURB_FLX = F, LTURB_DIAG = F, CSUBG_AUCV = "NONE", LSIGMAS = F,
+ LSIG_CONV = F, LSUBG_COND = F /
+&NAM_CH_MNHCn /
+&NAM_CONF CCONF = "RESTA", LFLAT = F, CEQNSYS = "DUR",
+ LLG=F, NMODEL = 1, NVERB = 0, CEXP = "D0128",
+ CSEG = "DAR02", CSPLIT = "BSPLITTING"
+ NHALO=1
+ LCHECK = F /
+&NAM_DYN XSEGLEN = 150.0 ! 150.0000 ,
+ LCORIO = T,
+ LNUMDIFU = F, LNUMDIFTH = F,
+ XALKTOP = 0.001, XALZBOT = 22000. /
+&NAM_BLANK /
+&NAM_NESTING /
+&NAM_BACKUP
+ XBAK_TIME(1,1) = 150.0 ! 3600.00000 ! 75. ! 3600.00000
+ XBAK_TIME(1,2) = 7200.00000
+ XBAK_TIME(1,3) = 10800.0000
+ XBAK_TIME(1,4) = 14400.0000
+ XBAK_TIME(1,5) = 18000.0000
+ XBAK_TIME(1,6) = 21600.0000
+ /
+&NAM_ISBAn /
+&NAM_SEAFLUXn /
+&NAM_DIAG_SURFn LSURF_BUDGET=T /
+&NAM_DIAG_ISBAn /
+&NAM_DIAG_SURF_ATMn /
diff --git a/MY_RUN/BENCH/CINES_MNH55X/004_Hector_128x128_MNH-55X/004_mesonh_step2/MESONH_HOST2005 b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_128x128_MNH-55X/004_mesonh_step2/MESONH_HOST2005
new file mode 100755
index 0000000000000000000000000000000000000000..07ad9fb226bfd7e7cc764749cb644e595ee25b13
--- /dev/null
+++ b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_128x128_MNH-55X/004_mesonh_step2/MESONH_HOST2005
@@ -0,0 +1,5 @@
+#!/bin/bash
+export ACC_DEVICE=HOST
+ACC_DEVICE_TYPE=${ACC_DEVICE}
+exec /home/escj/DEV/MNH-55X-dev-OPENACC-juan-03/src/dir_obj-LXnvhpc2005-R8I4-MNH-V5-4-2-MPIAUTO-${OPTLEVEL}/ZSOLVER/MESONH
+
diff --git a/MY_RUN/BENCH/CINES_MNH55X/004_Hector_128x128_MNH-55X/004_mesonh_step2/mppdb.nam b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_128x128_MNH-55X/004_mesonh_step2/mppdb.nam
new file mode 100644
index 0000000000000000000000000000000000000000..39cb2adaff74600f63d7f252fc0a4429c9c2b67d
--- /dev/null
+++ b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_128x128_MNH-55X/004_mesonh_step2/mppdb.nam
@@ -0,0 +1,7 @@
+&NAM_MPPDB
+MPPDB_DEBUG = .F. ,
+MPPDB_NBSON = 1 ,
+MPPDB_EXEC = "/home/escj/DEV/MNH-55X-dev-OPENACC-juan-03/MY_RUN/BENCH/CINES_MNH55X/004_Hector_128x128_MNH-55X/004_mesonh_step2/MESONH_HOST2005" ,
+MPPDB_WDIR = "/home/escj/DEV/MNH-55X-dev-OPENACC-juan-03/MY_RUN/BENCH/CINES_MNH55X/004_Hector_128x128_MNH-55X/004_mesonh_step2/dir_clone" ,
+MPPDB_CHECK_LB = .F.
+/
diff --git a/MY_RUN/BENCH/CINES_MNH55X/004_Hector_128x128_MNH-55X/004_mesonh_step2/parameters_mg.nam b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_128x128_MNH-55X/004_mesonh_step2/parameters_mg.nam
new file mode 100644
index 0000000000000000000000000000000000000000..5d76f4dff351b9c8873c37072d3f1f0747877d70
--- /dev/null
+++ b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_128x128_MNH-55X/004_mesonh_step2/parameters_mg.nam
@@ -0,0 +1,118 @@
+! *********************************************************************
+! *********************************************************************
+! ** **
+! ** Parameter file for geometric multigrid code **
+! ** **
+! *********************************************************************
+! *********************************************************************
+!
+! *********************************************************************
+! * General parameters
+! *********************************************************************
+¶meters_general
+ savefields = .F. ! Save fields to disk?
+/
+
+! *********************************************************************
+! * General solver parameters
+! *********************************************************************
+¶meters_solver
+ LUseO = F ,
+ LUseT = T ,
+ solvertype = 1, ! Solver type:
+ ! 1 : Richardson iteration
+ ! 2 : Conjugate gradient
+ resreduction = 1e-1 ! 1.0d-10 ! Required relative residual reduction
+ maxiter = 5 ! 50 ! Maximal number of iterations
+/
+
+! *********************************************************************
+! * Conjugate gradient parameters
+! *********************************************************************
+¶meters_conjugategradient
+ verbose = 10, ! Verbosity level
+ maxiter = 5, ! Maximal number of iterations
+ resreduction = 1.0e-1, ! Target residual reduction
+ n_prec = 1 ! Number of smoother applications in
+ ! preconditioner (N.B.: Using 0 is
+ ! inefficient, as the identity is used
+ ! for preconditioning, instead of using
+ ! unpreconditioned CG.)
+/
+
+! *********************************************************************
+! * Grid parameters
+! *********************************************************************
+¶meters_grid
+ n = 128 , ! 64, ! Number of horizontal grid cells
+ nz = 72, ! Number of vertical grid cells
+ L = 204800.0 ! 16000.0 metre * 256 pt grille ! 1.0, ! Size in horizontal direction
+ H = 19200.0 ! 150.0 metre * 128 niveaux ! 0.01, ! Size in vertical direction
+ vertbc = 2, ! Boundary conditions at top and bottom of the
+ ! atmosphere. 1 = DIRICHLET, 2 = NEUMANN
+ ! Note that Neumann boundary conditions only work
+ ! for coarsening in the horizontal only, as they are
+ ! not yet implemented in the prolongation operator.
+ graded = .F. ! Is the grid graded in the vertical direction?
+/
+
+! *********************************************************************
+! * Parallel communication parameters
+! *********************************************************************
+¶meters_communication
+ halo_size = 1 ! Size of halos (has to be 1 or 2)
+/
+
+! *********************************************************************
+! * Model parameters
+! *********************************************************************
+!
+! parameters of the Helmholtz operator
+!
+! -omega2*(d^2/dy^2 + d^2/dy^2 + lambda2*d^2/dz^2) u + delta u = RHS
+!
+¶meters_model
+ omega2 = 1.0,
+ lambda2 = 1.0 ! 100.0, ! Vertical coupling
+ delta = 0.0d0 ! Size of constant term
+/
+
+! *********************************************************************
+! * Smoother parameters
+! *********************************************************************
+!
+! parameters of the smoother
+!
+¶meters_smoother
+ smoother = 3, ! Smoother method
+ ! 3 = line SOR
+ ! 4 = line SSOR
+ ! 6 = line Jacobi
+ ordering = 2, ! Ordering of grid points (for smoother)
+
+ ! 1 = lexicographic
+ ! 2 = red-black ordering
+ !rho = 0.6666666666666666d0 ! Overrelaxation parameter
+ rho = 0.8d0 ! Overrelaxation parameter
+/
+
+! *********************************************************************
+! * Multigrid parameters
+! *********************************************************************
+¶meters_multigrid
+ verbose = 10, ! Verbosity level
+ n_lev = 8, ! Number of levels
+ lev_split = 3, ! First level where data is pulled together
+ n_presmooth = 1, ! Number of presmoothing steps
+ n_postsmooth = 1, ! Number of postsmoothing steps
+ n_coarsegridsmooth = 1, ! Number of smoothing steps on coarsest level
+ prolongation = 2 ! 2 best after modif !! ! Prologation method
+ ! 1 = constant interpolation
+ ! 2 = (tri-) linear interpolation
+ restriction = 1, ! Restriction method
+ ! 1 = cell average
+ ! 2 = Khalil
+ coarsegridsolver = 1 ! Solver on coarsest grid
+ ! 1 = use smoother
+ ! 2 = Conjugate gradient
+/
diff --git a/MY_RUN/BENCH/CINES_MNH55X/004_Hector_128x128_MNH-55X/004_mesonh_step2/run_mesonh_step2_xyz b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_128x128_MNH-55X/004_mesonh_step2/run_mesonh_step2_xyz
new file mode 100755
index 0000000000000000000000000000000000000000..03470ed7a719790e446b249af6d459944b6f46f4
--- /dev/null
+++ b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_128x128_MNH-55X/004_mesonh_step2/run_mesonh_step2_xyz
@@ -0,0 +1,26 @@
+#!/bin/bash
+#
+#
+set -x
+
+#export PGI_ACC_POOL_ALLOC=0
+export PGI_ACC_SYNCHRONOUS=1
+#export NVCOMPILER_ACC_POOL_ALLOC=0
+
+NP=${NP:-16}
+NPS=${NPS:-4}
+
+export MPIRUN=${MPIRUN:-"Mpirun -tag-output -report-bindings -bind-to none -map-by ppr:${NPS}:socket -x NVCOMPILER_ACC_POOL_ALLOC_MAXSIZE -x NVCOMPILER_ACC_POOL_ALLOC -x PGI_ACC_POOL_ALLOC -x PGI_ACC_SYNCHRONOUS -np ${NP} set_core_device_impair "}
+
+rm -f DA0128.*
+rm -f PGD00128.*
+rm -f D0128.1.DAR0?.* OUTPUT_LISTING1 pipe_name
+#
+ln -sf ../001_pgd1/PGD00128.* .
+ln -sf ../002_prep_ideal_case/DA0128.* .
+ln -sf ../003_mesonh_step1/D0128.1.DAR0?.* .
+#
+
+time ${MPIRUN} MESONH${XYZ}
+
+
diff --git a/MY_RUN/BENCH/CINES_MNH55X/004_Hector_128x128_MNH-55X/004_mesonh_step2/run_mesonh_step2_xyz_mppdb b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_128x128_MNH-55X/004_mesonh_step2/run_mesonh_step2_xyz_mppdb
new file mode 100755
index 0000000000000000000000000000000000000000..cd0f51b0bbd9e31776fa4e1cdb6abfbdb977a7f9
--- /dev/null
+++ b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_128x128_MNH-55X/004_mesonh_step2/run_mesonh_step2_xyz_mppdb
@@ -0,0 +1,48 @@
+#!/bin/bash
+#
+#
+
+set -x
+DIRCLONE=dir_clone
+mkdir -p ${DIRCLONE}
+
+export PGI_ACC_POOL_ALLOC=0
+#export PGI_ACC_POOL_SIZE=100MB
+
+export NP=${NP:-1}
+
+export MPIRUN=${MPIRUN:-Mpirun -tag-output -np ${NP}}
+
+#export PGI_ACC_NOTIFY=$(( 1+2+4+8+16+32 )) PGI_ACC_DEBUG=$(( 1+2+4+8+16+32 ))
+#export PGI_ACC_TIME=1
+
+export PGI_ACC_SYNCHRONOUS=1
+
+(
+cd ${DIRCLONE}
+#
+rm -f DA0128.*
+rm -f PGD00128.*
+rm -f D0128.1.DAR0?.* OUTPUT_LISTING1 pipe_name
+#
+cp ../EXSEG1.nam .
+ln -sf ../../001_pgd1/PGD00128.* .
+ln -sf ../../002_prep_ideal_case/DA0128.* .
+ln -sf ../../003_mesonh_step1/D0128.1.DAR01.* .
+#
+)
+
+#
+rm -f DA0128.*
+rm -f PGD00128.*
+rm -f D0128.1.DAR0?.* OUTPUT_LISTING1 pipe_name
+#
+ln -sf ../001_pgd1/PGD00128.* .
+ln -sf ../002_prep_ideal_case/DA0128.* .
+ln -sf ../003_mesonh_step1/D0128.1.DAR0?.* .
+#
+
+killall -r 'MESONH.*'
+time ${MPIRUN} MESONH${XYZ}
+
+
diff --git a/MY_RUN/BENCH/CINES_MNH55X/004_Hector_128x128_MNH-55X/005_mg_main_mnh_all/parameters_mg.nam b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_128x128_MNH-55X/005_mg_main_mnh_all/parameters_mg.nam
new file mode 120000
index 0000000000000000000000000000000000000000..adeab0e1859deb44804ccc14f23c2ccb35775079
--- /dev/null
+++ b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_128x128_MNH-55X/005_mg_main_mnh_all/parameters_mg.nam
@@ -0,0 +1 @@
+../004_mesonh_step2/parameters_mg.nam
\ No newline at end of file
diff --git a/MY_RUN/BENCH/CINES_MNH55X/004_Hector_128x128_MNH-55X/005_mg_main_mnh_all/run_mg_main_mnh_all_xyz b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_128x128_MNH-55X/005_mg_main_mnh_all/run_mg_main_mnh_all_xyz
new file mode 100755
index 0000000000000000000000000000000000000000..c3694f2de5a11d8600af4cf5874b3248c26057f4
--- /dev/null
+++ b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_128x128_MNH-55X/005_mg_main_mnh_all/run_mg_main_mnh_all_xyz
@@ -0,0 +1,18 @@
+#!/bin/bash
+#
+#
+set -x
+
+#export PGI_ACC_POOL_ALLOC=0
+export PGI_ACC_SYNCHRONOUS=1
+#export NVCOMPILER_ACC_POOL_ALLOC=0
+
+NP=${NP:-16}
+NPS=${NPS:-4}
+
+export MPIRUN=${MPIRUN:-"Mpirun -tag-output -report-bindings -bind-to none -map-by ppr:${NPS}:socket -x NVCOMPILER_ACC_POOL_ALLOC_MAXSIZE -x NVCOMPILER_ACC_POOL_ALLOC -x PGI_ACC_POOL_ALLOC -x PGI_ACC_SYNCHRONOUS -np ${NP} set_core_device_impair "}
+
+
+time ${MPIRUN} MG_MAIN_MNH_ALL${XYZ}
+
+
diff --git a/MY_RUN/BENCH/CINES_MNH55X/004_Hector_256x256_MNH-55X/001_pgd1/PRE_PGD1.nam b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_256x256_MNH-55X/001_pgd1/PRE_PGD1.nam
new file mode 100644
index 0000000000000000000000000000000000000000..a7edb249a9cc07b565c80de0c7b74d6a9528e220
--- /dev/null
+++ b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_256x256_MNH-55X/001_pgd1/PRE_PGD1.nam
@@ -0,0 +1,13 @@
+&NAM_CONFZ
+ NB_PROCIO_W=1 ,
+ !MPI_BUFFER_SIZE=40
+/
+&NAM_PGDFILE CPGDFILE="PGD00256" /
+&NAM_PGD_SCHEMES CNATURE='ISBA', CSEA='SEAFLX', CTOWN='NONE', CWATER='NONE' /
+&NAM_CONF_PROJ XLAT0=-11.5, XLON0=130.7, XRPK=0., XBETA=0. /
+&NAM_CONF_PROJ_GRID XLATCEN=-11.5, XLONCEN=130.7, NIMAX=256, NJMAX=256,
+ XDX=800.00000, XDY=800.00000 /
+&NAM_COVER YCOVER='ECOCLIMAP_v2.0', YCOVERFILETYPE='DIRECT' /
+&NAM_ZS YZS='gtopo30', YZSFILETYPE='DIRECT' /
+&NAM_ISBA YCLAY='CLAY_HWSD_MOY', YCLAYFILETYPE='DIRECT',
+ YSAND='SAND_HWSD_MOY', YSANDFILETYPE='DIRECT' /
diff --git a/MY_RUN/BENCH/CINES_MNH55X/004_Hector_256x256_MNH-55X/001_pgd1/get_pgd_files b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_256x256_MNH-55X/001_pgd1/get_pgd_files
new file mode 100755
index 0000000000000000000000000000000000000000..56726933a0f7608e0c4918f42e80d5aea76b669d
--- /dev/null
+++ b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_256x256_MNH-55X/001_pgd1/get_pgd_files
@@ -0,0 +1,30 @@
+#
+# Modif
+# J.Escobar 11/04/2014 get PGD files from 'dir_open' directory ( without psswd )
+# J.Escobar 25/04/2013 get LICENCE files
+#
+PREP_PGD_FILES=${PREP_PGD_FILES:-"$HOME/PREP_PGD_FILES_WWW"} ; export PREP_PGD_FILES
+echo "!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!"
+echo "!!!! WARNING !!!!"
+echo "!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!"
+echo
+echo you need 3GO to download this files in
+echo
+echo PREP_PGD_FILES=$PREP_PGD_FILES
+echo
+echo if OK press ENTER else CTRL-C
+read RIEN
+set -x
+mkdir -p $PREP_PGD_FILES
+cd $PREP_PGD_FILES
+PGD_URL="http://mesonh.aero.obs-mip.fr/mesonh/dir_open/dir_PGDFILES"
+WGET="wget"
+export PGD_URL
+for file in LICENSE_ECOCLIMAP.txt LICENSE_soil_data.txt \
+ gtopo30.dir gtopo30.hdr \
+ SAND_HWSD_MOY.hdr SAND_HWSD_MOY.dir CLAY_HWSD_MOY.hdr CLAY_HWSD_MOY.dir \
+ ECOCLIMAP_v2.0.hdr ECOCLIMAP_v2.0.dir
+do
+[ -f $file ] || ( ${WGET} -c -nd $PGD_URL/$file.gz ; gunzip $file.gz ; )
+done
+
diff --git a/MY_RUN/BENCH/CINES_MNH55X/004_Hector_256x256_MNH-55X/001_pgd1/run_prep_pgd_xyz b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_256x256_MNH-55X/001_pgd1/run_prep_pgd_xyz
new file mode 100755
index 0000000000000000000000000000000000000000..c4b8da5bf37afca5b11f863c02bd21ae92cd9ea0
--- /dev/null
+++ b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_256x256_MNH-55X/001_pgd1/run_prep_pgd_xyz
@@ -0,0 +1,36 @@
+#!/bin/bash
+
+export ACC_DEVICE_TYPE=HOST
+export MPIRUN="Mpirun -tag-output -report-bindings -bind-to none -np 4 set_core_device_impair "
+
+
+PREP_PGD_FILES=${PREP_PGD_FILES:-"$HOME/PREP_PGD_FILES_WWW"} ; export PREP_PGD_FILES
+#
+if [ ! -d $PREP_PGD_FILES ]
+then
+cat << EOF
+
+Your directory PREP_PGD_FILES=$PREP_PGD_FILES
+
+containing the files gtopo30*, ECOCLIMAP_v2.0*
+doesn't exist ( or was not found !!! )
+use the script 'get_pgd_files' to download
+this files from the MESONH WEB PAGES !!!
+( or change the variable PREP_PGD_FILES ... )
+
+After fixing it , run this script again !!!
+
+EOF
+exit 1
+else
+set -x
+#
+rm -f OUTPUT_LISTING0 pipe_name
+rm -f gtopo30.??? sand_fao.??? clay_fao.???
+rm -f SAND_HWSD_MOY.??? ECOCLIMAP_v2.0.??? ecoclimats_v2.???
+rm -f PGD00256.*
+#
+ln -sf $PREP_PGD_FILES/*.dir $PREP_PGD_FILES/*.hdr .
+#
+time ${MPIRUN} PREP_PGD${XYZ}
+fi
diff --git a/MY_RUN/BENCH/CINES_MNH55X/004_Hector_256x256_MNH-55X/002_prep_ideal_case/PRE_IDEA1.nam b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_256x256_MNH-55X/002_prep_ideal_case/PRE_IDEA1.nam
new file mode 100644
index 0000000000000000000000000000000000000000..0f9bb438c273171b5f5d94e36e1c2a51e42f29a0
--- /dev/null
+++ b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_256x256_MNH-55X/002_prep_ideal_case/PRE_IDEA1.nam
@@ -0,0 +1,226 @@
+&NAM_CONFZ
+ !NB_PROCIO_R=1 ,
+ !NB_PROCIO_W=1 ,
+ !MPI_BUFFER_SIZE=40
+/
+
+&NAM_REAL_PGD
+ CPGD_FILE ="PGD00256" ,
+ LREAD_ZS =.TRUE., LREAD_GROUND_PARAM =.TRUE.
+/
+&NAM_DIMn_PRE NIMAX=40, NJMAX=32 /
+&NAM_CONF_PRE LCARTESIAN=.FALSE.
+ CIDEAL='RSOU' CZS='FLAT'
+ NVERB=0 /
+&NAM_CONFn LUSERV= T /
+&NAM_LUNITn CINIFILE = "DA0256" , CINIFILEPGD = "PGD00256" /
+&NAM_DYNn_PRE
+ CPRESOPT= 'ZRESI' ,
+ NITR=4 XRELAX=1. /
+&NAM_LBCn_PRE CLBCX= 2*'OPEN' CLBCY= 2*'OPEN' /
+&NAM_VPROF_PRE CTYPELOC='IJGRID' NILOC=1 NJLOC=1
+ CFUNU='ZZZ' CFUNV='ZZZ'
+ LGEOSBAL=.FALSE. /
+&NAM_VER_GRID NKMAX=126, YZGRID_TYPE='FUNCTN',
+ ZDZGRD=40., ZDZTOP=210., ZZMAX_STRGRD=2500.,
+ ZSTRGRD=7., ZSTRTOP=7. /
+&NAM_GRn_PRE
+ CSURF='EXTE'
+ ! CSURF='NONE'
+ /
+&NAM_PREP_ISBA XTG_SURF= 311., XTG_ROOT= 303., XTG_DEEP= 302.,
+ XHUG_SURF= 0.16, XHUG_ROOT= 0.16, XHUG_DEEP= 0.16 /
+&NAM_PREP_SEAFLUX XSST_UNIF= 304. /
+ RSOU
+ 2005 11 30 0
+ 'PUVTHDMR'
+ 0.0000000E+00
+ 100300.0
+ 303.3000
+ 1.9630000E-02
+ 92
+ 100000.0 3.637668 -3.637668
+ 99900.00 2.572220 -4.455216
+ 99100.00 -4.612377 0.4035313
+ 96600.00 5.124864 -0.4483674
+ 93000.00 5.836996 -2.009839
+ 92800.00 5.801031 -2.111402
+ 92500.00 5.466062 -1.464627
+ 85000.00 0.1345103 -1.537459
+ 81400.00 -0.9020693 -1.849517
+ 71800.00 -2.797467 1.304481
+ 70000.00 -4.472232 1.198331
+ 60500.00 -3.289776 -1.464702
+ 59900.00 -3.208611 -1.634869
+ 56900.00 -2.329535 -2.025034
+ 55600.00 -2.105100 -2.257443
+ 50100.00 -0.5325915 -1.987659
+ 50000.00 -0.2679967 -1.519885
+ 49500.00 0.2507798 -2.042438
+ 46700.00 5.466062 1.464627
+ 45300.00 5.594935 2.608961
+ 44800.00 5.450725 2.898202
+ 43700.00 4.994327 3.628591
+ 42200.00 4.561049 4.891127
+ 41900.00 4.387573 5.047325
+ 41800.00 4.298817 5.123130
+ 40000.00 6.305391 5.290851
+ 39000.00 5.970908 4.027428
+ 38600.00 5.671552 3.543979
+ 38300.00 5.346259 3.086664
+ 35500.00 2.976104 3.546782
+ 32700.00 4.455215 2.572220
+ 31400.00 3.712562 4.270814
+ 30700.00 3.086664 5.346259
+ 30000.00 3.540875 5.056894
+ 28800.00 3.786532 4.205370
+ 26700.00 3.329551 2.419061
+ 25000.00 2.797467 1.304481
+ 24400.00 2.819808 1.255459
+ 23800.00 2.841289 1.206056
+ 21400.00 3.424857 1.112804
+ 20000.00 3.478403 0.9320353
+ 19300.00 3.383935 1.231651
+ 17400.00 3.411947 2.301387
+ 15000.00 2.950729 4.214078
+ 12700.00 2.167201 2.875973
+ 10200.00 1.322713 1.576348
+ 10000.00 0.4466614 2.533142
+ 9120.000 -3.306782 3.940869
+ 8700.000 -7.950636 2.130367
+ 8200.000 -8.712269 0.7622259
+ 8000.000 -9.224754 -0.8070621
+ 7600.000 -4.009694 -2.314998
+ 7300.000 -5.066284 -0.8933228
+ 7000.000 -4.196201 -1.956721
+ 6700.000 -1.013257 0.1786647
+ 6400.000 -2.107039 1.475365
+ 6340.000 -2.558960 1.726041
+ 5480.000 -13.17234 2.322640
+ 5300.000 -15.37459 1.345105
+ 5000.000 -12.81216 -1.120920
+ 4900.000 -12.66571 -2.233307
+ 4860.000 -12.25463 -1.504677
+ 4700.000 -10.76221 0.9415731
+ 4500.000 -11.37801 7.966970
+ 3800.000 -25.11183 2.197004
+ 3600.000 -22.54940 -1.972818
+ 3200.000 -22.72465 -4.417223
+ 3000.000 -22.36116 -5.991656
+ 2490.000 -21.48829 -2.258509
+ 2300.000 -21.07936 -0.7361050
+ 2200.000 -20.57776 -1.7989648E-06
+ 2080.000 -19.00834 -0.9961855
+ 2000.000 -17.93702 -1.569287
+ 1600.000 -14.74927 -10.32755
+ 1500.000 -13.52109 -6.304989
+ 1430.000 -16.89510 -4.527030
+ 1400.000 -18.23862 -3.215962
+ 1300.000 -15.46941 -5.630407
+ 1200.000 -5.594935 2.608962
+ 1190.000 -5.671552 3.543979
+ 1100.000 1.786646 10.13257
+ 1050.000 -3.736842 7.333968
+ 1020.000 -5.435582 4.725079
+ 1000.000 -5.594935 2.608962
+ 950.0000 -4.347303 8.176087
+ 900.0000 2.143975 12.15908
+ 889.9999 1.031246 11.78719
+ 800.0000 -4.728969 4.728969
+ 760.0000 2.890712 7.154763
+ 710.0000 8.644947 -3.318484
+ 700.0000 7.487652 -6.282886
+ 600.0000 -4.214078 -2.950729
+ 91
+ 100000.0 303.1000 1.8050000E-02
+ 99900.00 303.1000 1.8040001E-02
+ 99100.00 303.1000 1.7969999E-02
+ 96600.00 303.1000 1.7729999E-02
+ 93000.00 303.0000 1.7370002E-02
+ 92800.00 303.1000 1.6980000E-02
+ 92500.00 303.2000 1.6400000E-02
+ 85000.00 307.1000 1.1190000E-02
+ 81400.00 309.6000 6.6700005E-03
+ 71800.00 312.3000 6.5600001E-03
+ 70000.00 312.9000 6.5400004E-03
+ 60500.00 316.2000 6.1800000E-03
+ 59900.00 318.1000 5.3400006E-03
+ 56900.00 318.7000 4.9899998E-03
+ 55600.00 322.2000 3.3100001E-03
+ 50100.00 325.5000 2.6000000E-03
+ 50000.00 325.5000 2.5800001E-03
+ 49500.00 325.7000 3.1700002E-03
+ 46700.00 328.6000 1.4500001E-03
+ 45300.00 330.1000 9.4000006E-04
+ 44800.00 330.1000 1.9600000E-03
+ 43700.00 331.0000 2.1500003E-03
+ 42200.00 332.2000 1.9400001E-03
+ 41900.00 332.9000 9.6000003E-04
+ 41800.00 333.0000 9.7000005E-04
+ 40000.00 334.2000 1.1600000E-03
+ 39000.00 334.6000 1.0300000E-03
+ 38600.00 335.6000 6.5000000E-04
+ 38300.00 335.8000 6.0000003E-04
+ 35500.00 338.2000 2.5000001E-04
+ 32700.00 340.8000 9.0000009E-05
+ 31400.00 342.0000 5.0000002E-05
+ 30700.00 342.1000 4.0000003E-05
+ 30000.00 342.3000 4.0000003E-05
+ 28800.00 342.3000 1.2000000E-04
+ 26700.00 344.8000 1.0000001E-05
+ 25000.00 345.4000 1.0000001E-05
+ 24400.00 346.3000 2.0000001E-05
+ 23800.00 346.4000 9.0000009E-05
+ 21400.00 348.1000 1.0000001E-05
+ 20000.00 348.8000 1.0000001E-05
+ 19300.00 348.9000 2.0000001E-05
+ 17400.00 351.5000 1.0000001E-05
+ 15000.00 354.0000 7.1596442E-06
+ 12700.00 355.7000 4.4376361E-06
+ 10200.00 364.6000 1.4789329E-06
+ 10000.00 365.4000 1.2422363E-06
+ 9120.000 371.6000 1.2919259E-06
+ 8700.000 379.9000 1.5496893E-06
+ 8200.000 390.6000 1.8819877E-06
+ 8000.000 395.1000 2.0217396E-06
+ 7600.000 404.7000 2.3198761E-06
+ 7300.000 412.3000 2.4844724E-06
+ 7000.000 420.4000 2.4844724E-06
+ 6700.000 431.1000 2.4844724E-06
+ 6400.000 442.4000 2.4844724E-06
+ 6340.000 444.8000 2.4844724E-06
+ 5480.000 467.8000 2.4844724E-06
+ 5300.000 471.0000 2.4844724E-06
+ 5000.000 476.5000 2.4844724E-06
+ 4900.000 477.6000 2.4844724E-06
+ 4860.000 478.0000 2.4844724E-06
+ 4700.000 485.1000 2.4844724E-06
+ 4500.000 494.6000 2.4844724E-06
+ 3800.000 532.9000 2.4844724E-06
+ 3600.000 545.6000 2.4844724E-06
+ 3200.000 574.4000 2.4844724E-06
+ 3000.000 585.1000 2.4844724E-06
+ 2490.000 624.0000 2.4844724E-06
+ 2300.000 648.9000 2.4844724E-06
+ 2200.000 655.4000 2.4844724E-06
+ 2080.000 663.6000 2.4844724E-06
+ 2000.000 673.5000 2.4844724E-06
+ 1600.000 726.4000 2.4844724E-06
+ 1500.000 742.5000 2.4844724E-06
+ 1430.000 750.7000 2.4844724E-06
+ 1400.000 759.0000 2.4844724E-06
+ 1300.000 788.6000 2.4844724E-06
+ 1200.000 821.7000 2.4844724E-06
+ 1190.000 825.2000 2.4844724E-06
+ 1100.000 833.9000 2.4844724E-06
+ 1050.000 839.0000 2.4844724E-06
+ 1020.000 845.3000 2.4844724E-06
+ 1000.000 851.6000 2.4844724E-06
+ 950.0000 877.0000 2.4844724E-06
+ 900.0000 885.6000 2.4844724E-06
+ 889.9999 887.3000 2.4844724E-06
+ 800.0000 926.6000 2.4844724E-06
+ 760.0000 946.0000 2.4844724E-06
+ 710.0000 958.0000 2.4844724E-06
+ 700.0000 963.1000 2.4844724E-06
+ 600.0000 20.30000 2.4844724E-06
diff --git a/MY_RUN/BENCH/CINES_MNH55X/004_Hector_256x256_MNH-55X/002_prep_ideal_case/run_prep_ideal_xyz b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_256x256_MNH-55X/002_prep_ideal_case/run_prep_ideal_xyz
new file mode 100755
index 0000000000000000000000000000000000000000..6493fd00e6f6d69c0ec9de8b6588c82c816bd577
--- /dev/null
+++ b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_256x256_MNH-55X/002_prep_ideal_case/run_prep_ideal_xyz
@@ -0,0 +1,20 @@
+#!/bin/bash
+
+NP=${NP:-16}
+NPS=${NPS:-4}
+
+export ACC_DEVICE_TYPE=HOST
+export MPIRUN="Mpirun -tag-output -report-bindings --mca mpi_cuda_support 0 -map-by ppr:${NPS}:socket -bind-to none -np ${NP} set_core_device_impair"
+
+#
+set -x
+set -e
+#
+rm -f OUTPUT_LISTING1 pipe_name file_for_xtransfer
+rm -f PGD00256.*
+rm -f DA0256.*
+#
+ln -sf ../001_pgd1/PGD00256.* .
+#
+time ${MPIRUN} PREP_IDEAL_CASE${XYZ}
+#
diff --git a/MY_RUN/BENCH/CINES_MNH55X/004_Hector_256x256_MNH-55X/003_mesonh_step1/EXSEG1.nam b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_256x256_MNH-55X/003_mesonh_step1/EXSEG1.nam
new file mode 100644
index 0000000000000000000000000000000000000000..1f733b80a6013aaa15ffc2721e7b9076b87bd5b8
--- /dev/null
+++ b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_256x256_MNH-55X/003_mesonh_step1/EXSEG1.nam
@@ -0,0 +1,53 @@
+&NAM_CONFZ
+ ! NB_PROCIO_R=1 ,
+ ! NB_PROCIO_W=1 ,
+ ! LMNH_MPI_BSEND = T ,
+ MPI_BUFFER_SIZE = 200
+/
+
+&NAM_LUNITn CINIFILE = "DA0256" , CINIFILEPGD = "PGD00256" /
+&NAM_CONFn LUSERV = T, LUSERC = T, LUSERR = T, LUSERI = T,
+ LUSERS = T, LUSERG = T, LUSERH = F, LUSECI = T /
+&NAM_DYNn XTSTEP = 15.00000 ,
+ CPRESOPT = "ZRESI", NITR = 12
+ !CPRESOPT = "ZSOLV", NITR = 12
+ XRELAX = 1., LHORELAX_UVWTH = T, LHORELAX_RV = T, LVE_RELAX = T,
+ NRIMX = 6, NRIMY = 6, XRIMKMAX = 0.0005, XT4DIFU = 4000 /
+&NAM_ADVn CUVW_ADV_SCHEME = "WENO_K", CMET_ADV_SCHEME = "PPM_01",
+ CSV_ADV_SCHEME = "PPM_01" /
+&NAM_PARAMn CTURB = "TKEL" ! "NONE" ! "TKEL",
+ CRAD = "ECMW",
+ CCLOUD = "ICE3" ! "NONE" ! "ICE3",
+ CDCONV = "NONE", CSCONV = "NONE" /
+&NAM_PARAM_RADn XDTRAD = 1800., XDTRAD_CLONLY = 1800., LCLEAR_SKY = F,
+ NRAD_COLNBR = 500 /
+&NAM_PARAM_MFSHALLn XIMPL_MF = 1, CMF_UPDRAFT = "EDKF", CMF_CLOUD = "NONE",
+ LMIXUV = T, LMF_FLX = F /
+&NAM_LBCn CLBCX = 2*"OPEN", CLBCY = 2*"OPEN", XCPHASE = 20. /
+&NAM_TURBn XIMPL = 1., CTURBLEN = "DEAR", CTURBDIM = "3DIM",
+ LTURB_FLX = F, LTURB_DIAG = F, CSUBG_AUCV = "NONE", LSIGMAS = F,
+ LSIG_CONV = F, LSUBG_COND = F /
+&NAM_CH_MNHCn /
+&NAM_CONF CCONF = "START", LFLAT = F, CEQNSYS = "DUR",
+ LLG=F, NMODEL = 1, NVERB = 0, CEXP = "D0256",
+ CSEG = "DAR01", CSPLIT = "BSPLITTING"
+ NHALO=1
+ /
+&NAM_DYN XSEGLEN = 14400.0000 ! 21600.0000 ! 150. ! 14400.0000 , LCORIO = T,
+ LNUMDIFU = F, LNUMDIFTH = F,
+ XALKTOP = 0.001, XALZBOT = 22000. /
+&NAM_BLANK /
+&NAM_NESTING /
+&NAM_BACKUP
+ XBAK_TIME(1,1) = 3600.00000 ! 150. ! 3600.00000
+ XBAK_TIME(1,2) = 7200.00000
+ XBAK_TIME(1,3) = 10800.0000
+ XBAK_TIME(1,4) = 14400.0000
+ XBAK_TIME(1,5) = 18000.0000
+ XBAK_TIME(1,6) = 21600.0000
+ /
+&NAM_ISBAn /
+&NAM_SEAFLUXn /
+&NAM_DIAG_SURFn LSURF_BUDGET=T /
+&NAM_DIAG_ISBAn /
+&NAM_DIAG_SURF_ATMn /
diff --git a/MY_RUN/BENCH/CINES_MNH55X/004_Hector_256x256_MNH-55X/003_mesonh_step1/parameters_mg.nam b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_256x256_MNH-55X/003_mesonh_step1/parameters_mg.nam
new file mode 100644
index 0000000000000000000000000000000000000000..209e1d572e4d230aa3a8ad8fd4fc9450a5652197
--- /dev/null
+++ b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_256x256_MNH-55X/003_mesonh_step1/parameters_mg.nam
@@ -0,0 +1,120 @@
+! *********************************************************************
+! *********************************************************************
+! ** **
+! ** Parameter file for geometric multigrid code **
+! ** **
+! *********************************************************************
+! *********************************************************************
+!
+! *********************************************************************
+! * General parameters
+! *********************************************************************
+¶meters_general
+ savefields = .F. ! Save fields to disk?
+/
+
+! *********************************************************************
+! * General solver parameters
+! *********************************************************************
+¶meters_solver
+ LUseO = F ,
+ LUseT = T ,
+ solvertype = 1, ! Solver type:
+ ! 1 : Richardson iteration
+ ! 2 : Conjugate gradient
+ resreduction = 1e-1 ! 1.0d-15 ! Required relative residual reduction
+ maxiter = 5 ! Maximal number of iterations
+/
+
+! *********************************************************************
+! * Conjugate gradient parameters
+! *********************************************************************
+¶meters_conjugategradient
+ verbose = 10, ! Verbosity level
+ maxiter = 5, ! Maximal number of iterations
+ resreduction = 1.0e-1, ! Target residual reduction
+ n_prec = 1 ! Number of smoother applications in
+ ! preconditioner (N.B.: Using 0 is
+ ! inefficient, as the identity is used
+ ! for preconditioning, instead of using
+ ! unpreconditioned CG.)
+/
+
+! *********************************************************************
+! * Grid parameters
+! *********************************************************************
+¶meters_grid
+ n = 256 , ! 64, ! Number of horizontal grid cells
+ nz = 128, ! Number of vertical grid cells
+ L = 204800.0 ! 8000.0 metre * 256 pt grille ! 1.0, ! Size in horizontal direction
+ H = 19200.0 ! 150.0 metre * 128 niveaux ! 0.01, ! Size in vertical direction
+ vertbc = 2, ! Boundary conditions at top and bottom of the
+ ! atmosphere. 1 = DIRICHLET, 2 = NEUMANN
+ ! Note that Neumann boundary conditions only work
+ ! for coarsening in the horizontal only, as they are
+ ! not yet implemented in the prolongation operator.
+ graded = .F. ! Is the grid graded in the vertical direction?
+/
+
+! *********************************************************************
+! * Parallel communication parameters
+! *********************************************************************
+¶meters_communication
+ halo_size = 1 ! Size of halos (has to be 1 or 2)
+/
+
+! *********************************************************************
+! * Model parameters
+! *********************************************************************
+!
+! parameters of the Helmholtz operator
+!
+! -omega2*(d^2/dy^2 + d^2/dy^2 + lambda2*d^2/dz^2) u + delta u = RHS
+!
+¶meters_model
+ omega2 = 1.0,
+ lambda2 = 1.0 ! 100.0, ! Vertical coupling
+ delta = 0.0d0 ! Size of constant term
+/
+
+! *********************************************************************
+! * Smoother parameters
+! *********************************************************************
+!
+! parameters of the smoother
+!
+¶meters_smoother
+ smoother = 3, ! Smoother method
+ ! 3 = line SOR
+ ! 4 = line SSOR
+ ! 6 = line Jacobi
+ ordering = 2, ! Ordering of grid points (for smoother)
+
+ ! 1 = lexicographic
+ ! 2 = red-black ordering
+! rho = 0.5d0 ! Overrelaxation parameter
+ !rho = 0.6666666666666666d0 ! Overrelaxation parameter
+ rho = 0.8d0 ! Overrelaxation parameter
+! rho = 1.0d0 ! Overrelaxation parameter
+/
+
+! *********************************************************************
+! * Multigrid parameters
+! *********************************************************************
+¶meters_multigrid
+ verbose = 10, ! Verbosity level
+ n_lev = 9, ! Number of levels
+ lev_split = 5, ! First level where data is pulled together
+ n_presmooth = 1, ! Number of presmoothing steps
+ n_postsmooth = 1, ! Number of postsmoothing steps
+ n_coarsegridsmooth = 1, ! Number of smoothing steps on coarsest level
+ prolongation = 2 ! 2 best after modif !! ! Prologation method
+ ! 1 = constant interpolation
+ ! 2 = (tri-) linear interpolation
+ restriction = 1, ! Restriction method
+ ! 1 = cell average
+ ! 2 = Khalil
+ coarsegridsolver = 1 ! Solver on coarsest grid
+ ! 1 = use smoother
+ ! 2 = Conjugate gradient
+/
diff --git a/MY_RUN/BENCH/CINES_MNH55X/004_Hector_256x256_MNH-55X/003_mesonh_step1/run_mesonh_step1_xyz b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_256x256_MNH-55X/003_mesonh_step1/run_mesonh_step1_xyz
new file mode 100755
index 0000000000000000000000000000000000000000..2526cfb89e68ce8b7e9cb46f87f68aab266c35d4
--- /dev/null
+++ b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_256x256_MNH-55X/003_mesonh_step1/run_mesonh_step1_xyz
@@ -0,0 +1,23 @@
+
+
+#export PGI_ACC_POOL_ALLOC=0
+export PGI_ACC_SYNCHRONOUS=1
+
+NP=${NP:-16}
+NPS=${NPS:-4}
+
+export MPIRUN=${MPIRUN:-"Mpirun -tag-output -map-by ppr:${NPS}:socket -bind-to none -x PGI_ACC_POOL_ALLOC -x PGI_ACC_SYNCHRONOUS -np ${NP} set_core_device_impair "}
+
+
+#
+set -x
+set -e
+#
+rm -f DA0256.*
+rm -f PGD00256.*
+rm -f D0256.1.DAR01.* OUTPUT_LISTING* pipe_name
+#
+ln -sf ../001_pgd1/PGD00256.{des,nc} .
+ln -sf ../002_prep_ideal_case/DA0256.{des,nc} .
+#
+time ${MPIRUN} MESONH${XYZ}
diff --git a/MY_RUN/BENCH/CINES_MNH55X/004_Hector_256x256_MNH-55X/004_mesonh_step2/EXSEG1.nam b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_256x256_MNH-55X/004_mesonh_step2/EXSEG1.nam
new file mode 100644
index 0000000000000000000000000000000000000000..c20340edb8d4fd2ba9b4f4b3b6974b72553f674e
--- /dev/null
+++ b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_256x256_MNH-55X/004_mesonh_step2/EXSEG1.nam
@@ -0,0 +1,59 @@
+&NAM_CONFIO
+ LIO_ALLOW_NO_BACKUP = T , LIO_NO_WRITE = T
+/
+&NAM_CONFZ
+ ! NB_PROCIO_R=1 ,
+ ! NB_PROCIO_W=1 ,
+ LMNH_MPI_BSEND = F ,
+ ! MPI_BUFFER_SIZE = 40
+ !NZ_PROC=1
+/
+
+&NAM_LUNITn CINIFILE = "D0256.1.DAR01.004" , CINIFILEPGD = "PGD00256" /
+&NAM_CONFn LUSERV = T, LUSERC = T, LUSERR = T, LUSERI = T,
+ LUSERS = T, LUSERG = T, LUSERH = F, LUSECI = T /
+&NAM_DYNn XTSTEP = 15.00000 ,
+ CPRESOPT = "ZRESI",
+ !CPRESOPT = "ZSOLV",
+ NITR = 12,
+ XRELAX = 1., LHORELAX_UVWTH = T, LHORELAX_RV = T, LVE_RELAX = T,
+ NRIMX = 6, NRIMY = 6, XRIMKMAX = 0.0005, XT4DIFU = 4000 /
+&NAM_ADVn CUVW_ADV_SCHEME = "WENO_K", CMET_ADV_SCHEME = "PPM_01",
+ CSV_ADV_SCHEME = "PPM_01" /
+&NAM_PARAMn CTURB = "TKEL", ! "NONE" , ! "TKEL",
+ CRAD = "ECMWF",
+ CCLOUD = "ICE3", ! "NONE" , ! "ICE3",
+ CDCONV = "NONE", CSCONV = "NONE" /
+&NAM_PARAM_RADn XDTRAD = 1800., XDTRAD_CLONLY = 1800., LCLEAR_SKY = F,
+ NRAD_COLNBR = 500 /
+&NAM_PARAM_MFSHALLn XIMPL_MF = 1, CMF_UPDRAFT = "EDKF", CMF_CLOUD = "NONE",
+ LMIXUV = T, LMF_FLX = F /
+&NAM_LBCn CLBCX = 2*"OPEN", CLBCY = 2*"OPEN", XCPHASE = 20. /
+&NAM_TURBn XIMPL = 1., CTURBLEN = "DEAR", CTURBDIM = "3DIM",
+ LTURB_FLX = F, LTURB_DIAG = F, CSUBG_AUCV = "NONE", LSIGMAS = F,
+ LSIG_CONV = F, LSUBG_COND = F /
+&NAM_CH_MNHCn /
+&NAM_CONF CCONF = "RESTA", LFLAT = F, CEQNSYS = "DUR",
+ LLG=F, NMODEL = 1, NVERB = 0, CEXP = "D0256",
+ CSEG = "DAR02", CSPLIT = "BSPLITTING"
+ NHALO=1
+ LCHECK = F /
+&NAM_DYN XSEGLEN = 150.0 ! 150.0000 ,
+ LCORIO = T,
+ LNUMDIFU = F, LNUMDIFTH = F,
+ XALKTOP = 0.001, XALZBOT = 22000. /
+&NAM_BLANK /
+&NAM_NESTING /
+&NAM_BACKUP
+ XBAK_TIME(1,1) = 150.0 ! 3600.00000 ! 75. ! 3600.00000
+ XBAK_TIME(1,2) = 7200.00000
+ XBAK_TIME(1,3) = 10800.0000
+ XBAK_TIME(1,4) = 14400.0000
+ XBAK_TIME(1,5) = 18000.0000
+ XBAK_TIME(1,6) = 21600.0000
+ /
+&NAM_ISBAn /
+&NAM_SEAFLUXn /
+&NAM_DIAG_SURFn LSURF_BUDGET=T /
+&NAM_DIAG_ISBAn /
+&NAM_DIAG_SURF_ATMn /
diff --git a/MY_RUN/BENCH/CINES_MNH55X/004_Hector_256x256_MNH-55X/004_mesonh_step2/parameters_mg.nam b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_256x256_MNH-55X/004_mesonh_step2/parameters_mg.nam
new file mode 100644
index 0000000000000000000000000000000000000000..209e1d572e4d230aa3a8ad8fd4fc9450a5652197
--- /dev/null
+++ b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_256x256_MNH-55X/004_mesonh_step2/parameters_mg.nam
@@ -0,0 +1,120 @@
+! *********************************************************************
+! *********************************************************************
+! ** **
+! ** Parameter file for geometric multigrid code **
+! ** **
+! *********************************************************************
+! *********************************************************************
+!
+! *********************************************************************
+! * General parameters
+! *********************************************************************
+¶meters_general
+ savefields = .F. ! Save fields to disk?
+/
+
+! *********************************************************************
+! * General solver parameters
+! *********************************************************************
+¶meters_solver
+ LUseO = F ,
+ LUseT = T ,
+ solvertype = 1, ! Solver type:
+ ! 1 : Richardson iteration
+ ! 2 : Conjugate gradient
+ resreduction = 1e-1 ! 1.0d-15 ! Required relative residual reduction
+ maxiter = 5 ! Maximal number of iterations
+/
+
+! *********************************************************************
+! * Conjugate gradient parameters
+! *********************************************************************
+¶meters_conjugategradient
+ verbose = 10, ! Verbosity level
+ maxiter = 5, ! Maximal number of iterations
+ resreduction = 1.0e-1, ! Target residual reduction
+ n_prec = 1 ! Number of smoother applications in
+ ! preconditioner (N.B.: Using 0 is
+ ! inefficient, as the identity is used
+ ! for preconditioning, instead of using
+ ! unpreconditioned CG.)
+/
+
+! *********************************************************************
+! * Grid parameters
+! *********************************************************************
+¶meters_grid
+ n = 256 , ! 64, ! Number of horizontal grid cells
+ nz = 128, ! Number of vertical grid cells
+ L = 204800.0 ! 8000.0 metre * 256 pt grille ! 1.0, ! Size in horizontal direction
+ H = 19200.0 ! 150.0 metre * 128 niveaux ! 0.01, ! Size in vertical direction
+ vertbc = 2, ! Boundary conditions at top and bottom of the
+ ! atmosphere. 1 = DIRICHLET, 2 = NEUMANN
+ ! Note that Neumann boundary conditions only work
+ ! for coarsening in the horizontal only, as they are
+ ! not yet implemented in the prolongation operator.
+ graded = .F. ! Is the grid graded in the vertical direction?
+/
+
+! *********************************************************************
+! * Parallel communication parameters
+! *********************************************************************
+¶meters_communication
+ halo_size = 1 ! Size of halos (has to be 1 or 2)
+/
+
+! *********************************************************************
+! * Model parameters
+! *********************************************************************
+!
+! parameters of the Helmholtz operator
+!
+! -omega2*(d^2/dy^2 + d^2/dy^2 + lambda2*d^2/dz^2) u + delta u = RHS
+!
+¶meters_model
+ omega2 = 1.0,
+ lambda2 = 1.0 ! 100.0, ! Vertical coupling
+ delta = 0.0d0 ! Size of constant term
+/
+
+! *********************************************************************
+! * Smoother parameters
+! *********************************************************************
+!
+! parameters of the smoother
+!
+¶meters_smoother
+ smoother = 3, ! Smoother method
+ ! 3 = line SOR
+ ! 4 = line SSOR
+ ! 6 = line Jacobi
+ ordering = 2, ! Ordering of grid points (for smoother)
+
+ ! 1 = lexicographic
+ ! 2 = red-black ordering
+! rho = 0.5d0 ! Overrelaxation parameter
+ !rho = 0.6666666666666666d0 ! Overrelaxation parameter
+ rho = 0.8d0 ! Overrelaxation parameter
+! rho = 1.0d0 ! Overrelaxation parameter
+/
+
+! *********************************************************************
+! * Multigrid parameters
+! *********************************************************************
+¶meters_multigrid
+ verbose = 10, ! Verbosity level
+ n_lev = 9, ! Number of levels
+ lev_split = 5, ! First level where data is pulled together
+ n_presmooth = 1, ! Number of presmoothing steps
+ n_postsmooth = 1, ! Number of postsmoothing steps
+ n_coarsegridsmooth = 1, ! Number of smoothing steps on coarsest level
+ prolongation = 2 ! 2 best after modif !! ! Prologation method
+ ! 1 = constant interpolation
+ ! 2 = (tri-) linear interpolation
+ restriction = 1, ! Restriction method
+ ! 1 = cell average
+ ! 2 = Khalil
+ coarsegridsolver = 1 ! Solver on coarsest grid
+ ! 1 = use smoother
+ ! 2 = Conjugate gradient
+/
diff --git a/MY_RUN/BENCH/CINES_MNH55X/004_Hector_256x256_MNH-55X/004_mesonh_step2/run_mesonh_step2_xyz b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_256x256_MNH-55X/004_mesonh_step2/run_mesonh_step2_xyz
new file mode 100755
index 0000000000000000000000000000000000000000..4ed5fb5e7a97f97e04e8be9b56d1e0fbdacb2558
--- /dev/null
+++ b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_256x256_MNH-55X/004_mesonh_step2/run_mesonh_step2_xyz
@@ -0,0 +1,26 @@
+#!/bin/bash
+#
+#
+set -x
+
+#export PGI_ACC_POOL_ALLOC=0
+export PGI_ACC_SYNCHRONOUS=1
+#export NVCOMPILER_ACC_POOL_ALLOC=0
+
+NP=${NP:-16}
+NPS=${NPS:-4}
+
+export MPIRUN=${MPIRUN:-"Mpirun -tag-output -report-bindings -bind-to none -map-by ppr:${NPS}:socket -x NVCOMPILER_ACC_POOL_ALLOC_MAXSIZE -x NVCOMPILER_ACC_POOL_ALLOC -x PGI_ACC_POOL_ALLOC -x PGI_ACC_SYNCHRONOUS -np ${NP} set_core_device_impair "}
+
+rm -f DA0256.*
+rm -f PGD00256.*
+rm -f D0256.1.DAR0?.* OUTPUT_LISTING1 pipe_name
+#
+ln -sf ../001_pgd1/PGD00256.* .
+ln -sf ../002_prep_ideal_case/DA0256.* .
+ln -sf ../003_mesonh_step1/D0256.1.DAR0?.* .
+#
+
+time ${MPIRUN} MESONH${XYZ}
+
+
diff --git a/MY_RUN/BENCH/CINES_MNH55X/004_Hector_256x256_MNH-55X/005_mg_main_mnh_all/parameters_mg.nam b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_256x256_MNH-55X/005_mg_main_mnh_all/parameters_mg.nam
new file mode 120000
index 0000000000000000000000000000000000000000..adeab0e1859deb44804ccc14f23c2ccb35775079
--- /dev/null
+++ b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_256x256_MNH-55X/005_mg_main_mnh_all/parameters_mg.nam
@@ -0,0 +1 @@
+../004_mesonh_step2/parameters_mg.nam
\ No newline at end of file
diff --git a/MY_RUN/BENCH/CINES_MNH55X/004_Hector_256x256_MNH-55X/005_mg_main_mnh_all/run_mg_main_mnh_all_xyz b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_256x256_MNH-55X/005_mg_main_mnh_all/run_mg_main_mnh_all_xyz
new file mode 100755
index 0000000000000000000000000000000000000000..c3694f2de5a11d8600af4cf5874b3248c26057f4
--- /dev/null
+++ b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_256x256_MNH-55X/005_mg_main_mnh_all/run_mg_main_mnh_all_xyz
@@ -0,0 +1,18 @@
+#!/bin/bash
+#
+#
+set -x
+
+#export PGI_ACC_POOL_ALLOC=0
+export PGI_ACC_SYNCHRONOUS=1
+#export NVCOMPILER_ACC_POOL_ALLOC=0
+
+NP=${NP:-16}
+NPS=${NPS:-4}
+
+export MPIRUN=${MPIRUN:-"Mpirun -tag-output -report-bindings -bind-to none -map-by ppr:${NPS}:socket -x NVCOMPILER_ACC_POOL_ALLOC_MAXSIZE -x NVCOMPILER_ACC_POOL_ALLOC -x PGI_ACC_POOL_ALLOC -x PGI_ACC_SYNCHRONOUS -np ${NP} set_core_device_impair "}
+
+
+time ${MPIRUN} MG_MAIN_MNH_ALL${XYZ}
+
+
diff --git a/MY_RUN/BENCH/CINES_MNH55X/004_Hector_512x512_MNH-55X/001_pgd1/PRE_PGD1.nam b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_512x512_MNH-55X/001_pgd1/PRE_PGD1.nam
new file mode 100644
index 0000000000000000000000000000000000000000..07f27620734c560d2eeede6cb11f8ca3ccb8770b
--- /dev/null
+++ b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_512x512_MNH-55X/001_pgd1/PRE_PGD1.nam
@@ -0,0 +1,13 @@
+&NAM_CONFZ
+ NB_PROCIO_W=1 ,
+ !MPI_BUFFER_SIZE=40
+/
+&NAM_PGDFILE CPGDFILE="PGD00512" NHALO=0 /
+&NAM_PGD_SCHEMES CNATURE='ISBA', CSEA='SEAFLX', CTOWN='NONE', CWATER='NONE' /
+&NAM_CONF_PROJ XLAT0=-11.5, XLON0=130.7, XRPK=0., XBETA=0. /
+&NAM_CONF_PROJ_GRID XLATCEN=-11.5, XLONCEN=130.7, NIMAX=512, NJMAX=512,
+ XDX=400.00000, XDY=400.00000 /
+&NAM_COVER YCOVER='ECOCLIMAP_v2.0', YCOVERFILETYPE='DIRECT' /
+&NAM_ZS YZS='gtopo30', YZSFILETYPE='DIRECT' /
+&NAM_ISBA YCLAY='CLAY_HWSD_MOY', YCLAYFILETYPE='DIRECT',
+ YSAND='SAND_HWSD_MOY', YSANDFILETYPE='DIRECT' /
diff --git a/MY_RUN/BENCH/CINES_MNH55X/004_Hector_512x512_MNH-55X/001_pgd1/get_pgd_files b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_512x512_MNH-55X/001_pgd1/get_pgd_files
new file mode 100755
index 0000000000000000000000000000000000000000..56726933a0f7608e0c4918f42e80d5aea76b669d
--- /dev/null
+++ b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_512x512_MNH-55X/001_pgd1/get_pgd_files
@@ -0,0 +1,30 @@
+#
+# Modif
+# J.Escobar 11/04/2014 get PGD files from 'dir_open' directory ( without psswd )
+# J.Escobar 25/04/2013 get LICENCE files
+#
+PREP_PGD_FILES=${PREP_PGD_FILES:-"$HOME/PREP_PGD_FILES_WWW"} ; export PREP_PGD_FILES
+echo "!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!"
+echo "!!!! WARNING !!!!"
+echo "!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!"
+echo
+echo you need 3GO to download this files in
+echo
+echo PREP_PGD_FILES=$PREP_PGD_FILES
+echo
+echo if OK press ENTER else CTRL-C
+read RIEN
+set -x
+mkdir -p $PREP_PGD_FILES
+cd $PREP_PGD_FILES
+PGD_URL="http://mesonh.aero.obs-mip.fr/mesonh/dir_open/dir_PGDFILES"
+WGET="wget"
+export PGD_URL
+for file in LICENSE_ECOCLIMAP.txt LICENSE_soil_data.txt \
+ gtopo30.dir gtopo30.hdr \
+ SAND_HWSD_MOY.hdr SAND_HWSD_MOY.dir CLAY_HWSD_MOY.hdr CLAY_HWSD_MOY.dir \
+ ECOCLIMAP_v2.0.hdr ECOCLIMAP_v2.0.dir
+do
+[ -f $file ] || ( ${WGET} -c -nd $PGD_URL/$file.gz ; gunzip $file.gz ; )
+done
+
diff --git a/MY_RUN/BENCH/CINES_MNH55X/004_Hector_512x512_MNH-55X/001_pgd1/run_prep_pgd_xyz b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_512x512_MNH-55X/001_pgd1/run_prep_pgd_xyz
new file mode 100755
index 0000000000000000000000000000000000000000..342c7e22cf511ecaa4bb018bf4e51d45b47757e3
--- /dev/null
+++ b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_512x512_MNH-55X/001_pgd1/run_prep_pgd_xyz
@@ -0,0 +1,40 @@
+#!/bin/bash
+
+export ACC_DEVICE_TYPE=HOST
+
+NP=${NP:-16}
+NPS=${NPS:-1}
+
+export MPIRUN=${MPIRUN:-"Mpirun -tag-output --mca mpi_cuda_support 0 -map-by ppr:${NPS}:socket -bind-to none -np ${NP} set_core_device_impair "}
+
+
+PREP_PGD_FILES=${PREP_PGD_FILES:-"$HOME/PREP_PGD_FILES_WWW"} ; export PREP_PGD_FILES
+#
+if [ ! -d $PREP_PGD_FILES ]
+then
+cat << EOF
+
+Your directory PREP_PGD_FILES=$PREP_PGD_FILES
+
+containing the files gtopo30*, ECOCLIMAP_v2.0*
+doesn't exist ( or was not found !!! )
+use the script 'get_pgd_files' to download
+this files from the MESONH WEB PAGES !!!
+( or change the variable PREP_PGD_FILES ... )
+
+After fixing it , run this script again !!!
+
+EOF
+exit 1
+else
+set -x
+#
+rm -f OUTPUT_LISTING0 pipe_name
+rm -f gtopo30.??? sand_fao.??? clay_fao.???
+rm -f SAND_HWSD_MOY.??? ECOCLIMAP_v2.0.??? ecoclimats_v2.???
+rm -f PGD00512.*
+#
+ln -sf $PREP_PGD_FILES/*.dir $PREP_PGD_FILES/*.hdr .
+#
+time ${MPIRUN} PREP_PGD${XYZ}
+fi
diff --git a/MY_RUN/BENCH/CINES_MNH55X/004_Hector_512x512_MNH-55X/002_prep_ideal_case/PRE_IDEA1.nam b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_512x512_MNH-55X/002_prep_ideal_case/PRE_IDEA1.nam
new file mode 100644
index 0000000000000000000000000000000000000000..5b3f7253b15aba7334130cfad5fab26c738e3793
--- /dev/null
+++ b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_512x512_MNH-55X/002_prep_ideal_case/PRE_IDEA1.nam
@@ -0,0 +1,226 @@
+&NAM_CONFZ
+ !NB_PROCIO_R=1 ,
+ !NB_PROCIO_W=1 ,
+ MPI_BUFFER_SIZE=200
+/
+
+&NAM_REAL_PGD
+ CPGD_FILE ="PGD00512" ,
+ LREAD_ZS =.TRUE., LREAD_GROUND_PARAM =.TRUE.
+/
+&NAM_DIMn_PRE NIMAX=40, NJMAX=32 /
+&NAM_CONF_PRE LCARTESIAN=.FALSE.
+ CIDEAL='RSOU' CZS='FLAT'
+ NVERB=0 /
+&NAM_CONFn LUSERV= T /
+&NAM_LUNITn CINIFILE = "DA0512" , CINIFILEPGD = "PGD00512" /
+&NAM_DYNn_PRE
+ CPRESOPT= 'ZRESI' ,
+ NITR=4 XRELAX=1. /
+&NAM_LBCn_PRE CLBCX= 2*'OPEN' CLBCY= 2*'OPEN' /
+&NAM_VPROF_PRE CTYPELOC='IJGRID' NILOC=1 NJLOC=1
+ CFUNU='ZZZ' CFUNV='ZZZ'
+ LGEOSBAL=.FALSE. /
+&NAM_VER_GRID NKMAX=126, YZGRID_TYPE='FUNCTN',
+ ZDZGRD=40., ZDZTOP=210., ZZMAX_STRGRD=2500.,
+ ZSTRGRD=7., ZSTRTOP=7. /
+&NAM_GRn_PRE
+ CSURF='EXTE'
+ ! CSURF='NONE'
+ /
+&NAM_PREP_ISBA XTG_SURF= 311., XTG_ROOT= 303., XTG_DEEP= 302.,
+ XHUG_SURF= 0.16, XHUG_ROOT= 0.16, XHUG_DEEP= 0.16 /
+&NAM_PREP_SEAFLUX XSST_UNIF= 304. /
+ RSOU
+ 2005 11 30 0
+ 'PUVTHDMR'
+ 0.0000000E+00
+ 100300.0
+ 303.3000
+ 1.9630000E-02
+ 92
+ 100000.0 3.637668 -3.637668
+ 99900.00 2.572220 -4.455216
+ 99100.00 -4.612377 0.4035313
+ 96600.00 5.124864 -0.4483674
+ 93000.00 5.836996 -2.009839
+ 92800.00 5.801031 -2.111402
+ 92500.00 5.466062 -1.464627
+ 85000.00 0.1345103 -1.537459
+ 81400.00 -0.9020693 -1.849517
+ 71800.00 -2.797467 1.304481
+ 70000.00 -4.472232 1.198331
+ 60500.00 -3.289776 -1.464702
+ 59900.00 -3.208611 -1.634869
+ 56900.00 -2.329535 -2.025034
+ 55600.00 -2.105100 -2.257443
+ 50100.00 -0.5325915 -1.987659
+ 50000.00 -0.2679967 -1.519885
+ 49500.00 0.2507798 -2.042438
+ 46700.00 5.466062 1.464627
+ 45300.00 5.594935 2.608961
+ 44800.00 5.450725 2.898202
+ 43700.00 4.994327 3.628591
+ 42200.00 4.561049 4.891127
+ 41900.00 4.387573 5.047325
+ 41800.00 4.298817 5.123130
+ 40000.00 6.305391 5.290851
+ 39000.00 5.970908 4.027428
+ 38600.00 5.671552 3.543979
+ 38300.00 5.346259 3.086664
+ 35500.00 2.976104 3.546782
+ 32700.00 4.455215 2.572220
+ 31400.00 3.712562 4.270814
+ 30700.00 3.086664 5.346259
+ 30000.00 3.540875 5.056894
+ 28800.00 3.786532 4.205370
+ 26700.00 3.329551 2.419061
+ 25000.00 2.797467 1.304481
+ 24400.00 2.819808 1.255459
+ 23800.00 2.841289 1.206056
+ 21400.00 3.424857 1.112804
+ 20000.00 3.478403 0.9320353
+ 19300.00 3.383935 1.231651
+ 17400.00 3.411947 2.301387
+ 15000.00 2.950729 4.214078
+ 12700.00 2.167201 2.875973
+ 10200.00 1.322713 1.576348
+ 10000.00 0.4466614 2.533142
+ 9120.000 -3.306782 3.940869
+ 8700.000 -7.950636 2.130367
+ 8200.000 -8.712269 0.7622259
+ 8000.000 -9.224754 -0.8070621
+ 7600.000 -4.009694 -2.314998
+ 7300.000 -5.066284 -0.8933228
+ 7000.000 -4.196201 -1.956721
+ 6700.000 -1.013257 0.1786647
+ 6400.000 -2.107039 1.475365
+ 6340.000 -2.558960 1.726041
+ 5480.000 -13.17234 2.322640
+ 5300.000 -15.37459 1.345105
+ 5000.000 -12.81216 -1.120920
+ 4900.000 -12.66571 -2.233307
+ 4860.000 -12.25463 -1.504677
+ 4700.000 -10.76221 0.9415731
+ 4500.000 -11.37801 7.966970
+ 3800.000 -25.11183 2.197004
+ 3600.000 -22.54940 -1.972818
+ 3200.000 -22.72465 -4.417223
+ 3000.000 -22.36116 -5.991656
+ 2490.000 -21.48829 -2.258509
+ 2300.000 -21.07936 -0.7361050
+ 2200.000 -20.57776 -1.7989648E-06
+ 2080.000 -19.00834 -0.9961855
+ 2000.000 -17.93702 -1.569287
+ 1600.000 -14.74927 -10.32755
+ 1500.000 -13.52109 -6.304989
+ 1430.000 -16.89510 -4.527030
+ 1400.000 -18.23862 -3.215962
+ 1300.000 -15.46941 -5.630407
+ 1200.000 -5.594935 2.608962
+ 1190.000 -5.671552 3.543979
+ 1100.000 1.786646 10.13257
+ 1050.000 -3.736842 7.333968
+ 1020.000 -5.435582 4.725079
+ 1000.000 -5.594935 2.608962
+ 950.0000 -4.347303 8.176087
+ 900.0000 2.143975 12.15908
+ 889.9999 1.031246 11.78719
+ 800.0000 -4.728969 4.728969
+ 760.0000 2.890712 7.154763
+ 710.0000 8.644947 -3.318484
+ 700.0000 7.487652 -6.282886
+ 600.0000 -4.214078 -2.950729
+ 91
+ 100000.0 303.1000 1.8050000E-02
+ 99900.00 303.1000 1.8040001E-02
+ 99100.00 303.1000 1.7969999E-02
+ 96600.00 303.1000 1.7729999E-02
+ 93000.00 303.0000 1.7370002E-02
+ 92800.00 303.1000 1.6980000E-02
+ 92500.00 303.2000 1.6400000E-02
+ 85000.00 307.1000 1.1190000E-02
+ 81400.00 309.6000 6.6700005E-03
+ 71800.00 312.3000 6.5600001E-03
+ 70000.00 312.9000 6.5400004E-03
+ 60500.00 316.2000 6.1800000E-03
+ 59900.00 318.1000 5.3400006E-03
+ 56900.00 318.7000 4.9899998E-03
+ 55600.00 322.2000 3.3100001E-03
+ 50100.00 325.5000 2.6000000E-03
+ 50000.00 325.5000 2.5800001E-03
+ 49500.00 325.7000 3.1700002E-03
+ 46700.00 328.6000 1.4500001E-03
+ 45300.00 330.1000 9.4000006E-04
+ 44800.00 330.1000 1.9600000E-03
+ 43700.00 331.0000 2.1500003E-03
+ 42200.00 332.2000 1.9400001E-03
+ 41900.00 332.9000 9.6000003E-04
+ 41800.00 333.0000 9.7000005E-04
+ 40000.00 334.2000 1.1600000E-03
+ 39000.00 334.6000 1.0300000E-03
+ 38600.00 335.6000 6.5000000E-04
+ 38300.00 335.8000 6.0000003E-04
+ 35500.00 338.2000 2.5000001E-04
+ 32700.00 340.8000 9.0000009E-05
+ 31400.00 342.0000 5.0000002E-05
+ 30700.00 342.1000 4.0000003E-05
+ 30000.00 342.3000 4.0000003E-05
+ 28800.00 342.3000 1.2000000E-04
+ 26700.00 344.8000 1.0000001E-05
+ 25000.00 345.4000 1.0000001E-05
+ 24400.00 346.3000 2.0000001E-05
+ 23800.00 346.4000 9.0000009E-05
+ 21400.00 348.1000 1.0000001E-05
+ 20000.00 348.8000 1.0000001E-05
+ 19300.00 348.9000 2.0000001E-05
+ 17400.00 351.5000 1.0000001E-05
+ 15000.00 354.0000 7.1596442E-06
+ 12700.00 355.7000 4.4376361E-06
+ 10200.00 364.6000 1.4789329E-06
+ 10000.00 365.4000 1.2422363E-06
+ 9120.000 371.6000 1.2919259E-06
+ 8700.000 379.9000 1.5496893E-06
+ 8200.000 390.6000 1.8819877E-06
+ 8000.000 395.1000 2.0217396E-06
+ 7600.000 404.7000 2.3198761E-06
+ 7300.000 412.3000 2.4844724E-06
+ 7000.000 420.4000 2.4844724E-06
+ 6700.000 431.1000 2.4844724E-06
+ 6400.000 442.4000 2.4844724E-06
+ 6340.000 444.8000 2.4844724E-06
+ 5480.000 467.8000 2.4844724E-06
+ 5300.000 471.0000 2.4844724E-06
+ 5000.000 476.5000 2.4844724E-06
+ 4900.000 477.6000 2.4844724E-06
+ 4860.000 478.0000 2.4844724E-06
+ 4700.000 485.1000 2.4844724E-06
+ 4500.000 494.6000 2.4844724E-06
+ 3800.000 532.9000 2.4844724E-06
+ 3600.000 545.6000 2.4844724E-06
+ 3200.000 574.4000 2.4844724E-06
+ 3000.000 585.1000 2.4844724E-06
+ 2490.000 624.0000 2.4844724E-06
+ 2300.000 648.9000 2.4844724E-06
+ 2200.000 655.4000 2.4844724E-06
+ 2080.000 663.6000 2.4844724E-06
+ 2000.000 673.5000 2.4844724E-06
+ 1600.000 726.4000 2.4844724E-06
+ 1500.000 742.5000 2.4844724E-06
+ 1430.000 750.7000 2.4844724E-06
+ 1400.000 759.0000 2.4844724E-06
+ 1300.000 788.6000 2.4844724E-06
+ 1200.000 821.7000 2.4844724E-06
+ 1190.000 825.2000 2.4844724E-06
+ 1100.000 833.9000 2.4844724E-06
+ 1050.000 839.0000 2.4844724E-06
+ 1020.000 845.3000 2.4844724E-06
+ 1000.000 851.6000 2.4844724E-06
+ 950.0000 877.0000 2.4844724E-06
+ 900.0000 885.6000 2.4844724E-06
+ 889.9999 887.3000 2.4844724E-06
+ 800.0000 926.6000 2.4844724E-06
+ 760.0000 946.0000 2.4844724E-06
+ 710.0000 958.0000 2.4844724E-06
+ 700.0000 963.1000 2.4844724E-06
+ 600.0000 20.30000 2.4844724E-06
diff --git a/MY_RUN/BENCH/CINES_MNH55X/004_Hector_512x512_MNH-55X/002_prep_ideal_case/run_prep_ideal_xyz b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_512x512_MNH-55X/002_prep_ideal_case/run_prep_ideal_xyz
new file mode 100755
index 0000000000000000000000000000000000000000..1a85e665eccd99a35eb1c4498766beba6593b344
--- /dev/null
+++ b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_512x512_MNH-55X/002_prep_ideal_case/run_prep_ideal_xyz
@@ -0,0 +1,20 @@
+#!/bin/bash
+
+NP=${NP:-16}
+NPS=${NPS:-4}
+
+export ACC_DEVICE_TYPE=HOST
+export MPIRUN="Mpirun -tag-output -report-bindings --mca mpi_cuda_support 0 -map-by ppr:${NPS}:socket -bind-to none -np ${NP} set_core_device_impair"
+
+#
+set -x
+set -e
+#
+rm -f OUTPUT_LISTING1 pipe_name file_for_xtransfer
+rm -f PGD00512.*
+rm -f DA0512.*
+#
+ln -sf ../001_pgd1/PGD00512.* .
+#
+time ${MPIRUN} PREP_IDEAL_CASE${XYZ}
+#
diff --git a/MY_RUN/BENCH/CINES_MNH55X/004_Hector_512x512_MNH-55X/003_mesonh_step1/EXSEG1.nam b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_512x512_MNH-55X/003_mesonh_step1/EXSEG1.nam
new file mode 100644
index 0000000000000000000000000000000000000000..878afa281253ff16017a9c0177e961b3675533fc
--- /dev/null
+++ b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_512x512_MNH-55X/003_mesonh_step1/EXSEG1.nam
@@ -0,0 +1,54 @@
+&NAM_CONFZ
+ ! NB_PROCIO_R=1 ,
+ ! NB_PROCIO_W=1 ,
+ ! LMNH_MPI_BSEND = T ,
+ MPI_BUFFER_SIZE = 1000
+/
+
+&NAM_LUNITn CINIFILE = "DA0512" , CINIFILEPGD = "PGD00512" /
+&NAM_CONFn LUSERV = T, LUSERC = T, LUSERR = T, LUSERI = T,
+ LUSERS = T, LUSERG = T, LUSERH = F, LUSECI = T /
+&NAM_DYNn XTSTEP = 10.0 ,
+ CPRESOPT = "ZRESI", NITR = 12
+ !CPRESOPT = "ZSOLV", NITR = 12
+ XRELAX = 1., LHORELAX_UVWTH = T, LHORELAX_RV = T, LVE_RELAX = T,
+ NRIMX = 6, NRIMY = 6, XRIMKMAX = 0.0005, XT4DIFU = 4000 /
+&NAM_ADVn CUVW_ADV_SCHEME = "WENO_K", CMET_ADV_SCHEME = "PPM_01",
+ CSV_ADV_SCHEME = "PPM_01" /
+&NAM_PARAMn CTURB = "TKEL" ! "NONE" ! "TKEL",
+ CRAD = "ECMW",
+ CCLOUD = "ICE3" ! "NONE" ! "ICE3",
+ CDCONV = "NONE", CSCONV = "NONE" /
+&NAM_PARAM_RADn XDTRAD = 1800., XDTRAD_CLONLY = 1800., LCLEAR_SKY = F,
+ NRAD_COLNBR = 500 /
+&NAM_PARAM_MFSHALLn XIMPL_MF = 1, CMF_UPDRAFT = "EDKF", CMF_CLOUD = "NONE",
+ LMIXUV = T, LMF_FLX = F /
+&NAM_LBCn CLBCX = 2*"OPEN", CLBCY = 2*"OPEN", XCPHASE = 20. /
+&NAM_TURBn XIMPL = 1., CTURBLEN = "DEAR", CTURBDIM = "3DIM",
+ LTURB_FLX = F, LTURB_DIAG = F, CSUBG_AUCV = "NONE", LSIGMAS = F,
+ LSIG_CONV = F, LSUBG_COND = F /
+&NAM_CH_MNHCn /
+&NAM_CONF CCONF = "START", LFLAT = F, CEQNSYS = "DUR",
+ LLG=F, NMODEL = 1, NVERB = 0, CEXP = "D0512",
+ CSEG = "DAR01", CSPLIT = "BSPLITTING"
+ NHALO=1
+ /
+&NAM_DYN XSEGLEN = 14400.0000 ! 100. ! 14400.0000 ,
+ LCORIO = T,
+ LNUMDIFU = F, LNUMDIFTH = F,
+ XALKTOP = 0.001, XALZBOT = 22000. /
+&NAM_BLANK /
+&NAM_NESTING /
+&NAM_BACKUP
+ XBAK_TIME(1,1) = 3600.00000 ! 100. ! 3600.00000
+ XBAK_TIME(1,2) = 7200.00000
+ XBAK_TIME(1,3) = 10800.0000
+ XBAK_TIME(1,4) = 14400.0000
+ XBAK_TIME(1,5) = 18000.0000
+ XBAK_TIME(1,6) = 21600.0000
+ /
+&NAM_ISBAn /
+&NAM_SEAFLUXn /
+&NAM_DIAG_SURFn LSURF_BUDGET=T /
+&NAM_DIAG_ISBAn /
+&NAM_DIAG_SURF_ATMn /
diff --git a/MY_RUN/BENCH/CINES_MNH55X/004_Hector_512x512_MNH-55X/003_mesonh_step1/parameters_mg.nam b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_512x512_MNH-55X/003_mesonh_step1/parameters_mg.nam
new file mode 100644
index 0000000000000000000000000000000000000000..1a5d92f6f3e36ecd068964fd6fdf580cb1940fe6
--- /dev/null
+++ b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_512x512_MNH-55X/003_mesonh_step1/parameters_mg.nam
@@ -0,0 +1,118 @@
+! *********************************************************************
+! *********************************************************************
+! ** **
+! ** Parameter file for geometric multigrid code **
+! ** **
+! *********************************************************************
+! *********************************************************************
+!
+! *********************************************************************
+! * General parameters
+! *********************************************************************
+¶meters_general
+ savefields = .F. ! Save fields to disk?
+/
+
+! *********************************************************************
+! * General solver parameters
+! *********************************************************************
+¶meters_solver
+ LUseO = F ,
+ LUseT = T ,
+ solvertype = 1, ! Solver type:
+ ! 1 : Richardson iteration
+ ! 2 : Conjugate gradient
+ resreduction = 1e-1 ! 1.0d-15 ! Required relative residual reduction
+ maxiter = 5 ! Maximal number of iterations
+/
+
+! *********************************************************************
+! * Conjugate gradient parameters
+! *********************************************************************
+¶meters_conjugategradient
+ verbose = 10, ! Verbosity level
+ maxiter = 5, ! Maximal number of iterations
+ resreduction = 1.0e-1, ! Target residual reduction
+ n_prec = 1 ! Number of smoother applications in
+ ! preconditioner (N.B.: Using 0 is
+ ! inefficient, as the identity is used
+ ! for preconditioning, instead of using
+ ! unpreconditioned CG.)
+/
+
+! *********************************************************************
+! * Grid parameters
+! *********************************************************************
+¶meters_grid
+ n = 512 , ! 64, ! Number of horizontal grid cells
+ nz = 128, ! Number of vertical grid cells
+ L = 204800.0 ! 400.0 metre * 512 pt grille ! 1.0, ! Size in horizontal direction
+ H = 25600.0 ! 200.0 metre * 128 niveaux ! 0.01, ! Size in vertical direction
+ vertbc = 2, ! Boundary conditions at top and bottom of the
+ ! atmosphere. 1 = DIRICHLET, 2 = NEUMANN
+ ! Note that Neumann boundary conditions only work
+ ! for coarsening in the horizontal only, as they are
+ ! not yet implemented in the prolongation operator.
+ graded = .F. ! Is the grid graded in the vertical direction?
+/
+
+! *********************************************************************
+! * Parallel communication parameters
+! *********************************************************************
+¶meters_communication
+ halo_size = 1 ! Size of halos (has to be 1 or 2)
+/
+
+! *********************************************************************
+! * Model parameters
+! *********************************************************************
+!
+! parameters of the Helmholtz operator
+!
+! -omega2*(d^2/dy^2 + d^2/dy^2 + lambda2*d^2/dz^2) u + delta u = RHS
+!
+¶meters_model
+ omega2 = 1.0,
+ lambda2 = 1.0 ! 100.0, ! Vertical coupling
+ delta = 0.0d0 ! Size of constant term
+/
+
+! *********************************************************************
+! * Smoother parameters
+! *********************************************************************
+!
+! parameters of the smoother
+!
+¶meters_smoother
+ smoother = 3, ! Smoother method
+ ! 3 = line SOR
+ ! 4 = line SSOR
+ ! 6 = line Jacobi
+ ordering = 2, ! Ordering of grid points (for smoother)
+
+ ! 1 = lexicographic
+ ! 2 = red-black ordering
+!rho = 0.6666666666666666d0 ! Overrelaxation parameter
+ rho = 0.8d0 ! Overrelaxation parameter
+/
+
+! *********************************************************************
+! * Multigrid parameters
+! *********************************************************************
+¶meters_multigrid
+ verbose = 10, ! Verbosity level
+ n_lev = 10, ! Number of levels
+ lev_split = 5, ! First level where data is pulled together
+ n_presmooth = 1, ! Number of presmoothing steps
+ n_postsmooth = 1, ! Number of postsmoothing steps
+ n_coarsegridsmooth = 1, ! Number of smoothing steps on coarsest level
+ prolongation = 2 ! 2 best after modif !! ! Prologation method
+ ! 1 = constant interpolation
+ ! 2 = (tri-) linear interpolation
+ restriction = 1, ! Restriction method
+ ! 1 = cell average
+ ! 2 = Khalil
+ coarsegridsolver = 1 ! Solver on coarsest grid
+ ! 1 = use smoother
+ ! 2 = Conjugate gradient
+/
diff --git a/MY_RUN/BENCH/CINES_MNH55X/004_Hector_512x512_MNH-55X/003_mesonh_step1/run_mesonh_step1_xyz b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_512x512_MNH-55X/003_mesonh_step1/run_mesonh_step1_xyz
new file mode 100755
index 0000000000000000000000000000000000000000..1a3cfc09ce327c8c20cc728df069ac08e720c746
--- /dev/null
+++ b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_512x512_MNH-55X/003_mesonh_step1/run_mesonh_step1_xyz
@@ -0,0 +1,23 @@
+
+
+#export PGI_ACC_POOL_ALLOC=0
+export PGI_ACC_SYNCHRONOUS=1
+
+NP=${NP:-16}
+NPS=${NPS:-4}
+
+export MPIRUN=${MPIRUN:-"Mpirun -tag-output -report-bindings -bind-to none -map-by ppr:${NPS}:socket -x PGI_ACC_POOL_ALLOC -x PGI_ACC_SYNCHRONOUS -np ${NP} set_core_device_impair "}
+
+
+#
+set -x
+set -e
+#
+rm -f DA0512.*
+rm -f PGD00512.*
+rm -f D0512.1.DAR01.* OUTPUT_LISTING* pipe_name
+#
+ln -sf ../001_pgd1/PGD00512.{des,nc} .
+ln -sf ../002_prep_ideal_case/DA0512.{des,nc} .
+#
+time ${MPIRUN} MESONH${XYZ}
diff --git a/MY_RUN/BENCH/CINES_MNH55X/004_Hector_512x512_MNH-55X/004_mesonh_step2/EXSEG1.nam b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_512x512_MNH-55X/004_mesonh_step2/EXSEG1.nam
new file mode 100644
index 0000000000000000000000000000000000000000..8b73157a9f279cde77f15e96c489f18570dfb1dc
--- /dev/null
+++ b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_512x512_MNH-55X/004_mesonh_step2/EXSEG1.nam
@@ -0,0 +1,59 @@
+&NAM_CONFIO
+ LIO_ALLOW_NO_BACKUP = T , LIO_NO_WRITE = T
+/
+&NAM_CONFZ
+ ! NB_PROCIO_R=1 ,
+ ! NB_PROCIO_W=1 ,
+ ! LMNH_MPI_BSEND = T ,
+ MPI_BUFFER_SIZE = 1000
+/
+
+&NAM_LUNITn CINIFILE = "D0512.1.DAR01.004" ! "D0512.1.DAR01.003" ,
+ CINIFILEPGD = "PGD00512" /
+&NAM_CONFn LUSERV = T, LUSERC = T, LUSERR = T, LUSERI = T,
+ LUSERS = T, LUSERG = T, LUSERH = F, LUSECI = T /
+&NAM_DYNn XTSTEP = 10.00000 ,
+ CPRESOPT = "ZRESI",
+ !CPRESOPT = "ZSOLV",
+ NITR = 12,
+ XRELAX = 1., LHORELAX_UVWTH = T, LHORELAX_RV = T, LVE_RELAX = T,
+ NRIMX = 6, NRIMY = 6, XRIMKMAX = 0.0005, XT4DIFU = 4000 /
+&NAM_ADVn CUVW_ADV_SCHEME = "WENO_K", CMET_ADV_SCHEME = "PPM_01",
+ CSV_ADV_SCHEME = "PPM_01" /
+&NAM_PARAMn CTURB = "TKEL", ! "NONE" , ! "TKEL",
+ CRAD = "ECMWF",
+ CCLOUD = "ICE3", ! "NONE" , ! "ICE3",
+ CDCONV = "NONE", CSCONV = "NONE" /
+&NAM_PARAM_RADn XDTRAD = 1800., XDTRAD_CLONLY = 1800., LCLEAR_SKY = F,
+ NRAD_COLNBR = 500 /
+&NAM_PARAM_MFSHALLn XIMPL_MF = 1, CMF_UPDRAFT = "EDKF", CMF_CLOUD = "NONE",
+ LMIXUV = T, LMF_FLX = F /
+&NAM_LBCn CLBCX = 2*"OPEN", CLBCY = 2*"OPEN", XCPHASE = 20. /
+&NAM_TURBn XIMPL = 1., CTURBLEN = "DEAR", CTURBDIM = "3DIM",
+ LTURB_FLX = F, LTURB_DIAG = F, CSUBG_AUCV = "NONE", LSIGMAS = F,
+ LSIG_CONV = F, LSUBG_COND = F /
+&NAM_CH_MNHCn /
+&NAM_CONF CCONF = "RESTA", LFLAT = F, CEQNSYS = "DUR",
+ LLG=F, NMODEL = 1, NVERB = 0, CEXP = "D0512",
+ CSEG = "DAR02", CSPLIT = "BSPLITTING"
+ NHALO=1
+ LCHECK = F /
+&NAM_DYN XSEGLEN = 100.0 ! 150.0000 ,
+ LCORIO = T,
+ LNUMDIFU = F, LNUMDIFTH = F,
+ XALKTOP = 0.001, XALZBOT = 22000. /
+&NAM_BLANK /
+&NAM_NESTING /
+&NAM_BACKUP
+ XBAK_TIME(1,1) = 100.0 ! 3600.00000 ! 3600.00000
+ XBAK_TIME(1,2) = 7200.00000
+ XBAK_TIME(1,3) = 10800.0000
+ XBAK_TIME(1,4) = 14400.0000
+ XBAK_TIME(1,5) = 18000.0000
+ XBAK_TIME(1,6) = 21600.0000
+ /
+&NAM_ISBAn /
+&NAM_SEAFLUXn /
+&NAM_DIAG_SURFn LSURF_BUDGET=T /
+&NAM_DIAG_ISBAn /
+&NAM_DIAG_SURF_ATMn /
diff --git a/MY_RUN/BENCH/CINES_MNH55X/004_Hector_512x512_MNH-55X/004_mesonh_step2/parameters_mg.nam b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_512x512_MNH-55X/004_mesonh_step2/parameters_mg.nam
new file mode 100644
index 0000000000000000000000000000000000000000..1a5d92f6f3e36ecd068964fd6fdf580cb1940fe6
--- /dev/null
+++ b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_512x512_MNH-55X/004_mesonh_step2/parameters_mg.nam
@@ -0,0 +1,118 @@
+! *********************************************************************
+! *********************************************************************
+! ** **
+! ** Parameter file for geometric multigrid code **
+! ** **
+! *********************************************************************
+! *********************************************************************
+!
+! *********************************************************************
+! * General parameters
+! *********************************************************************
+¶meters_general
+ savefields = .F. ! Save fields to disk?
+/
+
+! *********************************************************************
+! * General solver parameters
+! *********************************************************************
+¶meters_solver
+ LUseO = F ,
+ LUseT = T ,
+ solvertype = 1, ! Solver type:
+ ! 1 : Richardson iteration
+ ! 2 : Conjugate gradient
+ resreduction = 1e-1 ! 1.0d-15 ! Required relative residual reduction
+ maxiter = 5 ! Maximal number of iterations
+/
+
+! *********************************************************************
+! * Conjugate gradient parameters
+! *********************************************************************
+¶meters_conjugategradient
+ verbose = 10, ! Verbosity level
+ maxiter = 5, ! Maximal number of iterations
+ resreduction = 1.0e-1, ! Target residual reduction
+ n_prec = 1 ! Number of smoother applications in
+ ! preconditioner (N.B.: Using 0 is
+ ! inefficient, as the identity is used
+ ! for preconditioning, instead of using
+ ! unpreconditioned CG.)
+/
+
+! *********************************************************************
+! * Grid parameters
+! *********************************************************************
+¶meters_grid
+ n = 512 , ! 64, ! Number of horizontal grid cells
+ nz = 128, ! Number of vertical grid cells
+ L = 204800.0 ! 400.0 metre * 512 pt grille ! 1.0, ! Size in horizontal direction
+ H = 25600.0 ! 200.0 metre * 128 niveaux ! 0.01, ! Size in vertical direction
+ vertbc = 2, ! Boundary conditions at top and bottom of the
+ ! atmosphere. 1 = DIRICHLET, 2 = NEUMANN
+ ! Note that Neumann boundary conditions only work
+ ! for coarsening in the horizontal only, as they are
+ ! not yet implemented in the prolongation operator.
+ graded = .F. ! Is the grid graded in the vertical direction?
+/
+
+! *********************************************************************
+! * Parallel communication parameters
+! *********************************************************************
+¶meters_communication
+ halo_size = 1 ! Size of halos (has to be 1 or 2)
+/
+
+! *********************************************************************
+! * Model parameters
+! *********************************************************************
+!
+! parameters of the Helmholtz operator
+!
+! -omega2*(d^2/dy^2 + d^2/dy^2 + lambda2*d^2/dz^2) u + delta u = RHS
+!
+¶meters_model
+ omega2 = 1.0,
+ lambda2 = 1.0 ! 100.0, ! Vertical coupling
+ delta = 0.0d0 ! Size of constant term
+/
+
+! *********************************************************************
+! * Smoother parameters
+! *********************************************************************
+!
+! parameters of the smoother
+!
+¶meters_smoother
+ smoother = 3, ! Smoother method
+ ! 3 = line SOR
+ ! 4 = line SSOR
+ ! 6 = line Jacobi
+ ordering = 2, ! Ordering of grid points (for smoother)
+
+ ! 1 = lexicographic
+ ! 2 = red-black ordering
+!rho = 0.6666666666666666d0 ! Overrelaxation parameter
+ rho = 0.8d0 ! Overrelaxation parameter
+/
+
+! *********************************************************************
+! * Multigrid parameters
+! *********************************************************************
+¶meters_multigrid
+ verbose = 10, ! Verbosity level
+ n_lev = 10, ! Number of levels
+ lev_split = 5, ! First level where data is pulled together
+ n_presmooth = 1, ! Number of presmoothing steps
+ n_postsmooth = 1, ! Number of postsmoothing steps
+ n_coarsegridsmooth = 1, ! Number of smoothing steps on coarsest level
+ prolongation = 2 ! 2 best after modif !! ! Prologation method
+ ! 1 = constant interpolation
+ ! 2 = (tri-) linear interpolation
+ restriction = 1, ! Restriction method
+ ! 1 = cell average
+ ! 2 = Khalil
+ coarsegridsolver = 1 ! Solver on coarsest grid
+ ! 1 = use smoother
+ ! 2 = Conjugate gradient
+/
diff --git a/MY_RUN/BENCH/CINES_MNH55X/004_Hector_512x512_MNH-55X/004_mesonh_step2/run_mesonh_step2_xyz b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_512x512_MNH-55X/004_mesonh_step2/run_mesonh_step2_xyz
new file mode 100755
index 0000000000000000000000000000000000000000..c10adb44e1c80d1049209cbdf0b33c94c6f17127
--- /dev/null
+++ b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_512x512_MNH-55X/004_mesonh_step2/run_mesonh_step2_xyz
@@ -0,0 +1,26 @@
+#!/bin/bash
+#
+#
+set -x
+
+#export PGI_ACC_POOL_ALLOC=0
+export PGI_ACC_SYNCHRONOUS=1
+#export NVCOMPILER_ACC_POOL_ALLOC=0
+
+NP=${NP:-16}
+NPS=${NPS:-4}
+
+export MPIRUN=${MPIRUN:-"Mpirun -tag-output -report-bindings -bind-to none -map-by ppr:${NPS}:socket -x NVCOMPILER_ACC_POOL_ALLOC_MAXSIZE -x NVCOMPILER_ACC_POOL_ALLOC -x PGI_ACC_POOL_ALLOC -x PGI_ACC_SYNCHRONOUS -np ${NP} set_core_device_impair "}
+
+rm -f DA0512.*
+rm -f PGD00512.*
+rm -f D0512.1.DAR0?.* OUTPUT_LISTING1 pipe_name
+#
+ln -sf ../001_pgd1/PGD00512.* .
+ln -sf ../002_prep_ideal_case/DA0512.* .
+ln -sf ../003_mesonh_step1/D0512.1.DAR0?.* .
+#
+
+time ${MPIRUN} MESONH${XYZ}
+
+
diff --git a/MY_RUN/BENCH/CINES_MNH55X/004_Hector_512x512_MNH-55X/005_mg_main_mnh_all/parameters_mg.nam b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_512x512_MNH-55X/005_mg_main_mnh_all/parameters_mg.nam
new file mode 120000
index 0000000000000000000000000000000000000000..adeab0e1859deb44804ccc14f23c2ccb35775079
--- /dev/null
+++ b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_512x512_MNH-55X/005_mg_main_mnh_all/parameters_mg.nam
@@ -0,0 +1 @@
+../004_mesonh_step2/parameters_mg.nam
\ No newline at end of file
diff --git a/MY_RUN/BENCH/CINES_MNH55X/004_Hector_512x512_MNH-55X/005_mg_main_mnh_all/run_mg_main_mnh_all_xyz b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_512x512_MNH-55X/005_mg_main_mnh_all/run_mg_main_mnh_all_xyz
new file mode 100755
index 0000000000000000000000000000000000000000..c3694f2de5a11d8600af4cf5874b3248c26057f4
--- /dev/null
+++ b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_512x512_MNH-55X/005_mg_main_mnh_all/run_mg_main_mnh_all_xyz
@@ -0,0 +1,18 @@
+#!/bin/bash
+#
+#
+set -x
+
+#export PGI_ACC_POOL_ALLOC=0
+export PGI_ACC_SYNCHRONOUS=1
+#export NVCOMPILER_ACC_POOL_ALLOC=0
+
+NP=${NP:-16}
+NPS=${NPS:-4}
+
+export MPIRUN=${MPIRUN:-"Mpirun -tag-output -report-bindings -bind-to none -map-by ppr:${NPS}:socket -x NVCOMPILER_ACC_POOL_ALLOC_MAXSIZE -x NVCOMPILER_ACC_POOL_ALLOC -x PGI_ACC_POOL_ALLOC -x PGI_ACC_SYNCHRONOUS -np ${NP} set_core_device_impair "}
+
+
+time ${MPIRUN} MG_MAIN_MNH_ALL${XYZ}
+
+
diff --git a/MY_RUN/BENCH/CINES_MNH55X/004_Hector_64x64_MNH-55X/001_pgd1/PRE_PGD1.nam b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_64x64_MNH-55X/001_pgd1/PRE_PGD1.nam
new file mode 100644
index 0000000000000000000000000000000000000000..98c1fb75ddf67ed2c004f85e38e92503dcaf6303
--- /dev/null
+++ b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_64x64_MNH-55X/001_pgd1/PRE_PGD1.nam
@@ -0,0 +1,13 @@
+&NAM_CONFZ
+ NB_PROCIO_W=1 ,
+ !MPI_BUFFER_SIZE=40
+/
+&NAM_PGDFILE CPGDFILE="PGD00064" /
+&NAM_PGD_SCHEMES CNATURE='ISBA', CSEA='SEAFLX', CTOWN='NONE', CWATER='NONE' /
+&NAM_CONF_PROJ XLAT0=-11.5, XLON0=130.7, XRPK=0., XBETA=0. /
+&NAM_CONF_PROJ_GRID XLATCEN=-11.5, XLONCEN=130.7, NIMAX=64, NJMAX=64,
+ XDX=3200.00000, XDY=3200.00000 /
+&NAM_COVER YCOVER='ECOCLIMAP_v2.0', YCOVERFILETYPE='DIRECT' /
+&NAM_ZS YZS='gtopo30', YZSFILETYPE='DIRECT' /
+&NAM_ISBA YCLAY='CLAY_HWSD_MOY', YCLAYFILETYPE='DIRECT',
+ YSAND='SAND_HWSD_MOY', YSANDFILETYPE='DIRECT' /
diff --git a/MY_RUN/BENCH/CINES_MNH55X/004_Hector_64x64_MNH-55X/001_pgd1/get_pgd_files b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_64x64_MNH-55X/001_pgd1/get_pgd_files
new file mode 100755
index 0000000000000000000000000000000000000000..56726933a0f7608e0c4918f42e80d5aea76b669d
--- /dev/null
+++ b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_64x64_MNH-55X/001_pgd1/get_pgd_files
@@ -0,0 +1,30 @@
+#
+# Modif
+# J.Escobar 11/04/2014 get PGD files from 'dir_open' directory ( without psswd )
+# J.Escobar 25/04/2013 get LICENCE files
+#
+PREP_PGD_FILES=${PREP_PGD_FILES:-"$HOME/PREP_PGD_FILES_WWW"} ; export PREP_PGD_FILES
+echo "!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!"
+echo "!!!! WARNING !!!!"
+echo "!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!"
+echo
+echo you need 3GO to download this files in
+echo
+echo PREP_PGD_FILES=$PREP_PGD_FILES
+echo
+echo if OK press ENTER else CTRL-C
+read RIEN
+set -x
+mkdir -p $PREP_PGD_FILES
+cd $PREP_PGD_FILES
+PGD_URL="http://mesonh.aero.obs-mip.fr/mesonh/dir_open/dir_PGDFILES"
+WGET="wget"
+export PGD_URL
+for file in LICENSE_ECOCLIMAP.txt LICENSE_soil_data.txt \
+ gtopo30.dir gtopo30.hdr \
+ SAND_HWSD_MOY.hdr SAND_HWSD_MOY.dir CLAY_HWSD_MOY.hdr CLAY_HWSD_MOY.dir \
+ ECOCLIMAP_v2.0.hdr ECOCLIMAP_v2.0.dir
+do
+[ -f $file ] || ( ${WGET} -c -nd $PGD_URL/$file.gz ; gunzip $file.gz ; )
+done
+
diff --git a/MY_RUN/BENCH/CINES_MNH55X/004_Hector_64x64_MNH-55X/001_pgd1/run_prep_pgd_xyz b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_64x64_MNH-55X/001_pgd1/run_prep_pgd_xyz
new file mode 100755
index 0000000000000000000000000000000000000000..827253ef48a7fd218717d6e6305133e583f428a6
--- /dev/null
+++ b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_64x64_MNH-55X/001_pgd1/run_prep_pgd_xyz
@@ -0,0 +1,46 @@
+#!/bin/bash
+#BSUB -a openmpi
+#BSUB -J Hector_80x64
+#BSUB -n 4
+#BSUB -q normal
+#BSUB -R "span[ptile=4]"
+#BSUB -o Sortie_Hector_80x64%J
+#BSUB -W 01:00
+#
+
+#
+#. /linkhome/rech/yiu/ryiu001/MNH-V5-1-4/conf/profile_mesonh-LXgfortranI4-MNH-V5-1-4-OMPI1-10-MPIAUTO-O2
+
+export MPIRUN="Mpirun -np 1"
+#export MPIRUN="Exec totalview"
+
+PREP_PGD_FILES=${PREP_PGD_FILES:-"$HOME/PREP_PGD_FILES_WWW"} ; export PREP_PGD_FILES
+#
+if [ ! -d $PREP_PGD_FILES ]
+then
+cat << EOF
+
+Your directory PREP_PGD_FILES=$PREP_PGD_FILES
+
+containing the files gtopo30*, ECOCLIMAP_v2.0*
+doesn't exist ( or was not found !!! )
+use the script 'get_pgd_files' to download
+this files from the MESONH WEB PAGES !!!
+( or change the variable PREP_PGD_FILES ... )
+
+After fixing it , run this script again !!!
+
+EOF
+exit 1
+else
+set -x
+#
+rm -f OUTPUT_LISTING0 pipe_name
+rm -f gtopo30.??? sand_fao.??? clay_fao.???
+rm -f SAND_HWSD_MOY.??? ECOCLIMAP_v2.0.??? ecoclimats_v2.???
+rm -f PGD00064.*
+#
+ln -sf $PREP_PGD_FILES/*.dir $PREP_PGD_FILES/*.hdr .
+#
+time ${MPIRUN} PREP_PGD${XYZ}
+fi
diff --git a/MY_RUN/BENCH/CINES_MNH55X/004_Hector_64x64_MNH-55X/002_prep_ideal_case/PRE_IDEA1.nam b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_64x64_MNH-55X/002_prep_ideal_case/PRE_IDEA1.nam
new file mode 100644
index 0000000000000000000000000000000000000000..d5542562c0c89612f6eda02f5a35001fb7924fe3
--- /dev/null
+++ b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_64x64_MNH-55X/002_prep_ideal_case/PRE_IDEA1.nam
@@ -0,0 +1,226 @@
+&NAM_CONFZ
+ !NB_PROCIO_R=1 ,
+ !NB_PROCIO_W=1 ,
+ !MPI_BUFFER_SIZE=40
+/
+
+&NAM_REAL_PGD
+ CPGD_FILE ="PGD00064" ,
+ LREAD_ZS =.TRUE., LREAD_GROUND_PARAM =.TRUE.
+/
+&NAM_DIMn_PRE NIMAX=40, NJMAX=32 /
+&NAM_CONF_PRE LCARTESIAN=.FALSE.
+ CIDEAL='RSOU' CZS='FLAT'
+ NVERB=0 /
+&NAM_CONFn LUSERV= T /
+&NAM_LUNITn CINIFILE = "DA0064" , CINIFILEPGD = "PGD00064" /
+&NAM_DYNn_PRE
+ CPRESOPT= 'ZRESI' ,
+ NITR=4 XRELAX=1. /
+&NAM_LBCn_PRE CLBCX= 2*'OPEN' CLBCY= 2*'OPEN' /
+&NAM_VPROF_PRE CTYPELOC='IJGRID' NILOC=1 NJLOC=1
+ CFUNU='ZZZ' CFUNV='ZZZ'
+ LGEOSBAL=.FALSE. /
+&NAM_VER_GRID NKMAX=126, YZGRID_TYPE='FUNCTN',
+ ZDZGRD=40., ZDZTOP=210., ZZMAX_STRGRD=2500.,
+ ZSTRGRD=7., ZSTRTOP=7. /
+&NAM_GRn_PRE
+ CSURF='EXTE'
+ ! CSURF='NONE'
+ /
+&NAM_PREP_ISBA XTG_SURF= 311., XTG_ROOT= 303., XTG_DEEP= 302.,
+ XHUG_SURF= 0.16, XHUG_ROOT= 0.16, XHUG_DEEP= 0.16 /
+&NAM_PREP_SEAFLUX XSST_UNIF= 304. /
+ RSOU
+ 2005 11 30 0
+ 'PUVTHDMR'
+ 0.0000000E+00
+ 100300.0
+ 303.3000
+ 1.9630000E-02
+ 92
+ 100000.0 3.637668 -3.637668
+ 99900.00 2.572220 -4.455216
+ 99100.00 -4.612377 0.4035313
+ 96600.00 5.124864 -0.4483674
+ 93000.00 5.836996 -2.009839
+ 92800.00 5.801031 -2.111402
+ 92500.00 5.466062 -1.464627
+ 85000.00 0.1345103 -1.537459
+ 81400.00 -0.9020693 -1.849517
+ 71800.00 -2.797467 1.304481
+ 70000.00 -4.472232 1.198331
+ 60500.00 -3.289776 -1.464702
+ 59900.00 -3.208611 -1.634869
+ 56900.00 -2.329535 -2.025034
+ 55600.00 -2.105100 -2.257443
+ 50100.00 -0.5325915 -1.987659
+ 50000.00 -0.2679967 -1.519885
+ 49500.00 0.2507798 -2.042438
+ 46700.00 5.466062 1.464627
+ 45300.00 5.594935 2.608961
+ 44800.00 5.450725 2.898202
+ 43700.00 4.994327 3.628591
+ 42200.00 4.561049 4.891127
+ 41900.00 4.387573 5.047325
+ 41800.00 4.298817 5.123130
+ 40000.00 6.305391 5.290851
+ 39000.00 5.970908 4.027428
+ 38600.00 5.671552 3.543979
+ 38300.00 5.346259 3.086664
+ 35500.00 2.976104 3.546782
+ 32700.00 4.455215 2.572220
+ 31400.00 3.712562 4.270814
+ 30700.00 3.086664 5.346259
+ 30000.00 3.540875 5.056894
+ 28800.00 3.786532 4.205370
+ 26700.00 3.329551 2.419061
+ 25000.00 2.797467 1.304481
+ 24400.00 2.819808 1.255459
+ 23800.00 2.841289 1.206056
+ 21400.00 3.424857 1.112804
+ 20000.00 3.478403 0.9320353
+ 19300.00 3.383935 1.231651
+ 17400.00 3.411947 2.301387
+ 15000.00 2.950729 4.214078
+ 12700.00 2.167201 2.875973
+ 10200.00 1.322713 1.576348
+ 10000.00 0.4466614 2.533142
+ 9120.000 -3.306782 3.940869
+ 8700.000 -7.950636 2.130367
+ 8200.000 -8.712269 0.7622259
+ 8000.000 -9.224754 -0.8070621
+ 7600.000 -4.009694 -2.314998
+ 7300.000 -5.066284 -0.8933228
+ 7000.000 -4.196201 -1.956721
+ 6700.000 -1.013257 0.1786647
+ 6400.000 -2.107039 1.475365
+ 6340.000 -2.558960 1.726041
+ 5480.000 -13.17234 2.322640
+ 5300.000 -15.37459 1.345105
+ 5000.000 -12.81216 -1.120920
+ 4900.000 -12.66571 -2.233307
+ 4860.000 -12.25463 -1.504677
+ 4700.000 -10.76221 0.9415731
+ 4500.000 -11.37801 7.966970
+ 3800.000 -25.11183 2.197004
+ 3600.000 -22.54940 -1.972818
+ 3200.000 -22.72465 -4.417223
+ 3000.000 -22.36116 -5.991656
+ 2490.000 -21.48829 -2.258509
+ 2300.000 -21.07936 -0.7361050
+ 2200.000 -20.57776 -1.7989648E-06
+ 2080.000 -19.00834 -0.9961855
+ 2000.000 -17.93702 -1.569287
+ 1600.000 -14.74927 -10.32755
+ 1500.000 -13.52109 -6.304989
+ 1430.000 -16.89510 -4.527030
+ 1400.000 -18.23862 -3.215962
+ 1300.000 -15.46941 -5.630407
+ 1200.000 -5.594935 2.608962
+ 1190.000 -5.671552 3.543979
+ 1100.000 1.786646 10.13257
+ 1050.000 -3.736842 7.333968
+ 1020.000 -5.435582 4.725079
+ 1000.000 -5.594935 2.608962
+ 950.0000 -4.347303 8.176087
+ 900.0000 2.143975 12.15908
+ 889.9999 1.031246 11.78719
+ 800.0000 -4.728969 4.728969
+ 760.0000 2.890712 7.154763
+ 710.0000 8.644947 -3.318484
+ 700.0000 7.487652 -6.282886
+ 600.0000 -4.214078 -2.950729
+ 91
+ 100000.0 303.1000 1.8050000E-02
+ 99900.00 303.1000 1.8040001E-02
+ 99100.00 303.1000 1.7969999E-02
+ 96600.00 303.1000 1.7729999E-02
+ 93000.00 303.0000 1.7370002E-02
+ 92800.00 303.1000 1.6980000E-02
+ 92500.00 303.2000 1.6400000E-02
+ 85000.00 307.1000 1.1190000E-02
+ 81400.00 309.6000 6.6700005E-03
+ 71800.00 312.3000 6.5600001E-03
+ 70000.00 312.9000 6.5400004E-03
+ 60500.00 316.2000 6.1800000E-03
+ 59900.00 318.1000 5.3400006E-03
+ 56900.00 318.7000 4.9899998E-03
+ 55600.00 322.2000 3.3100001E-03
+ 50100.00 325.5000 2.6000000E-03
+ 50000.00 325.5000 2.5800001E-03
+ 49500.00 325.7000 3.1700002E-03
+ 46700.00 328.6000 1.4500001E-03
+ 45300.00 330.1000 9.4000006E-04
+ 44800.00 330.1000 1.9600000E-03
+ 43700.00 331.0000 2.1500003E-03
+ 42200.00 332.2000 1.9400001E-03
+ 41900.00 332.9000 9.6000003E-04
+ 41800.00 333.0000 9.7000005E-04
+ 40000.00 334.2000 1.1600000E-03
+ 39000.00 334.6000 1.0300000E-03
+ 38600.00 335.6000 6.5000000E-04
+ 38300.00 335.8000 6.0000003E-04
+ 35500.00 338.2000 2.5000001E-04
+ 32700.00 340.8000 9.0000009E-05
+ 31400.00 342.0000 5.0000002E-05
+ 30700.00 342.1000 4.0000003E-05
+ 30000.00 342.3000 4.0000003E-05
+ 28800.00 342.3000 1.2000000E-04
+ 26700.00 344.8000 1.0000001E-05
+ 25000.00 345.4000 1.0000001E-05
+ 24400.00 346.3000 2.0000001E-05
+ 23800.00 346.4000 9.0000009E-05
+ 21400.00 348.1000 1.0000001E-05
+ 20000.00 348.8000 1.0000001E-05
+ 19300.00 348.9000 2.0000001E-05
+ 17400.00 351.5000 1.0000001E-05
+ 15000.00 354.0000 7.1596442E-06
+ 12700.00 355.7000 4.4376361E-06
+ 10200.00 364.6000 1.4789329E-06
+ 10000.00 365.4000 1.2422363E-06
+ 9120.000 371.6000 1.2919259E-06
+ 8700.000 379.9000 1.5496893E-06
+ 8200.000 390.6000 1.8819877E-06
+ 8000.000 395.1000 2.0217396E-06
+ 7600.000 404.7000 2.3198761E-06
+ 7300.000 412.3000 2.4844724E-06
+ 7000.000 420.4000 2.4844724E-06
+ 6700.000 431.1000 2.4844724E-06
+ 6400.000 442.4000 2.4844724E-06
+ 6340.000 444.8000 2.4844724E-06
+ 5480.000 467.8000 2.4844724E-06
+ 5300.000 471.0000 2.4844724E-06
+ 5000.000 476.5000 2.4844724E-06
+ 4900.000 477.6000 2.4844724E-06
+ 4860.000 478.0000 2.4844724E-06
+ 4700.000 485.1000 2.4844724E-06
+ 4500.000 494.6000 2.4844724E-06
+ 3800.000 532.9000 2.4844724E-06
+ 3600.000 545.6000 2.4844724E-06
+ 3200.000 574.4000 2.4844724E-06
+ 3000.000 585.1000 2.4844724E-06
+ 2490.000 624.0000 2.4844724E-06
+ 2300.000 648.9000 2.4844724E-06
+ 2200.000 655.4000 2.4844724E-06
+ 2080.000 663.6000 2.4844724E-06
+ 2000.000 673.5000 2.4844724E-06
+ 1600.000 726.4000 2.4844724E-06
+ 1500.000 742.5000 2.4844724E-06
+ 1430.000 750.7000 2.4844724E-06
+ 1400.000 759.0000 2.4844724E-06
+ 1300.000 788.6000 2.4844724E-06
+ 1200.000 821.7000 2.4844724E-06
+ 1190.000 825.2000 2.4844724E-06
+ 1100.000 833.9000 2.4844724E-06
+ 1050.000 839.0000 2.4844724E-06
+ 1020.000 845.3000 2.4844724E-06
+ 1000.000 851.6000 2.4844724E-06
+ 950.0000 877.0000 2.4844724E-06
+ 900.0000 885.6000 2.4844724E-06
+ 889.9999 887.3000 2.4844724E-06
+ 800.0000 926.6000 2.4844724E-06
+ 760.0000 946.0000 2.4844724E-06
+ 710.0000 958.0000 2.4844724E-06
+ 700.0000 963.1000 2.4844724E-06
+ 600.0000 20.30000 2.4844724E-06
diff --git a/MY_RUN/BENCH/CINES_MNH55X/004_Hector_64x64_MNH-55X/002_prep_ideal_case/run_prep_ideal_xyz b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_64x64_MNH-55X/002_prep_ideal_case/run_prep_ideal_xyz
new file mode 100755
index 0000000000000000000000000000000000000000..2cdc37f2a30123c4eb10d6e7fe0c9991ad1dc6c4
--- /dev/null
+++ b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_64x64_MNH-55X/002_prep_ideal_case/run_prep_ideal_xyz
@@ -0,0 +1,20 @@
+#!/bin/bash
+
+NP=${NP:-16}
+NPS=${NPS:-4}
+
+export ACC_DEVICE_TYPE=HOST
+export MPIRUN="Mpirun -tag-output -report-bindings --mca mpi_cuda_support 0 -map-by ppr:${NPS}:socket -bind-to none -np ${NP} set_core_device_impair"
+
+#
+set -x
+set -e
+#
+rm -f OUTPUT_LISTING1 pipe_name file_for_xtransfer
+rm -f PGD00064.*
+rm -f DA0064.*
+#
+ln -sf ../001_pgd1/PGD00064.* .
+#
+time ${MPIRUN} PREP_IDEAL_CASE${XYZ}
+#
diff --git a/MY_RUN/BENCH/CINES_MNH55X/004_Hector_64x64_MNH-55X/003_mesonh_step1/EXSEG1.nam b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_64x64_MNH-55X/003_mesonh_step1/EXSEG1.nam
new file mode 100644
index 0000000000000000000000000000000000000000..0898b916f1f8f098f34bdeffa2a342f7296dcd8e
--- /dev/null
+++ b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_64x64_MNH-55X/003_mesonh_step1/EXSEG1.nam
@@ -0,0 +1,55 @@
+&NAM_CONFZ
+ ! NB_PROCIO_R=1 ,
+ ! NB_PROCIO_W=1 ,
+ ! LMNH_MPI_BSEND = T ,
+ ! MPI_BUFFER_SIZE = 40
+/
+
+&NAM_LUNITn CINIFILE = "DA0064" , CINIFILEPGD = "PGD00064" /
+&NAM_CONFn LUSERV = T, LUSERC = T, LUSERR = T, LUSERI = T,
+ LUSERS = T, LUSERG = T, LUSERH = F, LUSECI = T /
+&NAM_DYNn XTSTEP = 15.00000 ,
+ CPRESOPT = "ZRESI", NITR = 12
+ !CPRESOPT = "ZSOLV", NITR = 12
+ XRELAX = 1., LHORELAX_UVWTH = T, LHORELAX_RV = T, LVE_RELAX = T,
+ NRIMX = 6, NRIMY = 6, XRIMKMAX = 0.0005, XT4DIFU = 4000 /
+&NAM_ADVn CUVW_ADV_SCHEME = "WENO_K", CMET_ADV_SCHEME = "PPM_01",
+ CSV_ADV_SCHEME = "PPM_01" /
+&NAM_PARAMn CTURB = "TKEL" ! "NONE" ! "TKEL",
+ CRAD = "ECMW" ! "NONE " ! "FIXE" ! "ECMW",
+ CCLOUD = "ICE3" ! "NONE" ! "ICE3",
+ CDCONV = "NONE", CSCONV = "NONE" /
+&NAM_PARAM_RADn XDTRAD = 1800., XDTRAD_CLONLY = 1800., LCLEAR_SKY = F,
+ NRAD_COLNBR = 500 /
+&NAM_PARAM_MFSHALLn XIMPL_MF = 1, CMF_UPDRAFT = "EDKF", CMF_CLOUD = "NONE",
+ LMIXUV = T, LMF_FLX = F /
+&NAM_LBCn CLBCX = 2*"OPEN", CLBCY = 2*"OPEN", XCPHASE = 20. /
+&NAM_TURBn XIMPL = 1., CTURBLEN = "DEAR", CTURBDIM = "3DIM",
+ LTURB_FLX = F, LTURB_DIAG = F, CSUBG_AUCV = "NONE", LSIGMAS = F,
+ LSIG_CONV = F, LSUBG_COND = F /
+&NAM_CH_MNHCn /
+&NAM_CONF CCONF = "START", LFLAT = F, CEQNSYS = "DUR",
+ LLG=F, NMODEL = 1, NVERB = 0, CEXP = "D0064",
+ CSEG = "DAR01", CSPLIT = "BSPLITTING"
+ NHALO=1
+ LCHECK=F
+ /
+&NAM_DYN XSEGLEN = 14400.0000 ! 150. ! 21600.0000
+ LCORIO = T,
+ LNUMDIFU = F, LNUMDIFTH = F,
+ XALKTOP = 0.001, XALZBOT = 22000. /
+&NAM_BLANK /
+&NAM_NESTING /
+&NAM_BACKUP
+ XBAK_TIME(1,1) = 3600.00000 ! 150.
+ XBAK_TIME(1,2) = 7200.00000
+ XBAK_TIME(1,3) = 10800.0000
+ XBAK_TIME(1,4) = 14400.0000
+ XBAK_TIME(1,5) = 18000.0000
+ XBAK_TIME(1,6) = 21600.0000
+ /
+&NAM_ISBAn /
+&NAM_SEAFLUXn /
+&NAM_DIAG_SURFn LSURF_BUDGET=T /
+&NAM_DIAG_ISBAn /
+&NAM_DIAG_SURF_ATMn /
diff --git a/MY_RUN/BENCH/CINES_MNH55X/004_Hector_64x64_MNH-55X/003_mesonh_step1/MESONH_HOST2005 b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_64x64_MNH-55X/003_mesonh_step1/MESONH_HOST2005
new file mode 100755
index 0000000000000000000000000000000000000000..f81d930cef2e920eca3ab0fa0b8c3f4a18ce5cb3
--- /dev/null
+++ b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_64x64_MNH-55X/003_mesonh_step1/MESONH_HOST2005
@@ -0,0 +1,5 @@
+#!/bin/bash
+export ACC_DEVICE=HOST
+ACC_DEVICE_TYPE=${ACC_DEVICE}
+exec /home/escj/DEV/MNH-55X-dev-OPENACC-juan-03/exe/MESONH${XYZ}
+
diff --git a/MY_RUN/BENCH/CINES_MNH55X/004_Hector_64x64_MNH-55X/003_mesonh_step1/mppdb.nam b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_64x64_MNH-55X/003_mesonh_step1/mppdb.nam
new file mode 100644
index 0000000000000000000000000000000000000000..3c7a9f6aa3a9a8d6f7cbcee9dfc444d31a62d63e
--- /dev/null
+++ b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_64x64_MNH-55X/003_mesonh_step1/mppdb.nam
@@ -0,0 +1,8 @@
+&NAM_MPPDB
+MPPDB_DEBUG = .F. ,
+MPPDB_NBSON = 1 ,
+!MPPDB_HOST = "localhost" ,
+MPPDB_EXEC = "/home/escj/DEV/MNH-55X-dev-OPENACC-juan-03/MY_RUN/BENCH/CINES_MNH55X/004_Hector_64x64_MNH-55X/003_mesonh_step1/MESONH_HOST2005" ,
+MPPDB_WDIR = "/home/escj/DEV/MNH-55X-dev-OPENACC-juan-03/MY_RUN/BENCH/CINES_MNH55X/004_Hector_64x64_MNH-55X/003_mesonh_step1/dir_clone" ,
+MPPDB_CHECK_LB = .F.
+/
diff --git a/MY_RUN/BENCH/CINES_MNH55X/004_Hector_64x64_MNH-55X/003_mesonh_step1/parameters_mg.nam b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_64x64_MNH-55X/003_mesonh_step1/parameters_mg.nam
new file mode 100644
index 0000000000000000000000000000000000000000..da6e1ac67e7e9cd235de8d628379403ef298c3ad
--- /dev/null
+++ b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_64x64_MNH-55X/003_mesonh_step1/parameters_mg.nam
@@ -0,0 +1,117 @@
+! *********************************************************************
+! *********************************************************************
+! ** **
+! ** Parameter file for geometric multigrid code **
+! ** **
+! *********************************************************************
+! *********************************************************************
+!
+! *********************************************************************
+! * General parameters
+! *********************************************************************
+¶meters_general
+ savefields = .F. ! Save fields to disk?
+/
+
+! *********************************************************************
+! * General solver parameters
+! *********************************************************************
+¶meters_solver
+ LUseO = T ,
+ LUseT = F ,
+ solvertype = 1, ! Solver type:
+ ! 1 : Richardson iteration
+ ! 2 : Conjugate gradient
+ resreduction = 1e-1 ! 1.0d-10 ! Required relative residual reduction
+ maxiter = 5 ! 50 ! Maximal number of iterations
+/
+
+! *********************************************************************
+! * Conjugate gradient parameters
+! *********************************************************************
+¶meters_conjugategradient
+ verbose = 10 ! Verbosity level
+ maxiter = 5, ! Maximal number of iterations
+ resreduction = 1.0e-1, ! Target residual reduction
+ n_prec = 1 ! Number of smoother applications in
+ ! preconditioner (N.B.: Using 0 is
+ ! inefficient, as the identity is used
+ ! for preconditioning, instead of using
+ ! unpreconditioned CG.)
+/
+
+! *********************************************************************
+! * Grid parameters
+! *********************************************************************
+¶meters_grid
+ n = 64, ! Number of horizontal grid cells
+ nz = 128, ! Number of vertical grid cells
+ L = 204800.0 ! 32000.0 metre * 64 pt grille ! 1.0, ! Size in horizontal direction
+ H = 19200.0 ! 150.0 metre * 128 niveaux ! 0.01, ! Size in vertical direction
+ vertbc = 2, ! Boundary conditions at top and bottom of the
+ ! atmosphere. 1 = DIRICHLET, 2 = NEUMANN
+ ! Note that Neumann boundary conditions only work
+ ! for coarsening in the horizontal only, as they are
+ ! not yet implemented in the prolongation operator.
+ graded = .F. ! Is the grid graded in the vertical direction?
+/
+
+! *********************************************************************
+! * Parallel communication parameters
+! *********************************************************************
+¶meters_communication
+ halo_size = 1 ! Size of halos (has to be 1 or 2)
+/
+
+! *********************************************************************
+! * Model parameters
+! *********************************************************************
+!
+! parameters of the Helmholtz operator
+!
+! -omega2*(d^2/dy^2 + d^2/dy^2 + lambda2*d^2/dz^2) u + delta u = RHS
+!
+¶meters_model
+ omega2 = 1.0,
+ lambda2 = 1.0 ! 100.0, ! Vertical coupling
+ delta = 0.0d0 ! Size of constant term
+/
+
+! *********************************************************************
+! * Smoother parameters
+! *********************************************************************
+!
+! parameters of the smoother
+!
+¶meters_smoother
+ smoother = 3, ! Smoother method
+ ! 3 = line SOR
+ ! 4 = line SSOR
+ ! 6 = line Jacobi
+ ordering = 2, ! Ordering of grid points (for smoother)
+ ! 1 = lexicographic
+ ! 2 = red-black ordering
+ !rho = 0.6666666666666666d0 ! Overrelaxation parameter
+ rho = 0.8d0 ! Overrelaxation parameter
+/
+
+! *********************************************************************
+! * Multigrid parameters
+! *********************************************************************
+¶meters_multigrid
+ verbose = 10, ! Verbosity level
+ n_lev = 7, ! Number of levels
+ lev_split = 3, ! First level where data is pulled together
+ n_presmooth = 1, ! Number of presmoothing steps
+ n_postsmooth = 1, ! Number of postsmoothing steps
+ n_coarsegridsmooth = 1, ! Number of smoothing steps on coarsest level
+ prolongation = 2 ! 2 best after modif !! ! Prologation method
+ ! 1 = constant interpolation
+ ! 2 = (tri-) linear interpolation
+ restriction = 1, ! Restriction method
+ ! 1 = cell average
+ ! 2 = Khalil
+ coarsegridsolver = 1 ! Solver on coarsest grid
+ ! 1 = use smoother
+ ! 2 = Conjugate gradient
+/
diff --git a/MY_RUN/BENCH/CINES_MNH55X/004_Hector_64x64_MNH-55X/003_mesonh_step1/run_mesonh_step1_xyz b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_64x64_MNH-55X/003_mesonh_step1/run_mesonh_step1_xyz
new file mode 100755
index 0000000000000000000000000000000000000000..b139bee388f05c7a19e396a1aa2d6d5d020fbc3a
--- /dev/null
+++ b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_64x64_MNH-55X/003_mesonh_step1/run_mesonh_step1_xyz
@@ -0,0 +1,23 @@
+
+
+#export PGI_ACC_POOL_ALLOC=0
+export PGI_ACC_SYNCHRONOUS=1
+
+NP=${NP:-16}
+NPS=${NPS:-4}
+
+export MPIRUN=${MPIRUN:-"Mpirun -tag-output -bind-to none -map-by ppr:${NPS}:socket -x PGI_ACC_POOL_ALLOC -x PGI_ACC_SYNCHRONOUS -np ${NP} set_core_device_impair "}
+
+
+#
+set -x
+set -e
+#
+rm -f DA0064.*
+rm -f PGD00064.*
+rm -f D0064.1.DAR01.* OUTPUT_LISTING* pipe_name
+#
+ln -sf ../001_pgd1/PGD00064.{des,nc} .
+ln -sf ../002_prep_ideal_case/DA0064.{des,nc} .
+#
+time ${MPIRUN} MESONH${XYZ}
diff --git a/MY_RUN/BENCH/CINES_MNH55X/004_Hector_64x64_MNH-55X/003_mesonh_step1/run_mesonh_step1_xyz_mppdb b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_64x64_MNH-55X/003_mesonh_step1/run_mesonh_step1_xyz_mppdb
new file mode 100755
index 0000000000000000000000000000000000000000..dc87ac29b2da19c0c0ddca9d7902e0e5d16c9f20
--- /dev/null
+++ b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_64x64_MNH-55X/003_mesonh_step1/run_mesonh_step1_xyz_mppdb
@@ -0,0 +1,33 @@
+#!/bin/bash
+#
+set -x
+#
+
+export MPIRUN=${MPIRUN:-"Mpirun --mca btl ^openib -tag-output -report-bindings -bind-to core -x ACC_DEVICE_TYPE=HOST -np 1 "}
+
+DIR_CLONE=dir_clone
+
+mkdir -p ${DIR_CLONE}
+
+(
+
+cd ${DIR_CLONE}
+
+rm -f DA0064.*
+rm -f PGD00064.*
+rm -f D0064.1.DAR01.* OUTPUT_LISTING* pipe_name
+#
+ln -sf ../../001_pgd1/PGD00064.{des,nc} .
+ln -sf ../../002_prep_ideal_case/DA0064.{des,nc} .
+cp ../EXSEG1.nam .
+
+)
+
+rm -f DA0064.*
+rm -f PGD00064.*
+rm -f D0064.1.DAR01.* OUTPUT_LISTING* pipe_name
+#
+ln -sf ../001_pgd1/PGD00064.{des,nc} .
+ln -sf ../002_prep_ideal_case/DA0064.{des,nc} .
+#
+time ${MPIRUN} MESONH${XYZ}
diff --git a/MY_RUN/BENCH/CINES_MNH55X/004_Hector_64x64_MNH-55X/004_mesonh_step2/EXSEG1.nam b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_64x64_MNH-55X/004_mesonh_step2/EXSEG1.nam
new file mode 100644
index 0000000000000000000000000000000000000000..a46063ee7c62303314fc9fc60781fdbb0b17ed81
--- /dev/null
+++ b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_64x64_MNH-55X/004_mesonh_step2/EXSEG1.nam
@@ -0,0 +1,60 @@
+&NAM_CONFIO
+ LIO_ALLOW_NO_BACKUP = T , LIO_NO_WRITE = T
+/
+&NAM_CONFZ
+ ! NB_PROCIO_R=1 ,
+ ! NB_PROCIO_W=1 ,
+ LMNH_MPI_BSEND = F ,
+ ! MPI_BUFFER_SIZE = 40
+ !NZ_PROC=1
+/
+
+&NAM_LUNITn CINIFILE = "D0064.1.DAR01.004" , CINIFILEPGD = "PGD00064" /
+&NAM_CONFn LUSERV = T, LUSERC = T, LUSERR = T, LUSERI = T,
+ LUSERS = T, LUSERG = T, LUSERH = F, LUSECI = T /
+&NAM_DYNn XTSTEP = 15.00000 ,
+ CPRESOPT = "ZRESI",
+ !CPRESOPT = "ZSOLV",
+ NITR = 12,
+ XRELAX = 1., LHORELAX_UVWTH = T, LHORELAX_RV = T, LVE_RELAX = T,
+ NRIMX = 6, NRIMY = 6, XRIMKMAX = 0.0005, XT4DIFU = 4000 /
+&NAM_ADVn CUVW_ADV_SCHEME = "WENO_K", CMET_ADV_SCHEME = "PPM_01",
+ CSV_ADV_SCHEME = "PPM_01" /
+&NAM_PARAMn CTURB = "TKEL", ! "NONE" , ! "TKEL",
+ CRAD = "ECMWF",
+ CCLOUD = "ICE3", ! "NONE" , ! "ICE3",
+ CDCONV = "NONE", CSCONV = "NONE" /
+&NAM_PARAM_RADn XDTRAD = 1800., XDTRAD_CLONLY = 1800., LCLEAR_SKY = F,
+ NRAD_COLNBR = 500 /
+&NAM_PARAM_MFSHALLn XIMPL_MF = 1, CMF_UPDRAFT = "EDKF", CMF_CLOUD = "NONE",
+ LMIXUV = T, LMF_FLX = F /
+&NAM_LBCn CLBCX = 2*"OPEN", CLBCY = 2*"OPEN", XCPHASE = 20. /
+&NAM_TURBn XIMPL = 1., CTURBLEN = "DEAR", CTURBDIM = "3DIM",
+ LTURB_FLX = F, LTURB_DIAG = F, CSUBG_AUCV = "NONE", LSIGMAS = F,
+ LSIG_CONV = F, LSUBG_COND = F /
+&NAM_CH_MNHCn /
+&NAM_CONF CCONF = "RESTA" ! "START" ! "RESTA",
+ LFLAT = F, CEQNSYS = "DUR",
+ LLG=F, NMODEL = 1, NVERB = 0, CEXP = "D0064",
+ CSEG = "DAR02", CSPLIT = "BSPLITTING"
+ NHALO=1
+ LCHECK = F /
+&NAM_DYN XSEGLEN = 150.0 ! 150.0000 ,
+ LCORIO = T,
+ LNUMDIFU = F, LNUMDIFTH = F,
+ XALKTOP = 0.001, XALZBOT = 22000. /
+&NAM_BLANK /
+&NAM_NESTING /
+&NAM_BACKUP
+ XBAK_TIME(1,1) = 150.0 ! 3600.00000 ! 75. ! 3600.00000
+ XBAK_TIME(1,2) = 7200.00000
+ XBAK_TIME(1,3) = 10800.0000
+ XBAK_TIME(1,4) = 14400.0000
+ XBAK_TIME(1,5) = 18000.0000
+ XBAK_TIME(1,6) = 21600.0000
+ /
+&NAM_ISBAn /
+&NAM_SEAFLUXn /
+&NAM_DIAG_SURFn LSURF_BUDGET=T /
+&NAM_DIAG_ISBAn /
+&NAM_DIAG_SURF_ATMn /
diff --git a/MY_RUN/BENCH/CINES_MNH55X/004_Hector_64x64_MNH-55X/004_mesonh_step2/MESONH_HOST2005 b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_64x64_MNH-55X/004_mesonh_step2/MESONH_HOST2005
new file mode 100755
index 0000000000000000000000000000000000000000..07ad9fb226bfd7e7cc764749cb644e595ee25b13
--- /dev/null
+++ b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_64x64_MNH-55X/004_mesonh_step2/MESONH_HOST2005
@@ -0,0 +1,5 @@
+#!/bin/bash
+export ACC_DEVICE=HOST
+ACC_DEVICE_TYPE=${ACC_DEVICE}
+exec /home/escj/DEV/MNH-55X-dev-OPENACC-juan-03/src/dir_obj-LXnvhpc2005-R8I4-MNH-V5-4-2-MPIAUTO-${OPTLEVEL}/ZSOLVER/MESONH
+
diff --git a/MY_RUN/BENCH/CINES_MNH55X/004_Hector_64x64_MNH-55X/004_mesonh_step2/mppdb.nam b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_64x64_MNH-55X/004_mesonh_step2/mppdb.nam
new file mode 100644
index 0000000000000000000000000000000000000000..19b2bcc6e70fa54b8b1d84b2b6ba7e8c677fdcb9
--- /dev/null
+++ b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_64x64_MNH-55X/004_mesonh_step2/mppdb.nam
@@ -0,0 +1,7 @@
+&NAM_MPPDB
+MPPDB_DEBUG = .F. ,
+MPPDB_NBSON = 1 ,
+MPPDB_EXEC = "/home/escj/DEV/MNH-55X-dev-OPENACC-juan-03/MY_RUN/BENCH/CINES_MNH55X/004_Hector_64x64_MNH-55X/004_mesonh_step2/MESONH_HOST2005" ,
+MPPDB_WDIR = "/home/escj/DEV/MNH-55X-dev-OPENACC-juan-03/MY_RUN/BENCH/CINES_MNH55X/004_Hector_64x64_MNH-55X/004_mesonh_step2/dir_clone" ,
+MPPDB_CHECK_LB = .F.
+/
diff --git a/MY_RUN/BENCH/CINES_MNH55X/004_Hector_64x64_MNH-55X/004_mesonh_step2/parameters_mg.nam b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_64x64_MNH-55X/004_mesonh_step2/parameters_mg.nam
new file mode 100644
index 0000000000000000000000000000000000000000..da6e1ac67e7e9cd235de8d628379403ef298c3ad
--- /dev/null
+++ b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_64x64_MNH-55X/004_mesonh_step2/parameters_mg.nam
@@ -0,0 +1,117 @@
+! *********************************************************************
+! *********************************************************************
+! ** **
+! ** Parameter file for geometric multigrid code **
+! ** **
+! *********************************************************************
+! *********************************************************************
+!
+! *********************************************************************
+! * General parameters
+! *********************************************************************
+¶meters_general
+ savefields = .F. ! Save fields to disk?
+/
+
+! *********************************************************************
+! * General solver parameters
+! *********************************************************************
+¶meters_solver
+ LUseO = T ,
+ LUseT = F ,
+ solvertype = 1, ! Solver type:
+ ! 1 : Richardson iteration
+ ! 2 : Conjugate gradient
+ resreduction = 1e-1 ! 1.0d-10 ! Required relative residual reduction
+ maxiter = 5 ! 50 ! Maximal number of iterations
+/
+
+! *********************************************************************
+! * Conjugate gradient parameters
+! *********************************************************************
+¶meters_conjugategradient
+ verbose = 10 ! Verbosity level
+ maxiter = 5, ! Maximal number of iterations
+ resreduction = 1.0e-1, ! Target residual reduction
+ n_prec = 1 ! Number of smoother applications in
+ ! preconditioner (N.B.: Using 0 is
+ ! inefficient, as the identity is used
+ ! for preconditioning, instead of using
+ ! unpreconditioned CG.)
+/
+
+! *********************************************************************
+! * Grid parameters
+! *********************************************************************
+¶meters_grid
+ n = 64, ! Number of horizontal grid cells
+ nz = 128, ! Number of vertical grid cells
+ L = 204800.0 ! 32000.0 metre * 64 pt grille ! 1.0, ! Size in horizontal direction
+ H = 19200.0 ! 150.0 metre * 128 niveaux ! 0.01, ! Size in vertical direction
+ vertbc = 2, ! Boundary conditions at top and bottom of the
+ ! atmosphere. 1 = DIRICHLET, 2 = NEUMANN
+ ! Note that Neumann boundary conditions only work
+ ! for coarsening in the horizontal only, as they are
+ ! not yet implemented in the prolongation operator.
+ graded = .F. ! Is the grid graded in the vertical direction?
+/
+
+! *********************************************************************
+! * Parallel communication parameters
+! *********************************************************************
+¶meters_communication
+ halo_size = 1 ! Size of halos (has to be 1 or 2)
+/
+
+! *********************************************************************
+! * Model parameters
+! *********************************************************************
+!
+! parameters of the Helmholtz operator
+!
+! -omega2*(d^2/dy^2 + d^2/dy^2 + lambda2*d^2/dz^2) u + delta u = RHS
+!
+¶meters_model
+ omega2 = 1.0,
+ lambda2 = 1.0 ! 100.0, ! Vertical coupling
+ delta = 0.0d0 ! Size of constant term
+/
+
+! *********************************************************************
+! * Smoother parameters
+! *********************************************************************
+!
+! parameters of the smoother
+!
+¶meters_smoother
+ smoother = 3, ! Smoother method
+ ! 3 = line SOR
+ ! 4 = line SSOR
+ ! 6 = line Jacobi
+ ordering = 2, ! Ordering of grid points (for smoother)
+ ! 1 = lexicographic
+ ! 2 = red-black ordering
+ !rho = 0.6666666666666666d0 ! Overrelaxation parameter
+ rho = 0.8d0 ! Overrelaxation parameter
+/
+
+! *********************************************************************
+! * Multigrid parameters
+! *********************************************************************
+¶meters_multigrid
+ verbose = 10, ! Verbosity level
+ n_lev = 7, ! Number of levels
+ lev_split = 3, ! First level where data is pulled together
+ n_presmooth = 1, ! Number of presmoothing steps
+ n_postsmooth = 1, ! Number of postsmoothing steps
+ n_coarsegridsmooth = 1, ! Number of smoothing steps on coarsest level
+ prolongation = 2 ! 2 best after modif !! ! Prologation method
+ ! 1 = constant interpolation
+ ! 2 = (tri-) linear interpolation
+ restriction = 1, ! Restriction method
+ ! 1 = cell average
+ ! 2 = Khalil
+ coarsegridsolver = 1 ! Solver on coarsest grid
+ ! 1 = use smoother
+ ! 2 = Conjugate gradient
+/
diff --git a/MY_RUN/BENCH/CINES_MNH55X/004_Hector_64x64_MNH-55X/004_mesonh_step2/run_mesonh_step2_xyz b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_64x64_MNH-55X/004_mesonh_step2/run_mesonh_step2_xyz
new file mode 100755
index 0000000000000000000000000000000000000000..a193cf5fec9815f718964f29cfab06aeb9aaf670
--- /dev/null
+++ b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_64x64_MNH-55X/004_mesonh_step2/run_mesonh_step2_xyz
@@ -0,0 +1,26 @@
+#!/bin/bash
+#
+#
+set -x
+
+#export PGI_ACC_POOL_ALLOC=0
+export PGI_ACC_SYNCHRONOUS=1
+#export NVCOMPILER_ACC_POOL_ALLOC=0
+
+NP=${NP:-16}
+NPS=${NPS:-4}
+
+export MPIRUN=${MPIRUN:-"Mpirun -tag-output -report-bindings -bind-to none -map-by ppr:${NPS}:socket -x NVCOMPILER_ACC_POOL_ALLOC_MAXSIZE -x NVCOMPILER_ACC_POOL_ALLOC -x PGI_ACC_POOL_ALLOC -x PGI_ACC_SYNCHRONOUS -np ${NP} set_core_device_impair "}
+
+rm -f DA0064.*
+rm -f PGD00064.*
+rm -f D0064.1.DAR0?.* OUTPUT_LISTING1 pipe_name
+#
+ln -sf ../001_pgd1/PGD00064.* .
+ln -sf ../002_prep_ideal_case/DA0064.* .
+ln -sf ../003_mesonh_step1/D0064.1.DAR0?.* .
+#
+
+time ${MPIRUN} MESONH${XYZ}
+
+
diff --git a/MY_RUN/BENCH/CINES_MNH55X/004_Hector_64x64_MNH-55X/004_mesonh_step2/run_mesonh_step2_xyz_mppdb b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_64x64_MNH-55X/004_mesonh_step2/run_mesonh_step2_xyz_mppdb
new file mode 100755
index 0000000000000000000000000000000000000000..6418882ea5c933e6a77676ac1f8380356c3a19c4
--- /dev/null
+++ b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_64x64_MNH-55X/004_mesonh_step2/run_mesonh_step2_xyz_mppdb
@@ -0,0 +1,48 @@
+#!/bin/bash
+#
+#
+
+set -x
+DIRCLONE=dir_clone
+mkdir -p ${DIRCLONE}
+
+export PGI_ACC_POOL_ALLOC=0
+#export PGI_ACC_POOL_SIZE=100MB
+
+export NP=${NP:-1}
+
+export MPIRUN=${MPIRUN:-Mpirun -tag-output -np ${NP}}
+
+#export PGI_ACC_NOTIFY=$(( 1+2+4+8+16+32 )) PGI_ACC_DEBUG=$(( 1+2+4+8+16+32 ))
+#export PGI_ACC_TIME=1
+
+export PGI_ACC_SYNCHRONOUS=1
+
+(
+cd ${DIRCLONE}
+#
+rm -f DA0064.*
+rm -f PGD00064.*
+rm -f D0064.1.DAR0?.* OUTPUT_LISTING1 pipe_name
+#
+cp ../EXSEG1.nam .
+ln -sf ../../001_pgd1/PGD00064.* .
+ln -sf ../../002_prep_ideal_case/DA0064.* .
+ln -sf ../../003_mesonh_step1/D0064.1.DAR01.* .
+#
+)
+
+#
+rm -f DA0064.*
+rm -f PGD00064.*
+rm -f D0064.1.DAR0?.* OUTPUT_LISTING1 pipe_name
+#
+ln -sf ../001_pgd1/PGD00064.* .
+ln -sf ../002_prep_ideal_case/DA0064.* .
+ln -sf ../003_mesonh_step1/D0064.1.DAR0?.* .
+#
+
+killall -r 'MESONH.*'
+time ${MPIRUN} MESONH${XYZ}
+
+
diff --git a/MY_RUN/BENCH/CINES_MNH55X/004_Hector_64x64_MNH-55X/005_mg_main_mnh_all/parameters_mg.nam b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_64x64_MNH-55X/005_mg_main_mnh_all/parameters_mg.nam
new file mode 120000
index 0000000000000000000000000000000000000000..adeab0e1859deb44804ccc14f23c2ccb35775079
--- /dev/null
+++ b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_64x64_MNH-55X/005_mg_main_mnh_all/parameters_mg.nam
@@ -0,0 +1 @@
+../004_mesonh_step2/parameters_mg.nam
\ No newline at end of file
diff --git a/MY_RUN/BENCH/CINES_MNH55X/004_Hector_64x64_MNH-55X/005_mg_main_mnh_all/run_mg_main_mnh_all_xyz b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_64x64_MNH-55X/005_mg_main_mnh_all/run_mg_main_mnh_all_xyz
new file mode 100755
index 0000000000000000000000000000000000000000..c3694f2de5a11d8600af4cf5874b3248c26057f4
--- /dev/null
+++ b/MY_RUN/BENCH/CINES_MNH55X/004_Hector_64x64_MNH-55X/005_mg_main_mnh_all/run_mg_main_mnh_all_xyz
@@ -0,0 +1,18 @@
+#!/bin/bash
+#
+#
+set -x
+
+#export PGI_ACC_POOL_ALLOC=0
+export PGI_ACC_SYNCHRONOUS=1
+#export NVCOMPILER_ACC_POOL_ALLOC=0
+
+NP=${NP:-16}
+NPS=${NPS:-4}
+
+export MPIRUN=${MPIRUN:-"Mpirun -tag-output -report-bindings -bind-to none -map-by ppr:${NPS}:socket -x NVCOMPILER_ACC_POOL_ALLOC_MAXSIZE -x NVCOMPILER_ACC_POOL_ALLOC -x PGI_ACC_POOL_ALLOC -x PGI_ACC_SYNCHRONOUS -np ${NP} set_core_device_impair "}
+
+
+time ${MPIRUN} MG_MAIN_MNH_ALL${XYZ}
+
+
diff --git a/MY_RUN/BENCH/CINES_MNH55X/Clean_MNH_files b/MY_RUN/BENCH/CINES_MNH55X/Clean_MNH_files
new file mode 100755
index 0000000000000000000000000000000000000000..e866afc41566ac11d859b95cff80967138c6b4fa
--- /dev/null
+++ b/MY_RUN/BENCH/CINES_MNH55X/Clean_MNH_files
@@ -0,0 +1,5 @@
+#!/bin/bash
+find . -name '*.des' -o -name '*.nc' -o -name '*.lfi' -o -name '*OUT*' -o -iname 'sorti*' \
+ -o -name '*.dir' -o -name '*.hdr' -o -name 'core' -o -name file_for_xtransfer \
+ -o -name PRESSURE -o -name 'REMAP*' -o -name 'fort.*' -o -name 'timing.txt*' | xargs -n1 rm -f
+find . -type d -name 'dir_*' | xargs -n1 rm -fr
diff --git a/bin/set_core_device b/bin/set_core_device
new file mode 100755
index 0000000000000000000000000000000000000000..da13274537617e4d83a4237e17d37b321a5e1512
--- /dev/null
+++ b/bin/set_core_device
@@ -0,0 +1,51 @@
+#!/bin/bash
+
+#set -e
+#Numactl='numactl --physcpubind '
+Numactl='taskset -c '
+
+if [[ "x${SLURM_HINT}" != *nomultithread* ]]
+then
+HYP_FAC=2
+else
+HYP_FAC=1
+fi
+
+#NB_DEVICE=$( echo ${SLURM_STEP_GPUS//,/ } | wc -w )
+NB_DEVICE=$( nvidia-smi -L | grep GPU | wc -l )
+[ ${NB_DEVICE} -eq 0 ] && NB_DEVICE=1
+
+export IP=${OMPI_COMM_WORLD_RANK:-${SLURM_PROCID}}
+export LIP=${OMPI_COMM_WORLD_LOCAL_RANK:-${SLURM_LOCALID}}
+export NP=${OMPI_COMM_WORLD_SIZE:-${SLURM_NTASKS}}
+export NN=${OMPI_MCA_orte_num_nodes:-${SLURM_NNODES}}
+
+export NPN=$(( NP / NN ))
+#export NB_HYP=${SLURM_CPUS_ON_NODE}
+export NB_HYP=${SLURM_JOB_CPUS_PER_NODE/(*)/}
+export NB_CORE=$(( ${NB_HYP} / HYP_FAC ))
+export NPC=$(( NB_CORE / NPN ))
+CORE=$(( LIP * NPC ))
+
+export HALF=$(( 1+ ( NPN -1 ) / 2 ))
+export SOC=$(( 1 *( LIP / HALF ) ))
+export RANK_SOC=$(( LIP % HALF ))
+export CORE_IMP=$(( SOC + 2*NPC*RANK_SOC ))
+
+export SURBOOK=$(( NPN / NB_DEVICE ))
+
+if [ ${SURBOOK} == 0 ]
+then
+export ACC_DEVICE_NUM=$(( LIP * 2 ))
+else
+export ACC_DEVICE_NUM=$(( LIP / SURBOOK ))
+fi
+
+echo IP=${IP} LIP=${LIP} NP=${NP} NN=${NN} NPN=${NPN} NPC=${NPC} HOST=`hostname` NB_CORE=${NB_CORE} CORE=${CORE} CORE_IMP=${CORE_IMP} HALF=$HALF SOC=$SOC RS=${RANK_SOC} ND=${NB_DEVICE} CD=${ACC_DEVICE_NUM}
+
+#EXEC=exec
+${EXEC} ${Numactl} ${CORE} $*
+
+#exec $*
+#$*
+
diff --git a/bin/set_core_device_impair b/bin/set_core_device_impair
new file mode 100755
index 0000000000000000000000000000000000000000..fa32268b8261f661a3fc64872c5ada90da2a1ad2
--- /dev/null
+++ b/bin/set_core_device_impair
@@ -0,0 +1,51 @@
+#!/bin/bash
+
+#set -e
+#Numactl='numactl --physcpubind '
+Numactl='taskset -c '
+
+if [[ "x${SLURM_HINT}" != *nomultithread* ]]
+then
+HYP_FAC=1
+else
+HYP_FAC=1
+fi
+
+#NB_DEVICE=$( echo ${SLURM_STEP_GPUS//,/ } | wc -w )
+NB_DEVICE=$( nvidia-smi -L | grep GPU | wc -l )
+[ ${NB_DEVICE} -eq 0 ] && NB_DEVICE=1
+
+export IP=${OMPI_COMM_WORLD_RANK:-${SLURM_PROCID}}
+export LIP=${OMPI_COMM_WORLD_LOCAL_RANK:-${SLURM_LOCALID}}
+export NP=${OMPI_COMM_WORLD_SIZE:-${SLURM_NTASKS}}
+export NN=${OMPI_MCA_orte_num_nodes:-${SLURM_NNODES}}
+
+export NPN=$(( NP / NN ))
+#export NB_HYP=${SLURM_CPUS_ON_NODE}
+export NB_HYP=${SLURM_JOB_CPUS_PER_NODE/(*)/}
+export NB_CORE=$(( ${NB_HYP} / HYP_FAC ))
+export NPC=$(( NB_CORE / NPN ))
+CORE=$(( LIP * NPC ))
+
+export HALF=$(( 1+ ( NPN -1 ) / 2 ))
+export SOC=$(( 1 *( LIP / HALF ) ))
+export RANK_SOC=$(( LIP % HALF ))
+export CORE_IMP=$(( SOC + 2*NPC*RANK_SOC ))
+
+export SURBOOK=$(( NPN / NB_DEVICE ))
+
+if [ ${SURBOOK} == 0 ]
+then
+export ACC_DEVICE_NUM=$(( LIP * 2 ))
+else
+export ACC_DEVICE_NUM=$(( LIP / SURBOOK ))
+fi
+
+echo IP=${IP} LIP=${LIP} NP=${NP} NN=${NN} NPN=${NPN} NPC=${NPC} HOST=`hostname` NB_CORE=${NB_CORE} CORE=${CORE} CORE_IMP=${CORE_IMP} HALF=$HALF SOC=$SOC RS=${RANK_SOC} ND=${NB_DEVICE} CD=${ACC_DEVICE_NUM}
+
+#EXEC=exec
+${EXEC} ${Numactl} ${CORE_IMP} $*
+
+#exec $*
+#$*
+
diff --git a/src/LIB/BITREP/modi_bitrep.f90 b/src/LIB/BITREP/modi_bitrep.f90
index c20d803c34d4003f0783c8582c66a3de20508dba..690baf97b1fe35f09cba7f3b586342883fa1b45a 100644
--- a/src/LIB/BITREP/modi_bitrep.f90
+++ b/src/LIB/BITREP/modi_bitrep.f90
@@ -1,8 +1,15 @@
MODULE MODI_BITREP
+!
+! MODIFICATIONS
+! -------------
+! J.Escobar : 12/08/2020: for ifort18 , add intent(in) on pure function
+!-----------------------------------------------------------------
!
USE, INTRINSIC :: ISO_C_BINDING
!
IMPLICIT NONE
+
+ REAL , PARAMETER, PRIVATE :: XPI = 3.1415926535897932384626433832795
!
CONTAINS
!
@@ -16,8 +23,8 @@ INTERFACE
PURE FUNCTION BR_ATAN_C(PIN) BIND(C,NAME="br_atan")
!$acc routine seq
IMPORT C_DOUBLE
- REAL(KIND=C_DOUBLE) :: BR_ATAN_C
- REAL(KIND=C_DOUBLE),VALUE :: PIN
+ REAL(KIND=C_DOUBLE) :: BR_ATAN_C
+ REAL(KIND=C_DOUBLE),VALUE,INTENT(IN) :: PIN
END FUNCTION
END INTERFACE
!
@@ -36,8 +43,8 @@ INTERFACE
PURE FUNCTION BR_EXP_C(PIN) BIND(C,NAME="br_exp")
!$acc routine seq
IMPORT C_DOUBLE
- REAL(KIND=C_DOUBLE) :: BR_EXP_C
- REAL(KIND=C_DOUBLE),VALUE :: PIN
+ REAL(KIND=C_DOUBLE) :: BR_EXP_C
+ REAL(KIND=C_DOUBLE),VALUE,INTENT(IN) :: PIN
END FUNCTION
END INTERFACE
!
@@ -56,8 +63,8 @@ INTERFACE
PURE FUNCTION BR_LOG_C(PIN) BIND(C,NAME="br_log")
!$acc routine seq
IMPORT C_DOUBLE
- REAL(KIND=C_DOUBLE) :: BR_LOG_C
- REAL(KIND=C_DOUBLE),VALUE :: PIN
+ REAL(KIND=C_DOUBLE) :: BR_LOG_C
+ REAL(KIND=C_DOUBLE),VALUE,INTENT(IN) :: PIN
END FUNCTION
END INTERFACE
!
@@ -107,4 +114,87 @@ BR_P4 = PVAL * PVAL * PVAL * PVAL
!
END FUNCTION BR_P4
!
+ELEMENTAL FUNCTION BR_SIN(PVAL)
+!$acc routine seq
+!
+REAL, INTENT(IN) :: PVAL
+REAL :: BR_SIN
+!
+INTERFACE
+ PURE FUNCTION BR_SIN_C(PIN) BIND(C,NAME="br_sin")
+!$acc routine seq
+ IMPORT C_DOUBLE
+ REAL(KIND=C_DOUBLE) :: BR_SIN_C
+ REAL(KIND=C_DOUBLE),VALUE,INTENT(IN) :: PIN
+ END FUNCTION
+END INTERFACE
+!
+BR_SIN = BR_SIN_C(REAL(PVAL,KIND=C_DOUBLE))
+!
+END FUNCTION BR_SIN
+!
+ELEMENTAL FUNCTION BR_ASIN(PVAL)
+!$acc routine seq
+!
+REAL, INTENT(IN) :: PVAL
+REAL :: BR_ASIN
+!
+INTERFACE
+ PURE FUNCTION BR_ASIN_C(PIN) BIND(C,NAME="br_asin")
+!$acc routine seq
+ IMPORT C_DOUBLE
+ REAL(KIND=C_DOUBLE) :: BR_ASIN_C
+ REAL(KIND=C_DOUBLE),VALUE,INTENT(IN) :: PIN
+ END FUNCTION
+END INTERFACE
+!
+BR_ASIN = BR_ASIN_C(REAL(PVAL,KIND=C_DOUBLE))
+!
+END FUNCTION BR_ASIN
+!
+ELEMENTAL FUNCTION BR_COS(PVAL)
+!$acc routine seq
+!
+REAL, INTENT(IN) :: PVAL
+REAL :: BR_COS
+!
+INTERFACE
+ PURE FUNCTION BR_COS_C(PIN) BIND(C,NAME="br_cos")
+!$acc routine seq
+ IMPORT C_DOUBLE
+ REAL(KIND=C_DOUBLE) :: BR_COS_C
+ REAL(KIND=C_DOUBLE),VALUE,INTENT(IN) :: PIN
+ END FUNCTION
+END INTERFACE
+!
+BR_COS = BR_COS_C(REAL(PVAL,KIND=C_DOUBLE))
+!
+END FUNCTION BR_COS
+!
+ELEMENTAL FUNCTION BR_ATAN2(PA,PB)
+!$acc routine seq
+!
+REAL, INTENT(IN) :: PA,PB
+REAL :: BR_ATAN2
+!
+if (PB > 0.0) then
+ BR_ATAN2 = br_atan(PA/PB);
+
+else if ((PB < 0.0) .and. (PA >= 0.0)) then
+ BR_ATAN2 = br_atan(PA/PB) + XPI;
+
+else if ((PB < 0.0) .and. (PA < 0.0)) then
+ BR_ATAN2 = br_atan(PA/PB) - XPI;
+
+else if ((PB == 0.0) .and. (PA > 0.0)) then
+ BR_ATAN2 = XPI / 2.0 ;
+
+else if ((PB == 0.0) .and. (PA < 0.0)) then
+ BR_ATAN2 = 0.0 - (XPI / 2.0 );
+
+else if ((PB == 0.0) .and. (PA == 0.0)) then
+ BR_ATAN2 = 0; ! represents undefined
+end if
+!
+ END FUNCTION BR_ATAN2
END MODULE MODI_BITREP
diff --git a/src/LIB/SURCOUCHE/src/mode_device.f90 b/src/LIB/SURCOUCHE/src/mode_device.f90
index 4fabf5c9884c2ec2dafa859a7ef8f72049c90548..6b56e3921fdcedad18eefe96810f1ae26121d7b1 100644
--- a/src/LIB/SURCOUCHE/src/mode_device.f90
+++ b/src/LIB/SURCOUCHE/src/mode_device.f90
@@ -245,6 +245,8 @@ CONTAINS
REAL :: ZVALUE
CHARACTER(LEN=:),ALLOCATABLE :: YNAME
+ RETURN
+
IF (PRESENT(PVALUE)) THEN
ZVALUE = PVALUE
ELSE
@@ -294,6 +296,8 @@ print *,'Initializing ',trim(YNAME),' on host'
REAL :: ZVALUE
CHARACTER(LEN=:),ALLOCATABLE :: YNAME
+ RETURN
+
IF (PRESENT(PVALUE)) THEN
ZVALUE = PVALUE
ELSE
@@ -343,6 +347,8 @@ print *,'Initializing ',trim(YNAME),' on host'
REAL :: ZVALUE
CHARACTER(LEN=:),ALLOCATABLE :: YNAME
+ RETURN
+
IF (PRESENT(PVALUE)) THEN
ZVALUE = PVALUE
ELSE
diff --git a/src/LIB/SURCOUCHE/src/mode_mnh_world.f90 b/src/LIB/SURCOUCHE/src/mode_mnh_world.f90
index 06d027e8a59ef393d3fb925c5948316a41d92bd0..7047c45b8500d3fb44e51210305b753b139e27e8 100644
--- a/src/LIB/SURCOUCHE/src/mode_mnh_world.f90
+++ b/src/LIB/SURCOUCHE/src/mode_mnh_world.f90
@@ -35,6 +35,7 @@ CONTAINS
!JUANZ
#ifdef MNH_OPENACC
USE OPENACC
+ USE MODE_OPENACC_SET_DEVICE
#endif
!USE IEEE_ARITHMETIC
@@ -57,6 +58,11 @@ CONTAINS
!JUANZ
INTEGER :: ILU
+#ifdef MNH_OPENACC
+ CHARACTER(LEN=28) :: CID_GPU
+ INTEGER :: ID_GPU,N_GPU
+#endif
+
#if 0
!Try to initialise device memory by creating a big array
REAL,dimension(:,:,:),allocatable :: big
@@ -77,6 +83,26 @@ CONTAINS
KINFO_ll = 0
CALL MPI_INITIALIZED(GISINIT, KINFO_ll)
IF (.NOT. GISINIT) THEN
+
+#ifdef MNH_OPENACC
+ !
+ ! I nvidia gpu set the good one <-> ACC_DEVICE_NUM
+ ! to avoid duplication of memory be allocating each mpi task all GPU
+ !
+ N_GPU = acc_get_num_devices(acc_device_nvidia)
+ IF ( N_GPU > 0 ) THEN
+ CALL GET_ENVIRONMENT_VARIABLE("ACC_DEVICE_NUM",CID_GPU)
+ read(CID_GPU,'(I5)') ID_GPU
+ print*,"CID_GPU=",CID_GPU," ID_GPU=",ID_GPU
+ CALL acc_set_device_num(ID_GPU,acc_device_nvidia)
+ !
+ ! get current device type for bug in atomic / nvhpc21.X
+ CALL MNH_OPENACC_GET_DEVICE_AT_INIT()
+ !
+ END IF
+!!$ ! acc init
+#endif
+
#ifdef MNH_GA
CALL MPI_INIT(KINFO_ll)
#else
diff --git a/src/LIB/SURCOUCHE/src/mode_mppdb.f90 b/src/LIB/SURCOUCHE/src/mode_mppdb.f90
index 47073588d50647e110bda3700ea3c3948c663600..28b3d7cbbb229b182a0f30d753e5def5ab16b47e 100644
--- a/src/LIB/SURCOUCHE/src/mode_mppdb.f90
+++ b/src/LIB/SURCOUCHE/src/mode_mppdb.f90
@@ -1164,7 +1164,8 @@ MODULE MODE_MPPDB
REAL :: ZPRECISION
REAL,DIMENSION(NMAXPAS) :: MAX_DIFF, MAX_VAL
REAL,DIMENSION(SIZE(PTAB,1),SIZE(PTAB,2),SIZE(PTAB,3)) :: ZTAB
- REAL,DIMENSION(:,:,:),ALLOCATABLE,TARGET :: TAB_ll,TAB_SON_ll
+ REAL,DIMENSION(:,:,:,:),ALLOCATABLE,TARGET :: TAB_ll
+ REAL,DIMENSION(:,:,:),ALLOCATABLE,TARGET :: TAB_SON_ll
#ifdef MNH_SP4
!pas de mpi_spawn sur IBM-SP ni MPI_ARGV_NULL etc ...
@@ -1227,8 +1228,8 @@ MODULE MODE_MPPDB
IIU_ll = IIMAX_ll+2*JPHEXT
IJU_ll = IJMAX_ll+2*JPHEXT
IKU_ll = SIZE(PTAB,3)
- IF (.NOT. ALLOCATED(TAB_ll)) ALLOCATE(TAB_ll(IIU_ll,IJU_ll,IKU_ll))
- CALL GATHERALL_FIELD_ll('XY',ZTAB,TAB_ll,IINFO_ll)
+ IF (.NOT. ALLOCATED(TAB_ll)) ALLOCATE(TAB_ll(IIU_ll,IJU_ll,IKU_ll,NPAS_ll))
+ CALL GATHERALL_FIELD_ll('XY',ZTAB,TAB_ll(:,:,:,IPAS),IINFO_ll)
IF (MPPDB_IRANK_WORLD.EQ.0) THEN
!
@@ -1255,18 +1256,18 @@ MODULE MODE_MPPDB
CALL MPI_RECV(TAB_SON_ll,SIZE(TAB_SON_ll),MNHREAL_MPI,I_FIRST_SON, &
NTAG,MPPDB_INTRA_COMM,MPI_STATUS_IGNORE,IINFO_ll)
!
- TAB_ll = ABS ( TAB_ll - TAB_SON_ll )
+ TAB_ll(:,:,:,IPAS) = ABS ( TAB_ll(:,:,:,IPAS) - TAB_SON_ll(:,:,:) )
!
! Set corners values to zero if we want to check the halos without the corners
IF ( MPPDB_CHECK_LB .AND. .NOT.MPPDB_CHECK_LB_CORNERS ) THEN
- TAB_ll(1:JPHEXT, 1:JPHEXT, 1:IKU_ll) = 0d0
- TAB_ll(1:JPHEXT, 1:JPHEXT, 1:IKU_ll) = 0d0
- TAB_ll(1:JPHEXT, IJU_ll-JPHEXT:IJU_ll, 1:IKU_ll) = 0d0
- TAB_ll(1:JPHEXT, IJU_ll-JPHEXT:IJU_ll, 1:IKU_ll) = 0d0
- TAB_ll(IIU_ll-JPHEXT:IIU_ll, 1:JPHEXT, 1:IKU_ll) = 0d0
- TAB_ll(IIU_ll-JPHEXT:IIU_ll, 1:JPHEXT, 1:IKU_ll) = 0d0
- TAB_ll(IIU_ll-JPHEXT:IIU_ll, IJU_ll-JPHEXT:IJU_ll, 1:IKU_ll) = 0d0
- TAB_ll(IIU_ll-JPHEXT:IIU_ll, IJU_ll-JPHEXT:IJU_ll, 1:IKU_ll) = 0d0
+ TAB_ll(1:JPHEXT, 1:JPHEXT, 1:IKU_ll,IPAS) = 0d0
+ TAB_ll(1:JPHEXT, 1:JPHEXT, 1:IKU_ll,IPAS) = 0d0
+ TAB_ll(1:JPHEXT, IJU_ll-JPHEXT:IJU_ll, 1:IKU_ll,IPAS) = 0d0
+ TAB_ll(1:JPHEXT, IJU_ll-JPHEXT:IJU_ll, 1:IKU_ll,IPAS) = 0d0
+ TAB_ll(IIU_ll-JPHEXT:IIU_ll, 1:JPHEXT, 1:IKU_ll,IPAS) = 0d0
+ TAB_ll(IIU_ll-JPHEXT:IIU_ll, 1:JPHEXT, 1:IKU_ll,IPAS) = 0d0
+ TAB_ll(IIU_ll-JPHEXT:IIU_ll, IJU_ll-JPHEXT:IJU_ll, 1:IKU_ll,IPAS) = 0d0
+ TAB_ll(IIU_ll-JPHEXT:IIU_ll, IJU_ll-JPHEXT:IJU_ll, 1:IKU_ll,IPAS) = 0d0
TAB_SON_ll(1:JPHEXT, 1:JPHEXT, 1:IKU_ll) = 0d0
TAB_SON_ll(1:JPHEXT, 1:JPHEXT, 1:IKU_ll) = 0d0
TAB_SON_ll(1:JPHEXT, IJU_ll-JPHEXT:IJU_ll, 1:IKU_ll) = 0d0
@@ -1290,7 +1291,7 @@ MODULE MODE_MPPDB
MAX_VAL(IPAS) = MAXVAL( ABS (TAB_SON_ll(IIB_SON_ll-IDIFF_HEXT:IIE_SON_ll+IDIFF_HEXT,&
IJB_SON_ll-IDIFF_HEXT:IJE_SON_ll+IDIFF_HEXT,1:IKU_SON_ll) ) )
- MAX_DIFF(IPAS) = MAXVAL( TAB_ll(IIB_ll-IDIFF_HEXT:IIE_ll+IDIFF_HEXT,IJB_ll-IDIFF_HEXT:IJE_ll+IDIFF_HEXT,1:IKU_ll))
+ MAX_DIFF(IPAS) = MAXVAL( TAB_ll(IIB_ll-IDIFF_HEXT:IIE_ll+IDIFF_HEXT,IJB_ll-IDIFF_HEXT:IJE_ll+IDIFF_HEXT,1:IKU_ll,IPAS))
!
IF ( MAX_VAL(IPAS) .EQ. 0.0 ) THEN
ZDIV=1.0
@@ -1306,7 +1307,7 @@ MODULE MODE_MPPDB
END IF
!flush(unit=OUTPUT_UNIT)
!
- DEALLOCATE(TAB_ll,TAB_SON_ll)
+ !DEALLOCATE(TAB_ll,TAB_SON_ll)
!
END IF
ELSE
@@ -1317,8 +1318,8 @@ MODULE MODE_MPPDB
IIU_ll = IIMAX_ll+2*JPHEXT
IJU_ll = IJMAX_ll+2*JPHEXT
IKU_ll = SIZE(PTAB,3)
- IF (.NOT. ALLOCATED(TAB_ll)) ALLOCATE(TAB_ll(IIU_ll,IJU_ll,IKU_ll))
- CALL GATHERALL_FIELD_ll('XY',ZTAB,TAB_ll,IINFO_ll)
+ IF (.NOT. ALLOCATED(TAB_ll)) ALLOCATE(TAB_ll(IIU_ll,IJU_ll,IKU_ll,NPAS_ll))
+ CALL GATHERALL_FIELD_ll('XY',ZTAB,TAB_ll(:,:,:,IPAS),IINFO_ll)
!
! SON WORLD
!
@@ -1331,7 +1332,7 @@ MODULE MODE_MPPDB
CALL MPI_BSEND(IHEXT_SON_ll,1,MNHINT_MPI,I_FIRST_FATHER, &
NTAG, MPPDB_INTRA_COMM, IINFO_ll)
- CALL MPI_BSEND(TAB_ll,SIZE(TAB_ll),MNHREAL_MPI,I_FIRST_FATHER, &
+ CALL MPI_BSEND(TAB_ll(:,:,:,IPAS),SIZE(TAB_ll(:,:,:,IPAS)),MNHREAL_MPI,I_FIRST_FATHER, &
NTAG, MPPDB_INTRA_COMM, IINFO_ll)
END IF
END IF
@@ -1402,6 +1403,7 @@ MODULE MODE_MPPDB
ELSE
CALL PRINT_MSG(NVERB_WARNING,'GEN','MPPDB_CHECK3D_REAL','NPAS_ll>2 not (yet) implemented')
END IF
+ DEALLOCATE(TAB_ll,TAB_SON_ll)
END IF
#endif
END SUBROUTINE MPPDB_CHECK3D_REAL
@@ -1666,7 +1668,7 @@ MODULE MODE_MPPDB
OK(IPAS) = .TRUE.
END IF
!
- DEALLOCATE(TAB_ll,TAB_SON_ll)
+ !DEALLOCATE(TAB_ll,TAB_SON_ll)
!
END IF
ELSE
@@ -1774,6 +1776,7 @@ MODULE MODE_MPPDB
ELSE
CALL PRINT_MSG(NVERB_WARNING,'GEN','MPPDB_CHECK2D_REAL','NPAS_ll>2 not (yet) implemented')
END IF
+ DEALLOCATE(TAB_ll,TAB_SON_ll)
END IF
#endif
END SUBROUTINE MPPDB_CHECK2D_REAL
diff --git a/src/MNH/advection_metsv.f90 b/src/MNH/advection_metsv.f90
index 6988a5a4f8ce4842fdda9543a6ffa8808287a3f7..4d98bbde12095e7dc982a4fdcba7b870b906bb14 100644
--- a/src/MNH/advection_metsv.f90
+++ b/src/MNH/advection_metsv.f90
@@ -174,7 +174,8 @@ use mode_argslist_ll, only: ADD3DFIELD_ll, ADD4DFIELD_ll, CLEANLIST_ll, LIST_
use mode_budget, only: Budget_store_init, Budget_store_end
#ifdef MNH_OPENACC
USE MODE_DEVICE
-USE MODE_MNH_ZWORK, ONLY : ZT3D, MNH_GET_ZT3D , MNH_REL_ZT3D
+USE MODE_MNH_ZWORK, ONLY: MNH_ALLOCATE_ZT3D, MNH_ALLOCATE_ZT4D, MNH_CHECK_IN_ZT3D, MNH_CHECK_OUT_ZT3D, &
+ MNH_GET_ZT3D, MNH_REL_ZT3D, MNH_REL_ZT4D, ZT3D
#endif
use mode_exchange_ll, only: UPDATE_HALO_ll
USE MODE_IO_FIELD_WRITE, only: IO_Field_write
@@ -242,45 +243,64 @@ REAL, DIMENSION(:,:,:), INTENT(OUT) :: PRTKES_ADV ! Advection TKE source te
!* 0.2 declarations of local variables
!
!
-REAL, DIMENSION(:,:,:),allocatable :: ZRUCPPM
-REAL, DIMENSION(:,:,:),allocatable :: ZRVCPPM
-REAL, DIMENSION(:,:,:),allocatable :: ZRWCPPM
+REAL, DIMENSION(:,:,:),pointer , contiguous :: ZRUCPPM
+REAL, DIMENSION(:,:,:),pointer , contiguous :: ZRVCPPM
+REAL, DIMENSION(:,:,:),pointer , contiguous :: ZRWCPPM
! contravariant
! components
! of momentum
-REAL, DIMENSION(:,:,:),allocatable :: ZCFLU
-REAL, DIMENSION(:,:,:),allocatable :: ZCFLV
-REAL, DIMENSION(:,:,:),allocatable :: ZCFLW
+REAL, DIMENSION(:,:,:),pointer , contiguous :: ZCFLU
+REAL, DIMENSION(:,:,:),pointer , contiguous :: ZCFLV
+REAL, DIMENSION(:,:,:),pointer , contiguous :: ZCFLW
! ! CFL numbers on each direction
-REAL, DIMENSION(:,:,:),allocatable :: ZCFL
+REAL, DIMENSION(:,:,:),pointer , contiguous :: ZCFL
! ! CFL number
+#ifdef MNH_OPENACC
+INTEGER :: IZRUCPPM,IZRVCPPM,IZRWCPPM,IZCFLU,IZCFLV,IZCFLW,IZCFL
+#endif
!
REAL :: ZCFLU_MAX, ZCFLV_MAX, ZCFLW_MAX, ZCFL_MAX ! maximum CFL numbers
!
-REAL, DIMENSION(:,:,:),allocatable :: ZTH
-REAL, DIMENSION(:,:,:),allocatable :: ZTKE
-REAL, DIMENSION(:,:,:),allocatable :: ZRTHS_OTHER
-REAL, DIMENSION(:,:,:),allocatable :: ZRTKES_OTHER
-REAL, DIMENSION(:,:,:),allocatable :: ZRTHS_PPM
-REAL, DIMENSION(:,:,:),allocatable :: ZRTKES_PPM
-REAL, DIMENSION(:,:,:,:),allocatable :: ZR
-REAL, DIMENSION(:,:,:,:),allocatable :: ZSV
-REAL, DIMENSION(:,:,:,:),allocatable :: ZSNWC
-REAL, DIMENSION(:,:,:,:),allocatable :: ZSNWC_INIT
-REAL, DIMENSION(:,:,:,:),allocatable :: ZRSNWCS
+REAL, DIMENSION(:,:,:),pointer , contiguous :: ZTH
+REAL, DIMENSION(:,:,:),pointer , contiguous :: ZTKE
+REAL, DIMENSION(:,:,:),pointer , contiguous :: ZRTHS_OTHER
+REAL, DIMENSION(:,:,:),pointer , contiguous :: ZRTKES_OTHER
+REAL, DIMENSION(:,:,:),pointer , contiguous :: ZRTHS_PPM
+REAL, DIMENSION(:,:,:),pointer , contiguous :: ZRTKES_PPM
+#ifdef MNH_OPENACC
+INTEGER :: IZTH,IZTKE,IZRTHS_OTHER,IZRTKES_OTHER,IZRTHS_PPM,IZRTKES_PPM
+#endif
+REAL, DIMENSION(:,:,:,:),pointer , contiguous :: ZR
+REAL, DIMENSION(:,:,:,:),pointer , contiguous :: ZSV
+REAL, DIMENSION(:,:,:,:),pointer , contiguous :: ZSNWC
+REAL, DIMENSION(:,:,:,:),pointer , contiguous :: ZSNWC_INIT
+REAL, DIMENSION(:,:,:,:),pointer , contiguous :: ZRSNWCS
+#ifdef MNH_OPENACC
+INTEGER :: IZR,IZSV,IZSNWC,IZSNWC_INIT,IZRSNWCS
+#endif
! Guess at the sub time step
-REAL, DIMENSION(:,:,:,:),allocatable :: ZRRS_OTHER
-REAL, DIMENSION(:,:,:,:),allocatable :: ZRSVS_OTHER
-REAL, DIMENSION(:,:,:,:),allocatable :: ZRSNWCS_OTHER
+REAL, DIMENSION(:,:,:,:),pointer , contiguous :: ZRRS_OTHER
+REAL, DIMENSION(:,:,:,:),pointer , contiguous :: ZRSVS_OTHER
+REAL, DIMENSION(:,:,:,:),pointer , contiguous :: ZRSNWCS_OTHER
+#ifdef MNH_OPENACC
+INTEGER :: IZRRS_OTHER,IZRSVS_OTHER,IZRSNWCS_OTHER
+#endif
! Tendencies since the beginning of the time step
-REAL, DIMENSION(:,:,:,:),allocatable :: ZRRS_PPM
-REAL, DIMENSION(:,:,:,:),allocatable :: ZRSVS_PPM
-REAL, DIMENSION(:,:,:,:),allocatable :: ZRSNWCS_PPM
+REAL, DIMENSION(:,:,:,:),pointer , contiguous :: ZRRS_PPM
+REAL, DIMENSION(:,:,:,:),pointer , contiguous :: ZRSVS_PPM
+REAL, DIMENSION(:,:,:,:),pointer , contiguous :: ZRSNWCS_PPM
+#ifdef MNH_OPENACC
+INTEGER :: IZRRS_PPM,IZRSVS_PPM,IZRSNWCS_PPM
+#endif
! Guess at the end of the sub time step
-REAL, DIMENSION(:,:,:),allocatable :: ZRHOX1,ZRHOX2
-REAL, DIMENSION(:,:,:),allocatable :: ZRHOY1,ZRHOY2
-REAL, DIMENSION(:,:,:),allocatable :: ZRHOZ1,ZRHOZ2
-REAL, DIMENSION(:,:,:),allocatable :: ZT,ZEXN,ZLV,ZLS,ZCPH
+REAL, DIMENSION(:,:,:),pointer , contiguous :: ZRHOX1,ZRHOX2
+REAL, DIMENSION(:,:,:),pointer , contiguous :: ZRHOY1,ZRHOY2
+REAL, DIMENSION(:,:,:),pointer , contiguous :: ZRHOZ1,ZRHOZ2
+REAL, DIMENSION(:,:,:),pointer , contiguous :: ZT,ZEXN,ZLV,ZLS,ZCPH
+#ifdef MNH_OPENACC
+INTEGER :: IZRHOX1,IZRHOX2,IZRHOY1,IZRHOY2,IZRHOZ1,IZRHOZ2 &
+ ,IZT,IZEXN,IZLV,IZLS,IZCPH
+#endif
! Temporary advected rhodj for PPM routines
!
@@ -301,6 +321,9 @@ INTEGER :: IIB, IIE, IJB, IJE,IKB,IKE
INTEGER :: IZ1, IZ2
#endif
TYPE(TFIELDDATA) :: TZFIELD
+!
+INTEGER :: JIU,JJU,JKU
+INTEGER :: JK
!-------------------------------------------------------------------------------
!$acc data present( PUT, PVT, PWT, PTHT, PTKET, PRHODJ, PPABST, PRT, PSVT, PTHVREF, &
!$acc & PDXX, PDYY, PDZZ, PDZX, PDZY, PRTHS, PRTKES, PRRS, PRSVS, PRTHS_CLD, PRRS_CLD, PRSVS_CLD, PRTKES_ADV )
@@ -332,43 +355,87 @@ IF (MPPDB_INITIALIZED) THEN
CALL MPPDB_CHECK(PRSVS,"ADVECTION_METSV beg:PRSVS")
END IF
-allocate( ZRUCPPM ( SIZE(PUT, 1), SIZE(PUT, 2), SIZE(PUT, 3) ) )
-allocate( ZRVCPPM ( SIZE(PUT, 1), SIZE(PUT, 2), SIZE(PUT, 3) ) )
-allocate( ZRWCPPM ( SIZE(PUT, 1), SIZE(PUT, 2), SIZE(PUT, 3) ) )
-allocate( ZCFLU ( SIZE(PUT, 1), SIZE(PUT, 2), SIZE(PUT, 3) ) )
-allocate( ZCFLV ( SIZE(PUT, 1), SIZE(PUT, 2), SIZE(PUT, 3) ) )
-allocate( ZCFLW ( SIZE(PUT, 1), SIZE(PUT, 2), SIZE(PUT, 3) ) )
-allocate( ZCFL ( SIZE(PUT, 1), SIZE(PUT, 2), SIZE(PUT, 3) ) )
-allocate( ZTH ( SIZE(PTHT, 1), SIZE(PTHT, 2), SIZE(PTHT, 3) ) )
-allocate( ZTKE ( SIZE(PTKET,1), SIZE(PTKET,2), SIZE(PTKET,3) ) )
-allocate( ZRTHS_OTHER ( SIZE(PTHT, 1), SIZE(PTHT, 2), SIZE(PTHT, 3) ) )
-allocate( ZRTKES_OTHER ( SIZE(PTKET,1), SIZE(PTKET,2), SIZE(PTKET,3) ) )
-allocate( ZRTHS_PPM ( SIZE(PTHT, 1), SIZE(PTHT, 2), SIZE(PTHT, 3) ) )
-allocate( ZRTKES_PPM ( SIZE(PTKET,1), SIZE(PTKET,2), SIZE(PTKET,3) ) )
-allocate( ZR ( SIZE(PRT, 1), SIZE(PRT, 2), SIZE(PRT, 3), SIZE(PRT, 4) ) )
-allocate( ZSV ( SIZE(PSVT, 1), SIZE(PSVT, 2), SIZE(PSVT, 3), SIZE(PSVT,4) ) )
-allocate( ZSNWC ( SIZE(PSVT, 1), SIZE(PSVT, 2), SIZE(PSVT, 3), NBLOWSNOW_2D ) )
-allocate( ZSNWC_INIT ( SIZE(PSVT, 1), SIZE(PSVT, 2), SIZE(PSVT, 3), NBLOWSNOW_2D ) )
-allocate( ZRSNWCS ( SIZE(PSVT, 1), SIZE(PSVT, 2), SIZE(PSVT, 3), NBLOWSNOW_2D ) )
-allocate( ZRRS_OTHER ( SIZE(PRT, 1), SIZE(PRT, 2), SIZE(PRT, 3), SIZE(PRT, 4) ) )
-allocate( ZRSVS_OTHER ( SIZE(PSVT, 1), SIZE(PSVT, 2), SIZE(PSVT, 3), SIZE(PSVT,4) ) )
-allocate( ZRSNWCS_OTHER( SIZE(PSVT, 1), SIZE(PSVT, 2), SIZE(PSVT, 3), NBLOWSNOW_2D ) )
-allocate( ZRRS_PPM ( SIZE(PRT, 1), SIZE(PRT, 2), SIZE(PRT, 3), SIZE(PRT, 4) ) )
-allocate( ZRSVS_PPM ( SIZE(PSVT, 1), SIZE(PSVT, 2), SIZE(PSVT, 3), SIZE(PSVT,4) ) )
-allocate( ZRSNWCS_PPM ( SIZE(PSVT, 1), SIZE(PSVT, 2), SIZE(PSVT, 3), NBLOWSNOW_2D ) )
-allocate( ZRHOX1 ( SIZE(PUT, 1), SIZE(PUT, 2), SIZE(PUT, 3) ) )
-allocate( ZRHOX2 ( SIZE(PUT, 1), SIZE(PUT, 2), SIZE(PUT, 3) ) )
-allocate( ZRHOY1 ( SIZE(PUT, 1), SIZE(PUT, 2), SIZE(PUT, 3) ) )
-allocate( ZRHOY2 ( SIZE(PUT, 1), SIZE(PUT, 2), SIZE(PUT, 3) ) )
-allocate( ZRHOZ1 ( SIZE(PUT, 1), SIZE(PUT, 2), SIZE(PUT, 3) ) )
-allocate( ZRHOZ2 ( SIZE(PUT, 1), SIZE(PUT, 2), SIZE(PUT, 3) ) )
-allocate( ZT ( SIZE(PUT, 1), SIZE(PUT, 2), SIZE(PUT, 3) ) )
-allocate( ZEXN ( SIZE(PUT, 1), SIZE(PUT, 2), SIZE(PUT, 3) ) )
-allocate( ZLV ( SIZE(PUT, 1), SIZE(PUT, 2), SIZE(PUT, 3) ) )
-allocate( ZLS ( SIZE(PUT, 1), SIZE(PUT, 2), SIZE(PUT, 3) ) )
-allocate( ZCPH ( SIZE(PUT, 1), SIZE(PUT, 2), SIZE(PUT, 3) ) )
+JIU = size(PUT, 1 )
+JJU = size(PUT, 2 )
+JKU = size(PUT, 3 )
+
+
+#ifndef MNH_OPENACC
+allocate( ZRUCPPM ( JIU,JJU,JKU ) )
+allocate( ZRVCPPM ( JIU,JJU,JKU ) )
+allocate( ZRWCPPM ( JIU,JJU,JKU ) )
+allocate( ZCFLU ( JIU,JJU,JKU ) )
+allocate( ZCFLV ( JIU,JJU,JKU ) )
+allocate( ZCFLW ( JIU,JJU,JKU ) )
+allocate( ZCFL ( JIU,JJU,JKU ) )
+allocate( ZTH ( JIU,JJU,JKU ) )
+allocate( ZTKE ( JIU,JJU,SIZE(PTKET,3)) )
+allocate( ZRTHS_OTHER ( JIU,JJU,JKU ) )
+allocate( ZRTKES_OTHER ( JIU,JJU,SIZE(PTKET,3)) )
+allocate( ZRTHS_PPM ( JIU,JJU,JKU ) )
+allocate( ZRTKES_PPM ( JIU,JJU,SIZE(PTKET,3)) )
+allocate( ZR ( JIU,JJU,JKU, SIZE(PRT, 4) ) )
+allocate( ZSV ( JIU,JJU,JKU, SIZE(PSVT,4) ) )
+allocate( ZSNWC ( JIU,JJU,JKU, NBLOWSNOW_2D ) )
+allocate( ZSNWC_INIT ( JIU,JJU,JKU, NBLOWSNOW_2D ) )
+allocate( ZRSNWCS ( JIU,JJU,JKU, NBLOWSNOW_2D ) )
+allocate( ZRRS_OTHER ( JIU,JJU,JKU, SIZE(PRT, 4) ) )
+allocate( ZRSVS_OTHER ( JIU,JJU,JKU, SIZE(PSVT,4) ) )
+allocate( ZRSNWCS_OTHER( JIU,JJU,JKU, NBLOWSNOW_2D ) )
+allocate( ZRRS_PPM ( JIU,JJU,JKU, SIZE(PRT, 4) ) )
+allocate( ZRSVS_PPM ( JIU,JJU,JKU, SIZE(PSVT,4) ) )
+allocate( ZRSNWCS_PPM ( JIU,JJU,JKU, NBLOWSNOW_2D ) )
+allocate( ZRHOX1 ( JIU,JJU,JKU ) )
+allocate( ZRHOX2 ( JIU,JJU,JKU ) )
+allocate( ZRHOY1 ( JIU,JJU,JKU ) )
+allocate( ZRHOY2 ( JIU,JJU,JKU ) )
+allocate( ZRHOZ1 ( JIU,JJU,JKU ) )
+allocate( ZRHOZ2 ( JIU,JJU,JKU ) )
+allocate( ZT ( JIU,JJU,JKU ) )
+allocate( ZEXN ( JIU,JJU,JKU ) )
+allocate( ZLV ( JIU,JJU,JKU ) )
+allocate( ZLS ( JIU,JJU,JKU ) )
+allocate( ZCPH ( JIU,JJU,JKU ) )
+#else
+CALL MNH_CHECK_IN_ZT3D("ADVECTION_METSV")
+IZRUCPPM = MNH_ALLOCATE_ZT3D( ZRUCPPM , JIU,JJU,JKU )
+IZRVCPPM = MNH_ALLOCATE_ZT3D( ZRVCPPM , JIU,JJU,JKU )
+IZRWCPPM = MNH_ALLOCATE_ZT3D( ZRWCPPM , JIU,JJU,JKU )
+IZCFLU = MNH_ALLOCATE_ZT3D( ZCFLU , JIU,JJU,JKU )
+IZCFLV = MNH_ALLOCATE_ZT3D( ZCFLV , JIU,JJU,JKU )
+IZCFLW = MNH_ALLOCATE_ZT3D( ZCFLW , JIU,JJU,JKU )
+IZCFL = MNH_ALLOCATE_ZT3D( ZCFL , JIU,JJU,JKU )
+IZTH = MNH_ALLOCATE_ZT3D( ZTH , JIU,JJU,JKU )
+IZTKE = MNH_ALLOCATE_ZT3D( ZTKE , JIU,JJU,SIZE(PTKET,3) )
+IZRTHS_OTHER = MNH_ALLOCATE_ZT3D( ZRTHS_OTHER , JIU,JJU,JKU )
+IZRTKES_OTHER = MNH_ALLOCATE_ZT3D( ZRTKES_OTHER , JIU,JJU,SIZE(PTKET,3) )
+IZRTHS_PPM = MNH_ALLOCATE_ZT3D( ZRTHS_PPM , JIU,JJU,JKU )
+IZRTKES_PPM = MNH_ALLOCATE_ZT3D( ZRTKES_PPM , JIU,JJU,SIZE(PTKET,3) )
+IZR = MNH_ALLOCATE_ZT4D( ZR , JIU,JJU,JKU, SIZE(PRT, 4) )
+IZSV = MNH_ALLOCATE_ZT4D( ZSV , JIU,JJU,JKU, SIZE(PSVT,4) )
+IZSNWC = MNH_ALLOCATE_ZT4D( ZSNWC , JIU,JJU,JKU, NBLOWSNOW_2D )
+IZSNWC_INIT = MNH_ALLOCATE_ZT4D( ZSNWC_INIT , JIU,JJU,JKU, NBLOWSNOW_2D )
+IZRSNWCS = MNH_ALLOCATE_ZT4D( ZRSNWCS , JIU,JJU,JKU, NBLOWSNOW_2D )
+IZRRS_OTHER = MNH_ALLOCATE_ZT4D( ZRRS_OTHER , JIU,JJU,JKU, SIZE(PRT, 4) )
+IZRSVS_OTHER = MNH_ALLOCATE_ZT4D( ZRSVS_OTHER , JIU,JJU,JKU, SIZE(PSVT,4) )
+IZRSNWCS_OTHER = MNH_ALLOCATE_ZT4D( ZRSNWCS_OTHER, JIU,JJU,JKU, NBLOWSNOW_2D )
+IZRRS_PPM = MNH_ALLOCATE_ZT4D( ZRRS_PPM , JIU,JJU,JKU, SIZE(PRT, 4) )
+IZRSVS_PPM = MNH_ALLOCATE_ZT4D( ZRSVS_PPM , JIU,JJU,JKU, SIZE(PSVT,4) )
+IZRSNWCS_PPM = MNH_ALLOCATE_ZT4D( ZRSNWCS_PPM , JIU,JJU,JKU, NBLOWSNOW_2D )
+IZRHOX1 = MNH_ALLOCATE_ZT3D( ZRHOX1 , JIU,JJU,JKU )
+IZRHOX2 = MNH_ALLOCATE_ZT3D( ZRHOX2 , JIU,JJU,JKU )
+IZRHOY1 = MNH_ALLOCATE_ZT3D( ZRHOY1 , JIU,JJU,JKU )
+IZRHOY2 = MNH_ALLOCATE_ZT3D( ZRHOY2 , JIU,JJU,JKU )
+IZRHOZ1 = MNH_ALLOCATE_ZT3D( ZRHOZ1 , JIU,JJU,JKU )
+IZRHOZ2 = MNH_ALLOCATE_ZT3D( ZRHOZ2 , JIU,JJU,JKU )
+IZT = MNH_ALLOCATE_ZT3D( ZT , JIU,JJU,JKU )
+IZEXN = MNH_ALLOCATE_ZT3D( ZEXN , JIU,JJU,JKU )
+IZLV = MNH_ALLOCATE_ZT3D( ZLV , JIU,JJU,JKU )
+IZLS = MNH_ALLOCATE_ZT3D( ZLS , JIU,JJU,JKU )
+IZCPH = MNH_ALLOCATE_ZT3D( ZCPH , JIU,JJU,JKU )
+#endif
-!$acc data create( ZRUCPPM, ZRVCPPM, ZRWCPPM, ZCFLU, ZCFLV, ZCFLW, ZCFL, ZTH, &
+!$acc data present( ZRUCPPM, ZRVCPPM, ZRWCPPM, ZCFLU, ZCFLV, ZCFLW, ZCFL, ZTH, &
!$acc & ZTKE, ZRTHS_OTHER, ZRTKES_OTHER, ZRTHS_PPM, ZRTKES_PPM, &
!$acc & ZR, ZSV, ZSNWC, ZSNWC_INIT, ZRSNWCS, ZRRS_OTHER, ZRSVS_OTHER, ZRSNWCS_OTHER, &
!$acc & ZRRS_PPM, ZRSVS_PPM, ZRSNWCS_PPM, ZRHOX1, ZRHOX2, ZRHOY1, ZRHOY2, ZRHOZ1, ZRHOZ2, &
@@ -473,8 +540,9 @@ END IF
!* 2.2 computes CFL numbers
!
!PW: not necessary: data already on device due to contrav_device !$acc update device(ZRUCPPM,ZRVCPPM,ZRWCPPM)
-!$acc kernels
+! acc kernels
IF (.NOT. L1D) THEN
+ !$acc kernels
ZCFLU(:,:,:) = 0.0 ; ZCFLV(:,:,:) = 0.0 ; ZCFLW(:,:,:) = 0.0
ZCFLU(IIB:IIE,IJB:IJE,:) = ABS(ZRUCPPM(IIB:IIE,IJB:IJE,:) * PTSTEP)
ZCFLV(IIB:IIE,IJB:IJE,:) = ABS(ZRVCPPM(IIB:IIE,IJB:IJE,:) * PTSTEP)
@@ -499,29 +567,49 @@ IF (.NOT. L1D) THEN
WHERE (XIBM_LS(IIB:IIE,IJB:IJE,:,3).GT.(-XIBM_EPSI)) ZCFLV(IIB:IIE,IJB:IJE,:)=0.
WHERE (XIBM_LS(IIB:IIE,IJB:IJE,:,4).GT.(-XIBM_EPSI)) ZCFLW(IIB:IIE,IJB:IJE,:)=0.
ENDIF
+ !$acc end kernels
#ifndef MNH_BITREP
IF (.NOT. L2D) THEN
- ZCFL(:,:,:) = SQRT(ZCFLU(:,:,:)**2+ZCFLV(:,:,:)**2+ZCFLW(:,:,:)**2)
+ !$acc kernels
+ ZCFL(:,:,:) = SQRT(ZCFLU(:,:,:)**2+ZCFLV(:,:,:)**2+ZCFLW(:,:,:)**2)
+ !$acc end kernels
ELSE
- ZCFL(:,:,:) = SQRT(ZCFLU(:,:,:)**2+ZCFLW(:,:,:)**2)
+ !$acc kernels
+ ZCFL(:,:,:) = SQRT(ZCFLU(:,:,:)**2+ZCFLW(:,:,:)**2)
+ !$acc end kernels
END IF
#else
IF (.NOT. L2D) THEN
- ZCFL(:,:,:) = SQRT(BR_P2(ZCFLU(:,:,:))+BR_P2(ZCFLV(:,:,:))+BR_P2(ZCFLW(:,:,:)))
+ !$acc kernels
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU )
+ ZCFL(JI,JJ,JK) = SQRT(BR_P2(ZCFLU(JI,JJ,JK))+BR_P2(ZCFLV(JI,JJ,JK))+BR_P2(ZCFLW(JI,JJ,JK)))
+ END DO
+ !$acc end kernels
ELSE
- ZCFL(:,:,:) = SQRT(BR_P2(ZCFLU(:,:,:))+BR_P2(ZCFLW(:,:,:)))
+ !$acc kernels
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU )
+ ZCFL(JI,JJ,JK) = SQRT(BR_P2(ZCFLU(JI,JJ,JK))+BR_P2(ZCFLW(JI,JJ,JK)))
+ END DO
+ !$acc end kernels
END IF
-#endif
+#endif
ELSE
+ !$acc kernels
ZCFLU(:,:,:) = 0.0 ; ZCFLV(:,:,:) = 0.0 ; ZCFLW(:,:,:) = 0.0
ZCFLW(IIB:IIE,IJB:IJE,:) = ABS(ZRWCPPM(IIB:IIE,IJB:IJE,:) * PTSTEP)
#ifndef MNH_BITREP
ZCFL(:,:,:) = SQRT(ZCFLW(:,:,:)**2)
#else
- ZCFL(:,:,:) = SQRT(BR_P2(ZCFLW(:,:,:)))
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU )
+ ZCFL(JI,JJ,JK) = SQRT(BR_P2(ZCFLW(JI,JJ,JK)))
+ END DO
#endif
+ !$acc end kernels
END IF
-!$acc end kernels
+! acc end kernels
!
!* prints in the file the 3D Courant numbers (one should flag this)
!
@@ -721,6 +809,7 @@ END IF
!
! Exchanges on processors
!
+#ifndef MNH_OPENACC
NULLIFY(TZFIELDS0_ll)
!!$IF(NHALO == 1) THEN
CALL ADD3DFIELD_ll( TZFIELDS0_ll, ZRTHS_OTHER, 'ADVECTION_METSV::ZRTHS_OTHER' )
@@ -731,8 +820,23 @@ NULLIFY(TZFIELDS0_ll)
CALL UPDATE_HALO_ll(TZFIELDS0_ll,IINFO_ll)
CALL CLEANLIST_ll(TZFIELDS0_ll)
!!$END IF
-!PW: TODO: update only what is needed...
-!$acc update device(ZRTHS_OTHER,ZRTKES_OTHER,ZRRS_OTHER,ZRSVS_OTHER)
+#else
+ CALL GET_HALO_D(ZRTHS_OTHER, HNAME='ADVECTION_METSV::ZRTHS_OTHER')
+ IF (GTKE) CALL GET_HALO_D(ZRTKES_OTHER,HNAME='ADVECTION_METSV::ZRTKES_OTHER')
+ DO JR=1,KRR
+ CALL GET_HALO_D(ZRRS_OTHER(:,:,:,JR),HNAME='ADVECTION_METSV::ZRRS_OTHER')
+ END DO
+ DO JSV = 1, KSV
+ CALL GET_HALO_D(ZRSVS_OTHER(:,:,:,JSV),HNAME='ADVECTION_METSV::ZRSVS_OTHER')
+ END DO
+ DO JSV = 1,NBLOWSNOW_2D
+ CALL GET_HALO_D(ZRSNWCS_OTHER(:,:,:,JSV),HNAME='ADVECTION_METSV::ZRSNWCS_OTHER')
+ END DO
+ !PW: TODO: update only what is needed...
+ ! acc update device(ZRTHS_OTHER,ZRTKES_OTHER,ZRRS_OTHER,ZRSVS_OTHER)
+#endif
+
+
!
!
@@ -748,11 +852,13 @@ CALL PPM_RHODJ(HLBCX,HLBCY, ZRUCPPM, ZRVCPPM, ZRWCPPM, &
!* values of the fields at the beginning of the time splitting loop
!$acc kernels
ZTH(:,:,:) = PTHT(:,:,:)
-ZTKE(:,:,:) = PTKET(:,:,:)
IF (KRR /=0 ) ZR(:,:,:,:) = PRT(:,:,:,:)
IF (KSV /=0 ) ZSV(:,:,:,:) = PSVT(:,:,:,:)
!
-IF (GTKE) PRTKES_ADV(:,:,:) = 0.
+IF (GTKE) THEN
+ PRTKES_ADV(:,:,:) = 0.
+ ZTKE(:,:,:) = PTKET(:,:,:)
+END IF
!$acc end kernels
!
IF(LBLOWSNOW) THEN
@@ -793,29 +899,44 @@ DO JSPL=1,KSPLIT
!
! Tendencies of PPM
!
-!$acc kernels
+! acc kernels
+ !$acc kernels
PRTHS(:,:,:) = PRTHS (:,:,:) + ZRTHS_PPM (:,:,:) / KSPLIT
IF (GTKE) PRTKES_ADV(:,:,:) = PRTKES_ADV(:,:,:) + ZRTKES_PPM(:,:,:) / KSPLIT
IF (KRR /=0) PRRS (:,:,:,:) = PRRS (:,:,:,:) + ZRRS_PPM (:,:,:,:) / KSPLIT
IF (KSV /=0 ) PRSVS (:,:,:,:) = PRSVS (:,:,:,:) + ZRSVS_PPM (:,:,:,:) / KSPLIT
+ !$acc end kernels
!
IF (JSPL<KSPLIT) THEN
!
! Guesses of the field inside the time splitting loop
!
+ !$acc kernels
ZTH(:,:,:) = ZTH(:,:,:) + ( ZRTHS_PPM(:,:,:) + ZRTHS_OTHER(:,:,:) + PRTHS_CLD(:,:,:)) * &
- ZTSTEP_PPM / PRHODJ(:,:,:)
- IF (GTKE) ZTKE(:,:,:) = ZTKE(:,:,:) + ( ZRTKES_PPM(:,:,:) + ZRTKES_OTHER(:,:,:) ) * ZTSTEP_PPM / PRHODJ(:,:,:)
- DO JR = 1, KRR
- ZR(:,:,:,JR) = ZR(:,:,:,JR) + ( ZRRS_PPM(:,:,:,JR) + ZRRS_OTHER(:,:,:,JR) + PRRS_CLD(:,:,:,JR) ) &
- * ZTSTEP_PPM / PRHODJ(:,:,:)
- END DO
+ ZTSTEP_PPM / PRHODJ(:,:,:)
+ !$acc end kernels
+ IF (GTKE) THEN
+ !$acc kernels
+ ZTKE(:,:,:) = ZTKE(:,:,:) + ( ZRTKES_PPM(:,:,:) + ZRTKES_OTHER(:,:,:) ) * ZTSTEP_PPM / PRHODJ(:,:,:)
+ !$acc end kernels
+ END IF
+ !$acc kernels
+ !$acc loop independent collapse(4)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU, JR=1:KRR )
+ ZR(JI,JJ,JK,JR) = ZR(JI,JJ,JK,JR) + ( ZRRS_PPM(JI,JJ,JK,JR) + ZRRS_OTHER(JI,JJ,JK,JR) + PRRS_CLD(JI,JJ,JK,JR) ) &
+ * ZTSTEP_PPM / PRHODJ(JI,JJ,JK)
+ END DO !CONCURRENT
+ !$acc loop seq
DO JSV = 1, KSV
- ZSV(:,:,:,JSV) = ZSV(:,:,:,JSV) + ( ZRSVS_PPM(:,:,:,JSV) + ZRSVS_OTHER(:,:,:,JSV) + &
- PRSVS_CLD(:,:,:,JSV) ) * ZTSTEP_PPM / PRHODJ(:,:,:)
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZSV(JI,JJ,JK,JSV) = ZSV(JI,JJ,JK,JSV) + ( ZRSVS_PPM(JI,JJ,JK,JSV) + ZRSVS_OTHER(JI,JJ,JK,JSV) + &
+ PRSVS_CLD(JI,JJ,JK,JSV) ) * ZTSTEP_PPM / PRHODJ(JI,JJ,JK)
+ END DO !CONCURRENT
END DO
+ !$acc end kernels
END IF
-!$acc end kernels
+! acc end kernels
!PW: bug PGI 18.10: not necessary for PRRS,PRSVS but error with decriptor not present
!$acc update self(PRRS,PRSVS)
@@ -868,6 +989,7 @@ DO JSPL=1,KSPLIT
!
! Exchanges fields between processors
!
+#ifndef MNH_OPENACC
NULLIFY(TZFIELDS1_ll)
!!$ IF(NHALO == 1) THEN
CALL ADD3DFIELD_ll( TZFIELDS1_ll, ZTH, 'ZTH' )
@@ -878,7 +1000,21 @@ DO JSPL=1,KSPLIT
CALL UPDATE_HALO_ll(TZFIELDS1_ll,IINFO_ll)
CALL CLEANLIST_ll(TZFIELDS1_ll)
!!$ END IF
- END IF
+#else
+ CALL GET_HALO_D(ZTH,HNAME='ZTH')
+ IF (GTKE) CALL GET_HALO_D(ZTKE,HNAME='ADVECTION_METSV::ZTKE')
+ DO JR=1,KRR
+ CALL GET_HALO_D(ZR(:,:,:,JR),HNAME='ADVECTION_METSV::ZR')
+ END DO
+ DO JSV = 1, KSV
+ CALL GET_HALO_D(ZSV(:,:,:,JSV),HNAME='ADVECTION_METSV::ZSV')
+ END DO
+ DO JSV = 1,NBLOWSNOW_2D
+ CALL GET_HALO_D(ZSNWC(:,:,:,JSV),HNAME='ADVECTION_METSV::ZSNWC')
+ END DO
+#endif
+
+ END IF
!
END DO
!
@@ -954,6 +1090,33 @@ END IF
!$acc end data
+#ifndef MNH_OPENACC
+deallocate ( ZRUCPPM, ZRVCPPM, ZRWCPPM, ZCFLU, ZCFLV, ZCFLW, ZCFL, ZTH, &
+ ZTKE, ZRTHS_OTHER, ZRTKES_OTHER, ZRTHS_PPM, ZRTKES_PPM, &
+ ZR, ZSV, ZSNWC, ZSNWC_INIT, ZRSNWCS, ZRRS_OTHER, ZRSVS_OTHER, ZRSNWCS_OTHER, &
+ ZRRS_PPM, ZRSVS_PPM, ZRSNWCS_PPM, ZRHOX1, ZRHOX2, ZRHOY1, ZRHOY2, ZRHOZ1, ZRHOZ2, &
+ ZT, ZEXN, ZLV, ZLS, ZCPH )
+#else
+CALL MNH_REL_ZT3D ( IZRHOX1, IZRHOX2, IZRHOY1, IZRHOY2, IZRHOZ1, IZRHOZ2, &
+ IZT, IZEXN, IZLV, IZLS, IZCPH )
+
+CALL MNH_REL_ZT4D ( NBLOWSNOW_2D , IZRSNWCS_PPM )
+CALL MNH_REL_ZT4D ( SIZE(PSVT,4) , IZRSVS_PPM )
+CALL MNH_REL_ZT4D ( SIZE(PRT, 4) , IZRRS_PPM )
+CALL MNH_REL_ZT4D ( NBLOWSNOW_2D , IZRSNWCS_OTHER )
+CALL MNH_REL_ZT4D ( SIZE(PSVT,4) , IZRSVS_OTHER )
+CALL MNH_REL_ZT4D ( SIZE(PRT, 4) , IZRRS_OTHER )
+CALL MNH_REL_ZT4D ( NBLOWSNOW_2D , IZRSNWCS )
+CALL MNH_REL_ZT4D ( NBLOWSNOW_2D , IZSNWC_INIT )
+CALL MNH_REL_ZT4D ( NBLOWSNOW_2D , IZSNWC )
+CALL MNH_REL_ZT4D ( SIZE(PSVT,4) , IZSV )
+CALL MNH_REL_ZT4D ( SIZE(PRT, 4) , IZR )
+
+CALL MNH_REL_ZT3D ( IZRUCPPM, IZRVCPPM, IZRWCPPM, IZCFLU, IZCFLV, IZCFLW, IZCFL, IZTH, &
+ IZTKE, IZRTHS_OTHER, IZRTKES_OTHER, IZRTHS_PPM, IZRTKES_PPM )
+CALL MNH_CHECK_OUT_ZT3D("ADVECTION_METSV")
+#endif
+
!$acc end data
END SUBROUTINE ADVECTION_METSV
diff --git a/src/MNH/advection_uvw.f90 b/src/MNH/advection_uvw.f90
index d005a36253abda9e818988769e609c91e7d85763..9451c5fbf499ed7621af282cf45f439484ea4a35 100644
--- a/src/MNH/advection_uvw.f90
+++ b/src/MNH/advection_uvw.f90
@@ -117,6 +117,7 @@ USE MODI_CONTRAV
#ifndef MNH_OPENACC
USE MODI_SHUMAN
#else
+USE MODI_GET_HALO, ONLY: GET_HALO_D
USE MODI_SHUMAN_DEVICE
#endif
!
@@ -245,7 +246,7 @@ ALLOCATE( ZMZM_RHODJ( SIZE(PUT,1), SIZE(PUT,2), SIZE(PUT,3) ) )
!$acc data create( zrut, zrvt, zrwt, zruct, zrvct, zrwct, zu, zv, zw, &
!$acc & zrus_other, zrvs_other, zrws_other, zrus_adv, zrvs_adv, zrws_adv, &
-!$acc & zrus_adv, zrvs_adv, zrws_adv, zmxm_rhodj, zmym_rhodj, zmzm_rhodj )
+!$acc & zmxm_rhodj, zmym_rhodj, zmzm_rhodj )
#ifdef MNH_OPENACC
#if 0
@@ -327,8 +328,9 @@ ZRUT(:,:,:) = PUT(:,:,:) * ZMXM_RHODJ(:,:,:)
ZRVT(:,:,:) = PVT(:,:,:) * ZMYM_RHODJ(:,:,:)
ZRWT(:,:,:) = PWT(:,:,:) * ZMZM_RHODJ(:,:,:)
!$acc end kernels
-!$acc update self(ZRUT,ZRVT)
+
!
+#ifndef MNH_OPENACC
NULLIFY(TZFIELD_ll)
!!$IF(NHALO == 1) THEN
CALL ADD3DFIELD_ll( TZFIELD_ll, ZRUT, 'ADVECTION_UVW::ZRUT' )
@@ -336,7 +338,14 @@ NULLIFY(TZFIELD_ll)
CALL UPDATE_HALO_ll(TZFIELD_ll,IINFO_ll)
CALL CLEANLIST_ll(TZFIELD_ll)
!!$END IF
-!$acc update device(ZRUT,ZRVT)
+#else
+! acc update self(ZRUT,ZRVT)
+ CALL GET_HALO_D(ZRUT,HNAME='ADVECTION_UVW::ZRUT')
+ CALL GET_HALO_D(ZRVT,HNAME='ADVECTION_UVW::ZRVT')
+! acc update device(ZRUT,ZRVT)
+#endif
+
+
!
#ifndef MNH_OPENACC
CALL CONTRAV (HLBCX,HLBCY,ZRUT,ZRVT,ZRWT,PDXX,PDYY,PDZZ,PDZX,PDZY,ZRUCT,ZRVCT,ZRWCT,4)
@@ -346,7 +355,8 @@ CALL CONTRAV_DEVICE (HLBCX,HLBCY,ZRUT,ZRVT,ZRWT,PDXX,PDYY,PDZZ,PDZX,PDZY,ZRUCT,Z
!Not necessary: already done in contrav_device !$acc update self(ZRUCT,ZRVCT,ZRWCT)
#endif
!
-NULLIFY(TZFIELDS_ll)
+#ifndef MNH_OPENACC
+ NULLIFY(TZFIELDS_ll)
!!$IF(NHALO == 1) THEN
CALL ADD3DFIELD_ll( TZFIELDS_ll, ZRWCT, 'ADVECTION_UVW::ZRWCT' )
CALL ADD3DFIELD_ll( TZFIELDS_ll, ZRUCT, 'ADVECTION_UVW::ZRUCT' )
@@ -354,7 +364,14 @@ NULLIFY(TZFIELDS_ll)
CALL UPDATE_HALO_ll(TZFIELDS_ll,IINFO_ll)
CALL CLEANLIST_ll(TZFIELDS_ll)
!!$END IF
-!$acc update device(ZRUCT,ZRVCT,ZRWCT) !Needed in advecuvw_weno_k called by advecuvw_rk
+#else
+ CALL GET_HALO_D(ZRUCT,HNAME='ADVECTION_UVW::ZRUCT')
+ CALL GET_HALO_D(ZRVCT,HNAME='ADVECTION_UVW::ZRVCT')
+ CALL GET_HALO_D(ZRWCT,HNAME='ADVECTION_UVW::ZRWCT')
+! acc update device(ZRUCT,ZRVCT,ZRWCT) !Needed in advecuvw_weno_k called by advecuvw_rk
+#endif
+
+
!
!-------------------------------------------------------------------------------
!
@@ -383,7 +400,8 @@ CALL ADV_BOUNDARIES_DEVICE (HLBCX, HLBCY, ZRWS_OTHER)
ZRWS_OTHER(:,:,IKE+1) = 0.
!$acc end kernels
-!$acc update self(ZRUS_OTHER,ZRVS_OTHER,ZRWS_OTHER)
+#ifndef MNH_OPENACC
+
NULLIFY(TZFIELDS0_ll)
!!$IF(NHALO == 1) THEN
CALL ADD3DFIELD_ll( TZFIELDS0_ll, ZRUS_OTHER, 'ADVECTION_UVW::ZRUS_OTHER' )
@@ -392,7 +410,15 @@ NULLIFY(TZFIELDS0_ll)
CALL UPDATE_HALO_ll(TZFIELDS0_ll,IINFO_ll)
CALL CLEANLIST_ll(TZFIELDS0_ll)
!!$END IF
-!$acc update device(ZRUS_OTHER,ZRVS_OTHER,ZRWS_OTHER)
+#else
+! acc update self(ZRUS_OTHER,ZRVS_OTHER,ZRWS_OTHER)
+ CALL GET_HALO_D(ZRUS_OTHER,HNAME='ADVECTION_UVW::ZRUS_OTHER' )
+ CALL GET_HALO_D(ZRVS_OTHER,HNAME='ADVECTION_UVW::ZRVS_OTHER' )
+ CALL GET_HALO_D(ZRWS_OTHER,HNAME='ADVECTION_UVW::ZRWS_OTHER' )
+! acc update device(ZRUS_OTHER,ZRVS_OTHER,ZRWS_OTHER)
+#endif
+
+
!
!
!
diff --git a/src/MNH/advecuvw_rk.f90 b/src/MNH/advecuvw_rk.f90
index b70ee322f63cc7e0793adcdc1354e7749ea3e8c3..20bc33af57e7d31b8becad374bffc72331e69454 100644
--- a/src/MNH/advecuvw_rk.f90
+++ b/src/MNH/advecuvw_rk.f90
@@ -475,11 +475,18 @@ RKLOOP: DO JS = 1, ISPL
CALL ADV_BOUNDARIES_DEVICE (HLBCX, HLBCY, ZVT, PVT, 'V' )
CALL ADV_BOUNDARIES_DEVICE (HLBCX, HLBCY, ZWT, PWT, 'W' )
#endif
-!
-!$acc update self(ZUT,ZVT,ZWT)
+ !
+#ifndef MNH_OPENACC
CALL UPDATE_HALO_ll(TZFIELDMT_ll,IINFO_ll)
CALL UPDATE_HALO2_ll(TZFIELDMT_ll, TZHALO2MT_ll, IINFO_ll)
-!$acc update device(ZUT,ZVT,ZWT)
+#else
+! acc update self(ZUT,ZVT,ZWT)
+ CALL GET_HALO_D(ZUT,HNAME='ZUT')
+ CALL GET_HALO_D(ZVT,HNAME='ZVT')
+ CALL GET_HALO_D(ZWT,HNAME='ZWT')
+ CALL UPDATE_HALO2_ll(TZFIELDMT_ll, TZHALO2MT_ll, IINFO_ll)
+! acc update device(ZUT,ZVT,ZWT)
+#endif
!
!* 4. Advection with WENO
! --------------------------
@@ -532,12 +539,18 @@ RKLOOP: DO JS = 1, ISPL
NULLIFY(TZFIELDS4_ll)
!
write ( ynum, '( I3 )' ) js
+#ifndef MNH_OPENACC
CALL ADD3DFIELD_ll( TZFIELDS4_ll, ZRUS(:,:,:,JS), 'ADVECUVW_RK::ZRUS(:,:,:,'//trim( adjustl( ynum ) )//')' )
CALL ADD3DFIELD_ll( TZFIELDS4_ll, ZRVS(:,:,:,JS), 'ADVECUVW_RK::ZRVS(:,:,:,'//trim( adjustl( ynum ) )//')' )
CALL ADD3DFIELD_ll( TZFIELDS4_ll, ZRWS(:,:,:,JS), 'ADVECUVW_RK::ZRWS(:,:,:,'//trim( adjustl( ynum ) )//')' )
CALL UPDATE_HALO_ll(TZFIELDS4_ll,IINFO_ll)
CALL CLEANLIST_ll(TZFIELDS4_ll)
-!$acc update device(ZRUS(:,:,:,JS),ZRVS(:,:,:,JS),ZRWS(:,:,:,JS))
+#else
+ CALL GET_HALO_D(ZRUS(:,:,:,JS),HNAME='ADVECUVW_RK::ZRUS(:,:,:,'//trim( adjustl( ynum ) )//')' )
+ CALL GET_HALO_D(ZRVS(:,:,:,JS),HNAME='ADVECUVW_RK::ZRVS(:,:,:,'//trim( adjustl( ynum ) )//')' )
+ CALL GET_HALO_D(ZRWS(:,:,:,JS),HNAME='ADVECUVW_RK::ZRWS(:,:,:,'//trim( adjustl( ynum ) )//')' )
+! acc update device(ZRUS(:,:,:,JS),ZRVS(:,:,:,JS),ZRWS(:,:,:,JS))
+#endif
!
IF (LIBM .AND. CIBM_ADV=='FREEZE') THEN
WHERE(XIBM_LS(:,:,:,2).GT.-XIBM_EPSI) ZRUS(:,:,:,JS)=ZUT(:,:,:)*PMXM_RHODJ(:,:,:)/PTSTEP
diff --git a/src/MNH/compare_with_pgd_domain.f90 b/src/MNH/compare_with_pgd_domain.f90
index 028dc1f804370fa98bc4321bc5a5892b50cc1776..8b698bb4085aa8070ac29d84115d294c68f39bec 100644
--- a/src/MNH/compare_with_pgd_domain.f90
+++ b/src/MNH/compare_with_pgd_domain.f90
@@ -178,6 +178,7 @@ IF ( (ABS(PLAT0-XLAT0)>ZEPS*MAX(1.,ABS(XLAT0))) &
WRITE(ILUOUT0,*) ' | INPUT FILE AND PHYSIOGRAPHIC DATA DOMAINS ARE DIFFERENTS |'
WRITE(ILUOUT0,*) ' +----------------------------------------------------------+'
WRITE(ILUOUT0,*)
+ WRITE(ILUOUT0,*)
!callabortstop
CALL PRINT_MSG(NVERB_FATAL,'GEN','COMPARE_WITH_PGD_DOMAIN','')
ENDIF
diff --git a/src/MNH/dyn_sources.f90 b/src/MNH/dyn_sources.f90
index 052eeebc48a26257ef84181bf9b6dca44471d888..72251666504f6ea74f20a6e3f75aaa44e2b7af29 100644
--- a/src/MNH/dyn_sources.f90
+++ b/src/MNH/dyn_sources.f90
@@ -253,7 +253,8 @@ IF ((.NOT.L1D).AND.(.NOT.LCARTESIAN) ) THEN
& MYF(PVT) * ZWORK1 - MZF(PWT) , &
& MYF(PVT) , MZF(PWT) , MXM(PWT) , MYM(PWT) )
CALL MPPDB_CHECK3DM("DYN_SOOURCES:SUITE",PRECISION,&
- & MXM(ZRVT),MXM(PVT),MXM(PWT),MXM(ZWORK1),MXM(ZWORK2),MXM(ZWORK3) )
+ & MXM(ZRVT),MXM(PVT),MXM(PWT),MXM(ZWORK1),MXM(ZWORK2),MXM(ZWORK3),&
+ & ZRUT,ZRVT,PRUS,PRVS,PRWS )
!
PRUS(:,:,:) = PRUS &
+ MXM( MYF(ZRVT*PVT) * ZWORK2 * ZWORK3 ) &
@@ -293,6 +294,9 @@ IF (LCORIO) THEN
ZWORK1(:,:,:) = SPREAD( PCORIOX(:,:),DIM=3,NCOPIES=IKU) * PRHODJ(:,:,:)
ZWORK2(:,:,:) = SPREAD( PCORIOY(:,:),DIM=3,NCOPIES=IKU) * PRHODJ(:,:,:)
+ !
+ CALL MPPDB_CHECK3DM("DYN_SOOURCES:CORIOLIS",PRECISION,&
+ & ZWORK1,ZWORK2,ZWORK3 )
!
PRUS(:,:,:) = PRUS - MXM( ZWORK2 * MZF(PWT) )
!
diff --git a/src/MNH/emoist.f90 b/src/MNH/emoist.f90
index 8fd26c4d75ed756d0091aae1de2d446e3467c898..142586b908ca18c7794f4171e876997dd8b4b77b 100644
--- a/src/MNH/emoist.f90
+++ b/src/MNH/emoist.f90
@@ -41,7 +41,6 @@ END SUBROUTINE EMOIST
END INTERFACE
!
END MODULE MODI_EMOIST
-!
! ############################################################################
#ifndef MNH_OPENACC
FUNCTION EMOIST(KRR,KRRI,PTHLM,PRM,PLOCPEXNM,PAMOIST,PSRCM) RESULT(PEMOIST)
@@ -101,8 +100,11 @@ SUBROUTINE EMOIST(KRR,KRRI,PTHLM,PRM,PLOCPEXNM,PAMOIST,PSRCM,PEMOIST)
USE MODD_CST
USE MODD_DYN_n, ONLY : LOCEAN
+#ifdef MNH_OPENACC
+USE MODE_MNH_ZWORK
+#endif
use mode_mppdb
-!
+
IMPLICIT NONE
!
!* 0.1 declarations of arguments and result
@@ -127,10 +129,15 @@ REAL,DIMENSION(:,:,:), INTENT(OUT):: PEMOIST ! result
!
!* 0.2 declarations of local variables
!
-REAL,DIMENSION(:,:,:), allocatable :: ZA, ZRW
+REAL,DIMENSION(:,:,:), pointer,contiguous :: ZA, ZRW
+#ifdef MNH_OPENACC
+INTEGER :: IZA,IZRW
+#endif
! ZA = coeft A, ZRW = total mixing ratio rw
REAL :: ZDELTA ! = Rv/Rd - 1
INTEGER :: JRR ! moist loop counter
+INTEGER :: JIU,JJU,JKU
+INTEGER :: JI,JJ,JK
!
!---------------------------------------------------------------------------
@@ -145,83 +152,111 @@ if ( mppdb_initialized ) then
call Mppdb_check( psrcm, "Emoist beg:psrcm" )
end if
-allocate( za ( size( pthlm, 1 ), size( pthlm, 2 ), size( pthlm, 3 ) ) )
-allocate( zrw ( size( pthlm, 1 ), size( pthlm, 2 ), size( pthlm, 3 ) ) )
+JIU = size( pthlm, 1 )
+JJU = size( pthlm, 2 )
+JKU = size( pthlm, 3 )
+
+#ifndef MNH_OPENACC
+allocate( za (JIU,JJU,JKU) )
+allocate( zrw (JIU,JJU,JKU ) )
+#else
+IZA = MNH_ALLOCATE_ZT3D( za , JIU,JJU,JKU )
+IZRW = MNH_ALLOCATE_ZT3D( zrw , JIU,JJU,JKU )
+#endif
-!$acc data create( za, zrw )
+!$acc data present( za, zrw )
!
!* 1. COMPUTE EMOIST
! --------------
-!$acc kernels
IF (LOCEAN) THEN
IF ( KRR == 0 ) THEN ! Unsalted
+!$acc kernels
PEMOIST(:,:,:) = 0.
- ELSE
+!$acc end kernels
+ELSE
+!$acc kernels
PEMOIST(:,:,:) = 1. ! Salted case
+!$acc end kernels
END IF
!
ELSE
!
IF ( KRR == 0 ) THEN ! dry case
- PEMOIST(:,:,:) = 0.
+!$acc kernels
+ PEMOIST(1:JIU,1:JJU,1:JKU) = 0.
+!$acc end kernels
ELSE IF ( KRR == 1 ) THEN ! only vapor
+!$acc kernels
ZDELTA = (XRV/XRD) - 1.
- PEMOIST(:,:,:) = ZDELTA*PTHLM(:,:,:)
+ PEMOIST(1:JIU,1:JJU,1:JKU) = ZDELTA*PTHLM(1:JIU,1:JJU,1:JKU)
+!$acc end kernels
ELSE ! liquid water & ice present
+!$acc kernels
ZDELTA = (XRV/XRD) - 1.
- ZRW(:,:,:) = PRM(:,:,:,1)
-!
- IF ( KRRI>0) THEN ! rc and ri case
- ZRW(:,:,:) = ZRW(:,:,:) + PRM(:,:,:,3)
- DO JRR=5,KRR
- ZRW(:,:,:) = ZRW(:,:,:) + PRM(:,:,:,JRR)
- ENDDO
- ZA(:,:,:) = 1. + ( & ! Compute A
- (1.+ZDELTA) * (PRM(:,:,:,1) - PRM(:,:,:,2) - PRM(:,:,:,4)) &
- -ZRW(:,:,:) &
- ) / (1. + ZRW(:,:,:))
+ ZRW(1:JIU,1:JJU,1:JKU) = PRM(1:JIU,1:JJU,1:JKU,1)
+!$acc end kernels
+!
+ IF ( KRRI>0) THEN ! rc and ri case
+!$acc kernels
+ ZRW(1:JIU,1:JJU,1:JKU) = ZRW(1:JIU,1:JJU,1:JKU) + PRM(1:JIU,1:JJU,1:JKU,3)
+ !$acc loop seq
+ DO JRR=5,KRR
+ ZRW(1:JIU,1:JJU,1:JKU) = ZRW(1:JIU,1:JJU,1:JKU) + PRM(1:JIU,1:JJU,1:JKU,JRR)
+ ENDDO
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZA(JI,JJ,JK) = 1. + ( & ! Compute A
+ (1.+ZDELTA) * (PRM(JI,JJ,JK,1) - PRM(JI,JJ,JK,2) - PRM(JI,JJ,JK,4)) &
+ -ZRW(JI,JJ,JK) &
+ ) / (1. + ZRW(JI,JJ,JK))
+ END DO !CONCURRENT
!
! Emoist = ZB + ZC * Amoist
! ZB is computed from line 1 to line 2
! ZC is computed from line 3 to line 5
! Amoist* 2 * SRC is computed at line 6
!
- PEMOIST(:,:,:) = ZDELTA * (PTHLM(:,:,:) + PLOCPEXNM(:,:,:)*( &
- PRM(:,:,:,2)+PRM(:,:,:,4)))&
- / (1. + ZRW(:,:,:)) &
- +( PLOCPEXNM(:,:,:) * ZA(:,:,:) &
- -(1.+ZDELTA) * (PTHLM(:,:,:) + PLOCPEXNM(:,:,:)*( &
- PRM(:,:,:,2)+PRM(:,:,:,4)))&
- / (1. + ZRW(:,:,:)) &
- ) * PAMOIST(:,:,:) * 2. * PSRCM(:,:,:)
- ELSE
- DO JRR=3,KRR
- ZRW(:,:,:) = ZRW(:,:,:) + PRM(:,:,:,JRR)
- ENDDO
- ZA(:,:,:) = 1. + ( & ! Compute ZA
- (1.+ZDELTA) * (PRM(:,:,:,1) - PRM(:,:,:,2)) &
- -ZRW(:,:,:) &
- ) / (1. + ZRW(:,:,:))
+ PEMOIST(1:JIU,1:JJU,1:JKU) = ZDELTA * (PTHLM(1:JIU,1:JJU,1:JKU) + PLOCPEXNM(1:JIU,1:JJU,1:JKU)*( &
+ PRM(1:JIU,1:JJU,1:JKU,2)+PRM(1:JIU,1:JJU,1:JKU,4)))&
+ / (1. + ZRW(1:JIU,1:JJU,1:JKU)) &
+ +( PLOCPEXNM(1:JIU,1:JJU,1:JKU) * ZA(1:JIU,1:JJU,1:JKU) &
+ -(1.+ZDELTA) * (PTHLM(1:JIU,1:JJU,1:JKU) + PLOCPEXNM(1:JIU,1:JJU,1:JKU)*( &
+ PRM(1:JIU,1:JJU,1:JKU,2)+PRM(1:JIU,1:JJU,1:JKU,4)))&
+ / (1. + ZRW(1:JIU,1:JJU,1:JKU)) &
+ ) * PAMOIST(1:JIU,1:JJU,1:JKU) * 2. * PSRCM(1:JIU,1:JJU,1:JKU)
+!$acc end kernels
+ ELSE
+!$acc kernels
+ !$acc loop seq
+ DO JRR=3,KRR
+ ZRW(1:JIU,1:JJU,1:JKU) = ZRW(1:JIU,1:JJU,1:JKU) + PRM(1:JIU,1:JJU,1:JKU,JRR)
+ ENDDO
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZA(JI,JJ,JK) = 1. + ( & ! Compute ZA
+ (1.+ZDELTA) * (PRM(JI,JJ,JK,1) - PRM(JI,JJ,JK,2)) &
+ -ZRW(JI,JJ,JK) &
+ ) / (1. + ZRW(JI,JJ,JK))
+ END DO !CONCURRENT
!
! Emoist = ZB + ZC * Amoist
! ZB is computed from line 1 to line 2
! ZC is computed from line 3 to line 5
! Amoist* 2 * SRC is computed at line 6
!
- PEMOIST(:,:,:) = ZDELTA * (PTHLM(:,:,:) + PLOCPEXNM(:,:,:)*PRM(:,:,:,2)) &
- / (1. + ZRW(:,:,:)) &
- +( PLOCPEXNM(:,:,:) * ZA(:,:,:) &
- -(1.+ZDELTA) * (PTHLM(:,:,:) + PLOCPEXNM(:,:,:)*PRM(:,:,:,2)) &
- / (1. + ZRW(:,:,:)) &
- ) * PAMOIST(:,:,:) * 2. * PSRCM(:,:,:)
+ PEMOIST(1:JIU,1:JJU,1:JKU) = ZDELTA * (PTHLM(1:JIU,1:JJU,1:JKU) + PLOCPEXNM(1:JIU,1:JJU,1:JKU)*PRM(1:JIU,1:JJU,1:JKU,2)) &
+ / (1. + ZRW(1:JIU,1:JJU,1:JKU)) &
+ +( PLOCPEXNM(1:JIU,1:JJU,1:JKU) * ZA(1:JIU,1:JJU,1:JKU) &
+ -(1.+ZDELTA) * (PTHLM(1:JIU,1:JJU,1:JKU) + PLOCPEXNM(1:JIU,1:JJU,1:JKU)*PRM(1:JIU,1:JJU,1:JKU,2)) &
+ / (1. + ZRW(1:JIU,1:JJU,1:JKU)) &
+ ) * PAMOIST(1:JIU,1:JJU,1:JKU) * 2. * PSRCM(1:JIU,1:JJU,1:JKU)
+!$acc end kernels
END IF
END IF
!
END IF
-!$acc end kernels
-
-deallocate( za, zrw )
+! acc end kernels
if ( mppdb_initialized ) then
!Check all out arrays
@@ -230,6 +265,12 @@ end if
!$acc end data
+#ifndef MNH_OPENACC
+deallocate( za, zrw )
+#else
+CALL MNH_REL_ZT3D( iza, izrw )
+#endif
+
!$acc end data
!---------------------------------------------------------------------------
diff --git a/src/MNH/etheta.f90 b/src/MNH/etheta.f90
index 34fd3015eb65017b47f80b0e090d9821ae90b18b..9e0099214e182cf8ffd02dc763f4a1731aaa3c7f 100644
--- a/src/MNH/etheta.f90
+++ b/src/MNH/etheta.f90
@@ -103,8 +103,11 @@ SUBROUTINE ETHETA(KRR,KRRI,PTHLM,PRM,PLOCPEXNM,PATHETA,PSRCM,PETHETA)
USE MODD_CST
USE MODD_DYN_n, ONLY : LOCEAN
+#ifdef MNH_OPENACC
+USE MODE_MNH_ZWORK, ONLY: MNH_ALLOCATE_ZT3D , MNH_REL_ZT3D
+#endif
use mode_mppdb
-!
+
IMPLICIT NONE
!
!* 0.1 declarations of arguments and result
@@ -132,8 +135,11 @@ REAL, DIMENSION(:,:,:), INTENT(OUT):: PETHETA ! result
!
!* 0.2 declarations of local variables
!
-REAL,DIMENSION(:,:,:), allocatable :: ZA, ZRW
+REAL,DIMENSION(:,:,:), pointer , contiguous :: ZA, ZRW
! ZA = coeft A, ZRW = total mixing ratio rw
+#ifdef MNH_OPENACC
+INTEGER :: IZA, IZRW
+#endif
REAL :: ZDELTA ! = Rv/Rd - 1
INTEGER :: JRR ! moist loop counter
!
@@ -150,73 +156,90 @@ if ( mppdb_initialized ) then
call Mppdb_check( psrcm, "Etheta beg:psrcm" )
end if
+#ifndef MNH_OPENACC
allocate( za ( size( pthlm, 1 ), size( pthlm, 2 ), size( pthlm, 3 ) ) )
allocate( zrw ( size( pthlm, 1 ), size( pthlm, 2 ), size( pthlm, 3 ) ) )
+#else
+iza = MNH_ALLOCATE_ZT3D( za , size( pthlm, 1 ), size( pthlm, 2 ), size( pthlm, 3 ) )
+izrw = MNH_ALLOCATE_ZT3D( zrw , size( pthlm, 1 ), size( pthlm, 2 ), size( pthlm, 3 ) )
+#endif
-!$acc data create( za, zrw )
+!$acc data present( za, zrw )
!
!* 1. COMPUTE ETHETA
! --------------
!
!
-!$acc kernels
IF (LOCEAN) THEN ! ocean case
+!$acc kernels
PETHETA(:,:,:) = 1.
-ELSE
- IF ( KRR == 0.) THEN ! dry case
- PETHETA(:,:,:) = 1.
- ELSE IF ( KRR == 1 ) THEN ! only vapor
- ZDELTA = (XRV/XRD) - 1.
- PETHETA(:,:,:) = 1. + ZDELTA*PRM(:,:,:,1)
- ELSE ! liquid water & ice present
- ZDELTA = (XRV/XRD) - 1.
- ZRW(:,:,:) = PRM(:,:,:,1)
-!
- IF ( KRRI>0 ) THEN ! rc and ri case
- ZRW(:,:,:) = ZRW(:,:,:) + PRM(:,:,:,3)
- DO JRR=5,KRR
- ZRW(:,:,:) = ZRW(:,:,:) + PRM(:,:,:,JRR)
- ENDDO
- ZA(:,:,:) = 1. + ( & ! Compute A
- (1.+ZDELTA) * (PRM(:,:,:,1) - PRM(:,:,:,2) - PRM(:,:,:,4)) &
- -ZRW(:,:,:) &
- ) / (1. + ZRW(:,:,:))
- !
- ! Etheta = ZA + ZC * Atheta
- ! ZC is computed from line 2 to line 5
- ! - Atheta * 2. * SRC is computed at line 6
- !
- PETHETA(:,:,:) = ZA(:,:,:) &
- +( PLOCPEXNM(:,:,:) * ZA(:,:,:) &
- -(1.+ZDELTA) * (PTHLM(:,:,:) + PLOCPEXNM(:,:,:)*( &
- PRM(:,:,:,2)+PRM(:,:,:,4)))&
- / (1. + ZRW(:,:,:)) &
- ) * PATHETA(:,:,:) * 2. * PSRCM(:,:,:)
- ELSE
- DO JRR=3,KRR
- ZRW(:,:,:) = ZRW(:,:,:) + PRM(:,:,:,JRR)
- ENDDO
- ZA(:,:,:) = 1. + ( & ! Compute A
- (1.+ZDELTA) * (PRM(:,:,:,1) - PRM(:,:,:,2)) &
- -ZRW(:,:,:) &
- ) / (1. + ZRW(:,:,:))
- !
- ! Etheta = ZA + ZC * Atheta
- ! ZC is computed from line 2 to line 5
- ! - Atheta * 2. * SRC is computed at line 6
- !
- PETHETA(:,:,:) = ZA(:,:,:) &
- +( PLOCPEXNM(:,:,:) * ZA(:,:,:) &
- -(1.+ZDELTA) * (PTHLM(:,:,:) + PLOCPEXNM(:,:,:)*PRM(:,:,:,2)) &
- / (1. + ZRW(:,:,:)) &
- ) * PATHETA(:,:,:) * 2. * PSRCM(:,:,:)
- END IF
- END IF
-END IF
+!$acc end kernels
+ELSE
+! acc kernels
+ IF ( KRR == 0 ) THEN ! dry case
+!$acc kernels
+ PETHETA(:,:,:) = 1.
+!$acc end kernels
+ ELSE IF ( KRR == 1 ) THEN ! only vapor
+!$acc kernels
+ ZDELTA = (XRV/XRD) - 1.
+ PETHETA(:,:,:) = 1. + ZDELTA*PRM(:,:,:,1)
+!$acc end kernels
+ ELSE ! liquid water & ice present
+!$acc kernels
+ ZDELTA = (XRV/XRD) - 1.
+ ZRW(:,:,:) = PRM(:,:,:,1)
!$acc end kernels
-deallocate( za, zrw )
+ IF ( KRRI>0 ) THEN ! rc and ri case
+ !$acc kernels
+ ZRW(:,:,:) = ZRW(:,:,:) + PRM(:,:,:,3)
+ !$acc loop seq
+ DO JRR=5,KRR
+ ZRW(:,:,:) = ZRW(:,:,:) + PRM(:,:,:,JRR)
+ ENDDO
+ ZA(:,:,:) = 1. + ( & ! Compute A
+ (1.+ZDELTA) * (PRM(:,:,:,1) - PRM(:,:,:,2) - PRM(:,:,:,4)) &
+ -ZRW(:,:,:) &
+ ) / (1. + ZRW(:,:,:))
+ !
+ ! Etheta = ZA + ZC * Atheta
+ ! ZC is computed from line 2 to line 5
+ ! - Atheta * 2. * SRC is computed at line 6
+ !
+ PETHETA(:,:,:) = ZA(:,:,:) &
+ +( PLOCPEXNM(:,:,:) * ZA(:,:,:) &
+ -(1.+ZDELTA) * (PTHLM(:,:,:) + PLOCPEXNM(:,:,:)*( &
+ PRM(:,:,:,2)+PRM(:,:,:,4)))&
+ / (1. + ZRW(:,:,:)) &
+ ) * PATHETA(:,:,:) * 2. * PSRCM(:,:,:)
+ !$acc end kernels
+ ELSE
+ !$acc kernels
+ !$acc loop seq
+ DO JRR=3,KRR
+ ZRW(:,:,:) = ZRW(:,:,:) + PRM(:,:,:,JRR)
+ ENDDO
+ ZA(:,:,:) = 1. + ( & ! Compute A
+ (1.+ZDELTA) * (PRM(:,:,:,1) - PRM(:,:,:,2)) &
+ -ZRW(:,:,:) &
+ ) / (1. + ZRW(:,:,:))
+ !
+ ! Etheta = ZA + ZC * Atheta
+ ! ZC is computed from line 2 to line 5
+ ! - Atheta * 2. * SRC is computed at line 6
+ !
+ PETHETA(:,:,:) = ZA(:,:,:) &
+ +( PLOCPEXNM(:,:,:) * ZA(:,:,:) &
+ -(1.+ZDELTA) * (PTHLM(:,:,:) + PLOCPEXNM(:,:,:)*PRM(:,:,:,2)) &
+ / (1. + ZRW(:,:,:)) &
+ ) * PATHETA(:,:,:) * 2. * PSRCM(:,:,:)
+ !$acc end kernels
+ END IF
+ END IF
+! acc end kernels
+END IF
if ( mppdb_initialized ) then
!Check all out arrays
@@ -225,6 +248,12 @@ end if
!$acc end data
+#ifndef MNH_OPENACC
+deallocate (za, zrw)
+#else
+CALL MNH_REL_ZT3D(iza, izrw)
+#endif
+
!$acc end data
!---------------------------------------------------------------------------
diff --git a/src/MNH/get_halo.f90 b/src/MNH/get_halo.f90
index 34daa24a1edd7ab984b153f8ed91f0fec92fa0bc..16aa1f8ed6f4c2474130ddf2f3118e9c9899392f 100644
--- a/src/MNH/get_halo.f90
+++ b/src/MNH/get_halo.f90
@@ -16,6 +16,9 @@ INTERFACE
SUBROUTINE GET_HALO2(PSRC, TP_PSRC_HALO2_ll, HNAME)
!
USE MODD_ARGSLIST_ll, ONLY : HALO2LIST_ll
+ !
+ IMPLICIT NONE
+ !
REAL, DIMENSION(:,:,:), INTENT(IN) :: PSRC ! variable at t
TYPE(HALO2LIST_ll), POINTER :: TP_PSRC_HALO2_ll ! halo2 for SRC
character(len=*), optional, intent(in) :: HNAME ! Name of the field to be added
@@ -25,6 +28,7 @@ END INTERFACE
!
INTERFACE
SUBROUTINE GET_HALO(PSRC, HDIR, HNAME)
+ IMPLICIT NONE
!
REAL, DIMENSION(:,:,:), INTENT(IN) :: PSRC ! variable at t
CHARACTER(len=4), OPTIONAL :: HDIR ! to send only halo on X or Y direction
@@ -36,6 +40,7 @@ END INTERFACE
#ifdef MNH_OPENACC
INTERFACE
SUBROUTINE GET_HALO_D(PSRC, HDIR, HNAME)
+ IMPLICIT NONE
!
REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PSRC ! variable at t
CHARACTER(len=4), OPTIONAL :: HDIR ! to send only halo on X or Y direction
@@ -43,16 +48,40 @@ INTERFACE
!
END SUBROUTINE GET_HALO_D
END INTERFACE
-#endif
!
INTERFACE
-SUBROUTINE DEL_HALO2_ll(TPHALO2LIST)
-!
-USE MODD_ARGSLIST_ll, ONLY : HALO2LIST_ll
-TYPE(HALO2LIST_ll), POINTER :: TPHALO2LIST ! list of HALO2_lls
-!
-END SUBROUTINE DEL_HALO2_ll
+ SUBROUTINE GET_HALO_START_D(PSRC,KNB_REQ,KREQ,HDIR)
+ IMPLICIT NONE
+ !
+ REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PSRC ! variable at t
+ !$acc declare present (PSRC)
+ INTEGER :: KNB_REQ , KREQ(8)
+ CHARACTER(len=4), OPTIONAL :: HDIR ! to send only halo on X or Y direction
+ !
+ END SUBROUTINE GET_HALO_START_D
+END INTERFACE
+INTERFACE
+ SUBROUTINE GET_HALO_STOP_D(PSRC,KNB_REQ,KREQ,HDIR)
+ IMPLICIT NONE
+ REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PSRC ! variable at t
+ !$acc declare present (PSRC)
+ INTEGER :: KNB_REQ , KREQ(8)
+ CHARACTER(len=4), OPTIONAL :: HDIR ! to send only halo on X or Y direction
+ END SUBROUTINE GET_HALO_STOP_D
+END INTERFACE
+#endif
!
+INTERFACE
+ SUBROUTINE DEL_HALO2_ll(TPHALO2LIST)
+ !
+ USE MODD_ARGSLIST_ll, ONLY : HALO2LIST_ll
+ !
+ IMPLICIT NONE
+ !
+ TYPE(HALO2LIST_ll), POINTER :: TPHALO2LIST ! list of HALO2_lls
+ !
+ END SUBROUTINE DEL_HALO2_ll
+ !
END INTERFACE
!
END MODULE MODI_GET_HALO
@@ -132,17 +161,417 @@ END SUBROUTINE GET_HALO
!-----------------------------------------------------------------------
#ifdef MNH_OPENACC
MODULE MODD_HALO_D
-IMPLICIT NONE
-REAL, SAVE , ALLOCATABLE, DIMENSION(:,:,:) :: ZNORTH_IN, ZSOUTH_IN, ZWEST_IN, ZEAST_IN
-REAL, SAVE , ALLOCATABLE, DIMENSION(:,:,:) :: ZNORTH_OUT, ZSOUTH_OUT, ZWEST_OUT, ZEAST_OUT
+
+ IMPLICIT NONE
+
+ REAL, SAVE , ALLOCATABLE, DIMENSION(:,:,:) :: ZNORTH_IN, ZSOUTH_IN, ZWEST_IN, ZEAST_IN
+ REAL, SAVE , ALLOCATABLE, DIMENSION(:,:,:) :: ZNORTH_OUT, ZSOUTH_OUT, ZWEST_OUT, ZEAST_OUT
+
+ LOGICAL, SAVE :: GFIRST_GET_HALO_D = .TRUE.
+
+ LOGICAL, SAVE :: GFIRST_INIT_HALO_D = .TRUE.
+ INTEGER, SAVE :: IHALO_1
+ INTEGER, SAVE :: NP_NORTH,NP_SOUTH,NP_WEST,NP_EAST
+
+CONTAINS
+
+ SUBROUTINE INIT_HALO_D()
+
+ USE MODE_MNH_ZWORK, ONLY : IIU,IJU,IKU
+ USE MODE_MNH_ZWORK, ONLY : IIB,IJB ,IIE,IJE
+ USE MODE_MNH_ZWORK, ONLY : GWEST , GEAST, GSOUTH , GNORTH
+ USE MODD_CONF, ONLY : NHALO
-LOGICAL, SAVE :: GFIRST_GET_HALO_D = .TRUE.
+ USE MODD_VAR_ll, ONLY : IP,NPROC,NP1,NP2
+
+
+ IMPLICIT NONE
+
+ IF (GFIRST_INIT_HALO_D) THEN
+ !
+ IHALO_1 = NHALO-1
+ !
+ ALLOCATE ( ZSOUTH_IN ( IIB:IIE , IJB:IJB+IHALO_1 , IKU ) )
+ ALLOCATE ( ZNORTH_IN ( IIB:IIE , IJE-IHALO_1:IJE , IKU ) )
+ ALLOCATE ( ZWEST_IN ( IIB:IIB+IHALO_1 , IJB:IJE , IKU ) )
+ ALLOCATE ( ZEAST_IN ( IIE-IHALO_1:IIE , IJB:IJE , IKU ) )
+ !$acc enter data create (ZNORTH_IN, ZSOUTH_IN, ZWEST_IN, ZEAST_IN)
+ !
+ ALLOCATE ( ZSOUTH_OUT ( IIB:IIE , 1:IJB-1 , IKU ) )
+ ALLOCATE ( ZNORTH_OUT ( IIB:IIE , IJE+1:IJU , IKU ) )
+ ALLOCATE ( ZWEST_OUT ( 1:IIB-1 , IJB:IJE , IKU ) )
+ ALLOCATE ( ZEAST_OUT ( IIE+1:IIU , IJB:IJE , IKU ) )
+ !$acc enter data create (ZNORTH_OUT, ZSOUTH_OUT, ZWEST_OUT, ZEAST_OUT)
+
+ IF (.NOT. GWEST ) THEN
+ NP_WEST = ( IP-1 -1 ) + 1
+ ELSE
+ NP_WEST = 0
+ ENDIF
+ IF (.NOT. GEAST ) THEN
+ NP_EAST = ( IP-1 +1 ) + 1
+ ELSE
+ NP_EAST = 0
+ ENDIF
+ IF (.NOT. GSOUTH ) THEN
+ NP_SOUTH = ( IP-1 -NP1 ) + 1
+ ELSE
+ NP_SOUTH = 0
+ ENDIF
+ IF (.NOT. GNORTH ) THEN
+ NP_NORTH = ( IP-1 +NP1 ) + 1
+ ELSE
+ NP_NORTH = 0
+ ENDIF
+
+ !print*,"PROC=",IP, GWEST,NP_WEST, GEAST,NP_EAST, GSOUTH,NP_SOUTH , GNORTH,NP_NORTH
+
+ GFIRST_INIT_HALO_D = .FALSE.
+
+ END IF
+
+ END SUBROUTINE INIT_HALO_D
END MODULE MODD_HALO_D
+! #########################
+ SUBROUTINE GET_HALO_D(PSRC,HDIR,HNAME)
+! #########################
+#define MNH_GPUDIRECT
+!
+USE MODD_HALO_D
+
+!USE MODE_MNH_ZWORK, ONLY : GWEST , GEAST, GSOUTH , GNORTH
+!USE MODE_MNH_ZWORK, ONLY : IIU,IJU,IKU
+!USE MODE_MNH_ZWORK, ONLY : IIB,IJB ,IIE,IJE
+!!
+!USE MODE_DEVICE
+USE MODE_MPPDB
+USE MODI_GET_HALO, ONLY : GET_HALO_START_D,GET_HALO_STOP_D
+!
+IMPLICIT NONE
+!
+REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PSRC ! variable at t
+!$acc declare present (PSRC)
+CHARACTER(len=4), OPTIONAL :: HDIR ! to send only halo on X or Y direction
+character(len=*), optional, intent(in) :: HNAME ! Name of the field to be added
+!
+INTEGER :: INB_REQ , IREQ(8)
+!
+CALL GET_HALO_START_D(PSRC,INB_REQ,IREQ,HDIR)
+CALL GET_HALO_STOP_D(PSRC,INB_REQ,IREQ,HDIR)
+!
+END SUBROUTINE GET_HALO_D
+! #########################
+ SUBROUTINE GET_HALO_START_D(PSRC,KNB_REQ,KREQ,HDIR)
+! #########################
+#define MNH_GPUDIRECT
+!
+USE MODD_HALO_D
+
+USE MODE_MNH_ZWORK, ONLY : GWEST , GEAST, GSOUTH , GNORTH
+USE MODE_MNH_ZWORK, ONLY : IIU,IJU,IKU
+USE MODE_MNH_ZWORK, ONLY : IIB,IJB ,IIE,IJE
+!
+USE MODD_VAR_ll, ONLY : NMNH_COMM_WORLD
+USE MODD_MPIF, ONLY : MPI_STATUSES_IGNORE
+USE MODD_PRECISION, ONLY : MNHREAL_MPI
+!
+USE MODE_DEVICE
+USE MODE_MPPDB
+!
+IMPLICIT NONE
+!
+REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PSRC ! variable at t
+!$acc declare present (PSRC)
+INTEGER :: KNB_REQ , KREQ(8)
+CHARACTER(len=4), OPTIONAL :: HDIR ! to send only halo on X or Y direction
+!
+INTEGER :: IERROR ! error return code
+
+INTEGER,PARAMETER :: IS_WEST=1 , IS_EAST=2, IS_SOUTH=3, IS_NORTH=4
+LOGICAL :: LX , LY
+INTEGER :: NB_REQ, IERR
+!
+
+CALL INIT_HALO_D()
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+!$acc data present (ZNORTH_IN, ZSOUTH_IN, ZWEST_IN, ZEAST_IN) &
+!$acc present (ZNORTH_OUT, ZSOUTH_OUT, ZWEST_OUT, ZEAST_OUT)
+
+LX = .FALSE.
+LY = .FALSE.
+
+IF (.NOT. PRESENT(HDIR) ) THEN
+LX = .TRUE.
+LY = .TRUE.
+ELSE
+!!$LX = ( HDIR == "01_X" .OR. HDIR == "S0_X" )
+!!$LY = ( HDIR == "01_Y" .OR. HDIR == "S0_Y" )
+LX = ( HDIR == "01_X" .OR. HDIR == "S0_X" .OR. HDIR == "S0_Y" )
+LY = ( HDIR == "01_Y" .OR. HDIR == "S0_Y" .OR. HDIR == "S0_X" )
+!!$print *,"IIB=",IIB," HDIR=",HDIR," LX=",LX," LY=",LY ; call flush(6)
+END IF
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+NB_REQ = 0
+
+!
+! Post the recieve of Zxxxx_IN buffer first via MPI(Gpu_direct)
+!
+
+IF (LX) THEN
+ IF (.NOT. GWEST) THEN
+#ifdef MNH_GPUDIRECT
+ !$acc host_data use_device(ZWEST_OUT)
+#endif
+ NB_REQ = NB_REQ + 1
+ CALL MPI_IRECV(ZWEST_OUT,SIZE(ZWEST_OUT),MNHREAL_MPI,NP_WEST-1,1000+IS_EAST,NMNH_COMM_WORLD,KREQ(NB_REQ),IERR)
+#ifdef MNH_GPUDIRECT
+ !$acc end host_data
+#endif
+ END IF
+ IF (.NOT.GEAST) THEN
+#ifdef MNH_GPUDIRECT
+ !$acc host_data use_device(ZEAST_OUT)
+#endif
+ NB_REQ = NB_REQ + 1
+ CALL MPI_IRECV(ZEAST_OUT,SIZE(ZEAST_OUT),MNHREAL_MPI,NP_EAST-1,1000+IS_WEST,NMNH_COMM_WORLD,KREQ(NB_REQ),IERR)
+#ifdef MNH_GPUDIRECT
+ !$acc end host_data
+#endif
+ ENDIF
+END IF
+
+IF (LY) THEN
+ IF (.NOT.GSOUTH) THEN
+#ifdef MNH_GPUDIRECT
+ !$acc host_data use_device(ZSOUTH_OUT)
+#endif
+ NB_REQ = NB_REQ + 1
+ CALL MPI_IRECV(ZSOUTH_OUT,SIZE(ZSOUTH_OUT),MNHREAL_MPI,NP_SOUTH-1,1000+IS_NORTH,NMNH_COMM_WORLD,KREQ(NB_REQ),IERR)
+#ifdef MNH_GPUDIRECT
+ !$acc end host_data
+#endif
+ ENDIF
+ IF (.NOT.GNORTH) THEN
+#ifdef MNH_GPUDIRECT
+ !$acc host_data use_device(ZNORTH_OUT)
+#endif
+ NB_REQ = NB_REQ + 1
+ CALL MPI_IRECV(ZNORTH_OUT,SIZE(ZNORTH_OUT),MNHREAL_MPI,NP_NORTH-1,1000+IS_SOUTH,NMNH_COMM_WORLD,KREQ(NB_REQ),IERR)
+#ifdef MNH_GPUDIRECT
+ !$acc end host_data
+#endif
+ ENDIF
+END IF
+
+!
+! Copy the halo(async) on the device PSRC to Zxxxx_IN buffer
+!
+
+IF (LX) THEN
+ IF (.NOT. GWEST) THEN
+ !$acc kernels async(IS_WEST)
+ ZWEST_IN ( IIB:IIB+IHALO_1 , IJB:IJE , : ) = PSRC( IIB:IIB+IHALO_1 , IJB:IJE , : )
+ !$acc end kernels
+ END IF
+ IF (.NOT.GEAST) THEN
+ !$acc kernels async(IS_EAST)
+ ZEAST_IN ( IIE-IHALO_1:IIE , IJB:IJE , : ) = PSRC( IIE-IHALO_1:IIE , IJB:IJE , : )
+ !$acc end kernels
+ ENDIF
+END IF
+
+IF (LY) THEN
+ IF (.NOT.GSOUTH) THEN
+ !$acc kernels async(IS_SOUTH)
+ ZSOUTH_IN ( IIB:IIE , IJB:IJB+IHALO_1 , : ) = PSRC( IIB:IIE , IJB:IJB+IHALO_1 , : )
+ !$acc end kernels
+ ENDIF
+ IF (.NOT.GNORTH) THEN
+ !$acc kernels async(IS_NORTH)
+ ZNORTH_IN ( IIB:IIE , IJE-IHALO_1:IJE , : ) = PSRC( IIB:IIE , IJE-IHALO_1:IJE , : )
+ !$acc end kernels
+ ENDIF
+ENDIF
+
+!$acc wait
+
+!
+! Send Zxxxx_IN buffer via MPI(Gpu_direct)
+!
+IF (LX) THEN
+ IF (.NOT. GWEST) THEN
+#ifdef MNH_GPUDIRECT
+ !$acc host_data use_device(ZWEST_IN)
+#else
+ !$acc update host(ZWEST_IN)
+#endif
+ NB_REQ = NB_REQ + 1
+ CALL MPI_ISEND(ZWEST_IN,SIZE(ZWEST_IN) ,MNHREAL_MPI,NP_WEST-1,1000+IS_WEST,NMNH_COMM_WORLD,KREQ(NB_REQ),IERR)
+#ifdef MNH_GPUDIRECT
+ !$acc end host_data
+#endif
+ END IF
+ IF (.NOT.GEAST) THEN
+#ifdef MNH_GPUDIRECT
+ !$acc host_data use_device(ZEAST_IN)
+#else
+ !$acc update host(ZEAST_IN)
+#endif
+ NB_REQ = NB_REQ + 1
+ CALL MPI_ISEND(ZEAST_IN,SIZE(ZEAST_IN) ,MNHREAL_MPI,NP_EAST-1,1000+IS_EAST,NMNH_COMM_WORLD,KREQ(NB_REQ),IERR)
+#ifdef MNH_GPUDIRECT
+ !$acc end host_data
+#endif
+ ENDIF
+END IF
+
+IF (LY) THEN
+ IF (.NOT.GSOUTH) THEN
+#ifdef MNH_GPUDIRECT
+ !$acc host_data use_device(ZSOUTH_IN)
+#else
+ !$acc update host(ZSOUTH_IN)
+#endif
+ NB_REQ = NB_REQ + 1
+ CALL MPI_ISEND(ZSOUTH_IN,SIZE(ZSOUTH_IN) ,MNHREAL_MPI,NP_SOUTH-1,1000+IS_SOUTH,NMNH_COMM_WORLD,KREQ(NB_REQ),IERR)
+#ifdef MNH_GPUDIRECT
+ !$acc end host_data
+#endif
+ ENDIF
+ IF (.NOT.GNORTH) THEN
+#ifdef MNH_GPUDIRECT
+ !$acc host_data use_device(ZNORTH_IN)
+#else
+ !$acc update host(ZNORTH_IN)
+#endif
+ NB_REQ = NB_REQ + 1
+ CALL MPI_ISEND(ZNORTH_IN,SIZE(ZNORTH_IN) ,MNHREAL_MPI,NP_NORTH-1,1000+IS_NORTH,NMNH_COMM_WORLD,KREQ(NB_REQ),IERR)
+#ifdef MNH_GPUDIRECT
+ !$acc end host_data
+#endif
+ ENDIF
+ENDIF
+
+!$acc end data
+
+KNB_REQ = NB_REQ
+!
+END SUBROUTINE GET_HALO_START_D
+!
+! #########################
+ SUBROUTINE GET_HALO_STOP_D(PSRC,KNB_REQ,KREQ,HDIR)
+! #########################
+#define MNH_GPUDIRECT
+!
+USE MODD_HALO_D
+
+USE MODE_MNH_ZWORK, ONLY : GWEST , GEAST, GSOUTH , GNORTH
+USE MODE_MNH_ZWORK, ONLY : IIU,IJU,IKU
+USE MODE_MNH_ZWORK, ONLY : IIB,IJB ,IIE,IJE
+!
+USE MODD_VAR_ll, ONLY : NMNH_COMM_WORLD
+USE MODD_MPIF, ONLY : MPI_STATUSES_IGNORE
+USE MODD_PRECISION, ONLY : MNHREAL_MPI
+!
+USE MODE_DEVICE
+USE MODE_MPPDB
+!
+IMPLICIT NONE
+!
+REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PSRC ! variable at t
+!$acc declare present (PSRC)
+INTEGER :: KNB_REQ , KREQ(8)
+CHARACTER(len=4), OPTIONAL :: HDIR ! to send only halo on X or Y direction
+!
+INTEGER :: IERROR ! error return code
+
+INTEGER,PARAMETER :: IS_WEST=1 , IS_EAST=2, IS_SOUTH=3, IS_NORTH=4
+LOGICAL :: LX , LY
+INTEGER :: NB_REQ, IERR
+!
+
+CALL INIT_HALO_D()
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+!$acc data present (ZNORTH_IN, ZSOUTH_IN, ZWEST_IN, ZEAST_IN) &
+!$acc present (ZNORTH_OUT, ZSOUTH_OUT, ZWEST_OUT, ZEAST_OUT)
+
+LX = .FALSE.
+LY = .FALSE.
+
+IF (.NOT. PRESENT(HDIR) ) THEN
+LX = .TRUE.
+LY = .TRUE.
+ELSE
+!!$LX = ( HDIR == "01_X" .OR. HDIR == "S0_X" )
+!!$LY = ( HDIR == "01_Y" .OR. HDIR == "S0_Y" )
+LX = ( HDIR == "01_X" .OR. HDIR == "S0_X" .OR. HDIR == "S0_Y" )
+LY = ( HDIR == "01_Y" .OR. HDIR == "S0_Y" .OR. HDIR == "S0_X" )
+!!$print *,"IIB=",IIB," HDIR=",HDIR," LX=",LX," LY=",LY ; call flush(6)
+END IF
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+NB_REQ = KNB_REQ
+
+CALL MPI_WAITALL(NB_REQ,KREQ,MPI_STATUSES_IGNORE,IERR)
+
+!
+! Copy back the Zxxx_OUT buffer recv via MPI(gpu_direct) to PSRC halo
+!
+
+IF (LX) THEN
+ IF (.NOT.GWEST) THEN
+#ifndef MNH_GPUDIRECT
+ !$acc update device(ZWEST_OUT) async(IS_WEST)
+#endif
+ !$acc kernels async(IS_WEST)
+ PSRC( 1:IIB-1 , IJB:IJE , : ) = ZWEST_OUT( 1:IIB-1 , IJB:IJE , : )
+ !$acc end kernels
+ ENDIF
+ IF (.NOT.GEAST) THEN
+#ifndef MNH_GPUDIRECT
+ !$acc update device(ZEAST_OUT) async(IS_EAST)
+#endif
+ !$acc kernels async(IS_EAST)
+ PSRC( IIE+1:IIU , IJB:IJE , : ) = ZEAST_OUT( IIE+1:IIU , IJB:IJE , : )
+ !$acc end kernels
+ ENDIF
+END IF
+IF (LY) THEN
+ IF (.NOT.GSOUTH) THEN
+#ifndef MNH_GPUDIRECT
+ !$acc update device(ZSOUTH_OUT) async(IS_SOUTH)
+#endif
+ !$acc kernels async(IS_SOUTH)
+ PSRC( IIB:IIE , 1:IJB-1 , : ) = ZSOUTH_OUT( IIB:IIE , 1:IJB-1 , : )
+ !$acc end kernels
+ ENDIF
+ IF (.NOT.GNORTH) THEN
+#ifndef MNH_GPUDIRECT
+ !$acc update device(ZNORTH_OUT) async(IS_NORTH)
+#endif
+ !$acc kernels async(IS_NORTH)
+ PSRC( IIB:IIE , IJE+1:IJU , : ) = ZNORTH_OUT ( IIB:IIE , IJE+1:IJU , : )
+ !$acc end kernels
+ ENDIF
+END IF
+!$acc wait
+
+!$acc end data
+!
+END SUBROUTINE GET_HALO_STOP_D
!-------------------------------------------------------------------------------
! ########################################
- SUBROUTINE GET_HALO_D(PSRC, HDIR, HNAME)
+ SUBROUTINE GET_HALO_DD(PSRC, HDIR, HNAME)
! ########################################
+#define MNH_GPUDIRECT
!
USE MODD_HALO_D
USE MODE_ll
@@ -155,6 +584,11 @@ USE MODE_MNH_ZWORK, ONLY : GWEST , GEAST, GSOUTH , GNORTH
USE MODD_CONF, ONLY : NHALO
USE MODE_DEVICE
USE MODE_MPPDB
+
+USE MODD_VAR_ll, ONLY : IP,NPROC,NP1,NP2
+USE MODD_VAR_ll, ONLY : NMNH_COMM_WORLD
+USE MODD_MPIF, ONLY : MPI_STATUSES_IGNORE
+USE MODD_PRECISION, ONLY : MNHREAL_MPI
!
IMPLICIT NONE
!
@@ -169,20 +603,21 @@ INTEGER, SAVE :: IIB,IJB ! Begining useful area in x,y,z directions
INTEGER, SAVE :: IIE,IJE ! End useful area in x,y,z directions
INTEGER,SAVE :: IIU,IJU,IKU
-INTEGER,SAVE :: IHALO_1
+
INTEGER,PARAMETER :: IS_WEST=1 , IS_EAST=2, IS_SOUTH=3, IS_NORTH=4
+INTEGER, SAVE :: IIBX,IJBX ! Extended Begining useful area in x,y,z directions
+INTEGER, SAVE :: IIEX,IJEX ! Extended End useful area in x,y,z directions
+
LOGICAL :: LX , LY
-!
-!LOGICAL, SAVE :: GFIRST_GET_HALO_D = .TRUE.
-!
+INTEGER :: INB_REQ , IREQ(8)
+INTEGER :: IERR
+
+if ( NPROC == 1 ) RETURN
!$acc data present ( PSRC )
-!JUANCHECK3D IF (GSMONOPROC) RETURN
-!
-#define _PW_NOINTERM
NULLIFY( TZ_PSRC_ll)
!
IF (GFIRST_GET_HALO_D ) THEN
@@ -195,34 +630,48 @@ IF (GFIRST_GET_HALO_D ) THEN
!
IHALO_1 = NHALO-1
!
-#ifndef _PW_NOINTERM
- ALLOCATE ( ZSOUTH_IN ( IIB:IIE , IJB:IJB+IHALO_1 , IKU ) )
- ALLOCATE ( ZNORTH_IN ( IIB:IIE , IJE-IHALO_1:IJE , IKU ) )
- ALLOCATE ( ZWEST_IN ( IIB:IIB+IHALO_1 , IJB:IJE , IKU ) )
- ALLOCATE ( ZEAST_IN ( IIE-IHALO_1:IIE , IJB:IJE , IKU ) )
+!!$ IIBX= 1 ; IIEX= IIU ; IJBX= 1 ; IJEX= IJU
+ IIBX= IIB ; IIEX= IIE ; IJBX= IJB ; IJEX= IJE
+
+ ALLOCATE ( ZSOUTH_IN ( IIBX:IIEX , IJB:IJB+IHALO_1 , IKU ) )
+ ALLOCATE ( ZNORTH_IN ( IIBX:IIEX , IJE-IHALO_1:IJE , IKU ) )
+ ALLOCATE ( ZWEST_IN ( IIB:IIB+IHALO_1 , IJBX:IJEX , IKU ) )
+ ALLOCATE ( ZEAST_IN ( IIE-IHALO_1:IIE , IJBX:IJEX , IKU ) )
!$acc enter data create (ZNORTH_IN, ZSOUTH_IN, ZWEST_IN, ZEAST_IN)
!
- ALLOCATE ( ZSOUTH_OUT ( IIB:IIE , 1:IJB-1 , IKU ) )
- ALLOCATE ( ZNORTH_OUT ( IIB:IIE , IJE+1:IJU , IKU ) )
- ALLOCATE ( ZWEST_OUT ( 1:IIB-1 , IJB:IJE , IKU ) )
- ALLOCATE ( ZEAST_OUT ( IIE+1:IIU , IJB:IJE , IKU ) )
+ ALLOCATE ( ZSOUTH_OUT ( IIBX:IIEX , 1:IJB-1 , IKU ) )
+ ALLOCATE ( ZNORTH_OUT ( IIBX:IIEX , IJE+1:IJU , IKU ) )
+ ALLOCATE ( ZWEST_OUT ( 1:IIB-1 , IJBX:IJEX , IKU ) )
+ ALLOCATE ( ZEAST_OUT ( IIE+1:IIU , IJBX:IJEX , IKU ) )
!$acc enter data create (ZNORTH_OUT, ZSOUTH_OUT, ZWEST_OUT, ZEAST_OUT)
- CALL INIT_ON_HOST_AND_DEVICE(ZSOUTH_IN,-1e99,'GET_HALO_D::ZSOUTH_IN')
- CALL INIT_ON_HOST_AND_DEVICE(ZNORTH_IN,-1e99,'GET_HALO_D::ZNORTH_IN')
- CALL INIT_ON_HOST_AND_DEVICE(ZWEST_IN,-1e99,'GET_HALO_D::ZWEST_IN')
- CALL INIT_ON_HOST_AND_DEVICE(ZEAST_IN,-1e99,'GET_HALO_D::ZEAST_IN')
-
- CALL INIT_ON_HOST_AND_DEVICE(ZSOUTH_OUT,-1e99,'GET_HALO_D::ZSOUTH_OUT')
- CALL INIT_ON_HOST_AND_DEVICE(ZNORTH_OUT,-1e99,'GET_HALO_D::ZNORTH_OUT')
- CALL INIT_ON_HOST_AND_DEVICE(ZWEST_OUT,-1e99,'GET_HALO_D::ZWEST_OUT')
- CALL INIT_ON_HOST_AND_DEVICE(ZEAST_OUT,-1e99,'GET_HALO_D::ZEAST_OUT')
-#endif
-
+ IF (.NOT. GWEST ) THEN
+ NP_WEST = ( IP-1 -1 ) + 1
+ ELSE
+ NP_WEST = 0
+ ENDIF
+ IF (.NOT. GEAST ) THEN
+ NP_EAST = ( IP-1 +1 ) + 1
+ ELSE
+ NP_EAST = 0
+ ENDIF
+ IF (.NOT. GSOUTH ) THEN
+ NP_SOUTH = ( IP-1 -NP1 ) + 1
+ ELSE
+ NP_SOUTH = 0
+ ENDIF
+ IF (.NOT. GNORTH ) THEN
+ NP_NORTH = ( IP-1 +NP1 ) + 1
+ ELSE
+ NP_NORTH = 0
+ ENDIF
+
+ !print*,"PROC=",IP, GWEST,NP_WEST, GEAST,NP_EAST, GSOUTH,NP_SOUTH , GNORTH,NP_NORTH
+
GFIRST_GET_HALO_D = .FALSE.
+
END IF
-
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
LX = .FALSE.
@@ -232,162 +681,215 @@ IF (.NOT. PRESENT(HDIR) ) THEN
LX = .TRUE.
LY = .TRUE.
ELSE
-LX = ( HDIR == "01_X" .OR. HDIR == "S0_X" )
-LY = ( HDIR == "01_Y" .OR. HDIR == "S0_Y" )
+ !
+ ! Problem of reproductibility in ppm_s0_x/y if only S0_X or S0_Y
+ ! so add S0_X + S0_Y for ppm_s0*
+ !
+!!$LX = ( HDIR == "01_X" .OR. HDIR == "S0_X" )
+!!$LY = ( HDIR == "01_Y" .OR. HDIR == "S0_Y" )
+LX = ( HDIR == "01_X" .OR. HDIR == "S0_X" .OR. HDIR == "S0_Y" )
+LY = ( HDIR == "01_Y" .OR. HDIR == "S0_Y" .OR. HDIR == "S0_X" )
+END IF
+
+!!$LX = .TRUE.
+!!$LY = .TRUE.
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+INB_REQ = 0
+
+!
+! Post the recieve of Zxxxx_IN buffer first via MPI(Gpu_direct)
+!
+
+IF (LX) THEN
+ IF (.NOT. GWEST) THEN
+#ifdef MNH_GPUDIRECT
+ !$acc host_data use_device(ZWEST_OUT)
+#endif
+ INB_REQ = INB_REQ + 1
+ CALL MPI_IRECV(ZWEST_OUT,SIZE(ZWEST_OUT),MNHREAL_MPI,NP_WEST-1,1000+IS_EAST,NMNH_COMM_WORLD,IREQ(INB_REQ),IERR)
+#ifdef MNH_GPUDIRECT
+ !$acc end host_data
+#endif
+ END IF
+ IF (.NOT.GEAST) THEN
+#ifdef MNH_GPUDIRECT
+ !$acc host_data use_device(ZEAST_OUT)
+#endif
+ INB_REQ = INB_REQ + 1
+ CALL MPI_IRECV(ZEAST_OUT,SIZE(ZEAST_OUT),MNHREAL_MPI,NP_EAST-1,1000+IS_WEST,NMNH_COMM_WORLD,IREQ(INB_REQ),IERR)
+#ifdef MNH_GPUDIRECT
+ !$acc end host_data
+#endif
+ ENDIF
+END IF
+
+IF (LY) THEN
+ IF (.NOT.GSOUTH) THEN
+#ifdef MNH_GPUDIRECT
+ !$acc host_data use_device(ZSOUTH_OUT)
+#endif
+ INB_REQ = INB_REQ + 1
+ CALL MPI_IRECV(ZSOUTH_OUT,SIZE(ZSOUTH_OUT),MNHREAL_MPI,NP_SOUTH-1,1000+IS_NORTH,NMNH_COMM_WORLD,IREQ(INB_REQ),IERR)
+#ifdef MNH_GPUDIRECT
+ !$acc end host_data
+#endif
+ ENDIF
+ IF (.NOT.GNORTH) THEN
+#ifdef MNH_GPUDIRECT
+ !$acc host_data use_device(ZNORTH_OUT)
+#endif
+ INB_REQ = INB_REQ + 1
+ CALL MPI_IRECV(ZNORTH_OUT,SIZE(ZNORTH_OUT),MNHREAL_MPI,NP_NORTH-1,1000+IS_SOUTH,NMNH_COMM_WORLD,IREQ(INB_REQ),IERR)
+#ifdef MNH_GPUDIRECT
+ !$acc end host_data
+#endif
+ ENDIF
END IF
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+!Copy the halo on the device PSRC to Zxxxx_IN
-!Copy the halo on the device PSRC to Zxxxx_IN and put it in the PSRC copy on the host
-#ifndef _PW_NOINTERM
IF (LX) THEN
IF (.NOT. GWEST) THEN
!$acc kernels async(IS_WEST)
- ZWEST_IN ( IIB:IIB+IHALO_1 , IJB:IJE , : ) = PSRC( IIB:IIB+IHALO_1 , IJB:IJE , : )
+ ZWEST_IN ( IIB:IIB+IHALO_1 , IJBX:IJEX , : ) = PSRC( IIB:IIB+IHALO_1 , IJBX:IJEX , : )
!$acc end kernels
- !$acc update host(ZWEST_IN) async(IS_WEST)
- END IF
+ END IF
IF (.NOT.GEAST) THEN
!$acc kernels async(IS_EAST)
- ZEAST_IN ( IIE-IHALO_1:IIE , IJB:IJE , : ) = PSRC( IIE-IHALO_1:IIE , IJB:IJE , : )
+ ZEAST_IN ( IIE-IHALO_1:IIE , IJBX:IJEX , : ) = PSRC( IIE-IHALO_1:IIE , IJBX:IJEX , : )
!$acc end kernels
- !$acc update host(ZEAST_IN) async(IS_EAST)
- ENDIF
+ ENDIF
END IF
IF (LY) THEN
IF (.NOT.GSOUTH) THEN
!$acc kernels async(IS_SOUTH)
- ZSOUTH_IN ( IIB:IIE , IJB:IJB+IHALO_1 , : ) = PSRC( IIB:IIE , IJB:IJB+IHALO_1 , : )
+ ZSOUTH_IN ( IIBX:IIEX , IJB:IJB+IHALO_1 , : ) = PSRC( IIBX:IIEX , IJB:IJB+IHALO_1 , : )
!$acc end kernels
- !$acc update host(ZSOUTH_IN) async(IS_SOUTH)
- ENDIF
+ ENDIF
IF (.NOT.GNORTH) THEN
!$acc kernels async(IS_NORTH)
- ZNORTH_IN ( IIB:IIE , IJE-IHALO_1:IJE , : ) = PSRC( IIB:IIE , IJE-IHALO_1:IJE , : )
+ ZNORTH_IN ( IIBX:IIEX , IJE-IHALO_1:IJE , : ) = PSRC( IIBX:IIEX , IJE-IHALO_1:IJE , : )
!$acc end kernels
- !$acc update host(ZNORTH_IN) async(IS_NORTH)
ENDIF
ENDIF
!$acc wait
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!
+! Send Zxxxx_IN buffer via MPI(Gpu_direct) or copy to host
+!
IF (LX) THEN
IF (.NOT. GWEST) THEN
- PSRC( IIB:IIB+IHALO_1 , IJB:IJE , : ) = ZWEST_IN ( IIB:IIB+IHALO_1 , IJB:IJE , : )
- ENDIF
- IF (.NOT.GEAST) THEN
- PSRC( IIE-IHALO_1:IIE , IJB:IJE , : ) = ZEAST_IN ( IIE-IHALO_1:IIE , IJB:IJE , : )
- ENDIF
-END IF
-IF (LY) THEN
- IF (.NOT.GSOUTH) THEN
- PSRC( IIB:IIE , IJB:IJB+IHALO_1 , : ) = ZSOUTH_IN ( IIB:IIE , IJB:IJB+IHALO_1 , : )
- ENDIF
- IF (.NOT.GNORTH) THEN
- PSRC( IIB:IIE , IJE-IHALO_1:IJE , : ) = ZNORTH_IN ( IIB:IIE , IJE-IHALO_1:IJE , : )
- ENDIF
-ENDIF
+#ifdef MNH_GPUDIRECT
+ !$acc host_data use_device(ZWEST_IN)
#else
-IF (LX) THEN
- IF (.NOT. GWEST) THEN
- !$acc update host(PSRC( IIB:IIB+IHALO_1 , IJB:IJE , : ))
- ENDIF
+ !$acc update host(ZWEST_IN)
+#endif
+ INB_REQ = INB_REQ + 1
+ CALL MPI_ISEND(ZWEST_IN,SIZE(ZWEST_IN) ,MNHREAL_MPI,NP_WEST-1,1000+IS_WEST,NMNH_COMM_WORLD,IREQ(INB_REQ),IERR)
+#ifdef MNH_GPUDIRECT
+ !$acc end host_data
+#endif
+ END IF
IF (.NOT.GEAST) THEN
- !$acc update host(PSRC( IIE-IHALO_1:IIE , IJB:IJE , : ))
+#ifdef MNH_GPUDIRECT
+ !$acc host_data use_device(ZEAST_IN)
+#else
+ !$acc update host(ZEAST_IN)
+#endif
+ INB_REQ = INB_REQ + 1
+ CALL MPI_ISEND(ZEAST_IN,SIZE(ZEAST_IN) ,MNHREAL_MPI,NP_EAST-1,1000+IS_EAST,NMNH_COMM_WORLD,IREQ(INB_REQ),IERR)
+#ifdef MNH_GPUDIRECT
+ !$acc end host_data
+#endif
ENDIF
END IF
+
IF (LY) THEN
IF (.NOT.GSOUTH) THEN
- !$acc update host(PSRC( IIB:IIE , IJB:IJB+IHALO_1 , : ))
+#ifdef MNH_GPUDIRECT
+ !$acc host_data use_device(ZSOUTH_IN)
+#else
+ !$acc update host(ZSOUTH_IN)
+#endif
+ INB_REQ = INB_REQ + 1
+ CALL MPI_ISEND(ZSOUTH_IN,SIZE(ZSOUTH_IN) ,MNHREAL_MPI,NP_SOUTH-1,1000+IS_SOUTH,NMNH_COMM_WORLD,IREQ(INB_REQ),IERR)
+#ifdef MNH_GPUDIRECT
+ !$acc end host_data
+#endif
ENDIF
IF (.NOT.GNORTH) THEN
- !$acc update host(PSRC( IIB:IIE , IJE-IHALO_1:IJE , : ))
- ENDIF
-ENDIF
+#ifdef MNH_GPUDIRECT
+ !$acc host_data use_device(ZNORTH_IN)
+#else
+ !$acc update host(ZNORTH_IN)
#endif
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-if ( present ( hname ) ) then
- yname = hname
-else
- yname = 'PSRC'
-end if
-
-IF (LX .OR. LY) THEN
- CALL ADD3DFIELD_ll( TZ_PSRC_ll, PSRC, 'GET_HALO::'//trim( yname ) )
- CALL UPDATE_HALO_ll(TZ_PSRC_ll,IERROR, HDIR=HDIR )
- CALL CLEANLIST_ll(TZ_PSRC_ll)
-ELSE
- !Necessary to allow comparisons/checks with standard GET_HALO
- CALL MPPDB_CHECK(PSRC,"UPDATE_HALO_ll::GET_HALO::"//trim( yname ))
+ INB_REQ = INB_REQ + 1
+ CALL MPI_ISEND(ZNORTH_IN,SIZE(ZNORTH_IN) ,MNHREAL_MPI,NP_NORTH-1,1000+IS_NORTH,NMNH_COMM_WORLD,IREQ(INB_REQ),IERR)
+#ifdef MNH_GPUDIRECT
+ !$acc end host_data
+#endif
+ ENDIF
ENDIF
-!Copy the halo on the host PSRC to Zxxxx_OUT and put it in the PSRC copy on the device
-#ifndef _PW_NOINTERM
-IF (LX) THEN
- IF (.NOT.GWEST) THEN
- ZWEST_OUT( 1:IIB-1 , IJB:IJE , : ) = PSRC( 1:IIB-1 , IJB:IJE , : )
- ENDIF
- IF (.NOT.GEAST) THEN
- ZEAST_OUT( IIE+1:IIU , IJB:IJE , : ) = PSRC( IIE+1:IIU , IJB:IJE , : )
- ENDIF
-END IF
-IF (LY) THEN
- IF (.NOT.GSOUTH) THEN
- ZSOUTH_OUT ( IIB:IIE , 1:IJB-1 , : ) = PSRC( IIB:IIE , 1:IJB-1 , : )
- ENDIF
- IF (.NOT.GNORTH) THEN
- ZNORTH_OUT ( IIB:IIE , IJE+1:IJU , : ) = PSRC( IIB:IIE , IJE+1:IJU , : )
- ENDIF
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+IF ( INB_REQ > 0 ) THEN
+ CALL MPI_WAITALL(INB_REQ,IREQ,MPI_STATUSES_IGNORE,IERR)
END IF
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! Is update halo
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+
IF (LX) THEN
IF (.NOT.GWEST) THEN
+#ifndef MNH_GPUDIRECT
!$acc update device(ZWEST_OUT) async(IS_WEST)
+#endif
!$acc kernels async(IS_WEST)
- PSRC( 1:IIB-1 , IJB:IJE , : ) = ZWEST_OUT( 1:IIB-1 , IJB:IJE , : )
+ PSRC( 1:IIB-1 , IJBX:IJEX , : ) = ZWEST_OUT( 1:IIB-1 , IJBX:IJEX , : )
!$acc end kernels
ENDIF
IF (.NOT.GEAST) THEN
+#ifndef MNH_GPUDIRECT
!$acc update device(ZEAST_OUT) async(IS_EAST)
+#endif
!$acc kernels async(IS_EAST)
- PSRC( IIE+1:IIU , IJB:IJE , : ) = ZEAST_OUT( IIE+1:IIU , IJB:IJE , : )
+ PSRC( IIE+1:IIU , IJBX:IJEX , : ) = ZEAST_OUT( IIE+1:IIU , IJBX:IJEX , : )
!$acc end kernels
ENDIF
END IF
IF (LY) THEN
IF (.NOT.GSOUTH) THEN
+#ifndef MNH_GPUDIRECT
!$acc update device(ZSOUTH_OUT) async(IS_SOUTH)
+#endif
!$acc kernels async(IS_SOUTH)
- PSRC( IIB:IIE , 1:IJB-1 , : ) = ZSOUTH_OUT( IIB:IIE , 1:IJB-1 , : )
+ PSRC( IIBX:IIEX , 1:IJB-1 , : ) = ZSOUTH_OUT( IIBX:IIEX , 1:IJB-1 , : )
!$acc end kernels
ENDIF
IF (.NOT.GNORTH) THEN
+#ifndef MNH_GPUDIRECT
!$acc update device(ZNORTH_OUT) async(IS_NORTH)
+#endif
!$acc kernels async(IS_NORTH)
- PSRC( IIB:IIE , IJE+1:IJU , : ) = ZNORTH_OUT ( IIB:IIE , IJE+1:IJU , : )
+ PSRC( IIBX:IIEX , IJE+1:IJU , : ) = ZNORTH_OUT ( IIBX:IIEX , IJE+1:IJU , : )
!$acc end kernels
ENDIF
END IF
!$acc wait
-#else
-IF (LX) THEN
- IF (.NOT.GWEST) THEN
- !$acc update device(PSRC( 1:IIB-1 , IJB:IJE , : ))
- ENDIF
- IF (.NOT.GEAST) THEN
- !$acc update device(PSRC( IIE+1:IIU , IJB:IJE , : ))
- ENDIF
-END IF
-IF (LY) THEN
- IF (.NOT.GSOUTH) THEN
- !$acc update device(PSRC( IIB:IIE , 1:IJB-1 , : ))
- ENDIF
- IF (.NOT.GNORTH) THEN
- !$acc update device(PSRC( IIB:IIE , IJE+1:IJU , : ))
- ENDIF
-END IF
-#endif
!$acc end data
-END SUBROUTINE GET_HALO_D
+END SUBROUTINE GET_HALO_DD
#endif
!-----------------------------------------------------------------------
!
diff --git a/src/MNH/gradient_u.f90 b/src/MNH/gradient_u.f90
index 0dde760c72d5da4f05a92966896012bd80da9846..a45e5903fb4c98852ee5dd750be323a72c7a8074 100644
--- a/src/MNH/gradient_u.f90
+++ b/src/MNH/gradient_u.f90
@@ -31,7 +31,7 @@ REAL, DIMENSION(:,:,:), INTENT(IN) :: PDXX ! metric coefficient dxx
REAL, DIMENSION(:,:,:), INTENT(IN) :: PDZZ ! metric coefficient dzz
REAL, DIMENSION(:,:,:), INTENT(IN) :: PDZX ! metric coefficient dzx
!
-REAL, DIMENSION(SIZE(PA,1),SIZE(PA,2),SIZE(PA,3)), INTENT(OUT) :: PGX_U_M_DEVICE ! result mass point
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PGX_U_M_DEVICE ! result mass point
!
END SUBROUTINE GX_U_M_DEVICE
#endif
@@ -58,7 +58,7 @@ REAL, DIMENSION(:,:,:), INTENT(IN) :: PDYY ! metric coefficient dyy
REAL, DIMENSION(:,:,:), INTENT(IN) :: PDZZ ! metric coefficient dzz
REAL, DIMENSION(:,:,:), INTENT(IN) :: PDZY ! metric coefficient dzy
!
-REAL, DIMENSION(SIZE(PA,1),SIZE(PA,2),SIZE(PA,3)), INTENT(OUT) :: PGY_U_UV_DEVICE ! result UV point
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PGY_U_UV_DEVICE ! result UV point
!
END SUBROUTINE GY_U_UV_DEVICE
#endif
@@ -81,7 +81,7 @@ INTEGER, INTENT(IN) :: KL ! +1 if grid goes from ground to
REAL, DIMENSION(:,:,:), INTENT(IN) :: PA ! variable at the U point
REAL, DIMENSION(:,:,:), INTENT(IN) :: PDZZ ! metric coefficient dzz
!
-REAL, DIMENSION(SIZE(PA,1),SIZE(PA,2),SIZE(PA,3)), INTENT(OUT) :: PGZ_U_UW_DEVICE ! result UW point
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PGZ_U_UW_DEVICE ! result UW point
!
END SUBROUTINE GZ_U_UW_DEVICE
#endif
@@ -201,6 +201,8 @@ END FUNCTION GX_U_M
USE MODI_SHUMAN_DEVICE
USE MODD_CONF
!
+USE MODE_MNH_ZWORK , ONLY : MNH_ALLOCATE_ZT3D , MNH_REL_ZT3D
+!
IMPLICIT NONE
!
!
@@ -213,24 +215,28 @@ REAL, DIMENSION(:,:,:), INTENT(IN) :: PDXX ! metric coefficient dxx
REAL, DIMENSION(:,:,:), INTENT(IN) :: PDZZ ! metric coefficient dzz
REAL, DIMENSION(:,:,:), INTENT(IN) :: PDZX ! metric coefficient dzx
!
-REAL, DIMENSION(SIZE(PA,1),SIZE(PA,2),SIZE(PA,3)), INTENT(OUT) :: PGX_U_M_DEVICE ! result mass point
-!
-REAL, DIMENSION(:,:,:), allocatable :: ZTMP1_DEVICE, ZTMP2_DEVICE, ZTMP3_DEVICE
-!
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PGX_U_M_DEVICE ! result mass point
!
!* 0.2 declaration of local variables
!
-! NONE
+REAL, DIMENSION(:,:,:), pointer , contiguous :: ZTMP1_DEVICE, ZTMP2_DEVICE, ZTMP3_DEVICE
+INTEGER :: IZTMP1_DEVICE, IZTMP2_DEVICE, IZTMP3_DEVICE
!
+INTEGER :: JIU,JJU,JKU
+INTEGER :: JI,JJ,JK
!----------------------------------------------------------------------------
!$acc data present( PA, PDXX, PDZZ, PDZX, PGX_U_M_DEVICE )
-allocate( ztmp1_device(size( pa, 1 ), size( pa, 2 ), size( pa, 3 ) ) )
-allocate( ztmp2_device(size( pa, 1 ), size( pa, 2 ), size( pa, 3 ) ) )
-allocate( ztmp3_device(size( pa, 1 ), size( pa, 2 ), size( pa, 3 ) ) )
+JIU = size(pa, 1 )
+JJU = size(pa, 2 )
+JKU = size(pa, 3 )
+
+iztmp1_device = MNH_ALLOCATE_ZT3D( ztmp1_device,JIU,JJU,JKU )
+iztmp2_device = MNH_ALLOCATE_ZT3D( ztmp2_device,JIU,JJU,JKU )
+iztmp3_device = MNH_ALLOCATE_ZT3D( ztmp3_device,JIU,JJU,JKU )
-!$acc data create( ztmp1_device, ztmp2_device, ztmp3_device )
+!$acc data present( ztmp1_device, ztmp2_device, ztmp3_device )
!
!* 1. DEFINITION of GX_U_M_DEVICE
@@ -239,11 +245,17 @@ IF (.NOT. LFLAT) THEN
CALL DXF_DEVICE(PA,ZTMP1_DEVICE)
CALL DZM_DEVICE(KKA,KKU,KL,PA,ZTMP2_DEVICE)
!$acc kernels
- ZTMP3_DEVICE(:,:,:) = PDZX(:,:,:) * ZTMP2_DEVICE(:,:,:)
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP3_DEVICE(JI,JJ,JK) = PDZX(JI,JJ,JK) * ZTMP2_DEVICE(JI,JJ,JK)
+ END DO !CONCURRENT
!$acc end kernels
CALL MXF_DEVICE(ZTMP3_DEVICE,ZTMP2_DEVICE)
!$acc kernels
- ZTMP3_DEVICE(:,:,:) = ZTMP2_DEVICE(:,:,:) / PDZZ(:,:,:)
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP3_DEVICE(JI,JJ,JK) = ZTMP2_DEVICE(JI,JJ,JK) / PDZZ(JI,JJ,JK)
+ END DO !CONCURRENT
!$acc end kernels
CALL MZF_DEVICE(KKA,KKU,KL,ZTMP3_DEVICE,ZTMP2_DEVICE)
CALL MXF_DEVICE(PDXX,ZTMP3_DEVICE)
@@ -260,6 +272,8 @@ END IF
!$acc end data
+CALL MNH_REL_ZT3D(iztmp1_device,iztmp2_device,iztmp3_device)
+
!$acc end data
!----------------------------------------------------------------------------
@@ -375,6 +389,8 @@ END FUNCTION GY_U_UV
USE MODI_SHUMAN_DEVICE
USE MODD_CONF
!
+USE MODE_MNH_ZWORK , ONLY : MNH_ALLOCATE_ZT3D , MNH_REL_ZT3D
+!
IMPLICIT NONE
!
!
@@ -387,24 +403,30 @@ REAL, DIMENSION(:,:,:), INTENT(IN) :: PDYY ! metric coefficient dyy
REAL, DIMENSION(:,:,:), INTENT(IN) :: PDZZ ! metric coefficient dzz
REAL, DIMENSION(:,:,:), INTENT(IN) :: PDZY ! metric coefficient dzy
!
-REAL, DIMENSION(SIZE(PA,1),SIZE(PA,2),SIZE(PA,3)), INTENT(OUT) :: PGY_U_UV_DEVICE ! result UV point
-!
-REAL, DIMENSION(:,:,:), allocatable :: ZTMP1_DEVICE, ZTMP2_DEVICE, ZTMP3_DEVICE
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PGY_U_UV_DEVICE ! result UV point
!
!
!* 0.2 declaration of local variables
!
-! NONE
+REAL, DIMENSION(:,:,:), pointer , contiguous :: ZTMP1_DEVICE, ZTMP2_DEVICE, ZTMP3_DEVICE
+INTEGER :: IZTMP1_DEVICE, IZTMP2_DEVICE, IZTMP3_DEVICE
+!
+INTEGER :: JIU,JJU,JKU
+INTEGER :: JI,JJ,JK
!
!----------------------------------------------------------------------------
!$acc data present( PA, PDYY, PDZZ, PDZY, PGY_U_UV_DEVICE )
-allocate( ztmp1_device(size( pa, 1 ), size( pa, 2 ), size( pa, 3 ) ) )
-allocate( ztmp2_device(size( pa, 1 ), size( pa, 2 ), size( pa, 3 ) ) )
-allocate( ztmp3_device(size( pa, 1 ), size( pa, 2 ), size( pa, 3 ) ) )
+JIU = size(pa, 1 )
+JJU = size(pa, 2 )
+JKU = size(pa, 3 )
+
+iztmp1_device = MNH_ALLOCATE_ZT3D( ztmp1_device,JIU,JJU,JKU )
+iztmp2_device = MNH_ALLOCATE_ZT3D( ztmp2_device,JIU,JJU,JKU )
+iztmp3_device = MNH_ALLOCATE_ZT3D( ztmp3_device,JIU,JJU,JKU )
-!$acc data create( ztmp1_device, ztmp2_device, ztmp3_device )
+!$acc data present( ztmp1_device, ztmp2_device, ztmp3_device )
!
!* 1. DEFINITION of GY_U_UV_DEVICE
@@ -414,18 +436,27 @@ IF (.NOT. LFLAT) THEN
CALL DZM_DEVICE(KKA,KKU,KL,PA,ZTMP1_DEVICE)
CALL MXM_DEVICE(PDZZ,ZTMP2_DEVICE)
!$acc kernels
- ZTMP3_DEVICE(:,:,:) = ZTMP1_DEVICE(:,:,:)/ZTMP2_DEVICE(:,:,:)
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP3_DEVICE(JI,JJ,JK) = ZTMP1_DEVICE(JI,JJ,JK)/ZTMP2_DEVICE(JI,JJ,JK)
+ END DO !CONCURRENT
!$acc end kernels
CALL MYM_DEVICE(ZTMP3_DEVICE,ZTMP1_DEVICE)
CALL MXM_DEVICE(PDZY,ZTMP2_DEVICE)
!$acc kernels
- ZTMP3_DEVICE(:,:,:) = ZTMP1_DEVICE(:,:,:)*ZTMP2_DEVICE(:,:,:)
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP3_DEVICE(JI,JJ,JK) = ZTMP1_DEVICE(JI,JJ,JK)*ZTMP2_DEVICE(JI,JJ,JK)
+ END DO !CONCURRENT
!$acc end kernels
CALL MZF_DEVICE(KKA,KKU,KL, ZTMP3_DEVICE,ZTMP2_DEVICE )
CALL DYM_DEVICE(PA,ZTMP1_DEVICE)
CALL MXM_DEVICE(PDYY,ZTMP3_DEVICE)
!$acc kernels
- PGY_U_UV_DEVICE(:,:,:)= ( ZTMP1_DEVICE(:,:,:) - ZTMP2_DEVICE(:,:,:) ) / ZTMP3_DEVICE(:,:,:)
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ PGY_U_UV_DEVICE(JI,JJ,JK)= ( ZTMP1_DEVICE(JI,JJ,JK) - ZTMP2_DEVICE(JI,JJ,JK) ) / ZTMP3_DEVICE(JI,JJ,JK)
+ END DO !CONCURRENT
!$acc end kernels
ELSE
CALL DYM_DEVICE(PA,ZTMP1_DEVICE)
@@ -437,6 +468,8 @@ END IF
!$acc end data
+CALL MNH_REL_ZT3D(iztmp1_device,iztmp2_device,iztmp3_device)
+
!$acc end data
!----------------------------------------------------------------------------
@@ -535,6 +568,7 @@ END FUNCTION GZ_U_UW
!
!
USE MODI_SHUMAN_DEVICE
+USE MODE_MNH_ZWORK , ONLY : MNH_ALLOCATE_ZT3D , MNH_REL_ZT3D
!
IMPLICIT NONE
!
@@ -546,23 +580,26 @@ INTEGER, INTENT(IN) :: KL ! +1 if grid goes from ground to
REAL, DIMENSION(:,:,:), INTENT(IN) :: PA ! variable at the U point
REAL, DIMENSION(:,:,:), INTENT(IN) :: PDZZ ! metric coefficient dzz
!
-REAL, DIMENSION(SIZE(PA,1),SIZE(PA,2),SIZE(PA,3)), INTENT(OUT) :: PGZ_U_UW_DEVICE ! result UW point
-!
-REAL, DIMENSION(:,:,:), allocatable :: ZTMP1_DEVICE, ZTMP2_DEVICE
-!
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PGZ_U_UW_DEVICE ! result UW point
!
!* 0.2 declaration of local variables
!
-! NONE
+REAL, DIMENSION(:,:,:), pointer , contiguous :: ZTMP1_DEVICE, ZTMP2_DEVICE
+INTEGER :: IZTMP1_DEVICE, IZTMP2_DEVICE
!
+INTEGER :: JIU,JJU,JKU
!----------------------------------------------------------------------------
!$acc data present( PA, PDZZ, PGZ_U_UW_DEVICE )
-allocate( ztmp1_device(size( pa, 1 ), size( pa, 2 ), size( pa, 3 ) ) )
-allocate( ztmp2_device(size( pa, 1 ), size( pa, 2 ), size( pa, 3 ) ) )
+JIU = size(pa, 1 )
+JJU = size(pa, 2 )
+JKU = size(pa, 3 )
-!$acc data create( ztmp1_device, ztmp2_device )
+iztmp1_device = MNH_ALLOCATE_ZT3D( ztmp1_device,JIU,JJU,JKU )
+iztmp2_device = MNH_ALLOCATE_ZT3D( ztmp2_device,JIU,JJU,JKU )
+
+!$acc data present( ztmp1_device, ztmp2_device )
!
!* 1. DEFINITION of GZ_U_UW_DEVICE
@@ -576,6 +613,8 @@ PGZ_U_UW_DEVICE(:,:,:)= ZTMP1_DEVICE(:,:,:) / ZTMP2_DEVICE(:,:,:)
!$acc end data
+CALL MNH_REL_ZT3D(iztmp1_device,iztmp2_device)
+
!$acc end data
!----------------------------------------------------------------------------
diff --git a/src/MNH/gradient_v.f90 b/src/MNH/gradient_v.f90
index 18730e274a0fbc3390eb5c6e906a24b9c3ee53de..2a7742d33000c42fd2bef1244aca99363badef59 100644
--- a/src/MNH/gradient_v.f90
+++ b/src/MNH/gradient_v.f90
@@ -32,7 +32,7 @@ REAL, DIMENSION(:,:,:), INTENT(IN) :: PDYY ! metric coefficient dyy
REAL, DIMENSION(:,:,:), INTENT(IN) :: PDZZ ! metric coefficient dzz
REAL, DIMENSION(:,:,:), INTENT(IN) :: PDZY ! metric coefficient dzy
!
-REAL, DIMENSION(SIZE(PA,1),SIZE(PA,2),SIZE(PA,3)), INTENT(OUT) :: PGY_V_M_DEVICE ! result mass point
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PGY_V_M_DEVICE ! result mass point
!
END SUBROUTINE GY_V_M_DEVICE
#endif
@@ -60,7 +60,7 @@ REAL, DIMENSION(:,:,:), INTENT(IN) :: PDXX ! metric coefficient dxx
REAL, DIMENSION(:,:,:), INTENT(IN) :: PDZZ ! metric coefficient dzz
REAL, DIMENSION(:,:,:), INTENT(IN) :: PDZX ! metric coefficient dzx
!
-REAL, DIMENSION(SIZE(PA,1),SIZE(PA,2),SIZE(PA,3)), INTENT(OUT) :: PGX_V_UV_DEVICE ! result UV point
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PGX_V_UV_DEVICE ! result UV point
!
END SUBROUTINE GX_V_UV_DEVICE
#endif
@@ -84,7 +84,7 @@ INTEGER, INTENT(IN) :: KL ! +1 if grid goes from ground to
REAL, DIMENSION(:,:,:), INTENT(IN) :: PA ! variable at the V point
REAL, DIMENSION(:,:,:), INTENT(IN) :: PDZZ ! metric coefficient dzz
!
-REAL, DIMENSION(SIZE(PA,1),SIZE(PA,2),SIZE(PA,3)), INTENT(OUT) :: PGZ_V_VW_DEVICE ! result VW point
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PGZ_V_VW_DEVICE ! result VW point
!
END SUBROUTINE GZ_V_VW_DEVICE
#endif
@@ -94,8 +94,6 @@ END INTERFACE
!
END MODULE MODI_GRADIENT_V
!
-!
-!
! #######################################################
FUNCTION GY_V_M(PA,PDYY,PDZZ,PDZY) RESULT(PGY_V_M)
! #######################################################
@@ -201,6 +199,7 @@ END FUNCTION GY_V_M
!
USE MODI_SHUMAN_DEVICE
USE MODD_CONF
+USE MODE_MNH_ZWORK , ONLY : MNH_ALLOCATE_ZT3D , MNH_REL_ZT3D
!
IMPLICIT NONE
!
@@ -214,9 +213,13 @@ REAL, DIMENSION(:,:,:), INTENT(IN) :: PDYY ! metric coefficient dyy
REAL, DIMENSION(:,:,:), INTENT(IN) :: PDZZ ! metric coefficient dzz
REAL, DIMENSION(:,:,:), INTENT(IN) :: PDZY ! metric coefficient dzy
!
-REAL, DIMENSION(SIZE(PA,1),SIZE(PA,2),SIZE(PA,3)), INTENT(OUT) :: PGY_V_M_DEVICE ! result mass point
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PGY_V_M_DEVICE ! result mass point
!
-REAL, DIMENSION(:,:,:), allocatable :: ZTMP1_DEVICE, ZTMP2_DEVICE, ZTMP3_DEVICE
+REAL, DIMENSION(:,:,:), pointer , contiguous :: ZTMP1_DEVICE, ZTMP2_DEVICE, ZTMP3_DEVICE
+INTEGER :: IZTMP1_DEVICE, IZTMP2_DEVICE, IZTMP3_DEVICE
+!
+INTEGER :: JIU,JJU,JKU
+INTEGER :: JI,JJ,JK
!
!* 0.2 declaration of local variables
!
@@ -226,11 +229,15 @@ REAL, DIMENSION(:,:,:), allocatable :: ZTMP1_DEVICE, ZTMP2_DEVICE, ZTMP3_DEVICE
!$acc data present( PA, PDYY, PDZZ, PDZY, PGY_V_M_DEVICE )
-allocate( ztmp1_device(size( pa, 1 ), size( pa, 2 ), size( pa, 3 ) ) )
-allocate( ztmp2_device(size( pa, 1 ), size( pa, 2 ), size( pa, 3 ) ) )
-allocate( ztmp3_device(size( pa, 1 ), size( pa, 2 ), size( pa, 3 ) ) )
+JIU = size(pa, 1 )
+JJU = size(pa, 2 )
+JKU = size(pa, 3 )
+
+iztmp1_device = MNH_ALLOCATE_ZT3D( ztmp1_device,JIU,JJU,JKU )
+iztmp2_device = MNH_ALLOCATE_ZT3D( ztmp2_device,JIU,JJU,JKU )
+iztmp3_device = MNH_ALLOCATE_ZT3D( ztmp3_device,JIU,JJU,JKU )
-!$acc data create( ztmp1_device, ztmp2_device, ztmp3_device )
+!$acc data present( ztmp1_device, ztmp2_device, ztmp3_device )
!
!* 1. DEFINITION of GY_V_M_DEVICE
@@ -239,13 +246,19 @@ allocate( ztmp3_device(size( pa, 1 ), size( pa, 2 ), size( pa, 3 ) ) )
IF (.NOT. LFLAT) THEN
CALL DYF_DEVICE(PA,ZTMP1_DEVICE)
CALL DZM_DEVICE(KKA,KKU,KL,PA,ZTMP2_DEVICE)
-!$acc kernels
- ZTMP3_DEVICE(:,:,:) = PDZY(:,:,:)*ZTMP2_DEVICE(:,:,:)
-!$acc end kernels
+ !$acc kernels
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP3_DEVICE(JI,JJ,JK) = PDZY(JI,JJ,JK)*ZTMP2_DEVICE(JI,JJ,JK)
+ END DO !CONCURRENT
+ !$acc end kernels
CALL MYF_DEVICE(ZTMP3_DEVICE,ZTMP2_DEVICE)
-!$acc kernels
- ZTMP3_DEVICE(:,:,:) = ZTMP2_DEVICE(:,:,:)/PDZZ(:,:,:)
-!$acc end kernels
+ !$acc kernels
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP3_DEVICE(JI,JJ,JK) = ZTMP2_DEVICE(JI,JJ,JK)/PDZZ(JI,JJ,JK)
+ END DO !CONCURRENT
+ !$acc end kernels
CALL MZF_DEVICE(KKA,KKU,KL,ZTMP3_DEVICE,ZTMP2_DEVICE)
CALL MYF_DEVICE(PDYY,ZTMP3_DEVICE)
!$acc kernels
@@ -261,6 +274,8 @@ END IF
!$acc end data
+CALL MNH_REL_ZT3D(iztmp1_device,iztmp2_device,iztmp3_device)
+
!$acc end data
!----------------------------------------------------------------------------
@@ -374,6 +389,7 @@ END FUNCTION GX_V_UV
!
USE MODI_SHUMAN_DEVICE
USE MODD_CONF
+USE MODE_MNH_ZWORK , ONLY : MNH_ALLOCATE_ZT3D , MNH_REL_ZT3D
!
IMPLICIT NONE
!
@@ -387,48 +403,61 @@ REAL, DIMENSION(:,:,:), INTENT(IN) :: PDXX ! metric coefficient dxx
REAL, DIMENSION(:,:,:), INTENT(IN) :: PDZZ ! metric coefficient dzz
REAL, DIMENSION(:,:,:), INTENT(IN) :: PDZX ! metric coefficient dzx
!
-REAL, DIMENSION(SIZE(PA,1),SIZE(PA,2),SIZE(PA,3)), INTENT(OUT) :: PGX_V_UV_DEVICE ! result UV point
-!
-REAL, DIMENSION(:,:,:), allocatable :: ZTMP1_DEVICE, ZTMP2_DEVICE, ZTMP3_DEVICE, ZTMP4_DEVICE
-!
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PGX_V_UV_DEVICE ! result UV point
!
!* 0.2 declaration of local variables
!
-! NONE
+REAL, DIMENSION(:,:,:), pointer , contiguous :: ZTMP1_DEVICE, ZTMP2_DEVICE, ZTMP3_DEVICE, ZTMP4_DEVICE
+INTEGER :: IZTMP1_DEVICE, IZTMP2_DEVICE, IZTMP3_DEVICE, IZTMP4_DEVICE
+!
+INTEGER :: JIU,JJU,JKU
+INTEGER :: JI,JJ,JK
!
!----------------------------------------------------------------------------
!$acc data present( PA, PDXX, PDZZ, PDZX, PGX_V_UV_DEVICE )
-allocate( ztmp1_device(size( pa, 1 ), size( pa, 2 ), size( pa, 3 ) ) )
-allocate( ztmp2_device(size( pa, 1 ), size( pa, 2 ), size( pa, 3 ) ) )
-allocate( ztmp3_device(size( pa, 1 ), size( pa, 2 ), size( pa, 3 ) ) )
-allocate( ztmp4_device(size( pa, 1 ), size( pa, 2 ), size( pa, 3 ) ) )
+JIU = size(pa, 1 )
+JJU = size(pa, 2 )
+JKU = size(pa, 3 )
+
+iztmp1_device = MNH_ALLOCATE_ZT3D( ztmp1_device,JIU,JJU,JKU )
+iztmp2_device = MNH_ALLOCATE_ZT3D( ztmp2_device,JIU,JJU,JKU )
+iztmp3_device = MNH_ALLOCATE_ZT3D( ztmp3_device,JIU,JJU,JKU )
+iztmp4_device = MNH_ALLOCATE_ZT3D( ztmp4_device,JIU,JJU,JKU )
-!$acc data create( ztmp1_device, ztmp2_device, ztmp3_device, ztmp4_device )
+!$acc data present( ztmp1_device, ztmp2_device, ztmp3_device, ztmp4_device )
!
!* 1. DEFINITION of GX_V_UV_DEVICE
! ---------------------
!
IF (.NOT. LFLAT) THEN
-
CALL DXM_DEVICE(PA,ZTMP1_DEVICE)
CALL MYM_DEVICE(PDZZ,ZTMP2_DEVICE)
CALL DZM_DEVICE(KKA,KKU,KL,PA,ZTMP3_DEVICE)
-!$acc kernels
- ZTMP4_DEVICE(:,:,:) = ZTMP3_DEVICE(:,:,:) / ZTMP2_DEVICE(:,:,:)
-!$acc end kernels
+ !$acc kernels
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP4_DEVICE(JI,JJ,JK) = ZTMP3_DEVICE(JI,JJ,JK) / ZTMP2_DEVICE(JI,JJ,JK)
+ END DO !CONCURRENT
+ !$acc end kernels
CALL MXM_DEVICE(ZTMP4_DEVICE,ZTMP2_DEVICE)
CALL MYM_DEVICE(PDZX,ZTMP3_DEVICE)
-!$acc kernels
- ZTMP4_DEVICE(:,:,:) = ZTMP2_DEVICE(:,:,:) *ZTMP3_DEVICE(:,:,:)
-!$acc end kernels
+ !$acc kernels
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP4_DEVICE(JI,JJ,JK) = ZTMP2_DEVICE(JI,JJ,JK) *ZTMP3_DEVICE(JI,JJ,JK)
+ END DO !CONCURRENT
+ !$acc end kernels
CALL MZF_DEVICE(KKA,KKU,KL,ZTMP4_DEVICE,ZTMP2_DEVICE)
CALL MYM_DEVICE(PDXX,ZTMP3_DEVICE)
-!$acc kernels
- PGX_V_UV_DEVICE(:,:,:)= ( ZTMP1_DEVICE(:,:,:) - ZTMP2_DEVICE(:,:,:) ) / ZTMP3_DEVICE(:,:,:)
-!$acc end kernels
+ !$acc kernels
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ PGX_V_UV_DEVICE(JI,JJ,JK)= ( ZTMP1_DEVICE(JI,JJ,JK) - ZTMP2_DEVICE(JI,JJ,JK) ) / ZTMP3_DEVICE(JI,JJ,JK)
+ END DO !CONCURRENT
+ !$acc end kernels
ELSE
CALL DXM_DEVICE(PA,ZTMP1_DEVICE)
CALL MYM_DEVICE(PDXX,ZTMP2_DEVICE)
@@ -439,6 +468,8 @@ END IF
!$acc end data
+CALL MNH_REL_ZT3D(iztmp1_device,iztmp2_device,iztmp3_device,iztmp4_device)
+
!$acc end data
!----------------------------------------------------------------------------
@@ -538,6 +569,8 @@ END FUNCTION GZ_V_VW
!
!
USE MODI_SHUMAN_DEVICE
+USE MODI_SHUMAN
+USE MODE_MNH_ZWORK , ONLY : MNH_ALLOCATE_ZT3D , MNH_REL_ZT3D
!
IMPLICIT NONE
!
@@ -549,22 +582,26 @@ INTEGER, INTENT(IN) :: KL ! +1 if grid goes from ground to
REAL, DIMENSION(:,:,:), INTENT(IN) :: PA ! variable at the V point
REAL, DIMENSION(:,:,:), INTENT(IN) :: PDZZ ! metric coefficient dzz
!
-REAL, DIMENSION(SIZE(PA,1),SIZE(PA,2),SIZE(PA,3)), INTENT(OUT) :: PGZ_V_VW_DEVICE ! result VW point
-!
-REAL, DIMENSION(:,:,:), allocatable :: ZTMP1_DEVICE, ZTMP2_DEVICE
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PGZ_V_VW_DEVICE ! result VW point
!
!* 0.2 declaration of local variables
!
-! NONE
+REAL, DIMENSION(:,:,:), pointer , contiguous :: ZTMP1_DEVICE, ZTMP2_DEVICE
+INTEGER :: IZTMP1_DEVICE, IZTMP2_DEVICE
!
+INTEGER :: JIU,JJU,JKU
!----------------------------------------------------------------------------
!$acc data present( PA, PDZZ, PGZ_V_VW_DEVICE )
-allocate( ztmp1_device(size( pa, 1 ), size( pa, 2 ), size( pa, 3 ) ) )
-allocate( ztmp2_device(size( pa, 1 ), size( pa, 2 ), size( pa, 3 ) ) )
+JIU = size(pa, 1 )
+JJU = size(pa, 2 )
+JKU = size(pa, 3 )
-!$acc data create( ztmp1_device, ztmp2_device )
+iztmp1_device = MNH_ALLOCATE_ZT3D( ztmp1_device,JIU,JJU,JKU )
+iztmp2_device = MNH_ALLOCATE_ZT3D( ztmp2_device,JIU,JJU,JKU )
+
+!$acc data present( ztmp1_device, ztmp2_device )
!
!* 1. DEFINITION of GZ_V_VW_DEVICE
@@ -578,9 +615,12 @@ PGZ_V_VW_DEVICE(:,:,:)= ZTMP1_DEVICE(:,:,:) / ZTMP2_DEVICE(:,:,:)
!$acc end data
+CALL MNH_REL_ZT3D(iztmp1_device,iztmp2_device)
+
!$acc end data
!----------------------------------------------------------------------------
!
END SUBROUTINE GZ_V_VW_DEVICE
#endif
+
diff --git a/src/MNH/gradient_w.f90 b/src/MNH/gradient_w.f90
index 83ecb6721ca5b624d53e8bf6dd6f5e3354499593..f49ddab87bdd5ec92a0742325d4926829de7cac7 100644
--- a/src/MNH/gradient_w.f90
+++ b/src/MNH/gradient_w.f90
@@ -28,7 +28,7 @@ INTEGER, INTENT(IN) :: KL ! +1 if grid goes from ground to
REAL, DIMENSION(:,:,:), INTENT(IN) :: PA ! variable at the W point
REAL, DIMENSION(:,:,:), INTENT(IN) :: PDZZ ! metric coefficient dzz
!
-REAL, DIMENSION(SIZE(PA,1),SIZE(PA,2),SIZE(PA,3)), INTENT(OUT) :: PGZ_W_M_DEVICE ! result mass point
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PGZ_W_M_DEVICE ! result mass point
!
END SUBROUTINE GZ_W_M_DEVICE
#endif
@@ -56,7 +56,7 @@ REAL, DIMENSION(:,:,:), INTENT(IN) :: PDXX ! metric coefficient dxx
REAL, DIMENSION(:,:,:), INTENT(IN) :: PDZZ ! metric coefficient dzz
REAL, DIMENSION(:,:,:), INTENT(IN) :: PDZX ! metric coefficient dzx
!
-REAL, DIMENSION(SIZE(PA,1),SIZE(PA,2),SIZE(PA,3)), INTENT(OUT) :: PGX_W_UW_DEVICE ! result UW point
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PGX_W_UW_DEVICE ! result UW point
!
END SUBROUTINE GX_W_UW_DEVICE
#endif
@@ -84,7 +84,7 @@ REAL, DIMENSION(:,:,:), INTENT(IN) :: PDYY ! metric coefficient dyy
REAL, DIMENSION(:,:,:), INTENT(IN) :: PDZZ ! metric coefficient dzz
REAL, DIMENSION(:,:,:), INTENT(IN) :: PDZY ! metric coefficient dzy
!
-REAL, DIMENSION(SIZE(PA,1),SIZE(PA,2),SIZE(PA,3)), INTENT(OUT) :: PGY_W_VW_DEVICE ! result VW point
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PGY_W_VW_DEVICE ! result VW point
!
END SUBROUTINE GY_W_VW_DEVICE
#endif
@@ -93,9 +93,7 @@ END SUBROUTINE GY_W_VW_DEVICE
END INTERFACE
!
END MODULE MODI_GRADIENT_W
-!
-!
-!
+!
! #######################################################
FUNCTION GZ_W_M(PA,PDZZ) RESULT(PGZ_W_M)
! #######################################################
@@ -181,6 +179,8 @@ END FUNCTION GZ_W_M
!
!
USE MODI_SHUMAN_DEVICE
+USE MODI_SHUMAN
+USE MODE_MNH_ZWORK , ONLY : MNH_ALLOCATE_ZT3D , MNH_REL_ZT3D
!
IMPLICIT NONE
!
@@ -192,20 +192,26 @@ INTEGER, INTENT(IN) :: KL ! +1 if grid goes from ground to
REAL, DIMENSION(:,:,:), INTENT(IN) :: PA ! variable at the W point
REAL, DIMENSION(:,:,:), INTENT(IN) :: PDZZ ! metric coefficient dzz
!
-REAL, DIMENSION(SIZE(PA,1),SIZE(PA,2),SIZE(PA,3)), INTENT(OUT) :: PGZ_W_M_DEVICE ! result mass point
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PGZ_W_M_DEVICE ! result mass point
!
!* 0.2 declaration of local variables
!
-REAL, DIMENSION(:,:,:), allocatable :: ZTMP1_DEVICE, ZTMP2_DEVICE
+REAL, DIMENSION(:,:,:), pointer , contiguous :: ZTMP1_DEVICE, ZTMP2_DEVICE
+INTEGER :: IZTMP1_DEVICE, IZTMP2_DEVICE
!
+INTEGER :: JIU,JJU,JKU
!----------------------------------------------------------------------------
!$acc data present( PA, PDZZ, PGZ_W_M_DEVICE )
-allocate( ztmp1_device(size( pa, 1 ), size( pa, 2 ), size( pa, 3 ) ) )
-allocate( ztmp2_device(size( pa, 1 ), size( pa, 2 ), size( pa, 3 ) ) )
+JIU = size(pa, 1 )
+JJU = size(pa, 2 )
+JKU = size(pa, 3 )
+
+iztmp1_device = MNH_ALLOCATE_ZT3D( ztmp1_device,JIU,JJU,JKU )
+iztmp2_device = MNH_ALLOCATE_ZT3D( ztmp2_device,JIU,JJU,JKU )
-!$acc data create( ztmp1_device, ztmp2_device )
+!$acc data present( ztmp1_device, ztmp2_device )
!
!* 1. DEFINITION of GZ_W_M_DEVICE
@@ -219,6 +225,8 @@ PGZ_W_M_DEVICE(:,:,:)= ZTMP1_DEVICE(:,:,:)/ZTMP2_DEVICE(:,:,:)
!$acc end data
+CALL MNH_REL_ZT3D(iztmp1_device,iztmp2_device)
+
!$acc end data
!----------------------------------------------------------------------------
@@ -323,6 +331,7 @@ END FUNCTION GX_W_UW
!
USE MODI_SHUMAN_DEVICE
USE MODD_CONF
+USE MODE_MNH_ZWORK , ONLY : MNH_ALLOCATE_ZT3D , MNH_REL_ZT3D
!
IMPLICIT NONE
!
@@ -336,23 +345,29 @@ REAL, DIMENSION(:,:,:), INTENT(IN) :: PDXX ! metric coefficient dxx
REAL, DIMENSION(:,:,:), INTENT(IN) :: PDZZ ! metric coefficient dzz
REAL, DIMENSION(:,:,:), INTENT(IN) :: PDZX ! metric coefficient dzx
!
-REAL, DIMENSION(SIZE(PA,1),SIZE(PA,2),SIZE(PA,3)), INTENT(OUT) :: PGX_W_UW_DEVICE ! result UW point
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PGX_W_UW_DEVICE ! result UW point
!
!* 0.2 declaration of local variables
!
-REAL, DIMENSION(:,:,:), allocatable :: ZTMP1_DEVICE, ZTMP2_DEVICE, ZTMP3_DEVICE, ZTMP4_DEVICE, ZTMP5_DEVICE
+REAL, DIMENSION(:,:,:), pointer , contiguous :: ZTMP1_DEVICE, ZTMP2_DEVICE, ZTMP3_DEVICE, ZTMP4_DEVICE, ZTMP5_DEVICE
+INTEGER :: IZTMP1_DEVICE, IZTMP2_DEVICE, IZTMP3_DEVICE,IZTMP4_DEVICE,IZTMP5_DEVICE
!
+INTEGER :: JIU,JJU,JKU
!----------------------------------------------------------------------------
!$acc data present( PA, PDXX, PDZZ, PDZX, PGX_W_UW_DEVICE )
-allocate( ztmp1_device(size( pa, 1 ), size( pa, 2 ), size( pa, 3 ) ) )
-allocate( ztmp2_device(size( pa, 1 ), size( pa, 2 ), size( pa, 3 ) ) )
-allocate( ztmp3_device(size( pa, 1 ), size( pa, 2 ), size( pa, 3 ) ) )
-allocate( ztmp4_device(size( pa, 1 ), size( pa, 2 ), size( pa, 3 ) ) )
-allocate( ztmp5_device(size( pa, 1 ), size( pa, 2 ), size( pa, 3 ) ) )
+JIU = size(pa, 1 )
+JJU = size(pa, 2 )
+JKU = size(pa, 3 )
-!$acc data create( ztmp1_device, ztmp2_device, ztmp3_device, ztmp4_device, ztmp5_device )
+iztmp1_device = MNH_ALLOCATE_ZT3D( ztmp1_device,JIU,JJU,JKU )
+iztmp2_device = MNH_ALLOCATE_ZT3D( ztmp2_device,JIU,JJU,JKU )
+iztmp3_device = MNH_ALLOCATE_ZT3D( ztmp3_device,JIU,JJU,JKU )
+iztmp4_device = MNH_ALLOCATE_ZT3D( ztmp4_device,JIU,JJU,JKU )
+iztmp5_device = MNH_ALLOCATE_ZT3D( ztmp5_device,JIU,JJU,JKU )
+
+!$acc data present( ztmp1_device, ztmp2_device, ztmp3_device, ztmp4_device, ztmp5_device )
!
!* 1. DEFINITION of GX_W_UW_DEVICE
@@ -383,6 +398,8 @@ END IF
!$acc end data
+CALL MNH_REL_ZT3D( iztmp1_device, iztmp2_device, iztmp3_device, iztmp4_device, iztmp5_device )
+
!$acc end data
!----------------------------------------------------------------------------
@@ -487,6 +504,7 @@ END FUNCTION GY_W_VW
!
USE MODI_SHUMAN_DEVICE
USE MODD_CONF
+USE MODE_MNH_ZWORK , ONLY : MNH_ALLOCATE_ZT3D , MNH_REL_ZT3D
!
IMPLICIT NONE
!
@@ -500,23 +518,30 @@ REAL, DIMENSION(:,:,:), INTENT(IN) :: PDYY ! metric coefficient dyy
REAL, DIMENSION(:,:,:), INTENT(IN) :: PDZZ ! metric coefficient dzz
REAL, DIMENSION(:,:,:), INTENT(IN) :: PDZY ! metric coefficient dzy
!
-REAL, DIMENSION(SIZE(PA,1),SIZE(PA,2),SIZE(PA,3)), INTENT(OUT) :: PGY_W_VW_DEVICE ! result VW point
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PGY_W_VW_DEVICE ! result VW point
!
!* 0.2 declaration of local variables
!
-REAL, DIMENSION(:,:,:), allocatable :: ZTMP1_DEVICE, ZTMP2_DEVICE, ZTMP3_DEVICE, ZTMP4_DEVICE, ZTMP5_DEVICE
+REAL, DIMENSION(:,:,:), pointer , contiguous :: ZTMP1_DEVICE, ZTMP2_DEVICE, ZTMP3_DEVICE, ZTMP4_DEVICE, ZTMP5_DEVICE
+INTEGER :: IZTMP1_DEVICE, IZTMP2_DEVICE, IZTMP3_DEVICE,IZTMP4_DEVICE,IZTMP5_DEVICE
+!
+INTEGER :: JIU,JJU,JKU
!
!----------------------------------------------------------------------------
!$acc data present( PA, PDYY, PDZZ, PDZY, PGY_W_VW_DEVICE )
-allocate( ztmp1_device(size( pa, 1 ), size( pa, 2 ), size( pa, 3 ) ) )
-allocate( ztmp2_device(size( pa, 1 ), size( pa, 2 ), size( pa, 3 ) ) )
-allocate( ztmp3_device(size( pa, 1 ), size( pa, 2 ), size( pa, 3 ) ) )
-allocate( ztmp4_device(size( pa, 1 ), size( pa, 2 ), size( pa, 3 ) ) )
-allocate( ztmp5_device(size( pa, 1 ), size( pa, 2 ), size( pa, 3 ) ) )
+JIU = size(pa, 1 )
+JJU = size(pa, 2 )
+JKU = size(pa, 3 )
-!$acc data create( ztmp1_device, ztmp2_device, ztmp3_device, ztmp4_device, ztmp5_device )
+iztmp1_device = MNH_ALLOCATE_ZT3D( ztmp1_device,JIU,JJU,JKU )
+iztmp2_device = MNH_ALLOCATE_ZT3D( ztmp2_device,JIU,JJU,JKU )
+iztmp3_device = MNH_ALLOCATE_ZT3D( ztmp3_device,JIU,JJU,JKU )
+iztmp4_device = MNH_ALLOCATE_ZT3D( ztmp4_device,JIU,JJU,JKU )
+iztmp5_device = MNH_ALLOCATE_ZT3D( ztmp5_device,JIU,JJU,JKU )
+
+!$acc data present( ztmp1_device, ztmp2_device, ztmp3_device, ztmp4_device, ztmp5_device )
!
!* 1. DEFINITION of GY_W_VW_DEVICE
@@ -547,9 +572,12 @@ END IF
!$acc end data
+CALL MNH_REL_ZT3D( iztmp1_device, iztmp2_device, iztmp3_device, iztmp4_device, iztmp5_device )
+
!$acc end data
!----------------------------------------------------------------------------
!
END SUBROUTINE GY_W_VW_DEVICE
#endif
+
diff --git a/src/MNH/gravity_impl.f90 b/src/MNH/gravity_impl.f90
index 600520cf575b0d5009a6c73815914a30dc6bfc1e..3b6366dda85cf55c331ffd63875f16d1270784e2 100644
--- a/src/MNH/gravity_impl.f90
+++ b/src/MNH/gravity_impl.f90
@@ -127,6 +127,9 @@ REAL, DIMENSION(:,:,:,:), allocatable :: ZR
!
INTEGER :: JR
!
+INTEGER :: JI,JJ,JK
+INTEGER :: JIU,JJU,JKU
+!
!-------------------------------------------------------------------------------
!$acc data present( PTHT, PRHODJ, PRT, PTHVREF, PRWS, PRTHS, PRRS, PRTHS_CLD, PRRS_CLD )
@@ -145,6 +148,10 @@ IF (MPPDB_INITIALIZED) THEN
CALL MPPDB_CHECK(PRWS, "GRAVITY_IMPL beg:PRWS")
END IF
+JIU = size(ptht, 1 )
+JJU = size(ptht, 2 )
+JKU = size(ptht, 3 )
+
allocate( zrws_grav( size( ptht, 1 ), size( ptht, 2 ), size( ptht, 3 ) ) )
allocate( zth ( size( ptht, 1 ), size( ptht, 2 ), size( ptht, 3 ) ) )
allocate( zr ( size( prt, 1 ), size( prt, 2 ), size( prt, 3 ), size( prt, 4 ) ) )
@@ -156,9 +163,10 @@ if ( lbudget_w ) call Budget_store_init( tbudgets(NBUDGET_W), 'GRAV', prws(:, :,
! guess of Theta at future time-step
!$acc kernels
ZTH(:,:,:) = (PRTHS(:,:,:) + PRTHS_CLD(:,:,:)) / PRHODJ(:,:,:) * PTSTEP
-DO JR = 1, KRR
- ZR(:,:,:,JR) = (PRRS(:,:,:,JR) + PRRS_CLD(:,:,:,JR)) / PRHODJ(:,:,:) * PTSTEP
-END DO
+!
+DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU , JR = 1:KRR )
+ ZR(JI,JJ,JK,JR) = (PRRS(JI,JJ,JK,JR) + PRRS_CLD(JI,JJ,JK,JR)) / PRHODJ(JI,JJ,JK) * PTSTEP
+END DO ! CONCURRENT
!$acc end kernels
!
#ifndef MNH_OPENACC
diff --git a/src/MNH/ini_dynamics.f90 b/src/MNH/ini_dynamics.f90
index e4d00f5bb6aa29d04e9ce3cdb3cf10e0ae4187cb..13ea80bc10b5480c3e8fb1e0d16f77034c2288fa 100644
--- a/src/MNH/ini_dynamics.f90
+++ b/src/MNH/ini_dynamics.f90
@@ -296,6 +296,13 @@ USE MODI_ZDIFFUSETUP
!
USE MODE_ll
USE MODE_TYPE_ZDIFFU
+#ifdef MNH_BITREP
+USE MODI_BITREP
+#define SIN BR_SIN
+#define COS BR_COS
+#endif
+!
+USE MODE_MPPDB
!
IMPLICIT NONE
!
@@ -474,6 +481,11 @@ IF (.NOT.LCARTESIAN) THEN
/ COS(PLAT(:,:)*ZCDR)
PCURVY (:,:) = SIN(ZGAMMA(:,:)) * (SIN(PLAT(:,:)*ZCDR) -XRPK) &
/ COS(PLAT(:,:)*ZCDR)
+ !
+ CALL MPPDB_CHECK2D(PCORIOX,"ini_dynamics:PCORIOX",PRECISION)
+ CALL MPPDB_CHECK2D(PCORIOY,"ini_dynamics:PCORIOY",PRECISION)
+ CALL MPPDB_CHECK2D(PCORIOZ,"ini_dynamics:PCORIOZ",PRECISION)
+ !
ELSE
ZMBETA = - (XBETA*ZCDR)
PCORIOX(:,:) = - 2. * XOMEGA * COS(XLAT0*ZCDR) * SIN(ZMBETA)
diff --git a/src/MNH/ini_modeln.f90 b/src/MNH/ini_modeln.f90
index 48b3a7348e239e3db4e139c6687184d781a7365c..3103dd95135169a32c2cd4cf34401ca1020cdd11 100644
--- a/src/MNH/ini_modeln.f90
+++ b/src/MNH/ini_modeln.f90
@@ -855,6 +855,7 @@ ALLOCATE(XRUS_PRES(IIU,IJU,IKU)); XRUS_PRES = 0.0
ALLOCATE(XRVS_PRES(IIU,IJU,IKU)); XRVS_PRES = 0.0
ALLOCATE(XRWS_PRES(IIU,IJU,IKU)); XRWS_PRES = 0.0
ALLOCATE(XRTHS(IIU,IJU,IKU)) ; XRTHS = 0.0
+!$acc enter data copyin(XRTHS)
ALLOCATE(XRTHS_CLD(IIU,IJU,IKU)); XRTHS_CLD = 0.0
IF ( LIBM ) THEN
@@ -1017,6 +1018,7 @@ ALLOCATE(XDYY(IIU,IJU,IKU))
ALLOCATE(XDZX(IIU,IJU,IKU))
ALLOCATE(XDZY(IIU,IJU,IKU))
ALLOCATE(XDZZ(IIU,IJU,IKU))
+!$acc enter data create(XDXX,XDYY,XDZZ,XDZX,XDZY)
!
!* 3.3 Modules MODD_REF and MODD_REF_n
!
@@ -1037,6 +1039,7 @@ ALLOCATE(XRHODREF(IIU,IJU,IKU))
ALLOCATE(XTHVREF(IIU,IJU,IKU))
ALLOCATE(XEXNREF(IIU,IJU,IKU))
ALLOCATE(XRHODJ(IIU,IJU,IKU))
+!$acc enter data create(XRHODJ)
IF (CEQNSYS=='DUR' .AND. LUSERV) THEN
ALLOCATE(XRVREF(IIU,IJU,IKU))
ELSE
diff --git a/src/MNH/ini_radiations.f90 b/src/MNH/ini_radiations.f90
index 883179c8b2dd82f38644f08aec0f048b9684bb41..9317321fa3b9c0a31bdfbffc3c11b7241a5dc01e 100644
--- a/src/MNH/ini_radiations.f90
+++ b/src/MNH/ini_radiations.f90
@@ -130,6 +130,11 @@ USE MODE_IO_FIELD_READ, only: IO_Field_read
USE MODE_ll
!
USE MODI_SHUMAN
+#ifdef MNH_BITREP
+USE MODI_BITREP
+#define ATAN BR_ATAN
+#define ATAN2 BR_ATAN2
+#endif
!
IMPLICIT NONE
!
diff --git a/src/MNH/ini_rain_ice.f90 b/src/MNH/ini_rain_ice.f90
index 62cabad5b587f48a6cd6d443c088c8c7cea8c2ca..d8200edbe6da802faa57c592f620033f47ce36fb 100644
--- a/src/MNH/ini_rain_ice.f90
+++ b/src/MNH/ini_rain_ice.f90
@@ -102,6 +102,8 @@ END MODULE MODI_INI_RAIN_ICE
!! S. Riette 2016-11: new ICE3/ICE4 options
!! P. Wautelet 22/01/2019 bug correction: incorrect write
! P. Wautelet 26/04/2019: replace non-standard FLOAT function by REAL function
+! J. Escobar 12/08/2020: Openacc PB, data partially present => add enter data on XGAMINC* , XKER_SDRYG
+! J. Escobar 13/08/2020: Openacc PB , missing enter/update data rain_ice_fast_rs/g
!
!-------------------------------------------------------------------------------
!
@@ -673,9 +675,18 @@ XGAMINC_BOUND_MIN = 1.0E-1 ! Minimal value of (Lbda * D_cs^lim)**alpha
XGAMINC_BOUND_MAX = 1.0E7 ! Maximal value of (Lbda * D_cs^lim)**alpha
ZRATE = EXP(LOG(XGAMINC_BOUND_MAX/XGAMINC_BOUND_MIN)/REAL(NGAMINC-1))
!
-IF( .NOT.ALLOCATED(XGAMINC_RIM1) ) ALLOCATE( XGAMINC_RIM1(NGAMINC) )
-IF( .NOT.ALLOCATED(XGAMINC_RIM2) ) ALLOCATE( XGAMINC_RIM2(NGAMINC) )
-IF( .NOT.ALLOCATED(XGAMINC_RIM4) ) ALLOCATE( XGAMINC_RIM4(NGAMINC) )
+IF( .NOT.ALLOCATED(XGAMINC_RIM1) ) THEN
+ ALLOCATE( XGAMINC_RIM1(NGAMINC) )
+ !$acc enter data create (XGAMINC_RIM1)
+END IF
+IF( .NOT.ALLOCATED(XGAMINC_RIM2) ) THEN
+ ALLOCATE( XGAMINC_RIM2(NGAMINC) )
+ !$acc enter data create (XGAMINC_RIM2)
+END IF
+IF( .NOT.ALLOCATED(XGAMINC_RIM4) ) THEN
+ ALLOCATE( XGAMINC_RIM4(NGAMINC) )
+ !$acc enter data create (XGAMINC_RIM4)
+END IF
!
DO J1=1,NGAMINC
ZBOUND = XGAMINC_BOUND_MIN*ZRATE**(J1-1)
@@ -684,6 +695,8 @@ DO J1=1,NGAMINC
XGAMINC_RIM4(J1) = GAMMA_INC(XNUS+XBG/XALPHAS ,ZBOUND)
END DO
!
+!$acc update device (XGAMINC_RIM1,XGAMINC_RIM2,XGAMINC_RIM4)
+!
XRIMINTP1 = XALPHAS / LOG(ZRATE)
XRIMINTP2 = 1.0 + XRIMINTP1*LOG( XDCSLIM/(XGAMINC_BOUND_MIN)**(1.0/XALPHAS) )
!
@@ -725,14 +738,24 @@ IND = 50 ! Interval number, collection efficiency and infinite diameter
ZESR = 1.0 ! factor used to integrate the dimensional distributions when
ZFDINFTY = 20.0 ! computing the kernels XKER_RACCSS, XKER_RACCS and XKER_SACCRG
!
-IF( .NOT.ALLOCATED(XKER_RACCSS) ) ALLOCATE( XKER_RACCSS(NACCLBDAS,NACCLBDAR) )
-IF( .NOT.ALLOCATED(XKER_RACCS ) ) ALLOCATE( XKER_RACCS (NACCLBDAS,NACCLBDAR) )
-IF( .NOT.ALLOCATED(XKER_SACCRG) ) ALLOCATE( XKER_SACCRG(NACCLBDAR,NACCLBDAS) )
+IF( .NOT.ALLOCATED(XKER_RACCSS) ) THEN
+ ALLOCATE( XKER_RACCSS(NACCLBDAS,NACCLBDAR) )
+ !$acc enter data create(XKER_RACCSS)
+END IF
+IF( .NOT.ALLOCATED(XKER_RACCS ) ) THEN
+ ALLOCATE( XKER_RACCS (NACCLBDAS,NACCLBDAR) )
+ !$acc enter data create(XKER_RACCS)
+END IF
+IF( .NOT.ALLOCATED(XKER_SACCRG) ) THEN
+ ALLOCATE( XKER_SACCRG(NACCLBDAR,NACCLBDAS) )
+ !$acc enter data create(XKER_SACCRG)
+END IF
!
CALL READ_XKER_RACCS (KACCLBDAS,KACCLBDAR,KND, &
PALPHAS,PNUS,PALPHAR,PNUR,PESR,PBS,PBR,PCS,PDS,PCR,PDR, &
PACCLBDAS_MAX,PACCLBDAR_MAX,PACCLBDAS_MIN,PACCLBDAR_MIN,&
PFDINFTY )
+!
IF( (KACCLBDAS/=NACCLBDAS) .OR. (KACCLBDAR/=NACCLBDAR) .OR. (KND/=IND) .OR. &
(PALPHAS/=XALPHAS) .OR. (PNUS/=XNUS) .OR. &
(PALPHAR/=XALPHAR) .OR. (PNUR/=XNUR) .OR. &
@@ -753,6 +776,8 @@ IF( (KACCLBDAS/=NACCLBDAS) .OR. (KACCLBDAR/=NACCLBDAR) .OR. (KND/=IND) .OR. &
ZESR, XBS, XCS, XDS, XCR, XDR, &
XACCLBDAS_MAX, XACCLBDAR_MAX, XACCLBDAS_MIN, XACCLBDAR_MIN, &
ZFDINFTY, XKER_SACCRG, XAG, XBS, XAS )
+ !$acc update device(XKER_RACCSS,XKER_RACCS,XKER_SACCRG)
+ !
WRITE(UNIT=KLUOUT,FMT='("*****************************************")')
WRITE(UNIT=KLUOUT,FMT='("**** UPDATE NEW SET OF RACSS KERNELS ****")')
WRITE(UNIT=KLUOUT,FMT='("**** UPDATE NEW SET OF RACS KERNELS ****")')
@@ -814,6 +839,9 @@ IF( (KACCLBDAS/=NACCLBDAS) .OR. (KACCLBDAR/=NACCLBDAR) .OR. (KND/=IND) .OR. &
PALPHAS,PNUS,PALPHAR,PNUR,PESR,PBS,PBR,PCS,PDS,PCR,PDR, &
PACCLBDAS_MAX,PACCLBDAR_MAX,PACCLBDAS_MIN,PACCLBDAR_MIN,&
PFDINFTY,XKER_RACCSS,XKER_RACCS,XKER_SACCRG )
+ !
+ !$acc update device(XKER_RACCSS,XKER_RACCS,XKER_SACCRG)
+ !
WRITE(UNIT=KLUOUT,FMT='(" Read XKER_RACCSS")')
WRITE(UNIT=KLUOUT,FMT='(" Read XKER_RACCS ")')
WRITE(UNIT=KLUOUT,FMT='(" Read XKER_SACCRG")')
@@ -935,12 +963,17 @@ IND = 50 ! Interval number, collection efficiency and infinite diameter
ZEGS = 1.0 ! factor used to integrate the dimensional distributions when
ZFDINFTY = 20.0 ! computing the kernels XKER_SDRYG
!
-IF( .NOT.ALLOCATED(XKER_SDRYG) ) ALLOCATE( XKER_SDRYG(NDRYLBDAG,NDRYLBDAS) )
+IF( .NOT.ALLOCATED(XKER_SDRYG) ) THEN
+ ALLOCATE( XKER_SDRYG(NDRYLBDAG,NDRYLBDAS) )
+ !$acc enter data create(XKER_SDRYG)
+END IF
!
CALL READ_XKER_SDRYG (KDRYLBDAG,KDRYLBDAS,KND, &
PALPHAG,PNUG,PALPHAS,PNUS,PEGS,PBS,PCG,PDG,PCS,PDS, &
PDRYLBDAG_MAX,PDRYLBDAS_MAX,PDRYLBDAG_MIN,PDRYLBDAS_MIN, &
PFDINFTY )
+!$acc update device(XKER_SDRYG)
+!
IF( (KDRYLBDAG/=NDRYLBDAG) .OR. (KDRYLBDAS/=NDRYLBDAS) .OR. (KND/=IND) .OR. &
(PALPHAG/=XALPHAG) .OR. (PNUG/=XNUG) .OR. &
(PALPHAS/=XALPHAS) .OR. (PNUS/=XNUS) .OR. &
@@ -953,6 +986,8 @@ IF( (KDRYLBDAG/=NDRYLBDAG) .OR. (KDRYLBDAS/=NDRYLBDAS) .OR. (KND/=IND) .OR. &
ZEGS, XBS, XCG, XDG, XCS, XDS, &
XDRYLBDAG_MAX, XDRYLBDAS_MAX, XDRYLBDAG_MIN, XDRYLBDAS_MIN, &
ZFDINFTY, XKER_SDRYG )
+ !$acc update device(XKER_SDRYG)
+ !
WRITE(UNIT=KLUOUT,FMT='("*****************************************")')
WRITE(UNIT=KLUOUT,FMT='("**** UPDATE NEW SET OF SDRYG KERNELS ****")')
WRITE(UNIT=KLUOUT,FMT='("*****************************************")')
@@ -993,6 +1028,8 @@ IF( (KDRYLBDAG/=NDRYLBDAG) .OR. (KDRYLBDAS/=NDRYLBDAS) .OR. (KND/=IND) .OR. &
PALPHAG,PNUG,PALPHAS,PNUS,PEGS,PBS,PCG,PDG,PCS,PDS, &
PDRYLBDAG_MAX,PDRYLBDAS_MAX,PDRYLBDAG_MIN,PDRYLBDAS_MIN, &
PFDINFTY,XKER_SDRYG )
+ !$acc update device(XKER_SDRYG)
+ !
WRITE(UNIT=KLUOUT,FMT='(" Read XKER_SDRYG")')
END IF
!
@@ -1001,7 +1038,10 @@ IND = 50 ! Number of interval used to integrate the dimensional
ZEGR = 1.0 ! distributions when computing the kernel XKER_RDRYG
ZFDINFTY = 20.0
!
-IF( .NOT.ALLOCATED(XKER_RDRYG) ) ALLOCATE( XKER_RDRYG(NDRYLBDAG,NDRYLBDAR) )
+IF( .NOT.ALLOCATED(XKER_RDRYG) ) THEN
+ ALLOCATE( XKER_RDRYG(NDRYLBDAG,NDRYLBDAR) )
+ !$acc enter data create(XKER_RDRYG)
+END IF
!
CALL READ_XKER_RDRYG (KDRYLBDAG,KDRYLBDAR,KND, &
PALPHAG,PNUG,PALPHAR,PNUR,PEGR,PBR,PCG,PDG,PCR,PDR, &
@@ -1019,6 +1059,7 @@ IF( (KDRYLBDAG/=NDRYLBDAG) .OR. (KDRYLBDAR/=NDRYLBDAR) .OR. (KND/=IND) .OR. &
ZEGR, XBR, XCG, XDG, XCR, XDR, &
XDRYLBDAG_MAX, XDRYLBDAR_MAX, XDRYLBDAG_MIN, XDRYLBDAR_MIN, &
ZFDINFTY, XKER_RDRYG )
+ !$acc update device(XKER_RDRYG)
WRITE(UNIT=KLUOUT,FMT='("*****************************************")')
WRITE(UNIT=KLUOUT,FMT='("**** UPDATE NEW SET OF RDRYG KERNELS ****")')
WRITE(UNIT=KLUOUT,FMT='("*****************************************")')
@@ -1059,6 +1100,7 @@ IF( (KDRYLBDAG/=NDRYLBDAG) .OR. (KDRYLBDAR/=NDRYLBDAR) .OR. (KND/=IND) .OR. &
PALPHAG,PNUG,PALPHAR,PNUR,PEGR,PBR,PCG,PDG,PCR,PDR, &
PDRYLBDAG_MAX,PDRYLBDAR_MAX,PDRYLBDAG_MIN,PDRYLBDAR_MIN, &
PFDINFTY,XKER_RDRYG )
+ !$acc update device(XKER_RDRYG)
WRITE(UNIT=KLUOUT,FMT='(" Read XKER_RDRYG")')
END IF
!
diff --git a/src/MNH/modd_metricsn.f90 b/src/MNH/modd_metricsn.f90
index 8a9b5711169cda8e71f89cba6792054d95e236d4..9777112cf10a7ae607ed55bfa8b9912cd76d64c0 100644
--- a/src/MNH/modd_metricsn.f90
+++ b/src/MNH/modd_metricsn.f90
@@ -48,7 +48,7 @@ TYPE(METRICS_t), DIMENSION(JPMODELMAX), TARGET, SAVE :: METRICS_MODEL
REAL, DIMENSION(:,:,:), POINTER, contiguous :: XDXX=>NULL(),XDZX=>NULL(), &
XDYY=>NULL(),XDZY=>NULL(),XDZZ=>NULL()
-!$acc declare create(XDXX,XDYY,XDZZ,XDZX,XDZY)
+! acc declare create(XDXX,XDYY,XDZZ,XDZX,XDZY)
CONTAINS
diff --git a/src/MNH/modd_refn.f90 b/src/MNH/modd_refn.f90
index 45981ba791acd92414962b2fd040e4b6eeb14434..9ebcc958ad3398ae6f78177c43eba57f265e2851 100644
--- a/src/MNH/modd_refn.f90
+++ b/src/MNH/modd_refn.f90
@@ -69,7 +69,7 @@ REAL, DIMENSION(:,:,:), POINTER, contiguous :: XTHVREF=>NULL()
REAL, DIMENSION(:,:,:), POINTER :: XRVREF=>NULL()
REAL, DIMENSION(:,:,:), POINTER, contiguous :: XEXNREF=>NULL()
REAL, DIMENSION(:,:,:), POINTER, contiguous :: XRHODJ=>NULL()
-!$acc declare create (XRHODJ)
+! acc declare create (XRHODJ)
REAL, POINTER :: XREFMASS=>NULL()
REAL, POINTER :: XMASS_O_PHI0=>NULL()
REAL, POINTER :: XLINMASS=>NULL()
diff --git a/src/MNH/mode_mnh_zwork.f90 b/src/MNH/mode_mnh_zwork.f90
index e94ced87e6e228072921babfb43980533eece795..95fc395d786492dc2b7a6cac48345b07d05ef94c 100644
--- a/src/MNH/mode_mnh_zwork.f90
+++ b/src/MNH/mode_mnh_zwork.f90
@@ -19,7 +19,7 @@ MODULE MODE_MNH_ZWORK
!
INTEGER,SAVE :: IJS,IJN, IIW,IIA
!
- INTEGER, SAVE :: IIU,IJU,IKU
+ INTEGER, SAVE :: IIU,IJU,IKU,IIJKU
LOGICAL, SAVE :: GWEST , GEAST
LOGICAL, SAVE :: GSOUTH , GNORTH
@@ -30,18 +30,48 @@ MODULE MODE_MNH_ZWORK
REAL, SAVE, ALLOCATABLE , DIMENSION(:,:,:) :: ZUNIT3D
- INTEGER, parameter :: JPMAX_T3D = 40
+ INTEGER, parameter :: JPMAX_T3D = 100
INTEGER , ALLOCATABLE, DIMENSION (:) :: NT3D_POOL
- INTEGER :: NT3D_TOP , NT3D_TOP_MAX = 0
+ INTEGER :: NT3D_TOP , NT3D_TOP_MAX = 0
+ INTEGER :: NT3D_TOP_CURRENT(JPMAX_T3D+1) , NT3D_TOP_CURRENT_INDEX = 0
!REAL , ALLOCATABLE, DIMENSION(:,:,:,:) , TARGET :: ZT3D_A1,ZT3D_A2,ZT3D_A3,ZT3D_A4
!REAL , POINTER , DIMENSION(:,:,:,:) :: ZT3D
- REAL,SAVE , ALLOCATABLE, DIMENSION(:,:,:,:) :: ZT3D
+ REAL,SAVE , ALLOCATABLE, TARGET , DIMENSION(:,:,:,:) :: ZT3D
+
+ REAL,SAVE , ALLOCATABLE, TARGET , DIMENSION(:) :: ZT1D_OSIZE
+ REAL,SAVE , ALLOCATABLE, TARGET , DIMENSION(:,:) :: ZT2D_OSIZE
+ REAL,SAVE , ALLOCATABLE, TARGET , DIMENSION(:,:,:) :: ZT3D_OSIZE
+ REAL,SAVE , ALLOCATABLE, TARGET , DIMENSION(:,:,:,:) :: ZT4D_OSIZE
+
+
TYPE TMODEL
REAL , POINTER, DIMENSION(:,:,:,:) :: X
END TYPE TMODEL
TYPE(TMODEL) , DIMENSION(10) :: MODEL
+ INTEGER, parameter :: JPMAX_T3D_G = 12
+ INTEGER , ALLOCATABLE, DIMENSION (:) :: NT3D_POOL_G
+ INTEGER :: NT3D_TOP_G , NT3D_TOP_G_MAX = 0
+ LOGICAL,SAVE , ALLOCATABLE, TARGET , DIMENSION(:,:,:,:) :: GT3D
+ LOGICAL,SAVE , ALLOCATABLE, TARGET , DIMENSION(:,:) :: GT2D_OSIZE
+
+ INTEGER, parameter :: JPMAX_T3D_I = 4
+ INTEGER , ALLOCATABLE, DIMENSION (:) :: NT3D_POOL_I
+ INTEGER :: NT3D_TOP_I , NT3D_TOP_I_MAX = 0
+ INTEGER,SAVE , ALLOCATABLE, TARGET , DIMENSION(:,:,:,:) :: IT3D
+
+ INTEGER, parameter :: JPMAX_T1D_R = 60
+ INTEGER , ALLOCATABLE, DIMENSION (:) :: NT1D_POOL_R
+ INTEGER :: NT1D_TOP_R , NT1D_TOP_R_MAX = 0
+ REAL,SAVE , ALLOCATABLE, TARGET , DIMENSION(:,:) :: ZT1D
+
+ INTEGER, parameter :: JPMAX_T1D_I = 30
+ INTEGER , ALLOCATABLE, DIMENSION (:) :: NT1D_POOL_I
+ INTEGER :: NT1D_TOP_I , NT1D_TOP_I_MAX = 0
+ INTEGER,SAVE , ALLOCATABLE, TARGET , DIMENSION(:,:) :: IT1D
+ INTEGER,SAVE , ALLOCATABLE, TARGET , DIMENSION(:) :: IT1D_OSIZE
+
CONTAINS
SUBROUTINE MNH_ALLOC_ZWORK(IMODEL)
@@ -64,6 +94,7 @@ CONTAINS
!
CALL GET_DIM_EXT_ll('B',IIU,IJU)
IKU=NKMAX + 2* JPVEXT
+ IIJKU = IIU*IJU*IKU
!
! Computation bound
!
@@ -93,18 +124,76 @@ CONTAINS
ALLOCATE (ZUNIT3D(IIU,IJU,IKU))
!$acc enter data create(ZUNIT3D)
+!----- Real pool
+
!ALLOCATE (ZT3D_A1(IIU,IJU,IKU,JPMAX_T3D))
!MODEL(1)%X => ZT3D_A1
!ZT3D => MODEL(1)%X
ALLOCATE (ZT3D(IIU,IJU,IKU,JPMAX_T3D))
!$acc enter data create(ZT3D)
+ ALLOCATE (ZT1D_OSIZE(0))
+ ALLOCATE (ZT2D_OSIZE(IIU,0))
+ ALLOCATE (ZT3D_OSIZE(IIU,IJU,0))
+ ALLOCATE (ZT4D_OSIZE(IIU,IJU,IKU,0))
+ !$acc enter data create(ZT1D_OSIZE,ZT2D_OSIZE,ZT3D_OSIZE,ZT4D_OSIZE)
+
ALLOCATE (NT3D_POOL(JPMAX_T3D))
NT3D_TOP = 0
DO JI = 1, JPMAX_T3D
NT3D_POOL(JI) = JI
END DO
+!------ Logical pool
+
+ ALLOCATE (GT3D(IIU,IJU,IKU,JPMAX_T3D_G))
+ !$acc enter data create(GT3D)
+
+ ALLOCATE (GT2D_OSIZE(IIU,0))
+ !$acc enter data create(GT2D_OSIZE)
+
+ ALLOCATE (NT3D_POOL_G(JPMAX_T3D_G))
+ NT3D_TOP_G = 0
+ DO JI = 1, JPMAX_T3D_G
+ NT3D_POOL_G(JI) = JI
+ END DO
+
+!------ Integer pool
+
+ ALLOCATE (IT3D(IIU,IJU,IKU,JPMAX_T3D_I))
+ !$acc enter data create(IT3D)
+
+ ALLOCATE (NT3D_POOL_I(JPMAX_T3D_I))
+ NT3D_TOP_I = 0
+ DO JI = 1, JPMAX_T3D_I
+ NT3D_POOL_I(JI) = JI
+ END DO
+
+!------ Real 1D pool
+
+ ALLOCATE (ZT1D(IIU*IJU*IKU,JPMAX_T1D_R))
+ !$acc enter data create(ZT1D)
+
+ ALLOCATE (NT1D_POOL_R(JPMAX_T1D_R))
+ NT1D_TOP_R = 0
+ DO JI = 1, JPMAX_T1D_R
+ NT1D_POOL_R(JI) = JI
+ END DO
+
+!------ Integer 1D pool
+
+ ALLOCATE (IT1D(IIU*IJU*IKU,JPMAX_T1D_I))
+ ALLOCATE (IT1D_OSIZE(0))
+ !$acc enter data create(IT1D,IT1D_OSIZE)
+
+ ALLOCATE (NT1D_POOL_I(JPMAX_T1D_I))
+ NT1D_TOP_I = 0
+ DO JI = 1, JPMAX_T1D_I
+ NT1D_POOL_I(JI) = JI
+ END DO
+
+!------ Default values
+
!$acc kernels
ZPSRC_HALO2_WEST = XUNDEF
@@ -113,12 +202,18 @@ CONTAINS
ZUNIT3D = 1.0
ZT3D = XUNDEF
+ ZT1D = XUNDEF
+
+ IT3D = 0.0
+ IT1D = 0.0
+
+ GT3D = .FALSE.
!$acc end kernels
!$acc update host (ZPSRC_HALO2_WEST,ZPSRC_HALO2_SOUTH)
!$acc update host (ZUNIT3D)
- !$acc update host (ZT3D)
+ !$acc update host (ZT3D,ZT1D)
END IF
@@ -131,17 +226,15 @@ CONTAINS
INTEGER :: KTEMP
IF (NT3D_TOP == JPMAX_T3D ) THEN
+ WRITE( *, '( " MNH_GET_ZT3D_N0: NT3D_TOP too big (increaze JPMAX_T3D) , NT3D_TOP=",I4 )' ) NT3D_TOP
call Print_msg( NVERB_FATAL, 'GEN', 'MNH_GET_ZT3D_N0', 'NT3D_TOP too big (increaze JPMAX_T3D)' )
ELSE
NT3D_TOP = NT3D_TOP + 1
KTEMP = NT3D_POOL(NT3D_TOP)
- IF ( NT3D_POOL(NT3D_TOP) == -1 ) THEN
- call Print_msg( NVERB_FATAL, 'GEN', 'MNH_GET_ZT3D_N0', 'slice already reserved' )
- END IF
- NT3D_POOL(NT3D_TOP) = -1
+ NT3D_POOL(NT3D_TOP) = - KTEMP
IF ( NT3D_TOP > NT3D_TOP_MAX ) THEN
NT3D_TOP_MAX = NT3D_TOP
- WRITE( *, '( " MNH_GET_ZT3D: NT3D_TOP_MAX=",I4," KTEMP=",I4 )' ) NT3D_TOP_MAX,KTEMP
+ !WRITE( *, '( " MNH_GET_ZT3D: NT3D_TOP_MAX=",I4," KTEMP=",I4 )' ) NT3D_TOP_MAX,KTEMP
END IF
ENDIF
!WRITE( *, '( "MNH_GET_ZT3D: reserving ZT3D (",I4,")" )' ) KTEMP
@@ -176,7 +269,6 @@ CONTAINS
IF (PRESENT(KTEMP17)) CALL MNH_GET_ZT3D_N0(KTEMP17)
IF (PRESENT(KTEMP18)) CALL MNH_GET_ZT3D_N0(KTEMP18)
-
END SUBROUTINE MNH_GET_ZT3D
SUBROUTINE MNH_GET_ZT4D(KSIZE,KBEG,KEND)
@@ -189,16 +281,17 @@ CONTAINS
INTEGER :: JI
IF (NT3D_TOP + KSIZE > JPMAX_T3D ) THEN
- call Print_msg( NVERB_FATAL, 'GEN', 'MNH_GET_ZT4D', 'NT3D_TOP too big (increaze JPMAX_T3D)' )
+ WRITE( *, '( " MNH_GET_ZT4D: NT3D_TOP+KSIZE too big (increaze JPMAX_T3D) , NT3D_TOP=",I4 )' ) NT3D_TOP+KSIZE
+ call Print_msg( NVERB_FATAL, 'GEN', 'MNH_GET_ZT4D', 'NT3D_TOP+ KSIZE too big (increaze JPMAX_T3D)' )
ELSE
KBEG = NT3D_TOP + 1
KEND = NT3D_TOP + KSIZE
NT3D_TOP = NT3D_TOP + KSIZE
DO JI = KBEG, KEND
- IF (NT3D_POOL(JI) == -1) THEN
+ IF (NT3D_POOL(JI) <= 0 ) THEN
call Print_msg( NVERB_FATAL, 'GEN', 'MNH_GET_ZT4D', 'trying to use area already reserved' )
END IF
- NT3D_POOL(JI) = -1
+ NT3D_POOL(JI) = -JI
END DO
IF ( NT3D_TOP > NT3D_TOP_MAX ) THEN
NT3D_TOP_MAX = NT3D_TOP
@@ -215,50 +308,59 @@ CONTAINS
INTEGER :: KTEMP
+ IF ( KTEMP .EQ. 0 ) THEN
+ ! Special case Zero size array do nothing
+ RETURN
+ ELSE
+
IF ( ( NT3D_TOP > JPMAX_T3D ) .OR. ( NT3D_TOP < 1 ) ) THEN
call Print_msg( NVERB_FATAL, 'GEN', 'MNH_REL_ZT3D_N0', 'invalid value for NT3D_TOP' )
ELSE
NT3D_POOL(KTEMP) = KTEMP
IF (KTEMP == NT3D_TOP) THEN
NT3D_TOP = NT3D_TOP - 1
- DO WHILE (NT3D_TOP > 0 )
- if ( NT3D_POOL(NT3D_TOP) == -1 ) exit
- NT3D_TOP = NT3D_TOP - 1
- END DO
+ ELSE
+ WRITE( *, '( "MNH_REL_ZT3D: releasing ZT3D (",2I8,")" )' ) KTEMP, NT3D_TOP
+ call Print_msg( NVERB_FATAL, 'GEN', 'MNH_REL_ZT3D_N0', 'invalid value for KTEMP <> NT3D_TOP' )
END IF
ENDIF
!WRITE( *, '( "MNH_REL_ZT3D: releasing ZT3D (",I4,")" )' ) KTEMP
+ ENDIF
END SUBROUTINE MNH_REL_ZT3D_N0
SUBROUTINE MNH_REL_ZT3D(KTEMP1,KTEMP2,KTEMP3,KTEMP4,KTEMP5,KTEMP6,KTEMP7,KTEMP8,KTEMP9, &
- KTEMP10,KTEMP11,KTEMP12,KTEMP13,KTEMP14,KTEMP15,KTEMP16,KTEMP17,KTEMP18)
+ KTEMP10,KTEMP11,KTEMP12,KTEMP13,KTEMP14,KTEMP15,KTEMP16,KTEMP17,KTEMP18, &
+ KTEMP19,KTEMP20)
IMPLICIT NONE
INTEGER :: KTEMP1
INTEGER,OPTIONAL :: KTEMP2,KTEMP3,KTEMP4,KTEMP5,KTEMP6,KTEMP7,KTEMP8,KTEMP9
INTEGER,OPTIONAL :: KTEMP10,KTEMP11,KTEMP12,KTEMP13,KTEMP14,KTEMP15,KTEMP16,KTEMP17,KTEMP18
+ INTEGER,OPTIONAL :: KTEMP19,KTEMP20
- CALL MNH_REL_ZT3D_N0(KTEMP1)
- IF (PRESENT(KTEMP2)) CALL MNH_REL_ZT3D_N0(KTEMP2)
- IF (PRESENT(KTEMP3)) CALL MNH_REL_ZT3D_N0(KTEMP3)
- IF (PRESENT(KTEMP4)) CALL MNH_REL_ZT3D_N0(KTEMP4)
- IF (PRESENT(KTEMP5)) CALL MNH_REL_ZT3D_N0(KTEMP5)
- IF (PRESENT(KTEMP6)) CALL MNH_REL_ZT3D_N0(KTEMP6)
- IF (PRESENT(KTEMP7)) CALL MNH_REL_ZT3D_N0(KTEMP7)
- IF (PRESENT(KTEMP8)) CALL MNH_REL_ZT3D_N0(KTEMP8)
- IF (PRESENT(KTEMP9)) CALL MNH_REL_ZT3D_N0(KTEMP9)
- IF (PRESENT(KTEMP10)) CALL MNH_REL_ZT3D_N0(KTEMP10)
- IF (PRESENT(KTEMP11)) CALL MNH_REL_ZT3D_N0(KTEMP11)
- IF (PRESENT(KTEMP12)) CALL MNH_REL_ZT3D_N0(KTEMP12)
- IF (PRESENT(KTEMP13)) CALL MNH_REL_ZT3D_N0(KTEMP13)
- IF (PRESENT(KTEMP14)) CALL MNH_REL_ZT3D_N0(KTEMP14)
- IF (PRESENT(KTEMP15)) CALL MNH_REL_ZT3D_N0(KTEMP15)
- IF (PRESENT(KTEMP16)) CALL MNH_REL_ZT3D_N0(KTEMP16)
- IF (PRESENT(KTEMP17)) CALL MNH_REL_ZT3D_N0(KTEMP17)
+ IF (PRESENT(KTEMP20)) CALL MNH_REL_ZT3D_N0(KTEMP20)
+ IF (PRESENT(KTEMP19)) CALL MNH_REL_ZT3D_N0(KTEMP19)
IF (PRESENT(KTEMP18)) CALL MNH_REL_ZT3D_N0(KTEMP18)
-
+ IF (PRESENT(KTEMP17)) CALL MNH_REL_ZT3D_N0(KTEMP17)
+ IF (PRESENT(KTEMP16)) CALL MNH_REL_ZT3D_N0(KTEMP16)
+ IF (PRESENT(KTEMP15)) CALL MNH_REL_ZT3D_N0(KTEMP15)
+ IF (PRESENT(KTEMP14)) CALL MNH_REL_ZT3D_N0(KTEMP14)
+ IF (PRESENT(KTEMP13)) CALL MNH_REL_ZT3D_N0(KTEMP13)
+ IF (PRESENT(KTEMP12)) CALL MNH_REL_ZT3D_N0(KTEMP12)
+ IF (PRESENT(KTEMP11)) CALL MNH_REL_ZT3D_N0(KTEMP11)
+ IF (PRESENT(KTEMP10)) CALL MNH_REL_ZT3D_N0(KTEMP10)
+ IF (PRESENT(KTEMP9)) CALL MNH_REL_ZT3D_N0(KTEMP9)
+ IF (PRESENT(KTEMP8)) CALL MNH_REL_ZT3D_N0(KTEMP8)
+ IF (PRESENT(KTEMP7)) CALL MNH_REL_ZT3D_N0(KTEMP7)
+ IF (PRESENT(KTEMP6)) CALL MNH_REL_ZT3D_N0(KTEMP6)
+ IF (PRESENT(KTEMP5)) CALL MNH_REL_ZT3D_N0(KTEMP5)
+ IF (PRESENT(KTEMP4)) CALL MNH_REL_ZT3D_N0(KTEMP4)
+ IF (PRESENT(KTEMP3)) CALL MNH_REL_ZT3D_N0(KTEMP3)
+ IF (PRESENT(KTEMP2)) CALL MNH_REL_ZT3D_N0(KTEMP2)
+ CALL MNH_REL_ZT3D_N0(KTEMP1)
+
END SUBROUTINE MNH_REL_ZT3D
SUBROUTINE MNH_REL_ZT4D(KSIZE,KBEG)
@@ -271,8 +373,11 @@ CONTAINS
character(len=16) :: ytxt1, ytxt2
INTEGER :: JI
+ IF ( KSIZE .EQ. 0 ) THEN
+ ! special case of O zero 4D array => ZT4D_OSIZE
+ RETURN
+ END IF
IF ( KBEG + KSIZE -1 /= NT3D_TOP ) THEN
-!PW TODO: implement holes management
write( ytxt1, '( I4, "-", I4 )' ) kbeg, kbeg + ksize - 1
write( ytxt2, '( I4 )' ) NT3D_TOP
call Print_msg( NVERB_ERROR, 'GEN', 'MNH_REL_ZT4D', 'trying to free area (' // trim( ytxt1 ) // &
@@ -283,17 +388,584 @@ CONTAINS
END IF
DO JI = KBEG, KBEG+KSIZE-1
- IF (NT3D_POOL(JI) /= -1) THEN
- call Print_msg( NVERB_ERROR, 'GEN', 'MNH_REL_ZT4D', 'trying to free area not reserved' )
+ IF (NT3D_POOL(JI) /= - JI ) THEN
+ call Print_msg( NVERB_ERROR, 'GEN', 'MNH_REL_ZT4D', 'trying to free area not reserved' )
+ ELSE
+ NT3D_POOL(JI) = JI
END IF
- NT3D_POOL(JI) = JI
END DO
NT3D_TOP = NT3D_TOP - KSIZE
!WRITE( *, '( "MNH_REL_ZT4D: releasing ZT3D (",I4,I4,")" )' ) KBEG,KBEG+KSIZE-1
END SUBROUTINE MNH_REL_ZT4D
+ FUNCTION MNH_ALLOCATE_ZT3D(PTAB,KI,KJ,KK) RESULT (KINDEX)
+
+ REAL, POINTER, CONTIGUOUS , DIMENSION(:,:,:), INTENT(INOUT) :: PTAB
+ INTEGER , INTENT(IN) :: KI,KJ,KK
+ INTEGER :: KINDEX
+
+ !local
+
+ IF ( (KI .EQ. IIU) .AND. (KJ .EQ. IJU) ) THEN
+ CALL MNH_GET_ZT3D_N0(KINDEX)
+ IF (KK .LE. IKU) THEN
+ PTAB => ZT3D(:,:,1:KK,KINDEX)
+ ELSE IF (KK .EQ.0 ) THEN
+ PTAB => ZT3D_OSIZE
+ ELSE
+ call Print_msg( NVERB_ERROR, 'GEN', 'MNH_ALLOCATE_ZT3D', ' Size mismatsh ' )
+ END IF
+ ELSE
+ call Print_msg( NVERB_ERROR, 'GEN', 'MNH_ALLOCATE_ZT3D', ' Size mismatsh ' )
+ END IF
+
+ END FUNCTION MNH_ALLOCATE_ZT3D
+
+ FUNCTION MNH_ALLOCATE_ZT4D(PTAB,KI,KJ,KK,KL) RESULT (KINDEX_BEG)
+
+ REAL, POINTER, CONTIGUOUS , DIMENSION(:,:,:,:), INTENT(INOUT) :: PTAB
+ INTEGER , INTENT(IN) :: KI,KJ,KK,KL
+ INTEGER :: KINDEX_BEG
+
+ !local
+
+ INTEGER :: KINDEX_END
+
+ IF ( (KI .EQ. IIU) .AND. (KJ .EQ. IJU) .AND. (KK .EQ. IKU) ) THEN
+ IF ( KL .GE. 1 ) THEN
+ CALL MNH_GET_ZT4D(KL,KINDEX_BEG,KINDEX_END)
+ PTAB => ZT3D(:,:,:,KINDEX_BEG:KINDEX_END)
+ ELSE
+ PTAB => ZT4D_OSIZE
+ KINDEX_BEG = 0
+ END IF
+ ELSE
+ call Print_msg( NVERB_ERROR, 'GEN', 'MNH_ALLOCATE_ZT4D', ' Size mismatsh ' )
+ END IF
+
+ END FUNCTION MNH_ALLOCATE_ZT4D
+
+ FUNCTION MNH_ALLOCATE_ZT2D(PTAB,KI,KJ) RESULT (KINDEX)
+
+ REAL, POINTER, CONTIGUOUS , DIMENSION(:,:), INTENT(INOUT) :: PTAB
+ INTEGER , INTENT(IN) :: KI,KJ
+ INTEGER :: KINDEX
+
+ !local
+
+ IF (KI .EQ. IIU) THEN
+ CALL MNH_GET_ZT3D_N0(KINDEX)
+ IF (KJ .EQ. IJU) THEN
+ PTAB => ZT3D(:,:,1,KINDEX)
+ ELSE IF (KJ .EQ. 0) THEN
+ PTAB => ZT2D_OSIZE
+ ELSE
+ call Print_msg( NVERB_ERROR, 'GEN', 'MNH_ALLOCATE_ZT2D', ' Size mismatsh ' )
+ END IF
+ ELSE
+ call Print_msg( NVERB_ERROR, 'GEN', 'MNH_ALLOCATE_ZT2D', ' Size mismatsh ' )
+ END IF
+
+ END FUNCTION MNH_ALLOCATE_ZT2D
+
+ FUNCTION MNH_ALLOCATE_ZT3DP(PTAB,KI,KJ,KKB,KKE) RESULT (KINDEX)
+
+ REAL, POINTER, CONTIGUOUS , DIMENSION(:,:,:), INTENT(INOUT) :: PTAB
+ INTEGER , INTENT(IN) :: KI,KJ,KKB,KKE
+ INTEGER :: KINDEX
+
+ !local
+
+ IF ( (KI .EQ. IIU) .AND. (KJ .EQ. IJU) .AND. (KKB .LE. IKU) .AND. (KKE .LE. IKU) ) THEN
+ CALL MNH_GET_ZT3D_N0(KINDEX)
+ PTAB(1:,1:,KKB:) => ZT3D(:,:,KKB:KKE,KINDEX)
+ ELSE
+ call Print_msg( NVERB_ERROR, 'GEN', 'MNH_ALLOCATE_ZT3DP', ' Size mismatsh ' )
+ END IF
+
+ END FUNCTION MNH_ALLOCATE_ZT3DP
+
+!-------- Logical Pool Managment
+
+ SUBROUTINE MNH_GET_GT3D_N0(KTEMP)
+
+ IMPLICIT NONE
+
+ INTEGER :: KTEMP
+
+ IF (NT3D_TOP_G == JPMAX_T3D_G ) THEN
+ WRITE( *, '( " MNH_GET_GT3D_N0: NT3D_TOP_G too big (increaze JPMAX_T3D_G) , NT3D_TOP_G=",I4 )' ) NT3D_TOP_G
+ call Print_msg( NVERB_FATAL, 'GEN', 'MNH_GET_GT3D_N0', 'NT3D_TOP_G too big (increaze JPMAX_T3D_G)' )
+ ELSE
+ NT3D_TOP_G = NT3D_TOP_G + 1
+ KTEMP = NT3D_POOL_G(NT3D_TOP_G)
+ NT3D_POOL_G(NT3D_TOP_G) = - KTEMP
+ IF ( NT3D_TOP_G > NT3D_TOP_G_MAX ) THEN
+ NT3D_TOP_G_MAX = NT3D_TOP_G
+ !WRITE( *, '( " MNH_GET_GT3D: NT3D_TOP_G_MAX=",I4," KTEMP=",I4 )' ) NT3D_TOP_G_MAX,KTEMP
+ END IF
+ ENDIF
+ !WRITE( *, '( "MNH_GET_GT3D: reserving GT3D (",I4,")" )' ) KTEMP
+
+ END SUBROUTINE MNH_GET_GT3D_N0
+
+ SUBROUTINE MNH_GET_GT3D(KTEMP1,KTEMP2,KTEMP3,KTEMP4,KTEMP5,KTEMP6,KTEMP7,KTEMP8,KTEMP9, &
+ KTEMP10,KTEMP11,KTEMP12,KTEMP13,KTEMP14,KTEMP15,KTEMP16,KTEMP17,KTEMP18)
+
+ IMPLICIT NONE
+
+ INTEGER :: KTEMP1
+ INTEGER,OPTIONAL :: KTEMP2,KTEMP3,KTEMP4,KTEMP5,KTEMP6,KTEMP7,KTEMP8,KTEMP9
+ INTEGER,OPTIONAL :: KTEMP10,KTEMP11,KTEMP12,KTEMP13,KTEMP14,KTEMP15,KTEMP16,KTEMP17,KTEMP18
+
+ CALL MNH_GET_GT3D_N0(KTEMP1)
+ IF (PRESENT(KTEMP2)) CALL MNH_GET_GT3D_N0(KTEMP2)
+ IF (PRESENT(KTEMP3)) CALL MNH_GET_GT3D_N0(KTEMP3)
+ IF (PRESENT(KTEMP4)) CALL MNH_GET_GT3D_N0(KTEMP4)
+ IF (PRESENT(KTEMP5)) CALL MNH_GET_GT3D_N0(KTEMP5)
+ IF (PRESENT(KTEMP6)) CALL MNH_GET_GT3D_N0(KTEMP6)
+ IF (PRESENT(KTEMP7)) CALL MNH_GET_GT3D_N0(KTEMP7)
+ IF (PRESENT(KTEMP8)) CALL MNH_GET_GT3D_N0(KTEMP8)
+ IF (PRESENT(KTEMP9)) CALL MNH_GET_GT3D_N0(KTEMP9)
+ IF (PRESENT(KTEMP10)) CALL MNH_GET_GT3D_N0(KTEMP10)
+ IF (PRESENT(KTEMP11)) CALL MNH_GET_GT3D_N0(KTEMP11)
+ IF (PRESENT(KTEMP12)) CALL MNH_GET_GT3D_N0(KTEMP12)
+ IF (PRESENT(KTEMP13)) CALL MNH_GET_GT3D_N0(KTEMP13)
+ IF (PRESENT(KTEMP14)) CALL MNH_GET_GT3D_N0(KTEMP14)
+ IF (PRESENT(KTEMP15)) CALL MNH_GET_GT3D_N0(KTEMP15)
+ IF (PRESENT(KTEMP16)) CALL MNH_GET_GT3D_N0(KTEMP16)
+ IF (PRESENT(KTEMP17)) CALL MNH_GET_GT3D_N0(KTEMP17)
+ IF (PRESENT(KTEMP18)) CALL MNH_GET_GT3D_N0(KTEMP18)
+
+ END SUBROUTINE MNH_GET_GT3D
+
+ SUBROUTINE MNH_REL_GT3D_N0(KTEMP)
+
+ IMPLICIT NONE
+
+ INTEGER :: KTEMP
+
+ IF ( ( NT3D_TOP_G > JPMAX_T3D_G ) .OR. ( NT3D_TOP_G < 1 ) ) THEN
+ call Print_msg( NVERB_FATAL, 'GEN', 'MNH_REL_GT3D_N0', 'invalid value for NT3D_TOP_G' )
+ ELSE
+ NT3D_POOL_G(KTEMP) = KTEMP
+ IF (KTEMP == NT3D_TOP_G) THEN
+ NT3D_TOP_G = NT3D_TOP_G - 1
+ ELSE
+ WRITE( *, '( "MNH_REL_GT3D: releasing GT3D (",2I8,")" )' ) KTEMP, NT3D_TOP_G
+ call Print_msg( NVERB_FATAL, 'GEN', 'MNH_REL_GT3D_N0', 'invalid value for KTEMP <> NT3D_TOP_G' )
+ END IF
+ ENDIF
+ !WRITE( *, '( "MNH_REL_GT3D: releasing GT3D (",I4,")" )' ) KTEMP
+
+ END SUBROUTINE MNH_REL_GT3D_N0
+
+ SUBROUTINE MNH_REL_GT3D(KTEMP1,KTEMP2,KTEMP3,KTEMP4,KTEMP5,KTEMP6,KTEMP7,KTEMP8,KTEMP9, &
+ KTEMP10,KTEMP11,KTEMP12,KTEMP13,KTEMP14,KTEMP15,KTEMP16,KTEMP17,KTEMP18, &
+ KTEMP19,KTEMP20)
+
+ IMPLICIT NONE
+
+ INTEGER :: KTEMP1
+ INTEGER,OPTIONAL :: KTEMP2,KTEMP3,KTEMP4,KTEMP5,KTEMP6,KTEMP7,KTEMP8,KTEMP9
+ INTEGER,OPTIONAL :: KTEMP10,KTEMP11,KTEMP12,KTEMP13,KTEMP14,KTEMP15,KTEMP16,KTEMP17,KTEMP18
+ INTEGER,OPTIONAL :: KTEMP19,KTEMP20
+
+ IF (PRESENT(KTEMP20)) CALL MNH_REL_GT3D_N0(KTEMP20)
+ IF (PRESENT(KTEMP19)) CALL MNH_REL_GT3D_N0(KTEMP19)
+ IF (PRESENT(KTEMP18)) CALL MNH_REL_GT3D_N0(KTEMP18)
+ IF (PRESENT(KTEMP17)) CALL MNH_REL_GT3D_N0(KTEMP17)
+ IF (PRESENT(KTEMP16)) CALL MNH_REL_GT3D_N0(KTEMP16)
+ IF (PRESENT(KTEMP15)) CALL MNH_REL_GT3D_N0(KTEMP15)
+ IF (PRESENT(KTEMP14)) CALL MNH_REL_GT3D_N0(KTEMP14)
+ IF (PRESENT(KTEMP13)) CALL MNH_REL_GT3D_N0(KTEMP13)
+ IF (PRESENT(KTEMP12)) CALL MNH_REL_GT3D_N0(KTEMP12)
+ IF (PRESENT(KTEMP11)) CALL MNH_REL_GT3D_N0(KTEMP11)
+ IF (PRESENT(KTEMP10)) CALL MNH_REL_GT3D_N0(KTEMP10)
+ IF (PRESENT(KTEMP9)) CALL MNH_REL_GT3D_N0(KTEMP9)
+ IF (PRESENT(KTEMP8)) CALL MNH_REL_GT3D_N0(KTEMP8)
+ IF (PRESENT(KTEMP7)) CALL MNH_REL_GT3D_N0(KTEMP7)
+ IF (PRESENT(KTEMP6)) CALL MNH_REL_GT3D_N0(KTEMP6)
+ IF (PRESENT(KTEMP5)) CALL MNH_REL_GT3D_N0(KTEMP5)
+ IF (PRESENT(KTEMP4)) CALL MNH_REL_GT3D_N0(KTEMP4)
+ IF (PRESENT(KTEMP3)) CALL MNH_REL_GT3D_N0(KTEMP3)
+ IF (PRESENT(KTEMP2)) CALL MNH_REL_GT3D_N0(KTEMP2)
+ CALL MNH_REL_GT3D_N0(KTEMP1)
+
+ END SUBROUTINE MNH_REL_GT3D
+
+ FUNCTION MNH_ALLOCATE_GT3D(PTAB,KI,KJ,KK) RESULT (KINDEX)
+
+ LOGICAL, POINTER, CONTIGUOUS , DIMENSION(:,:,:), INTENT(INOUT) :: PTAB
+ INTEGER , INTENT(IN) :: KI,KJ,KK
+ INTEGER :: KINDEX
+
+ !local
+
+ IF ( (KI .EQ. IIU) .AND. (KJ .EQ. IJU) .AND. (KK .EQ. IKU) ) THEN
+ CALL MNH_GET_GT3D_N0(KINDEX)
+ PTAB => GT3D(:,:,:,KINDEX)
+ ELSE
+ call Print_msg( NVERB_ERROR, 'GEN', 'MNH_ALLOCATE_GT3D', ' Size mismatsh ' )
+ END IF
+
+ END FUNCTION MNH_ALLOCATE_GT3D
+
+ FUNCTION MNH_ALLOCATE_GT2D(PTAB,KI,KJ) RESULT (KINDEX)
+
+ LOGICAL, POINTER, CONTIGUOUS , DIMENSION(:,:), INTENT(INOUT) :: PTAB
+ INTEGER , INTENT(IN) :: KI,KJ
+ INTEGER :: KINDEX
+
+ !local
+
+ IF (KI .EQ. IIU) THEN
+ CALL MNH_GET_GT3D_N0(KINDEX)
+ IF (KJ .EQ. IJU) THEN
+ PTAB => GT3D(:,:,1,KINDEX)
+ ELSE IF (KJ .EQ. 0) THEN
+ PTAB => GT2D_OSIZE
+ ELSE
+ call Print_msg( NVERB_ERROR, 'GEN', 'MNH_ALLOCATE_GT2D', ' Size mismatsh ' )
+ END IF
+ ELSE
+ call Print_msg( NVERB_ERROR, 'GEN', 'MNH_ALLOCATE_GT2D', ' Size mismatsh ' )
+ END IF
+
+ END FUNCTION MNH_ALLOCATE_GT2D
+
+ !------------ End Logical Pool
+
+ !-------- Real 1D Pool Managment
+
+ SUBROUTINE MNH_GET_ZT1D_N0(KTEMP)
+
+ IMPLICIT NONE
+
+ INTEGER :: KTEMP
+
+ IF (NT1D_TOP_R == JPMAX_T1D_R ) THEN
+ WRITE( *, '( " MNH_GET_ZT1D_N0: NT1D_TOP_R too big (increaze JPMAX_T1D_R) , NT1D_TOP_R=",I4 )' ) NT1D_TOP_R
+ call Print_msg( NVERB_FATAL, 'GEN', 'MNH_GET_ZT1D_N0', 'NT1D_TOP_R too big (increaze JPMAX_T1D_R)' )
+ ELSE
+ NT1D_TOP_R = NT1D_TOP_R + 1
+ KTEMP = NT1D_POOL_R(NT1D_TOP_R)
+ NT1D_POOL_R(NT1D_TOP_R) = - KTEMP
+ IF ( NT1D_TOP_R > NT1D_TOP_R_MAX ) THEN
+ NT1D_TOP_R_MAX = NT1D_TOP_R
+ !WRITE( *, '( " MNH_GET_ZT1D: NT1D_TOP_R_MAX=",I4," KTEMP=",I4 )' ) NT1D_TOP_R_MAX,KTEMP
+ END IF
+ ENDIF
+ !WRITE( *, '( "MNH_GET_ZT1D: reserving ZT1D (",I4,")" )' ) KTEMP
+
+ END SUBROUTINE MNH_GET_ZT1D_N0
+
+ SUBROUTINE MNH_GET_ZT1D(KTEMP1,KTEMP2,KTEMP3,KTEMP4,KTEMP5,KTEMP6,KTEMP7,KTEMP8,KTEMP9, &
+ KTEMP10,KTEMP11,KTEMP12,KTEMP13,KTEMP14,KTEMP15,KTEMP16,KTEMP17,KTEMP18)
+
+ IMPLICIT NONE
+
+ INTEGER :: KTEMP1
+ INTEGER,OPTIONAL :: KTEMP2,KTEMP3,KTEMP4,KTEMP5,KTEMP6,KTEMP7,KTEMP8,KTEMP9
+ INTEGER,OPTIONAL :: KTEMP10,KTEMP11,KTEMP12,KTEMP13,KTEMP14,KTEMP15,KTEMP16,KTEMP17,KTEMP18
+
+ CALL MNH_GET_ZT1D_N0(KTEMP1)
+ IF (PRESENT(KTEMP2)) CALL MNH_GET_ZT1D_N0(KTEMP2)
+ IF (PRESENT(KTEMP3)) CALL MNH_GET_ZT1D_N0(KTEMP3)
+ IF (PRESENT(KTEMP4)) CALL MNH_GET_ZT1D_N0(KTEMP4)
+ IF (PRESENT(KTEMP5)) CALL MNH_GET_ZT1D_N0(KTEMP5)
+ IF (PRESENT(KTEMP6)) CALL MNH_GET_ZT1D_N0(KTEMP6)
+ IF (PRESENT(KTEMP7)) CALL MNH_GET_ZT1D_N0(KTEMP7)
+ IF (PRESENT(KTEMP8)) CALL MNH_GET_ZT1D_N0(KTEMP8)
+ IF (PRESENT(KTEMP9)) CALL MNH_GET_ZT1D_N0(KTEMP9)
+ IF (PRESENT(KTEMP10)) CALL MNH_GET_ZT1D_N0(KTEMP10)
+ IF (PRESENT(KTEMP11)) CALL MNH_GET_ZT1D_N0(KTEMP11)
+ IF (PRESENT(KTEMP12)) CALL MNH_GET_ZT1D_N0(KTEMP12)
+ IF (PRESENT(KTEMP13)) CALL MNH_GET_ZT1D_N0(KTEMP13)
+ IF (PRESENT(KTEMP14)) CALL MNH_GET_ZT1D_N0(KTEMP14)
+ IF (PRESENT(KTEMP15)) CALL MNH_GET_ZT1D_N0(KTEMP15)
+ IF (PRESENT(KTEMP16)) CALL MNH_GET_ZT1D_N0(KTEMP16)
+ IF (PRESENT(KTEMP17)) CALL MNH_GET_ZT1D_N0(KTEMP17)
+ IF (PRESENT(KTEMP18)) CALL MNH_GET_ZT1D_N0(KTEMP18)
+
+ END SUBROUTINE MNH_GET_ZT1D
+
+ SUBROUTINE MNH_REL_ZT1D_N0(KTEMP)
+
+ IMPLICIT NONE
+
+ INTEGER :: KTEMP
+
+ IF ( ( NT1D_TOP_R > JPMAX_T1D_R ) .OR. ( NT1D_TOP_R < 1 ) ) THEN
+ call Print_msg( NVERB_FATAL, 'GEN', 'MNH_REL_ZT1D_N0', 'invalid value for NT1D_TOP_R' )
+ ELSE
+ NT1D_POOL_R(KTEMP) = KTEMP
+ IF (KTEMP == NT1D_TOP_R) THEN
+ NT1D_TOP_R = NT1D_TOP_R - 1
+ ELSE
+ WRITE( *, '( "MNH_REL_ZT1D_N0: invalid value for KTEMP <> NT1D_TOP_R (",2I8,")" )' ) KTEMP, NT1D_TOP_R
+ FLUSH(6)
+ call Print_msg( NVERB_FATAL, 'GEN', 'MNH_REL_ZT1D_N0', 'invalid value for KTEMP <> NT1D_TOP_R' )
+ END IF
+ ENDIF
+ !WRITE( *, '( "MNH_REL_ZT1D_N0: releasing ZT1D (",I4,")" )' ) KTEMP
+
+ END SUBROUTINE MNH_REL_ZT1D_N0
+
+ SUBROUTINE MNH_REL_ZT1D(KTEMP1,KTEMP2,KTEMP3,KTEMP4,KTEMP5,KTEMP6,KTEMP7,KTEMP8,KTEMP9, &
+ KTEMP10,KTEMP11,KTEMP12,KTEMP13,KTEMP14,KTEMP15,KTEMP16,KTEMP17,KTEMP18, &
+ KTEMP19,KTEMP20)
+
+ IMPLICIT NONE
+
+ INTEGER :: KTEMP1
+ INTEGER,OPTIONAL :: KTEMP2,KTEMP3,KTEMP4,KTEMP5,KTEMP6,KTEMP7,KTEMP8,KTEMP9
+ INTEGER,OPTIONAL :: KTEMP10,KTEMP11,KTEMP12,KTEMP13,KTEMP14,KTEMP15,KTEMP16,KTEMP17,KTEMP18
+ INTEGER,OPTIONAL :: KTEMP19,KTEMP20
+
+ IF (PRESENT(KTEMP20)) CALL MNH_REL_ZT1D_N0(KTEMP20)
+ IF (PRESENT(KTEMP19)) CALL MNH_REL_ZT1D_N0(KTEMP19)
+ IF (PRESENT(KTEMP18)) CALL MNH_REL_ZT1D_N0(KTEMP18)
+ IF (PRESENT(KTEMP17)) CALL MNH_REL_ZT1D_N0(KTEMP17)
+ IF (PRESENT(KTEMP16)) CALL MNH_REL_ZT1D_N0(KTEMP16)
+ IF (PRESENT(KTEMP15)) CALL MNH_REL_ZT1D_N0(KTEMP15)
+ IF (PRESENT(KTEMP14)) CALL MNH_REL_ZT1D_N0(KTEMP14)
+ IF (PRESENT(KTEMP13)) CALL MNH_REL_ZT1D_N0(KTEMP13)
+ IF (PRESENT(KTEMP12)) CALL MNH_REL_ZT1D_N0(KTEMP12)
+ IF (PRESENT(KTEMP11)) CALL MNH_REL_ZT1D_N0(KTEMP11)
+ IF (PRESENT(KTEMP10)) CALL MNH_REL_ZT1D_N0(KTEMP10)
+ IF (PRESENT(KTEMP9)) CALL MNH_REL_ZT1D_N0(KTEMP9)
+ IF (PRESENT(KTEMP8)) CALL MNH_REL_ZT1D_N0(KTEMP8)
+ IF (PRESENT(KTEMP7)) CALL MNH_REL_ZT1D_N0(KTEMP7)
+ IF (PRESENT(KTEMP6)) CALL MNH_REL_ZT1D_N0(KTEMP6)
+ IF (PRESENT(KTEMP5)) CALL MNH_REL_ZT1D_N0(KTEMP5)
+ IF (PRESENT(KTEMP4)) CALL MNH_REL_ZT1D_N0(KTEMP4)
+ IF (PRESENT(KTEMP3)) CALL MNH_REL_ZT1D_N0(KTEMP3)
+ IF (PRESENT(KTEMP2)) CALL MNH_REL_ZT1D_N0(KTEMP2)
+ CALL MNH_REL_ZT1D_N0(KTEMP1)
+
+ END SUBROUTINE MNH_REL_ZT1D
+
+ FUNCTION MNH_ALLOCATE_ZT1D(PTAB,KI) RESULT (KINDEX)
+
+ REAL, POINTER, CONTIGUOUS , DIMENSION(:), INTENT(INOUT) :: PTAB
+ INTEGER , INTENT(IN) :: KI
+ INTEGER :: KINDEX
+
+ !local
+
+ IF (KI .EQ. IIJKU) THEN
+ CALL MNH_GET_ZT1D_N0(KINDEX)
+ PTAB => ZT1D(:,KINDEX)
+ ELSE
+ call Print_msg( NVERB_ERROR, 'GEN', 'MNH_ALLOCATE_ZT1D', ' Size mismatsh ' )
+ END IF
+ !WRITE( *, '( "MNH_ALLOCATE_ZT1D: KI=(",I4,") , KINDEX=(",I4,")" )' ) KI,KINDEX
+ !FLUSH(6)
+
+ END FUNCTION MNH_ALLOCATE_ZT1D
+
+ FUNCTION MNH_ALLOCATE_ZT1DP(PTAB,KI) RESULT (KINDEX)
+
+ REAL, POINTER, CONTIGUOUS , DIMENSION(:), INTENT(INOUT) :: PTAB
+ INTEGER , INTENT(IN) :: KI
+ INTEGER :: KINDEX
+
+ !local
+
+ IF (KI .LE. IIJKU) THEN
+ CALL MNH_GET_ZT1D_N0(KINDEX)
+ IF (KI .NE. 0) THEN
+ PTAB(1:KI) => ZT1D(:,KINDEX)
+ ELSE
+ PTAB => ZT1D_OSIZE
+ END IF
+ ELSE
+ call Print_msg( NVERB_ERROR, 'GEN', 'MNH_ALLOCATE_ZT1DP', ' Size mismatsh ' )
+ END IF
+ !WRITE( *, '( "MNH_ALLOCATE_ZT1DP: KI=(",I9,") , KINDEX=(",I4,")" )' ) KI,KINDEX
+
+ END FUNCTION MNH_ALLOCATE_ZT1DP
+
+ ! End Real 1D management
+
+ !-------- Integer 1D Pool Managment
+
+ SUBROUTINE MNH_GET_IT1D_N0(KTEMP)
+
+ IMPLICIT NONE
+
+ INTEGER :: KTEMP
+
+ IF (NT1D_TOP_I == JPMAX_T1D_I ) THEN
+ WRITE( *, '( " MNH_GET_IT1D_N0: NT1D_TOP_I too big (increaze JPMAX_T1D_I) , NT1D_TOP_I=",I4 )' ) NT1D_TOP_I
+ call Print_msg( NVERB_FATAL, 'GEN', 'MNH_GET_IT1D_N0', 'NT1D_TOP_I too big (increaze JPMAX_T1D_I)' )
+ ELSE
+ NT1D_TOP_I = NT1D_TOP_I + 1
+ KTEMP = NT1D_POOL_I(NT1D_TOP_I)
+ NT1D_POOL_I(NT1D_TOP_I) = - KTEMP
+ IF ( NT1D_TOP_I > NT1D_TOP_I_MAX ) THEN
+ NT1D_TOP_I_MAX = NT1D_TOP_I
+ !WRITE( *, '( " MNH_GET_IT1D: NT1D_TOP_I_MAX=",I4," KTEMP=",I4 )' ) NT1D_TOP_I_MAX,KTEMP
+ END IF
+ ENDIF
+ !WRITE( *, '( "MNH_GET_IT1D: reserving IT1D (",I4,")" )' ) KTEMP
+
+ END SUBROUTINE MNH_GET_IT1D_N0
+
+ SUBROUTINE MNH_GET_IT1D(KTEMP1,KTEMP2,KTEMP3,KTEMP4,KTEMP5,KTEMP6,KTEMP7,KTEMP8,KTEMP9, &
+ KTEMP10,KTEMP11,KTEMP12,KTEMP13,KTEMP14,KTEMP15,KTEMP16,KTEMP17,KTEMP18)
+
+ IMPLICIT NONE
+
+ INTEGER :: KTEMP1
+ INTEGER,OPTIONAL :: KTEMP2,KTEMP3,KTEMP4,KTEMP5,KTEMP6,KTEMP7,KTEMP8,KTEMP9
+ INTEGER,OPTIONAL :: KTEMP10,KTEMP11,KTEMP12,KTEMP13,KTEMP14,KTEMP15,KTEMP16,KTEMP17,KTEMP18
+
+ CALL MNH_GET_IT1D_N0(KTEMP1)
+ IF (PRESENT(KTEMP2)) CALL MNH_GET_IT1D_N0(KTEMP2)
+ IF (PRESENT(KTEMP3)) CALL MNH_GET_IT1D_N0(KTEMP3)
+ IF (PRESENT(KTEMP4)) CALL MNH_GET_IT1D_N0(KTEMP4)
+ IF (PRESENT(KTEMP5)) CALL MNH_GET_IT1D_N0(KTEMP5)
+ IF (PRESENT(KTEMP6)) CALL MNH_GET_IT1D_N0(KTEMP6)
+ IF (PRESENT(KTEMP7)) CALL MNH_GET_IT1D_N0(KTEMP7)
+ IF (PRESENT(KTEMP8)) CALL MNH_GET_IT1D_N0(KTEMP8)
+ IF (PRESENT(KTEMP9)) CALL MNH_GET_IT1D_N0(KTEMP9)
+ IF (PRESENT(KTEMP10)) CALL MNH_GET_IT1D_N0(KTEMP10)
+ IF (PRESENT(KTEMP11)) CALL MNH_GET_IT1D_N0(KTEMP11)
+ IF (PRESENT(KTEMP12)) CALL MNH_GET_IT1D_N0(KTEMP12)
+ IF (PRESENT(KTEMP13)) CALL MNH_GET_IT1D_N0(KTEMP13)
+ IF (PRESENT(KTEMP14)) CALL MNH_GET_IT1D_N0(KTEMP14)
+ IF (PRESENT(KTEMP15)) CALL MNH_GET_IT1D_N0(KTEMP15)
+ IF (PRESENT(KTEMP16)) CALL MNH_GET_IT1D_N0(KTEMP16)
+ IF (PRESENT(KTEMP17)) CALL MNH_GET_IT1D_N0(KTEMP17)
+ IF (PRESENT(KTEMP18)) CALL MNH_GET_IT1D_N0(KTEMP18)
+
+ END SUBROUTINE MNH_GET_IT1D
+
+ SUBROUTINE MNH_REL_IT1D_N0(KTEMP)
+
+ IMPLICIT NONE
+
+ INTEGER :: KTEMP
+
+ IF ( ( NT1D_TOP_I > JPMAX_T1D_I ) .OR. ( NT1D_TOP_I < 1 ) ) THEN
+ call Print_msg( NVERB_FATAL, 'GEN', 'MNH_REL_IT1D_N0', 'invalid value for NT1D_TOP_I' )
+ ELSE
+ NT1D_POOL_I(KTEMP) = KTEMP
+ IF (KTEMP == NT1D_TOP_I) THEN
+ NT1D_TOP_I = NT1D_TOP_I - 1
+ ELSE
+ WRITE( *, '( "MNH_REL_IT1D_N0: invalid value for KTEMP <> NT1D_TOP_I (",2I8,")" )' ) KTEMP, NT1D_TOP_I
+ FLUSH(6)
+ call Print_msg( NVERB_FATAL, 'GEN', 'MNH_REL_IT1D_N0', 'invalid value for KTEMP <> NT1D_TOP_R' )
+ END IF
+ ENDIF
+ !WRITE( *, '( "MNH_REL_IT1D_N0: releasing IT1D (",I4,")" )' ) KTEMP
+
+ END SUBROUTINE MNH_REL_IT1D_N0
+
+ SUBROUTINE MNH_REL_IT1D(KTEMP1,KTEMP2,KTEMP3,KTEMP4,KTEMP5,KTEMP6,KTEMP7,KTEMP8,KTEMP9, &
+ KTEMP10,KTEMP11,KTEMP12,KTEMP13,KTEMP14,KTEMP15,KTEMP16,KTEMP17,KTEMP18, &
+ KTEMP19,KTEMP20)
+
+ IMPLICIT NONE
+
+ INTEGER :: KTEMP1
+ INTEGER,OPTIONAL :: KTEMP2,KTEMP3,KTEMP4,KTEMP5,KTEMP6,KTEMP7,KTEMP8,KTEMP9
+ INTEGER,OPTIONAL :: KTEMP10,KTEMP11,KTEMP12,KTEMP13,KTEMP14,KTEMP15,KTEMP16,KTEMP17,KTEMP18
+ INTEGER,OPTIONAL :: KTEMP19,KTEMP20
+
+ IF (PRESENT(KTEMP20)) CALL MNH_REL_IT1D_N0(KTEMP20)
+ IF (PRESENT(KTEMP19)) CALL MNH_REL_IT1D_N0(KTEMP19)
+ IF (PRESENT(KTEMP18)) CALL MNH_REL_IT1D_N0(KTEMP18)
+ IF (PRESENT(KTEMP17)) CALL MNH_REL_IT1D_N0(KTEMP17)
+ IF (PRESENT(KTEMP16)) CALL MNH_REL_IT1D_N0(KTEMP16)
+ IF (PRESENT(KTEMP15)) CALL MNH_REL_IT1D_N0(KTEMP15)
+ IF (PRESENT(KTEMP14)) CALL MNH_REL_IT1D_N0(KTEMP14)
+ IF (PRESENT(KTEMP13)) CALL MNH_REL_IT1D_N0(KTEMP13)
+ IF (PRESENT(KTEMP12)) CALL MNH_REL_IT1D_N0(KTEMP12)
+ IF (PRESENT(KTEMP11)) CALL MNH_REL_IT1D_N0(KTEMP11)
+ IF (PRESENT(KTEMP10)) CALL MNH_REL_IT1D_N0(KTEMP10)
+ IF (PRESENT(KTEMP9)) CALL MNH_REL_IT1D_N0(KTEMP9)
+ IF (PRESENT(KTEMP8)) CALL MNH_REL_IT1D_N0(KTEMP8)
+ IF (PRESENT(KTEMP7)) CALL MNH_REL_IT1D_N0(KTEMP7)
+ IF (PRESENT(KTEMP6)) CALL MNH_REL_IT1D_N0(KTEMP6)
+ IF (PRESENT(KTEMP5)) CALL MNH_REL_IT1D_N0(KTEMP5)
+ IF (PRESENT(KTEMP4)) CALL MNH_REL_IT1D_N0(KTEMP4)
+ IF (PRESENT(KTEMP3)) CALL MNH_REL_IT1D_N0(KTEMP3)
+ IF (PRESENT(KTEMP2)) CALL MNH_REL_IT1D_N0(KTEMP2)
+ CALL MNH_REL_IT1D_N0(KTEMP1)
+
+ END SUBROUTINE MNH_REL_IT1D
+
+ FUNCTION MNH_ALLOCATE_IT1D(PTAB,KI) RESULT (KINDEX)
+
+ INTEGER, POINTER, CONTIGUOUS , DIMENSION(:), INTENT(INOUT) :: PTAB
+ INTEGER , INTENT(IN) :: KI
+ INTEGER :: KINDEX
+
+ !local
+
+ IF (KI .EQ. IIJKU) THEN
+ CALL MNH_GET_IT1D_N0(KINDEX)
+ PTAB => IT1D(:,KINDEX)
+ ELSE
+ call Print_msg( NVERB_ERROR, 'GEN', 'MNH_ALLOCATE_IT1D', ' Size mismatsh ' )
+ END IF
+ !WRITE( *, '( "MNH_ALLOCATE_IT1D: KI=(",I4,") , KINDEX=(",I4,")" )' ) KI,KINDEX
+ !FLUSH(6)
+
+ END FUNCTION MNH_ALLOCATE_IT1D
+
+ FUNCTION MNH_ALLOCATE_IT1DP(PTAB,KI) RESULT (KINDEX)
+
+ INTEGER, POINTER, CONTIGUOUS , DIMENSION(:), INTENT(INOUT) :: PTAB
+ INTEGER , INTENT(IN) :: KI
+ INTEGER :: KINDEX
+
+ !local
+
+ IF (KI .LE. IIJKU) THEN
+ CALL MNH_GET_IT1D_N0(KINDEX)
+ IF (KI .NE. 0) THEN
+ PTAB(1:KI) => IT1D(:,KINDEX)
+ ELSE
+ PTAB => IT1D_OSIZE
+ END IF
+ ELSE
+ call Print_msg( NVERB_ERROR, 'GEN', 'MNH_ALLOCATE_IT1DP', ' Size mismatsh ' )
+ END IF
+ !WRITE( *, '( "MNH_ALLOCATE_IT1DP: KI=(",I9,") , KINDEX=(",I4,")" )' ) KI,KINDEX
+
+ END FUNCTION MNH_ALLOCATE_IT1DP
+
+ ! End Integer 1D management
+
+ SUBROUTINE MNH_CHECK_IN_ZT3D(HSUB)
+ IMPLICIT NONE
+
+ CHARACTER(LEN=*) :: HSUB
+
+ !print*,"MNH_CHECK_IN_ZT3D => " , NT3D_TOP_CURRENT_INDEX+1 , HSUB
+ NT3D_TOP_CURRENT_INDEX = NT3D_TOP_CURRENT_INDEX + 1
+ NT3D_TOP_CURRENT(NT3D_TOP_CURRENT_INDEX) = NT3D_TOP
+ END SUBROUTINE MNH_CHECK_IN_ZT3D
+
+ SUBROUTINE MNH_CHECK_OUT_ZT3D(HSUB)
+ IMPLICIT NONE
+ CHARACTER(LEN=*) :: HSUB
+
+ !print*,"MNH_CHECK_OUT_ZT3D <= " , NT3D_TOP_CURRENT_INDEX , HSUB
+ IF ( NT3D_TOP_CURRENT(NT3D_TOP_CURRENT_INDEX) .NE. NT3D_TOP ) THEN
+ WRITE( *, '( "MNH_CHECK_OUT_ZT3D : NT3D_TOP_CURRENT .NE. NT3D_TOP (",2I8,")" )' ) NT3D_TOP_CURRENT , NT3D_TOP
+ call Print_msg( NVERB_ERROR, 'GEN', 'MNH_CHECK_OUT_ZT3D', ' CHECK IN/OUT MISTASK ' )
+ ELSE
+ NT3D_TOP_CURRENT_INDEX = NT3D_TOP_CURRENT_INDEX - 1
+ END IF
+ END SUBROUTINE MNH_CHECK_OUT_ZT3D
END MODULE MODE_MNH_ZWORK
#endif
diff --git a/src/MNH/mode_openacc.f90 b/src/MNH/mode_openacc.f90
new file mode 100644
index 0000000000000000000000000000000000000000..10f1d683dc6f2c449f042de73f266da4a32d80de
--- /dev/null
+++ b/src/MNH/mode_openacc.f90
@@ -0,0 +1,7 @@
+#ifdef _FAKEOPENACC
+MODULE OPENACC
+END MODULE OPENACC
+#else
+MODULE OPENACC_FAKEOPENACC
+END MODULE OPENACC_FAKEOPENACC
+#endif
diff --git a/src/MNH/mode_openacc_set_device.f90 b/src/MNH/mode_openacc_set_device.f90
new file mode 100644
index 0000000000000000000000000000000000000000..bd440f9809d4c832c1ebac8b11ea6419e58cff7a
--- /dev/null
+++ b/src/MNH/mode_openacc_set_device.f90
@@ -0,0 +1,113 @@
+!define NO_SWAP_DEVICE
+#ifdef NO_SWAP_DEVICE
+#define SWAP_DEVICE_RETURN return
+#else
+#define SWAP_DEVICE_RETURN
+#endif
+MODULE MODE_OPENACC_SET_DEVICE
+
+#ifndef _FAKEOPENACC
+ USE openacc , ONLY : acc_device_kind , acc_device_nvidia, acc_device_host
+#endif
+
+ IMPLICIT NONE
+
+#ifndef _FAKEOPENACC
+ INTEGER(kind=acc_device_kind) :: mnh_idevice_type_at_init = -1000
+ INTEGER(kind=acc_device_kind) :: mnh_idevice_type_current = -1
+#endif
+
+ integer :: iswitch_cpu_gpu = 5
+
+CONTAINS
+
+ SUBROUTINE MNH_OPENACC_GET_DEVICE_AT_INIT()
+
+#ifndef _FAKEOPENACC
+ USE&
+ openacc , ONLY : acc_get_device_type,acc_device_kind
+
+ IMPLICIT NONE
+
+ INTEGER(kind=acc_device_kind) :: idevice_type
+
+ SWAP_DEVICE_RETURN
+
+ if ( mnh_idevice_type_at_init .EQ. -1000 ) then
+ mnh_idevice_type_at_init = acc_get_device_type()
+ mnh_idevice_type_current = mnh_idevice_type_at_init
+ print*,'mnh_idevice_type_at_init=',mnh_idevice_type_at_init
+ end if
+#endif
+
+ END SUBROUTINE MNH_OPENACC_GET_DEVICE_AT_INIT
+
+ SUBROUTINE MNH_OPENACC_GET_DEVICE()
+
+#ifndef _FAKEOPENACC
+ USE&
+ openacc , ONLY : acc_get_device_type,acc_device_kind
+
+ IMPLICIT NONE
+
+ INTEGER(kind=acc_device_kind) :: idevice_type
+
+ SWAP_DEVICE_RETURN
+
+ idevice_type = acc_get_device_type()
+ mnh_idevice_type_current = idevice_type
+ print*,'idevice_type=',idevice_type
+#endif
+
+ END SUBROUTINE MNH_OPENACC_GET_DEVICE
+
+ SUBROUTINE MNH_OPENACC_SET_DEVICE_HOST()
+
+#ifndef _FAKEOPENACC
+ USE&
+ openacc , ONLY : acc_set_device_type,acc_device_host,acc_get_device_type
+
+ IMPLICIT NONE
+
+ SWAP_DEVICE_RETURN
+
+ call acc_set_device_type(acc_device_host)
+ mnh_idevice_type_current = acc_device_host
+
+#endif
+
+ END SUBROUTINE MNH_OPENACC_SET_DEVICE_HOST
+
+ SUBROUTINE MNH_OPENACC_SET_DEVICE_NVIDIA()
+
+#ifndef _FAKEOPENACC
+ USE&
+ openacc , ONLY : acc_set_device_type,acc_device_nvidia,acc_get_device_type
+
+ IMPLICIT NONE
+
+ SWAP_DEVICE_RETURN
+
+ call acc_set_device_type(acc_device_nvidia)
+ mnh_idevice_type_current = acc_device_nvidia
+#endif
+
+ END SUBROUTINE MNH_OPENACC_SET_DEVICE_NVIDIA
+
+ SUBROUTINE MNH_OPENACC_SET_DEVICE_DEFAULT()
+
+#ifndef _FAKEOPENACC
+ USE&
+ openacc , ONLY : acc_set_device_type,acc_device_nvidia,acc_get_device_type
+
+ IMPLICIT NONE
+
+ SWAP_DEVICE_RETURN
+
+ call acc_set_device_type(mnh_idevice_type_at_init)
+ mnh_idevice_type_current = mnh_idevice_type_at_init
+#endif
+
+ END SUBROUTINE MNH_OPENACC_SET_DEVICE_DEFAULT
+
+END MODULE MODE_OPENACC_SET_DEVICE
diff --git a/src/MNH/mode_prandtl.f90 b/src/MNH/mode_prandtl.f90
index e9cfa91ece9b6ec247e5d05ad0dd9eecd78f6bc6..5fa00542e1e3e920d35624c7816886f43813ce6c 100644
--- a/src/MNH/mode_prandtl.f90
+++ b/src/MNH/mode_prandtl.f90
@@ -16,6 +16,7 @@ USE MODD_PARAMETERS, ONLY : JPVEXT_TURB
#ifdef MNH_OPENACC
use mode_msg
+USE MODE_MNH_ZWORK , ONLY : MNH_ALLOCATE_ZT3D , MNH_REL_ZT3D, MNH_ALLOCATE_GT3D , MNH_REL_GT3D
#endif
#ifdef MNH_BITREP
@@ -38,9 +39,18 @@ REAL, DIMENSION(:,:,:), INTENT(IN) :: PF_LIM ! Value of F when Phi3 is
! ! larger than Phi_lim
REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PF ! function F to smooth
!
+#ifndef MNH_OPENACC
REAL, DIMENSION(SIZE(PF,1),SIZE(PF,2),SIZE(PF,3)) :: ZCOEF
+#else
+REAL, DIMENSION(:,:,:), pointer,contiguous :: ZCOEF
+INTEGER :: IZCOEF
+#endif
-!$acc data present( PPHI3, PF_LIM, PF ) create( ZCOEF )
+#ifdef MNH_OPENACC
+ IZCOEF = MNH_ALLOCATE_ZT3D( ZCOEF , SIZE(PF,1),SIZE(PF,2),SIZE(PF,3) )
+#endif
+
+!$acc data present( PPHI3, PF_LIM, PF ) present( ZCOEF )
!* adds a artificial correction to smooth the function near the discontinuity
! point at Phi3 = Phi_lim
@@ -57,6 +67,10 @@ PF(:,:,:) = ZCOEF(:,:,:) * PF &
!$acc end data
+#ifdef MNH_OPENACC
+CALL MNH_REL_ZT3D(IZCOEF)
+#endif
+
END SUBROUTINE SMOOTH_TURB_FUNCT
!----------------------------------------------------------------------------
#ifndef MNH_OPENACC
@@ -78,44 +92,71 @@ SUBROUTINE PHI3(PREDTH1,PREDR1,PRED2TH3,PRED2R3,PRED2THR3,HTURBDIM,OUSERV,PPHI3)
#endif
!
INTEGER :: IKB, IKE
- LOGICAL,DIMENSION(:,:,:), allocatable :: PHI3LOGIC
- REAL, DIMENSION(:,:,:), allocatable :: ZW1, ZW2
+ LOGICAL,DIMENSION(:,:,:), pointer , contiguous :: GPHI3LOGIC
+ REAL, DIMENSION(:,:,:), pointer , contiguous :: ZW1, ZW2
+#ifdef MNH_OPENACC
+ INTEGER :: IGPHI3LOGIC, IZW1, IZW2
+#endif
+ INTEGER :: JIU,JJU,JKU
+ INTEGER :: JI,JJ,JK
+
!$acc data present( PREDTH1, PREDR1, PRED2TH3, PRED2R3, PRED2THR3, PPHI3 )
IKB = 1+JPVEXT_TURB
IKE = SIZE(PREDTH1,3)-JPVEXT_TURB
+JIU = size( predth1, 1 )
+JJU = size( predth1, 2 )
+JKU = size( predth1, 3 )
+
+#ifndef MNH_OPENACC
allocate( zw1 ( size( predth1, 1 ), size( predth1, 2 ), size( predth1, 3 ) ) )
allocate( zw2 ( size( predth1, 1 ), size( predth1, 2 ), size( predth1, 3 ) ) )
-allocate( phi3logic( size( predth1, 1 ), size( predth1, 2 ), size( predth1, 3 ) ) )
+allocate( gphi3logic( size( predth1, 1 ), size( predth1, 2 ), size( predth1, 3 ) ) )
+#else
+izw1 = MNH_ALLOCATE_ZT3D( zw1 , JIU,JJU,JKU )
+izw2 = MNH_ALLOCATE_ZT3D( zw2 , JIU,JJU,JKU )
+igphi3logic = MNH_ALLOCATE_GT3D( gphi3logic, JIU,JJU,JKU )
+#endif
-!$acc data create( zw1, zw2, phi3logic )
+!$acc data present( zw1, zw2, gphi3logic )
!$acc kernels
IF (HTURBDIM=='3DIM') THEN
!* 3DIM case
IF (OUSERV) THEN
- ZW1(:,:,:) = 1. + 1.5* (PREDTH1(:,:,:)+PREDR1(:,:,:)) + &
#ifndef MNH_BITREP
- ( 0.5 * (PREDTH1(:,:,:)**2+PREDR1(:,:,:)**2) &
-#else
- ( 0.5 * (BR_P2(PREDTH1(:,:,:))+BR_P2(PREDR1(:,:,:))) &
-#endif
- + PREDTH1(:,:,:) * PREDR1(:,:,:) &
- )
+ DO CONCURRENT (JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZW1(JI,JJ,JK) = 1. + 1.5* (PREDTH1(JI,JJ,JK)+PREDR1(JI,JJ,JK)) + &
+ ( 0.5 * (PREDTH1(JI,JJ,JK)**2+PREDR1(JI,JJ,JK)**2) &
+ + PREDTH1(JI,JJ,JK) * PREDR1(JI,JJ,JK) &
+ )
+ END DO
+#else
+ DO CONCURRENT (JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZW1(JI,JJ,JK) = 1. + 1.5* (PREDTH1(JI,JJ,JK)+PREDR1(JI,JJ,JK)) + &
+ ( 0.5 * (BR_P2(PREDTH1(JI,JJ,JK))+BR_P2(PREDR1(JI,JJ,JK))) &
+ + PREDTH1(JI,JJ,JK) * PREDR1(JI,JJ,JK) &
+ )
+ END DO
+#endif
ZW2(:,:,:) = 0.5 * (PRED2TH3(:,:,:)-PRED2R3(:,:,:))
PPHI3(:,:,:)= 1. - &
( ( (1.+PREDR1(:,:,:)) * &
(PRED2THR3(:,:,:) + PRED2TH3(:,:,:)) / PREDTH1(:,:,:) &
) + ZW2(:,:,:) &
) / ZW1(:,:,:)
- ELSE
- ZW1(:,:,:) = 1. + 1.5* PREDTH1(:,:,:) + &
-#ifndef MNH_BITREP
- 0.5* PREDTH1(:,:,:)**2
+ ELSE
+#ifndef MNH_BITREP
+ DO CONCURRENT (JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZW1(JI,JJ,JK) = 1. + 1.5* PREDTH1(JI,JJ,JK) + &
+ 0.5* PREDTH1(JI,JJ,JK)**2
#else
- 0.5* BR_P2(PREDTH1(:,:,:))
+ DO CONCURRENT (JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZW1(JI,JJ,JK) = 1. + 1.5* PREDTH1(JI,JJ,JK) + &
+ 0.5* BR_P2(PREDTH1(JI,JJ,JK))
+ END DO
#endif
ZW2(:,:,:) = 0.5* PRED2TH3(:,:,:)
PPHI3(:,:,:)= 1. - &
@@ -125,8 +166,8 @@ IF (HTURBDIM=='3DIM') THEN
!WARNING: BUG PGI (tested up to PGI 16.10): necessary to use a logical mask
!because the compiler does not manage correctly the .OR. in the WHERE
!WHERE( PPHI3 <= 0. .OR. PPHI3 > XPHI_LIM )
- PHI3LOGIC = (PPHI3 <= 0. .OR. PPHI3 > XPHI_LIM)
- WHERE( PHI3LOGIC )
+ GPHI3LOGIC = (PPHI3 <= 0. .OR. PPHI3 > XPHI_LIM)
+ WHERE( GPHI3LOGIC )
PPHI3 = XPHI_LIM
END WHERE
@@ -145,6 +186,13 @@ PPHI3(:,:,IKE+1)=PPHI3(:,:,IKE)
!$acc end data
+#ifndef MNH_OPENACC
+deallocate ( zw1,zw2,gphi3logic)
+#else
+CALL MNH_REL_ZT3D(IZW1,IZW2)
+CALL MNH_REL_GT3D(IGPHI3LOGIC)
+#endif
+
!$acc end data
#ifndef MNH_OPENACC
@@ -173,13 +221,20 @@ SUBROUTINE PSI_SV(PREDTH1,PREDR1,PREDS1,PRED2THS,PRED2RS,PPHI3,PPSI3,PPSI_SV)
!
INTEGER :: IKB, IKE
INTEGER :: JSV
- LOGICAL, DIMENSION(:,:,:), allocatable :: PSILOGIC
+ LOGICAL, DIMENSION(:,:,:), pointer , contiguous :: GPSILOGIC
+#ifdef MNH_OPENACC
+ INTEGER :: IGPSILOGIC
+#endif
!$acc data present( PREDTH1, PREDR1, PREDS1, PRED2THS, PRED2RS, PPHI3, PPSI3, PPSI_SV )
-allocate( psilogic( size( pred2ths, 1 ), size( pred2ths, 2 ), size( pred2ths, 3 ) ) )
+#ifndef MNH_OPENACC
+allocate( gpsilogic( size( pred2ths, 1 ), size( pred2ths, 2 ), size( pred2ths, 3 ) ) )
+#else
+igpsilogic = MNH_ALLOCATE_GT3D( gpsilogic , size( pred2ths, 1 ), size( pred2ths, 2 ), size( pred2ths, 3 ) )
+#endif
-!$acc data create( psilogic )
+!$acc data present( gpsilogic )
IKB = 1+JPVEXT_TURB
IKE = SIZE(PREDTH1,3)-JPVEXT_TURB
@@ -197,8 +252,8 @@ DO JSV=1,SIZE(PPSI_SV,4)
!because the compiler does not manage correctly the .AND. in the WHERE
!Failure during execution
!WHERE ( (PPSI_SV(:,:,:,JSV) <=0.).AND. (PREDTH1+PREDR1) <= 0. )
- PSILOGIC = ((PPSI_SV(:,:,:,JSV) <=0.).AND. (PREDTH1+PREDR1) <= 0. )
- WHERE ( PSILOGIC )
+ GPSILOGIC = ((PPSI_SV(:,:,:,JSV) <=0.).AND. (PREDTH1+PREDR1) <= 0. )
+ WHERE ( GPSILOGIC )
PPSI_SV(:,:,:,JSV)=XPHI_LIM
END WHERE
PPSI_SV(:,:,:,JSV) = MAX( 1.E-4, MIN(XPHI_LIM,PPSI_SV(:,:,:,JSV)) )
@@ -210,6 +265,12 @@ END DO
!$acc end data
+#ifndef MNH_OPENACC
+deallocate( gpsilogic )
+#else
+CALL MNH_REL_GT3D(IGPSILOGIC)
+#endif
+
!$acc end data
#ifndef MNH_OPENACC
@@ -400,16 +461,17 @@ SUBROUTINE D_PHI3DTDZ2_O_DDTDZ(PPHI3,PREDTH1,PREDR1,PRED2TH3,PRED2THR3,PDTDZ,HTU
#endif
INTEGER :: IKB, IKE
#ifdef MNH_OPENACC
- REAL, DIMENSION(:,:,:), allocatable :: ZTMP1_DEVICE
+ REAL, DIMENSION(:,:,:), pointer , contiguous :: ZTMP1_DEVICE
+ INTEGER :: IZTMP1_DEVICE
#endif
!$acc data present( PPHI3, PREDTH1, PREDR1, PRED2TH3, PRED2THR3, PDTDZ, PD_PHI3DTDZ2_O_DDTDZ )
#ifdef MNH_OPENACC
-allocate( ztmp1_device(size( predth1, 1 ), size( predth1, 2 ), size( predth1, 3 ) ) )
+iztmp1_device = MNH_ALLOCATE_ZT3D( ztmp1_device, size( predth1, 1 ), size( predth1, 2 ), size( predth1, 3 ) )
#endif
-!$acc data create( ztmp1_device )
+!$acc data present( ztmp1_device )
IKB = 1+JPVEXT_TURB
IKE = SIZE(PREDTH1,3)-JPVEXT_TURB
@@ -483,6 +545,10 @@ PD_PHI3DTDZ2_O_DDTDZ(:,:,IKE+1)=PD_PHI3DTDZ2_O_DDTDZ(:,:,IKE)
!$acc end data
+#ifdef MNH_OPENACC
+CALL MNH_REL_ZT3D( iztmp1_device )
+#endif
+
!$acc end data
#ifndef MNH_OPENACC
diff --git a/src/MNH/modeln.f90 b/src/MNH/modeln.f90
index 3ad1f6d48935f03b92625175642e0eeb33d481eb..1d7902e71600f36c4b02a2ec3ba29123cd61a2ec 100644
--- a/src/MNH/modeln.f90
+++ b/src/MNH/modeln.f90
@@ -1602,13 +1602,16 @@ ZTIME1 = ZTIME2
XTIME_BU_PROCESS = 0.
XTIME_LES_BU_PROCESS = 0.
!
+!$acc update device(XRTHS)
+!
!$acc data create (XUT, XVT, XWT) &
!$acc & copyin (XTHT, XPABST, XRT, XSVT, XRTHS_CLD, XRRS_CLD, XTHVREF) &
-!$acc & copy (XRTHS, XRRS, XRUS, XRVS, XRWS) &
+!$acc & copy (XRRS, XRUS, XRVS, XRWS) &
!$acc & copy (XRWS_PRES) & !XRWS_PRES copy and not copyout (hidden in UPDATE_HALO)
!$acc & present(XDXX, XDYY, XDZZ, XDZX, XDZY, XRHODJ)
!
!$acc update device(XUT, XVT, XWT, XRHODJ)
+
!
!
!$acc data copyin (XTKET, XRSVS_CLD) &
@@ -1624,6 +1627,8 @@ CALL ADVECTION_METSV ( TZBAKFILE, CUVW_ADV_SCHEME, &
XRTHS_CLD, XRRS_CLD, XRSVS_CLD, XRTKEMS )
!$acc end data
!
+!$acc update host(XRTHS)
+!
CALL SECOND_MNH2(ZTIME2)
!
XT_ADV = XT_ADV + ZTIME2 - ZTIME1 - XTIME_LES_BU_PROCESS - XTIME_BU_PROCESS
@@ -1901,6 +1906,9 @@ IF (CCLOUD /= 'NONE' .AND. CELEC == 'NONE') THEN
!$acc & XINPRC, XINPRR, XINPRS, XINPRG, XINPRH, XINDEP, &
!$acc & XHLC_HRC, XHLC_HCF, XHLI_HRI, XHLI_HCF) &
!$acc & copyout(XSRCT, XRAINFR)
+
+!$acc update device ( XRTHS )
+
IF (CSURF=='EXTE') THEN
ALLOCATE (ZSEA(SIZE(XRHODJ,1),SIZE(XRHODJ,2)))
ALLOCATE (ZTOWN(SIZE(XRHODJ,1),SIZE(XRHODJ,2)))
@@ -1952,6 +1960,9 @@ IF (CCLOUD /= 'NONE' .AND. CELEC == 'NONE') THEN
XHLC_HRC, XHLC_HCF, XHLI_HRI, XHLI_HCF )
END IF
!$acc end data
+
+!$acc update host(XRTHS)
+
XRTHS_CLD(:, :, : ) = XRTHS(:, :, : ) - XRTHS_CLD(:, :, : )
XRRS_CLD (:, :, :, : ) = XRRS (:, :, :, : ) - XRRS_CLD (:, :, :, : )
XRSVS_CLD(:, :, :, : ) = XRSVS(:, :, :, : ) - XRSVS_CLD(:, :, :, : )
diff --git a/src/MNH/ppm.f90 b/src/MNH/ppm.f90
index bbfb03a46a9d816096ff70da3be9a12cc1f95a55..9d1f1e611442938ce2be15e478ba071ce05e7bb0 100644
--- a/src/MNH/ppm.f90
+++ b/src/MNH/ppm.f90
@@ -2704,9 +2704,9 @@ ENDIF
#ifndef MNH_OPENACC
CALL GET_HALO(ZPHAT, HNAME='ZPHAT')
#else
-!$acc update self(ZPHAT)
-CALL GET_HALO(ZPHAT(:,:,:), HDIR="Z0_X", HNAME='ZPHAT')
-!$acc update device(ZPHAT)
+! acc update self(ZPHAT)
+!CALL GET_HALO_D(ZPHAT(:,:,:), HDIR="Z0_X", HNAME='ZPHAT')
+! acc update device(ZPHAT)
#endif
!
!$acc kernels
@@ -2739,9 +2739,9 @@ CALL GET_HALO(ZPHAT(:,:,:), HDIR="Z0_X", HNAME='ZPHAT')
#ifndef MNH_OPENACC
CALL GET_HALO(ZFPOS, HNAME='ZFPOS') ! JUAN
#else
-!$acc update self(ZFPOS)
-CALL GET_HALO(ZFPOS(:,:,:), HDIR="Z0_X", HNAME='ZFPOS') ! JUAN
-!$acc update device(ZFPOS)
+! acc update self(ZFPOS)
+!CALL GET_HALO_D(ZFPOS(:,:,:), HDIR="Z0_X", HNAME='ZFPOS') ! JUAN
+! acc update device(ZFPOS)
#endif
!
!$acc kernels
@@ -2767,9 +2767,9 @@ CALL GET_HALO(ZFPOS(:,:,:), HDIR="Z0_X", HNAME='ZFPOS') ! JUAN
#ifndef MNH_OPENACC
CALL GET_HALO(ZFNEG, HNAME='ZFNEG') ! JUAN
#else
-!$acc update self(ZFNEG)
-CALL GET_HALO(ZFNEG, HDIR="Z0_X", HNAME='ZFNEG') ! JUAN
-!$acc update device(ZFNEG)
+! acc update self(ZFNEG)
+!CALL GET_HALO_D(ZFNEG, HDIR="Z0_X", HNAME='ZFNEG') ! JUAN
+! acc update device(ZFNEG)
#endif
!
!$acc kernels
@@ -3039,7 +3039,7 @@ IF ( L2D ) THEN
CALL MPPDB_CHECK(PR,"PPM_S0_Y end:PR")
! RETURN
ELSE !not L2D
-!
+ !
CALL GET_HALO2(PSRC, TZ_PSRC_HALO2_ll, HNAME='PSRC')
ZPSRC_HALO2_SOUTH(:,:) = TZ_PSRC_HALO2_ll%HALO2%SOUTH(:,:)
!$acc update device (ZPSRC_HALO2_SOUTH)
@@ -3150,9 +3150,9 @@ CASE ('OPEN')
#ifndef MNH_OPENACC
CALL GET_HALO(ZPHAT, HNAME='ZPHAT')
#else
-!$acc update self(ZPHAT)
-CALL GET_HALO(ZPHAT(:,:,:), HDIR="Z0_Y", HNAME='ZPHAT')
-!$acc update device(ZPHAT)
+! acc update self(ZPHAT)
+!CALL GET_HALO_D(ZPHAT(:,:,:), HDIR="Z0_Y", HNAME='ZPHAT')
+! acc update device(ZPHAT)
#endif
!
!$acc kernels
@@ -3187,9 +3187,9 @@ CALL GET_HALO(ZPHAT(:,:,:), HDIR="Z0_Y", HNAME='ZPHAT')
#ifndef MNH_OPENACC
CALL GET_HALO(ZFPOS, HNAME='ZFPOS') ! JUAN
#else
-!$acc update self(ZFPOS)
-CALL GET_HALO(ZFPOS(:,:,:), HDIR="Z0_Y", HNAME='ZFPOS') ! JUAN
-!$acc update device(ZFPOS)
+! acc update self(ZFPOS)
+!CALL GET_HALO_D(ZFPOS(:,:,:), HDIR="Z0_Y", HNAME='ZFPOS') ! JUAN
+! acc update device(ZFPOS)
#endif
!
!$acc kernels
@@ -3216,9 +3216,9 @@ CALL GET_HALO(ZFPOS(:,:,:), HDIR="Z0_Y", HNAME='ZFPOS') ! JUAN
#ifndef MNH_OPENACC
CALL GET_HALO(ZFNEG, HNAME='ZFNEG') ! JUAN
#else
-!$acc update self(ZFNEG)
- CALL GET_HALO(ZFNEG, HDIR="Z0_Y", HNAME='ZFNEG') ! JUAN
-!$acc update device(ZFNEG)
+! acc update self(ZFNEG)
+! CALL GET_HALO_D(ZFNEG, HDIR="Z0_Y", HNAME='ZFNEG') ! JUAN
+! acc update device(ZFNEG)
#endif
!
!$acc kernels
diff --git a/src/MNH/ppm_met.f90 b/src/MNH/ppm_met.f90
index f9f2d3e6c88d45055141df3efaa9c99bb350780b..76cebf49b03a496a32f8a592b08912b71ba6770e 100644
--- a/src/MNH/ppm_met.f90
+++ b/src/MNH/ppm_met.f90
@@ -170,7 +170,7 @@ END IF
!* 1. COMPUTES THE DOMAIN DIMENSIONS
! ------------------------------
!
-GTKEALLOC = SIZE(PTKET,1) /= 0
+GTKEALLOC = SIZE(PTKET) /= 0
!
!-------------------------------------------------------------------------------
!
diff --git a/src/MNH/prandtl.f90 b/src/MNH/prandtl.f90
index 9442f71eb20b9b0ecad3ac894793d7dd0d7c80ed..ebe407a91ff106f5a3848955f86c1fe4e8176757 100644
--- a/src/MNH/prandtl.f90
+++ b/src/MNH/prandtl.f90
@@ -73,8 +73,6 @@ END INTERFACE
!
END MODULE MODI_PRANDTL
!
-!
-!
! ###########################################################
SUBROUTINE PRANDTL(KKA,KKU,KKL,KRR,KRRI,OTURB_DIAG, &
HTURBDIM, &
@@ -220,6 +218,11 @@ USE MODI_SHUMAN
USE MODI_SHUMAN_DEVICE
#endif
!
+#ifdef MNH_OPENACC
+USE MODE_MNH_ZWORK , ONLY : MNH_ALLOCATE_ZT3D , MNH_REL_ZT3D, &
+ MNH_CHECK_IN_ZT3D,MNH_CHECK_OUT_ZT3D
+#endif
+!
IMPLICIT NONE
!
!
@@ -272,7 +275,11 @@ REAL, DIMENSION(:,:,:), INTENT(OUT) :: PEMOIST ! coefficient E_moist
!
! 0.2 declaration of local variables
!
-REAL, DIMENSION(:,:,:), allocatable :: ZW1, ZW2 ! work arrays
+REAL, DIMENSION(:,:,:), pointer , contiguous :: ZW1
+REAL, DIMENSION(:,:,:), pointer , contiguous :: ZW2 ! work arrays
+#ifdef MNH_OPENACC
+INTEGER :: IZW1, IZW2
+#endif
!
INTEGER :: IKB ! vertical index value for the first inner mass point
INTEGER :: IKE ! vertical index value for the last inner mass point
@@ -283,13 +290,17 @@ INTEGER :: JLOOP
REAL :: ZMINVAL
!
#ifdef MNH_OPENACC
-REAL, DIMENSION(:,:,:), allocatable :: ZTMP1_DEVICE
-REAL, DIMENSION(:,:,:), allocatable :: ZTMP2_DEVICE
-REAL, DIMENSION(:,:,:), allocatable :: ZTMP3_DEVICE
-REAL, DIMENSION(:,:,:), allocatable :: ZTMP4_DEVICE
-REAL, DIMENSION(:,:,:), allocatable :: ZTMP5_DEVICE
+REAL, DIMENSION(:,:,:), pointer , contiguous :: ZTMP1_DEVICE
+REAL, DIMENSION(:,:,:), pointer , contiguous :: ZTMP2_DEVICE
+REAL, DIMENSION(:,:,:), pointer , contiguous :: ZTMP3_DEVICE
+REAL, DIMENSION(:,:,:), pointer , contiguous :: ZTMP4_DEVICE
+REAL, DIMENSION(:,:,:), pointer , contiguous :: ZTMP5_DEVICE
+INTEGER :: IZTMP1_DEVICE,IZTMP2_DEVICE,IZTMP3_DEVICE,IZTMP4_DEVICE,IZTMP5_DEVICE
#endif
TYPE(TFIELDDATA) :: TZFIELD
+!
+INTEGER :: JIU,JJU,JKU
+INTEGER :: JI,JJ,JK
! ---------------------------------------------------------------------------
!$acc data present( PDXX, PDYY, PDZZ, PDZX, PDZY, &
@@ -318,18 +329,28 @@ if ( mppdb_initialized ) then
call Mppdb_check( psrcm, "Prandtl beg:psrcm" )
end if
-allocate( zw1(size( pthlm, 1 ), size( pthlm, 2 ), size( pthlm, 3 ) ) )
-allocate( zw2(size( pthlm, 1 ), size( pthlm, 2 ), size( pthlm, 3 ) ) )
+JIU = size( pthlm, 1 )
+JJU = size( pthlm, 2 )
+JKU = size( pthlm, 3 )
+
+#ifndef MNH_OPENACC
+allocate( zw1(JIU,JJU,JKU ) )
+allocate( zw2(JIU,JJU,JKU ) )
+#else
+CALL MNH_CHECK_IN_ZT3D("PRANDTL")
+izw1 = MNH_ALLOCATE_ZT3D( zw1, JIU,JJU,JKU )
+izw2 = MNH_ALLOCATE_ZT3D( zw2, JIU,JJU,JKU )
+#endif
#ifdef MNH_OPENACC
-allocate( ztmp1_device(size( pthlm, 1 ), size( pthlm, 2 ), size( pthlm, 3 ) ) )
-allocate( ztmp2_device(size( pthlm, 1 ), size( pthlm, 2 ), size( pthlm, 3 ) ) )
-allocate( ztmp3_device(size( pthlm, 1 ), size( pthlm, 2 ), size( pthlm, 3 ) ) )
-allocate( ztmp4_device(size( pthlm, 1 ), size( pthlm, 2 ), size( pthlm, 3 ) ) )
-allocate( ztmp5_device(size( pthlm, 1 ), size( pthlm, 2 ), size( pthlm, 3 ) ) )
+iztmp1_device = MNH_ALLOCATE_ZT3D( ztmp1_device, JIU,JJU,JKU )
+iztmp2_device = MNH_ALLOCATE_ZT3D( ztmp2_device, JIU,JJU,JKU )
+iztmp3_device = MNH_ALLOCATE_ZT3D( ztmp3_device, JIU,JJU,JKU )
+iztmp4_device = MNH_ALLOCATE_ZT3D( ztmp4_device, JIU,JJU,JKU )
+iztmp5_device = MNH_ALLOCATE_ZT3D( ztmp5_device, JIU,JJU,JKU )
#endif
-!$acc data create( zw1, zw2, ztmp1_device, ztmp2_device, ztmp3_device, ztmp4_device, ztmp5_device )
+!$acc data present( zw1, zw2, ztmp1_device, ztmp2_device, ztmp3_device, ztmp4_device, ztmp5_device )
!
!* 1. DEFAULT VALUES, 1D REDELSPERGER NUMBERS
@@ -396,17 +417,17 @@ ELSE
IF (KRR /= 0) THEN ! moist case
CALL GZ_M_W_DEVICE(KKA,KKU,KKL,PTHLM,PDZZ,ZTMP1_DEVICE)
!$acc kernels async
- PREDTH1(:,:,:)= XCTV*PBLL_O_E(:,:,:) * PETHETA(:,:,:) * ZTMP1_DEVICE
+ PREDTH1(:,:,:)= XCTV*PBLL_O_E(:,:,:) * PETHETA(:,:,:) * ZTMP1_DEVICE(:,:,:)
!$acc end kernels
CALL GZ_M_W_DEVICE(KKA,KKU,KKL,PRM(:,:,:,1),PDZZ,ZTMP2_DEVICE)
!$acc kernels async
- PREDR1(:,:,:) = XCTV*PBLL_O_E(:,:,:) * PEMOIST(:,:,:) * ZTMP2_DEVICE
+ PREDR1(:,:,:) = XCTV*PBLL_O_E(:,:,:) * PEMOIST(:,:,:) * ZTMP2_DEVICE(:,:,:)
!$acc end kernels
!$acc wait
ELSE ! dry case
CALL GZ_M_W_DEVICE(KKA,KKU,KKL,PTHLM,PDZZ,ZTMP1_DEVICE)
!$acc kernels
- PREDTH1(:,:,:)= XCTV*PBLL_O_E(:,:,:) * ZTMP1_DEVICE
+ PREDTH1(:,:,:)= XCTV*PBLL_O_E(:,:,:) * ZTMP1_DEVICE(:,:,:)
PREDR1(:,:,:) = 0.
!$acc end kernels
END IF
@@ -416,48 +437,66 @@ END IF
! 3. Limits on 1D Redelperger numbers
! --------------------------------
!
-!$acc kernels
ZMINVAL = (1.-1./XPHI_LIM)
!
-ZW1 = 1.
-ZW2 = 1.
-!
-WHERE (PREDTH1+PREDR1<-ZMINVAL)
- ZW1 = (-ZMINVAL) / (PREDTH1+PREDR1)
+!$acc kernels
+DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZW1(JI,JJ,JK) = 1.
+ ZW2(JI,JJ,JK) = 1.
+END DO
+
+WHERE (PREDTH1(:,:,:)+PREDR1(:,:,:) < -ZMINVAL)
+ ZW1(:,:,:) = (-ZMINVAL) / (PREDTH1(:,:,:)+PREDR1(:,:,:))
END WHERE
-!
-WHERE (PREDTH1<-ZMINVAL)
- ZW2 = (-ZMINVAL) / (PREDTH1)
+
+WHERE (PREDTH1(:,:,:) < -ZMINVAL)
+ ZW2(:,:,:) = (-ZMINVAL) / (PREDTH1(:,:,:))
END WHERE
-ZW2 = MIN(ZW1,ZW2)
-!
-ZW1 = 1.
-WHERE (PREDR1<-ZMINVAL)
- ZW1 = (-ZMINVAL) / (PREDR1)
+!$acc loop independent collapse(3)
+DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZW2(JI,JJ,JK) = MIN( ZW1(JI,JJ,JK),ZW2(JI,JJ,JK) )
+END DO
+
+ZW1(:,:,:) = 1.
+WHERE (PREDR1(:,:,:)<-ZMINVAL)
+ ZW1(:,:,:) = (-ZMINVAL) / (PREDR1(:,:,:))
END WHERE
-ZW1 = MIN(ZW2,ZW1)
+
+!!$ZW1(:,:,:) = MIN(ZW2(:,:,:),ZW1(:,:,:))
+!$acc loop independent collapse(3)
+DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZW1(JI,JJ,JK) = MIN( ZW2(JI,JJ,JK),ZW1(JI,JJ,JK) )
+END DO
!
+!$acc end kernels
!
! 3. Modification of Mixing length and dissipative length
! ----------------------------------------------------
!
-PBLL_O_E(:,:,:) = PBLL_O_E(:,:,:) * ZW1(:,:,:)
-PREDTH1 (:,:,:) = PREDTH1 (:,:,:) * ZW1(:,:,:)
-PREDR1 (:,:,:) = PREDR1 (:,:,:) * ZW1(:,:,:)
+!$acc kernels
+!
+DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ PBLL_O_E(JI,JJ,JK) = PBLL_O_E(JI,JJ,JK) * ZW1(JI,JJ,JK)
+ PREDTH1 (JI,JJ,JK) = PREDTH1 (JI,JJ,JK) * ZW1(JI,JJ,JK)
+ PREDR1 (JI,JJ,JK) = PREDR1 (JI,JJ,JK) * ZW1(JI,JJ,JK)
+END DO !CONCURRENT
!
! 4. Threshold for very small (in absolute value) Redelperger numbers
! ----------------------------------------------------------------
!
-ZW2=SIGN(1.,PREDTH1(:,:,:))
+ZW2(:,:,:)=SIGN(1.,PREDTH1(:,:,:))
PREDTH1(:,:,:)= ZW2(:,:,:) * MAX(XMNH_TINY_12, ZW2(:,:,:)*PREDTH1(:,:,:))
+!$acc end kernels
!
IF (.NOT.LOCEAN) THEN
IF (KRR /= 0) THEN ! dry case
+!$acc kernels
ZW2=SIGN(1.,PREDR1(:,:,:))
PREDR1(:,:,:)= ZW2(:,:,:) * MAX(XMNH_TINY_12, ZW2(:,:,:)*PREDR1(:,:,:))
+!$acc end kernels
END IF
END IF
-!$acc end kernels
+
!
!---------------------------------------------------------------------------
!
@@ -471,14 +510,14 @@ END DO
DO JSV=1,ISV
CALL GZ_M_W_DEVICE(KKA,KKU,KKL,PSVM(:,:,:,JSV),PDZZ,ZTMP1_DEVICE)
!$acc kernels
- PREDS1(:,:,:,JSV)=XCTV*PBLL_O_E(:,:,:)*ZTMP1_DEVICE
+ PREDS1(:,:,:,JSV)=XCTV*PBLL_O_E(:,:,:)*ZTMP1_DEVICE(:,:,:)
!$acc end kernels
END DO
#endif
!
!$acc kernels
DO JSV=1,ISV
- ZW2=SIGN(1.,PREDS1(:,:,:,JSV))
+ ZW2(:,:,:)=SIGN(1.,PREDS1(:,:,:,JSV))
PREDS1(:,:,:,JSV)= ZW2(:,:,:) * MAX(XMNH_TINY_12, ZW2(:,:,:)*PREDS1(:,:,:,JSV))
END DO
!$acc end kernels
@@ -490,7 +529,7 @@ END DO
!
IF(HTURBDIM=='1DIM') THEN ! 1D case
!
-!$acc kernels async
+!$acc kernels ! async
#ifndef MNH_BITREP
PRED2TH3(:,:,:) = PREDTH1(:,:,:)**2
#else
@@ -498,7 +537,7 @@ IF(HTURBDIM=='1DIM') THEN ! 1D case
#endif
!$acc end kernels
!
-!$acc kernels async
+!$acc kernels ! async
#ifndef MNH_BITREP
PRED2R3(:,:,:) = PREDR1(:,:,:) **2
#else
@@ -506,10 +545,10 @@ IF(HTURBDIM=='1DIM') THEN ! 1D case
#endif
!$acc end kernels
!
-!$acc kernels async
+!$acc kernels ! async
PRED2THR3(:,:,:) = PREDTH1(:,:,:) * PREDR1(:,:,:)
!$acc end kernels
-!$acc wait
+! acc wait
!
ELSE IF (L2D) THEN ! 3D case in a 2D model
!
@@ -527,17 +566,27 @@ ELSE IF (L2D) THEN ! 3D case in a 2D model
CALL GX_M_M_DEVICE(KKA,KKU,KKL,PTHLM,PDXX,PDZZ,PDZX,ZTMP1_DEVICE)
!$acc kernels
#ifndef MNH_BITREP
- ZTMP1_DEVICE = ZTMP1_DEVICE**2
+!$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP1_DEVICE(JI,JJ,JK) = ZTMP1_DEVICE(JI,JJ,JK)**2
+ END DO !CONCURRENT
#else
- ZTMP1_DEVICE = BR_P2(ZTMP1_DEVICE)
+!$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP1_DEVICE(JI,JJ,JK) = BR_P2(ZTMP1_DEVICE(JI,JJ,JK))
+ END DO !CONCURRENT
#endif
!$acc end kernels
CALL MZM_DEVICE(ZTMP1_DEVICE,ZTMP2_DEVICE )
-!$acc kernels async
+!$acc kernels ! async
#ifndef MNH_BITREP
- PRED2TH3(:,:,:)= PREDTH1(:,:,:)**2+(XCTV*PBLL_O_E(:,:,:)*PETHETA(:,:,:) )**2 * ZTMP2_DEVICE
+ PRED2TH3(:,:,:) = PREDTH1(:,:,:)**2 &
+ + (XCTV*PBLL_O_E(:,:,:)*PETHETA(:,:,:) )**2 &
+ * ZTMP2_DEVICE(:,:,:)
#else
- PRED2TH3(:,:,:)= BR_P2(PREDTH1(:,:,:))+BR_P2(XCTV*PBLL_O_E(:,:,:)*PETHETA(:,:,:) ) * ZTMP2_DEVICE
+ PRED2TH3(:,:,:) = BR_P2(PREDTH1(:,:,:)) &
+ + BR_P2(XCTV*PBLL_O_E(:,:,:)*PETHETA(:,:,:) ) &
+ * ZTMP2_DEVICE(:,:,:)
#endif
PRED2TH3(:,:,IKB)=PRED2TH3(:,:,IKB+KKL)
!$acc end kernels
@@ -545,28 +594,40 @@ ELSE IF (L2D) THEN ! 3D case in a 2D model
!
#ifndef MNH_OPENACC
#ifndef MNH_BITREP
- PRED2R3(:,:,:)= PREDR1(:,:,:)**2 + (XCTV*PBLL_O_E(:,:,:)*PEMOIST(:,:,:))**2 * &
- MZM( GX_M_M(PRM(:,:,:,1),PDXX,PDZZ,PDZX)**2 )
+ PRED2R3(:,:,:) = PREDR1(:,:,:)**2 &
+ + (XCTV*PBLL_O_E(:,:,:)*PEMOIST(:,:,:))**2 &
+ * MZM( GX_M_M(PRM(:,:,:,1),PDXX,PDZZ,PDZX)**2 )
#else
- PRED2R3(:,:,:)= BR_P2(PREDR1(:,:,:)) + BR_P2(XCTV*PBLL_O_E(:,:,:)*PEMOIST(:,:,:)) * &
- MZM( BR_P2(GX_M_M(PRM(:,:,:,1),PDXX,PDZZ,PDZX)) )
+ PRED2R3(:,:,:) = BR_P2(PREDR1(:,:,:)) &
+ + BR_P2(XCTV*PBLL_O_E(:,:,:)*PEMOIST(:,:,:)) &
+ * MZM( BR_P2(GX_M_M(PRM(:,:,:,1),PDXX,PDZZ,PDZX)) )
#endif
PRED2R3(:,:,IKB)=PRED2R3(:,:,IKB+KKL)
#else
CALL GX_M_M_DEVICE(KKA,KKU,KKL,PRM(:,:,:,1),PDXX,PDZZ,PDZX,ZTMP1_DEVICE)
!$acc kernels
#ifndef MNH_BITREP
- ZTMP1_DEVICE = ZTMP1_DEVICE**2
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP1_DEVICE(JI,JJ,JK) = ZTMP1_DEVICE(JI,JJ,JK)**2
+ END DO !CONCURRENT
#else
- ZTMP1_DEVICE = BR_P2(ZTMP1_DEVICE)
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP1_DEVICE(JI,JJ,JK) = BR_P2(ZTMP1_DEVICE(JI,JJ,JK))
+ END DO !CONCURRENT
#endif
!$acc end kernels
CALL MZM_DEVICE(ZTMP1_DEVICE,ZTMP2_DEVICE )
-!$acc kernels async
+!$acc kernels ! async
#ifndef MNH_BITREP
- PRED2R3(:,:,:)= PREDR1(:,:,:)**2 + (XCTV*PBLL_O_E(:,:,:)*PEMOIST(:,:,:))**2 * ZTMP2_DEVICE
+ PRED2R3(:,:,:) = PREDR1(:,:,:)**2 &
+ + (XCTV*PBLL_O_E(:,:,:)*PEMOIST(:,:,:))**2 &
+ * ZTMP2_DEVICE(:,:,:)
#else
- PRED2R3(:,:,:)= BR_P2(PREDR1(:,:,:)) + BR_P2(XCTV*PBLL_O_E(:,:,:)*PEMOIST(:,:,:)) * ZTMP2_DEVICE
+ PRED2R3(:,:,:) = BR_P2(PREDR1(:,:,:)) &
+ + BR_P2(XCTV*PBLL_O_E(:,:,:)*PEMOIST(:,:,:)) &
+ * ZTMP2_DEVICE(:,:,:)
#endif
PRED2R3(:,:,IKB)=PRED2R3(:,:,IKB+KKL)
!$acc end kernels
@@ -574,9 +635,11 @@ ELSE IF (L2D) THEN ! 3D case in a 2D model
!
#ifndef MNH_OPENACC
#ifndef MNH_BITREP
- PRED2THR3(:,:,:)= PREDR1(:,:,:) * PREDTH1(:,:,:) + XCTV**2*PBLL_O_E(:,:,:)**2 * &
+ PRED2THR3(:,:,:) = PREDR1(:,:,:) * PREDTH1(:,:,:) &
+ + XCTV**2*PBLL_O_E(:,:,:)**2 * &
#else
- PRED2THR3(:,:,:)= PREDR1(:,:,:) * PREDTH1(:,:,:) + BR_P2(XCTV)*BR_P2(PBLL_O_E(:,:,:)) * &
+ PRED2THR3(:,:,:) = PREDR1(:,:,:) * PREDTH1(:,:,:) &
+ + BR_P2(XCTV)*BR_P2(PBLL_O_E(:,:,:)) * &
#endif
PEMOIST(:,:,:) * PETHETA(:,:,:) * &
MZM( GX_M_M(PRM(:,:,:,1),PDXX,PDZZ,PDZX)* &
@@ -586,19 +649,28 @@ ELSE IF (L2D) THEN ! 3D case in a 2D model
CALL GX_M_M_DEVICE(KKA,KKU,KKL,PRM(:,:,:,1),PDXX,PDZZ,PDZX,ZTMP1_DEVICE)
CALL GX_M_M_DEVICE(KKA,KKU,KKL,PTHLM ,PDXX,PDZZ,PDZX,ZTMP2_DEVICE)
!$acc kernels
- ZTMP1_DEVICE = ZTMP1_DEVICE * ZTMP2_DEVICE
+!$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP1_DEVICE(JI,JJ,JK) = ZTMP1_DEVICE(JI,JJ,JK) * ZTMP2_DEVICE(JI,JJ,JK)
+ END DO
!$acc end kernels
CALL MZM_DEVICE(ZTMP1_DEVICE,ZTMP2_DEVICE)
-!$acc kernels async
+!$acc kernels ! async
#ifndef MNH_BITREP
- PRED2THR3(:,:,:)= PREDR1(:,:,:) * PREDTH1(:,:,:) + XCTV**2*PBLL_O_E(:,:,:)**2 * &
+ PRED2THR3(:,:,:)= PREDR1(:,:,:) * PREDTH1(:,:,:) &
+ + XCTV**2*PBLL_O_E(:,:,:)**2 &
+ * PEMOIST(:,:,:) * PETHETA(:,:,:) &
+ * ZTMP2_DEVICE(:,:,:)
#else
- PRED2THR3(:,:,:)= PREDR1(:,:,:) * PREDTH1(:,:,:) + BR_P2(XCTV)*BR_P2(PBLL_O_E(:,:,:)) * &
-#endif
- PEMOIST(:,:,:) * PETHETA(:,:,:) * ZTMP2_DEVICE
+!$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ PRED2THR3(JI,JJ,JK)= PREDR1(JI,JJ,JK) * PREDTH1(JI,JJ,JK) + BR_P2(XCTV)*BR_P2(PBLL_O_E(JI,JJ,JK)) * &
+ PEMOIST(JI,JJ,JK) * PETHETA(JI,JJ,JK) * ZTMP2_DEVICE(JI,JJ,JK)
+ END DO
+#endif
PRED2THR3(:,:,IKB)=PRED2THR3(:,:,IKB+KKL)
!$acc end kernels
-!$acc wait
+! acc wait
#endif
!
ELSE ! dry 3D case in a 2D model
@@ -618,17 +690,23 @@ call Print_msg( NVERB_WARNING, 'GEN', 'PRANDTL', 'OpenACC: L2D=.T. and KRR=0 not
CALL GX_M_M_DEVICE(KKA,KKU,KKL,PTHLM,PDXX,PDZZ,PDZX,ZTMP1_DEVICE)
!$acc kernels
#ifndef MNH_BITREP
- ZTMP1_DEVICE = ZTMP1_DEVICE**2
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP1_DEVICE(JI,JJ,JK) = ZTMP1_DEVICE(JI,JJ,JK)**2
+ END DO !CONCURRENT
#else
- ZTMP1_DEVICE = BR_P2(ZTMP1_DEVICE)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP1_DEVICE(JI,JJ,JK) = BR_P2(ZTMP1_DEVICE(JI,JJ,JK))
+ END DO !CONCURRENT
#endif
!$acc end kernels
CALL MZM_DEVICE(ZTMP1_DEVICE,ZTMP2_DEVICE)
!$acc kernels
#ifndef MNH_BITREP
- PRED2TH3(:,:,:) = PREDTH1(:,:,:)**2 + XCTV**2*PBLL_O_E(:,:,:)**2 * ZTMP2_DEVICE
+ PRED2TH3(:,:,:) = PREDTH1(:,:,:)**2 + XCTV**2*PBLL_O_E(:,:,:)**2 * &
+ ZTMP2_DEVICE(:,:,:)
#else
- PRED2TH3(:,:,:) = BR_P2(PREDTH1(:,:,:)) + BR_P2(XCTV)*BR_P2(PBLL_O_E(:,:,:)) * ZTMP2_DEVICE
+ PRED2TH3(:,:,:) = BR_P2(PREDTH1(:,:,:)) + BR_P2(XCTV)*BR_P2(PBLL_O_E(:,:,:)) * &
+ ZTMP2_DEVICE(:,:,:)
#endif
!PW: merge kernels + remove async to prevent compiler crash...(bug PGI 19.10)
! !$acc end kernels
@@ -653,13 +731,15 @@ ELSE ! 3D case in a 3D model
IF (KRR /= 0) THEN ! moist 3D case
#ifndef MNH_OPENACC
#ifndef MNH_BITREP
- PRED2TH3(:,:,:)= PREDTH1(:,:,:)**2 + ( XCTV*PBLL_O_E(:,:,:)*PETHETA(:,:,:) )**2 * &
- MZM( GX_M_M(PTHLM,PDXX,PDZZ,PDZX)**2 &
- + GY_M_M(PTHLM,PDYY,PDZZ,PDZY)**2 )
+ PRED2TH3(:,:,:) = PREDTH1(:,:,:)**2 &
+ + ( XCTV*PBLL_O_E(:,:,:)*PETHETA(:,:,:) )**2 &
+ * MZM( GX_M_M(PTHLM,PDXX,PDZZ,PDZX)**2 &
+ + GY_M_M(PTHLM,PDYY,PDZZ,PDZY)**2 )
#else
- PRED2TH3(:,:,:)= BR_P2(PREDTH1(:,:,:)) + BR_P2( XCTV*PBLL_O_E(:,:,:)*PETHETA(:,:,:) ) * &
- MZM( BR_P2(GX_M_M(PTHLM,PDXX,PDZZ,PDZX)) &
- + BR_P2(GY_M_M(PTHLM,PDYY,PDZZ,PDZY)) )
+ PRED2TH3(:,:,:) = BR_P2(PREDTH1(:,:,:)) &
+ + BR_P2( XCTV*PBLL_O_E(:,:,:)*PETHETA(:,:,:) ) &
+ * MZM( BR_P2(GX_M_M(PTHLM,PDXX,PDZZ,PDZX)) &
+ + BR_P2(GY_M_M(PTHLM,PDYY,PDZZ,PDZY)) )
#endif
PRED2TH3(:,:,IKB)=PRED2TH3(:,:,IKB+KKL)
#else
@@ -667,17 +747,27 @@ ELSE ! 3D case in a 3D model
CALL GY_M_M_DEVICE(KKA,KKU,KKL,PTHLM,PDYY,PDZZ,PDZY,ZTMP2_DEVICE)
!$acc kernels
#ifndef MNH_BITREP
- ZTMP1_DEVICE = ZTMP1_DEVICE**2 + ZTMP2_DEVICE**2
+!$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP1_DEVICE(JI,JJ,JK) = ZTMP1_DEVICE(JI,JJ,JK)**2 + ZTMP2_DEVICE(JI,JJ,JK)**2
+ END DO
#else
- ZTMP1_DEVICE = BR_P2(ZTMP1_DEVICE) + BR_P2(ZTMP2_DEVICE)
+!$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP1_DEVICE(JI,JJ,JK) = BR_P2(ZTMP1_DEVICE(JI,JJ,JK)) + BR_P2(ZTMP2_DEVICE(JI,JJ,JK))
+ END DO
#endif
!$acc end kernels
CALL MZM_DEVICE(ZTMP1_DEVICE,ZTMP2_DEVICE)
!$acc kernels
#ifndef MNH_BITREP
- PRED2TH3(:,:,:)= PREDTH1(:,:,:)**2 + ( XCTV*PBLL_O_E(:,:,:)*PETHETA(:,:,:) )**2 * ZTMP2_DEVICE
+ PRED2TH3(:,:,:) = PREDTH1(:,:,:)**2 &
+ + ( XCTV*PBLL_O_E(:,:,:)*PETHETA(:,:,:) )**2 &
+ * ZTMP2_DEVICE(:,:,:)
#else
- PRED2TH3(:,:,:)= BR_P2(PREDTH1(:,:,:)) + BR_P2( XCTV*PBLL_O_E(:,:,:)*PETHETA(:,:,:) ) * ZTMP2_DEVICE
+ PRED2TH3(:,:,:) = BR_P2(PREDTH1(:,:,:)) &
+ + BR_P2( XCTV*PBLL_O_E(:,:,:)*PETHETA(:,:,:) ) &
+ * ZTMP2_DEVICE(:,:,:)
#endif
PRED2TH3(:,:,IKB)=PRED2TH3(:,:,IKB+KKL)
!$acc end kernels
@@ -685,13 +775,15 @@ ELSE ! 3D case in a 3D model
!
#ifndef MNH_OPENACC
#ifndef MNH_BITREP
- PRED2R3(:,:,:)= PREDR1(:,:,:)**2 + (XCTV*PBLL_O_E(:,:,:)*PEMOIST(:,:,:))**2 * &
- MZM( GX_M_M(PRM(:,:,:,1),PDXX,PDZZ,PDZX)**2 + &
- GY_M_M(PRM(:,:,:,1),PDYY,PDZZ,PDZY)**2 )
+ PRED2R3(:,:,:) = PREDR1(:,:,:)**2 &
+ + (XCTV*PBLL_O_E(:,:,:)*PEMOIST(:,:,:))**2 &
+ * MZM( GX_M_M(PRM(:,:,:,1),PDXX,PDZZ,PDZX)**2 &
+ + GY_M_M(PRM(:,:,:,1),PDYY,PDZZ,PDZY)**2 )
#else
- PRED2R3(:,:,:)= BR_P2(PREDR1(:,:,:)) + BR_P2(XCTV*PBLL_O_E(:,:,:)*PEMOIST(:,:,:)) * &
- MZM( BR_P2(GX_M_M(PRM(:,:,:,1),PDXX,PDZZ,PDZX)) + &
- BR_P2(GY_M_M(PRM(:,:,:,1),PDYY,PDZZ,PDZY)) )
+ PRED2R3(:,:,:) = BR_P2(PREDR1(:,:,:)) &
+ + BR_P2(XCTV*PBLL_O_E(:,:,:)*PEMOIST(:,:,:)) &
+ * MZM( BR_P2(GX_M_M(PRM(:,:,:,1),PDXX,PDZZ,PDZX)) &
+ +BR_P2(GY_M_M(PRM(:,:,:,1),PDYY,PDZZ,PDZY)) )
#endif
PRED2R3(:,:,IKB)=PRED2R3(:,:,IKB+KKL)
#else
@@ -699,31 +791,43 @@ ELSE ! 3D case in a 3D model
CALL GY_M_M_DEVICE(KKA,KKU,KKL,PRM(:,:,:,1),PDYY,PDZZ,PDZY,ZTMP2_DEVICE)
!$acc kernels
#ifndef MNH_BITREP
- ZTMP1_DEVICE = ZTMP1_DEVICE**2 + ZTMP2_DEVICE**2
+!$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP1_DEVICE(JI,JJ,JK) = ZTMP1_DEVICE(JI,JJ,JK)**2 + ZTMP2_DEVICE(JI,JJ,JK)**2
+ END DO
#else
- ZTMP1_DEVICE = BR_P2(ZTMP1_DEVICE) + BR_P2(ZTMP2_DEVICE)
+!$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP1_DEVICE(JI,JJ,JK) = BR_P2(ZTMP1_DEVICE(JI,JJ,JK)) + BR_P2(ZTMP2_DEVICE(JI,JJ,JK))
+ END DO
#endif
!$acc end kernels
CALL MZM_DEVICE(ZTMP1_DEVICE,ZTMP2_DEVICE)
!$acc kernels
#ifndef MNH_BITREP
- PRED2R3(:,:,:)= PREDR1(:,:,:)**2 + (XCTV*PBLL_O_E(:,:,:)*PEMOIST(:,:,:))**2 * ZTMP2_DEVICE
+ PRED2R3(:,:,:) = PREDR1(:,:,:)**2 &
+ + (XCTV*PBLL_O_E(:,:,:)*PEMOIST(:,:,:))**2 &
+ * ZTMP2_DEVICE(:,:,:)
#else
- PRED2R3(:,:,:)= BR_P2(PREDR1(:,:,:)) + BR_P2(XCTV*PBLL_O_E(:,:,:)*PEMOIST(:,:,:)) * ZTMP2_DEVICE
+ PRED2R3(:,:,:) = BR_P2(PREDR1(:,:,:)) &
+ + BR_P2(XCTV*PBLL_O_E(:,:,:)*PEMOIST(:,:,:)) &
+ * ZTMP2_DEVICE(:,:,:)
#endif
!$acc end kernels
-!$acc kernels async
+!$acc kernels ! async
PRED2R3(:,:,IKB)=PRED2R3(:,:,IKB+KKL)
!$acc end kernels
#endif
!
#ifndef MNH_OPENACC
#ifndef MNH_BITREP
- PRED2THR3(:,:,:)= PREDR1(:,:,:) * PREDTH1(:,:,:) + XCTV**2*PBLL_O_E(:,:,:)**2 * &
+ PRED2THR3(:,:,:) = PREDR1(:,:,:) * PREDTH1(:,:,:) &
+ + XCTV**2*PBLL_O_E(:,:,:)**2 * &
#else
- PRED2THR3(:,:,:)= PREDR1(:,:,:) * PREDTH1(:,:,:) + BR_P2(XCTV)*BR_P2(PBLL_O_E(:,:,:)) * &
+ PRED2THR3(:,:,:) = PREDR1(:,:,:) * PREDTH1(:,:,:) &
+ + BR_P2(XCTV)*BR_P2(PBLL_O_E(:,:,:)) * &
#endif
- PEMOIST(:,:,:) * PETHETA(:,:,:) * &
+ PEMOIST(:,:,:) * PETHETA(:,:,:) * &
MZM( GX_M_M(PRM(:,:,:,1),PDXX,PDZZ,PDZX)* &
GX_M_M(PTHLM,PDXX,PDZZ,PDZX)+ &
GY_M_M(PRM(:,:,:,1),PDYY,PDZZ,PDZY)* &
@@ -735,21 +839,27 @@ ELSE ! 3D case in a 3D model
CALL GY_M_M_DEVICE(KKA,KKU,KKL,PRM(:,:,:,1),PDYY,PDZZ,PDZY,ZTMP3_DEVICE)
CALL GY_M_M_DEVICE(KKA,KKU,KKL,PTHLM ,PDYY,PDZZ,PDZY,ZTMP4_DEVICE)
!$acc kernels
- ZTMP1_DEVICE = ZTMP1_DEVICE*ZTMP2_DEVICE+ZTMP3_DEVICE*ZTMP4_DEVICE
+!$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP1_DEVICE(JI,JJ,JK) = ZTMP1_DEVICE(JI,JJ,JK)*ZTMP2_DEVICE(JI,JJ,JK)+ &
+ ZTMP3_DEVICE(JI,JJ,JK)*ZTMP4_DEVICE(JI,JJ,JK)
+ END DO
!$acc end kernels
CALL MZM_DEVICE(ZTMP1_DEVICE,ZTMP2_DEVICE)
!$acc kernels
#ifndef MNH_BITREP
- PRED2THR3(:,:,:)= PREDR1(:,:,:) * PREDTH1(:,:,:) + XCTV**2*PBLL_O_E(:,:,:)**2 * &
+ PRED2THR3(:,:,:)= PREDR1(:,:,:) * PREDTH1(:,:,:) &
+ + XCTV**2*PBLL_O_E(:,:,:)**2 * &
#else
- PRED2THR3(:,:,:)= PREDR1(:,:,:) * PREDTH1(:,:,:) + BR_P2(XCTV)*BR_P2(PBLL_O_E(:,:,:)) * &
+ PRED2THR3(:,:,:)= PREDR1(:,:,:) * PREDTH1(:,:,:) &
+ + BR_P2(XCTV)*BR_P2(PBLL_O_E(:,:,:)) * &
#endif
- PEMOIST(:,:,:) * PETHETA(:,:,:) * ZTMP2_DEVICE
+ PEMOIST(:,:,:) * PETHETA(:,:,:) * ZTMP2_DEVICE(:,:,:)
!$acc end kernels
-!$acc kernels async
+!$acc kernels ! async
PRED2THR3(:,:,IKB)=PRED2THR3(:,:,IKB+KKL)
!$acc end kernels
-!$acc wait
+! acc wait
#endif
!
ELSE ! dry 3D case in a 3D model
@@ -771,32 +881,40 @@ call Print_msg( NVERB_WARNING, 'GEN', 'PRANDTL', 'OpenACC: L2D=.F. and KRR=0 not
CALL GY_M_M_DEVICE(KKA,KKU,KKL,PTHLM,PDYY,PDZZ,PDZY,ZTMP2_DEVICE)
!$acc kernels
#ifndef MNH_BITREP
- ZTMP1_DEVICE = ZTMP1_DEVICE**2 + ZTMP2_DEVICE**2
+!$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP1_DEVICE(JI,JJ,JK) = ZTMP1_DEVICE(JI,JJ,JK)**2 + ZTMP2_DEVICE(JI,JJ,JK)**2
+ END DO
#else
- ZTMP1_DEVICE = BR_P2(ZTMP1_DEVICE) + BR_P2(ZTMP2_DEVICE)
+!$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP1_DEVICE(JI,JJ,JK) = BR_P2(ZTMP1_DEVICE(JI,JJ,JK)) + BR_P2(ZTMP2_DEVICE(JI,JJ,JK))
+ END DO
#endif
!$acc end kernels
CALL MZM_DEVICE(ZTMP1_DEVICE,ZTMP2_DEVICE)
!$acc kernels
#ifndef MNH_BITREP
- PRED2TH3(:,:,:) = PREDTH1(:,:,:)**2 + XCTV**2*PBLL_O_E(:,:,:)**2 * ZTMP2_DEVICE
+ PRED2TH3(:,:,:) = PREDTH1(:,:,:)**2 + XCTV**2*PBLL_O_E(:,:,:)**2 &
+ * ZTMP2_DEVICE(:,:,:)
#else
- PRED2TH3(:,:,:) = BR_P2(PREDTH1(:,:,:)) + BR_P2(XCTV)*BR_P2(PBLL_O_E(:,:,:)) * ZTMP2_DEVICE
+ PRED2TH3(:,:,:) = BR_P2(PREDTH1(:,:,:)) + BR_P2(XCTV)*BR_P2(PBLL_O_E(:,:,:)) &
+ * ZTMP2_DEVICE(:,:,:)
#endif
!$acc end kernels
#endif
-!$acc kernels async
+!$acc kernels ! async
PRED2TH3(:,:,IKB)=PRED2TH3(:,:,IKB+KKL)
!$acc end kernels
!
-!$acc kernels async
+!$acc kernels ! async
PRED2R3(:,:,:) = 0.
!$acc end kernels
!
-!$acc kernels async
+!$acc kernels ! async
PRED2THR3(:,:,:) = 0.
!$acc end kernels
-!$acc wait
+! acc wait
!
END IF
!
@@ -810,16 +928,20 @@ END IF ! end of the if structure on the turbulence dimensionnality
!
IF(HTURBDIM=='1DIM') THEN
! 1D case
-!$acc kernels
DO JSV=1,ISV
+ !$acc kernels
PRED2THS3(:,:,:,JSV) = PREDS1(:,:,:,JSV) * PREDTH1(:,:,:)
+ !$acc end kernels
IF (KRR /= 0) THEN
+ !$acc kernels
PRED2RS3(:,:,:,JSV) = PREDR1(:,:,:) *PREDS1(:,:,:,JSV)
+ !$acc end kernels
ELSE
+ !$acc kernels
PRED2RS3(:,:,:,JSV) = 0.
+ !$acc end kernels
END IF
ENDDO
-!$acc end kernels
!
ELSE IF (L2D) THEN ! 3D case in a 2D model
!
@@ -857,9 +979,9 @@ ELSE IF (L2D) THEN ! 3D case in a 2D model
IF (LOCEAN) THEN
!$acc kernels
#ifndef MNH_BITREP
- ZTMP1_DEVICE = (XG * XALPHAOC *PLM * PLEPS / PTKEM)**2
+ ZTMP1_DEVICE(:,:,:) = (XG * XALPHAOC *PLM * PLEPS / PTKEM)**2
#else
- ZTMP1_DEVICE = BR_P2(XG * XALPHAOC *PLM * PLEPS / PTKEM)
+ ZTMP1_DEVICE(:,:,:) = BR_P2(XG * XALPHAOC *PLM * PLEPS / PTKEM)
#endif
!$acc end kernels
CALL MZM_DEVICE(ZTMP1_DEVICE,ZW1)
@@ -872,9 +994,9 @@ ELSE IF (L2D) THEN ! 3D case in a 2D model
DO JSV=1,ISV
!$acc kernels
#ifndef MNH_BITREP
- ZTMP1_DEVICE = (XG / PTHVREF * PLM * PLEPS / PTKEM)**2
+ ZTMP1_DEVICE(:,:,:) = (XG / PTHVREF * PLM * PLEPS / PTKEM)**2
#else
- ZTMP1_DEVICE = BR_P2(XG / PTHVREF * PLM * PLEPS / PTKEM)
+ ZTMP1_DEVICE(:,:,:) = BR_P2(XG / PTHVREF * PLM * PLEPS / PTKEM)
#endif
!$acc end kernels
CALL MZM_DEVICE(ZTMP1_DEVICE,ZW1)
@@ -895,11 +1017,11 @@ ELSE IF (L2D) THEN ! 3D case in a 2D model
CALL GX_M_M_DEVICE(KKA,KKU,KKL,PSVM(:,:,:,JSV),PDXX,PDZZ,PDZX,ZTMP1_DEVICE)
CALL GX_M_M_DEVICE(KKA,KKU,KKL,PTHLM ,PDXX,PDZZ,PDZX,ZTMP2_DEVICE)
!$acc kernels
- ZTMP1_DEVICE = ZTMP1_DEVICE*ZTMP2_DEVICE
+ ZTMP1_DEVICE(:,:,:) = ZTMP1_DEVICE(:,:,:)*ZTMP2_DEVICE(:,:,:)
!$acc end kernels
CALL MZM_DEVICE(ZTMP1_DEVICE,ZTMP2_DEVICE)
!$acc kernels
- PRED2THS3(:,:,:,JSV) = PREDTH1(:,:,:) * PREDS1(:,:,:,JSV) + ZW1 * ZTMP2_DEVICE
+ PRED2THS3(:,:,:,JSV) = PREDTH1(:,:,:) * PREDS1(:,:,:,JSV) + ZW1(:,:,:) * ZTMP2_DEVICE(:,:,:)
!$acc end kernels
#endif
!
@@ -914,12 +1036,12 @@ ELSE IF (L2D) THEN ! 3D case in a 2D model
CALL GX_M_M_DEVICE(KKA,KKU,KKL,PSVM(:,:,:,JSV),PDXX,PDZZ,PDZX,ZTMP1_DEVICE)
CALL GX_M_M_DEVICE(KKA,KKU,KKL,PRM(:,:,:,1) ,PDXX,PDZZ,PDZX,ZTMP2_DEVICE)
!$acc kernels
- ZTMP1_DEVICE = ZTMP1_DEVICE*ZTMP2_DEVICE
+ ZTMP1_DEVICE(:,:,:) = ZTMP1_DEVICE(:,:,:)*ZTMP2_DEVICE(:,:,:)
!$acc end kernels
CALL MZM_DEVICE(ZTMP1_DEVICE,ZTMP2_DEVICE)
!$acc kernels
PRED2RS3(:,:,:,JSV) = PREDR1(:,:,:) * PREDS1(:,:,:,JSV) + &
- ZW1 * PEMOIST * ZTMP2_DEVICE
+ ZW1(:,:,:) * PEMOIST * ZTMP2_DEVICE(:,:,:)
!$acc end kernels
#endif
ELSE
@@ -951,22 +1073,22 @@ ELSE ! 3D case in a 3D model
DO JSV=1,ISV
!$acc kernels
#ifndef MNH_BITREP
- ZTMP1_DEVICE = (XG / PTHVREF * PLM * PLEPS / PTKEM)**2
+ ZTMP1_DEVICE(:,:,:) = (XG / PTHVREF * PLM * PLEPS / PTKEM)**2
#else
- ZTMP1_DEVICE = BR_P2(XG / PTHVREF * PLM * PLEPS / PTKEM)
+ ZTMP1_DEVICE(:,:,:) = BR_P2(XG / PTHVREF * PLM * PLEPS / PTKEM)
#endif
!$acc end kernels
CALL MZM_DEVICE(ZTMP1_DEVICE,ZW1)
IF (KRR /= 0) THEN
!$acc kernels
- ZW1 = ZW1*PETHETA
+ ZW1(:,:,:) = ZW1(:,:,:)*PETHETA
!$acc end kernels
END IF
#endif
!
#ifndef MNH_OPENACC
PRED2THS3(:,:,:,JSV) = PREDTH1(:,:,:) * PREDS1(:,:,:,JSV) + &
- ZW1* &
+ ZW1(:,:,:)* &
MZM(GX_M_M(PSVM(:,:,:,JSV),PDXX,PDZZ,PDZX)* &
GX_M_M(PTHLM,PDXX,PDZZ,PDZX) &
+GY_M_M(PSVM(:,:,:,JSV),PDYY,PDZZ,PDZY)* &
@@ -978,11 +1100,13 @@ ELSE ! 3D case in a 3D model
CALL GY_M_M_DEVICE(KKA,KKU,KKL,PSVM(:,:,:,JSV),PDYY,PDZZ,PDZY,ZTMP3_DEVICE)
CALL GY_M_M_DEVICE(KKA,KKU,KKL,PTHLM ,PDYY,PDZZ,PDZY,ZTMP4_DEVICE)
!$acc kernels
- ZTMP1_DEVICE = ZTMP1_DEVICE*ZTMP2_DEVICE+ZTMP3_DEVICE*ZTMP4_DEVICE
+ ZTMP1_DEVICE(:,:,:) = ZTMP1_DEVICE(:,:,:)*ZTMP2_DEVICE(:,:,:)+&
+ ZTMP3_DEVICE(:,:,:)*ZTMP4_DEVICE(:,:,:)
!$acc end kernels
CALL MZM_DEVICE(ZTMP1_DEVICE,ZTMP2_DEVICE)
!$acc kernels
- PRED2THS3(:,:,:,JSV) = PREDTH1(:,:,:) * PREDS1(:,:,:,JSV) + ZW1 * ZTMP2_DEVICE
+ PRED2THS3(:,:,:,JSV) = PREDTH1(:,:,:) * PREDS1(:,:,:,JSV) + &
+ ZW1(:,:,:) * ZTMP2_DEVICE(:,:,:)
!$acc end kernels
#endif
!
@@ -1001,12 +1125,13 @@ ELSE ! 3D case in a 3D model
CALL GY_M_M_DEVICE(KKA,KKU,KKL,PSVM(:,:,:,JSV),PDYY,PDZZ,PDZY,ZTMP3_DEVICE)
CALL GY_M_M_DEVICE(KKA,KKU,KKL,PRM(:,:,:,1) ,PDYY,PDZZ,PDZY,ZTMP4_DEVICE)
!$acc kernels
- ZTMP1_DEVICE = ZTMP1_DEVICE*ZTMP2_DEVICE+ZTMP3_DEVICE*ZTMP4_DEVICE
+ ZTMP1_DEVICE(:,:,:) = ZTMP1_DEVICE(:,:,:)*ZTMP2_DEVICE(:,:,:)+&
+ ZTMP3_DEVICE(:,:,:)*ZTMP4_DEVICE(:,:,:)
!$acc end kernels
CALL MZM_DEVICE(ZTMP1_DEVICE,ZTMP2_DEVICE)
!$acc kernels
PRED2RS3(:,:,:,JSV) = PREDR1(:,:,:) * PREDS1(:,:,:,JSV) + &
- ZW1 * PEMOIST * ZTMP2_DEVICE
+ ZW1(:,:,:) * PEMOIST * ZTMP2_DEVICE(:,:,:)
!$acc end kernels
#endif
ELSE
@@ -1109,8 +1234,16 @@ end if
!$acc end data
+#ifdef MNH_OPENACC
+CALL MNH_REL_ZT3D(IZW1, IZW2,IZTMP1_DEVICE,IZTMP2_DEVICE,IZTMP3_DEVICE,IZTMP4_DEVICE,IZTMP5_DEVICE)
+CALL MNH_CHECK_OUT_ZT3D("PRANDTL")
+#else
+DEALLOCATE(ZW1,ZW2)
+#endif
+
!$acc end data
!---------------------------------------------------------------------------
!
END SUBROUTINE PRANDTL
+
diff --git a/src/MNH/rain_ice.f90 b/src/MNH/rain_ice.f90
index ddad84fccc481cda99545ccd86bb1f0254cdab33..247faecdba54cfbdef61648118b6fe57151358eb 100644
--- a/src/MNH/rain_ice.f90
+++ b/src/MNH/rain_ice.f90
@@ -254,6 +254,11 @@ use mode_tools_ll, only: GET_INDICE_ll
USE MODI_BITREP
#endif
USE MODI_ICE4_RAINFR_VERT
+#ifdef MNH_OPENACC
+USE MODE_MNH_ZWORK , ONLY : MNH_ALLOCATE_ZT3D , MNH_REL_ZT3D, MNH_ALLOCATE_ZT1DP , MNH_REL_ZT1D , &
+ MNH_ALLOCATE_GT3D , MNH_REL_GT3D, &
+ MNH_ALLOCATE_IT1D , MNH_REL_IT1D
+#endif
IMPLICIT NONE
!
@@ -332,33 +337,45 @@ INTEGER :: IKB,IKTB,IKT !
INTEGER :: IKE,IKTE !
!
INTEGER :: IMICRO
-INTEGER, DIMENSION(:), ALLOCATABLE :: I1,I2,I3 ! Used to replace the COUNT
+INTEGER, DIMENSION(:), POINTER, CONTIGUOUS :: I1,I2,I3 ! Used to replace the COUNT
+#ifdef MNH_OPENACC
+INTEGER :: II1,II2,II3
+#endif
INTEGER :: JL ! and PACK intrinsics
-LOGICAL, DIMENSION(:,:,:), ALLOCATABLE &
- :: GMICRO ! Test where to compute all processes
+LOGICAL, DIMENSION(:,:,:), POINTER, CONTIGUOUS &
+ :: GMICRO ! Test where to compute all processes
+#ifdef MNH_OPENACC
+INTEGER :: IGMICRO
+#endif
REAL :: ZINVTSTEP
REAL :: ZCOEFFRCM
-REAL, DIMENSION(:), ALLOCATABLE :: ZRVT ! Water vapor m.r. at t
-REAL, DIMENSION(:), ALLOCATABLE :: ZRCT ! Cloud water m.r. at t
-REAL, DIMENSION(:), ALLOCATABLE :: ZRRT ! Rain water m.r. at t
-REAL, DIMENSION(:), ALLOCATABLE :: ZRIT ! Pristine ice m.r. at t
-REAL, DIMENSION(:), ALLOCATABLE :: ZRST ! Snow/aggregate m.r. at t
-REAL, DIMENSION(:), ALLOCATABLE :: ZRGT ! Graupel m.r. at t
-REAL, DIMENSION(:), ALLOCATABLE :: ZRHT ! Hail m.r. at t
-REAL, DIMENSION(:), ALLOCATABLE :: ZCIT ! Pristine ice conc. at t
-!
-REAL, DIMENSION(:), ALLOCATABLE :: ZRVS ! Water vapor m.r. source
-REAL, DIMENSION(:), ALLOCATABLE :: ZRCS ! Cloud water m.r. source
-REAL, DIMENSION(:), ALLOCATABLE :: ZRRS ! Rain water m.r. source
-REAL, DIMENSION(:), ALLOCATABLE :: ZRIS ! Pristine ice m.r. source
-REAL, DIMENSION(:), ALLOCATABLE :: ZRSS ! Snow/aggregate m.r. source
-REAL, DIMENSION(:), ALLOCATABLE :: ZRGS ! Graupel m.r. source
-REAL, DIMENSION(:), ALLOCATABLE :: ZRHS ! Hail m.r. source
-REAL, DIMENSION(:), ALLOCATABLE :: ZTHS ! Theta source
-REAL, DIMENSION(:), ALLOCATABLE :: ZTHT ! Potential temperature
-REAL, DIMENSION(:), ALLOCATABLE :: ZTHLT ! Liquid potential temperature
-!
-REAL, DIMENSION(:), ALLOCATABLE :: ZRHODREF, & ! RHO Dry REFerence
+REAL, DIMENSION(:), POINTER, CONTIGUOUS :: ZRVT ! Water vapor m.r. at t
+REAL, DIMENSION(:), POINTER, CONTIGUOUS :: ZRCT ! Cloud water m.r. at t
+REAL, DIMENSION(:), POINTER, CONTIGUOUS :: ZRRT ! Rain water m.r. at t
+REAL, DIMENSION(:), POINTER, CONTIGUOUS :: ZRIT ! Pristine ice m.r. at t
+REAL, DIMENSION(:), POINTER, CONTIGUOUS :: ZRST ! Snow/aggregate m.r. at t
+REAL, DIMENSION(:), POINTER, CONTIGUOUS :: ZRGT ! Graupel m.r. at t
+REAL, DIMENSION(:), POINTER, CONTIGUOUS :: ZRHT ! Hail m.r. at t
+REAL, DIMENSION(:), POINTER, CONTIGUOUS :: ZCIT ! Pristine ice conc. at t
+#ifdef MNH_OPENACC
+INTEGER :: IZRVT,IZRCT,IZRRT,IZRIT,IZRST,IZRGT,IZRHT,IZCIT
+#endif
+!
+REAL, DIMENSION(:), POINTER, CONTIGUOUS :: ZRVS ! Water vapor m.r. source
+REAL, DIMENSION(:), POINTER, CONTIGUOUS :: ZRCS ! Cloud water m.r. source
+REAL, DIMENSION(:), POINTER, CONTIGUOUS :: ZRRS ! Rain water m.r. source
+REAL, DIMENSION(:), POINTER, CONTIGUOUS :: ZRIS ! Pristine ice m.r. source
+REAL, DIMENSION(:), POINTER, CONTIGUOUS :: ZRSS ! Snow/aggregate m.r. source
+REAL, DIMENSION(:), POINTER, CONTIGUOUS :: ZRGS ! Graupel m.r. source
+REAL, DIMENSION(:), POINTER, CONTIGUOUS :: ZRHS ! Hail m.r. source
+REAL, DIMENSION(:), POINTER, CONTIGUOUS :: ZTHS ! Theta source
+REAL, DIMENSION(:), POINTER, CONTIGUOUS :: ZTHT ! Potential temperature
+REAL, DIMENSION(:), POINTER, CONTIGUOUS :: ZTHLT ! Liquid potential temperature
+#ifdef MNH_OPENACC
+INTEGER :: IZRVS,IZRCS,IZRRS,IZRIS,IZRSS,IZRGS,IZRHS,IZTHS,IZTHT,IZTHLT
+#endif
+!
+REAL, DIMENSION(:), POINTER, CONTIGUOUS :: ZRHODREF, & ! RHO Dry REFerence
ZRHODJ, & ! RHO times Jacobian
ZZT, & ! Temperature
ZPRES, & ! Pressure
@@ -395,12 +412,27 @@ REAL, DIMENSION(:), ALLOCATABLE :: ZRHODREF, & ! RHO Dry REFerence
ZHLC_LRCLOCAL ! HLCLOUDS : LWC that is Low LWC local in LCF
! note that ZRC/CF = ZHLC_HRCLOCAL+ ZHLC_LRCLOCAL
! = ZHLC_HRC/HCF+ ZHLC_LRC/LCF
-REAL, DIMENSION(:,:), ALLOCATABLE :: ZZW1 ! Work arrays
-REAL, DIMENSION(:,:,:), ALLOCATABLE :: ZRR, ZRS, ZRG ! work arrays
#ifdef MNH_OPENACC
-REAL, DIMENSION(:,:,:), ALLOCATABLE :: ZRS_ZERO, ZRG_ZERO ! work arrays filled with zeros
+INTEGER :: IZRHODREF,IZZT,IZPRES,IZEXNREF,IZSIGMA_RC,IZCF,IZRF
+INTEGER :: IZHLC_HCF,IZHLC_LCF,IZHLC_HRC,IZHLC_LRC,IZHLC_RCMAX
+INTEGER :: IZRCRAUTC,IZHLC_HRCLOCAL,IZHLC_LRCLOCAL
+INTEGER :: IZZW,IZLSFACT,IZLVFACT,IZUSW,IZSSI,IZLBDAR,IZLBDAR_RF
+INTEGER :: IZLBDAS,IZLBDAG,IZLBDAH,IZRDRYG,IZRWETG,IZAI,IZCJ
+INTEGER :: IZKA,IZDV,IZRHODJ
+#endif
+
+REAL, DIMENSION(:,:,:), POINTER, CONTIGUOUS :: ZRR, ZRS, ZRG ! work arrays
+#ifdef MNH_OPENACC
+REAL, DIMENSION(:,:,:), POINTER, CONTIGUOUS :: ZRS_ZERO, ZRG_ZERO ! work arrays filled with zeros
#endif
-REAL, DIMENSION(:,:,:), ALLOCATABLE :: ZT ! Temperature
+REAL, DIMENSION(:,:,:), POINTER, CONTIGUOUS :: ZT ! Temperature
+#ifdef MNH_OPENACC
+INTEGER :: IZRR, IZRS, IZRG, IZRS_ZERO, IZRG_ZERO, IZT
+#endif
+
+INTEGER :: IIU,IJU,IKU, IIJKU
+!
+LOGICAl :: GPDF_SIGM
!
! IN variables
!
@@ -462,18 +494,36 @@ IF ( KRR == 7 ) THEN
END IF
#endif
+IIU = size(PEXNREF, 1 )
+IJU = size(PEXNREF, 2 )
+IKU = size(PEXNREF, 3 )
+IIJKU = IIU * IJU * IKU
+
+#ifndef MNH_OPENACC
ALLOCATE( I1(SIZE(PEXNREF)), I2(SIZE(PEXNREF)), I3(SIZE(PEXNREF)) )
-ALLOCATE( GMICRO(SIZE(PEXNREF,1),SIZE(PEXNREF,2),SIZE(PEXNREF,3)) )
-ALLOCATE( ZRR (SIZE(PEXNREF,1),SIZE(PEXNREF,2),SIZE(PEXNREF,3)) )
-ALLOCATE( ZRS (SIZE(PEXNREF,1),SIZE(PEXNREF,2),SIZE(PEXNREF,3)) )
-ALLOCATE( ZRG (SIZE(PEXNREF,1),SIZE(PEXNREF,2),SIZE(PEXNREF,3)) )
-#ifdef MNH_OPENACC
-ALLOCATE( ZRS_ZERO(SIZE(PEXNREF,1),SIZE(PEXNREF,2),SIZE(PEXNREF,3)) )
-ALLOCATE( ZRG_ZERO(SIZE(PEXNREF,1),SIZE(PEXNREF,2),SIZE(PEXNREF,3)) )
+#else
+II1 = MNH_ALLOCATE_IT1D( I1, IIJKU )
+II2 = MNH_ALLOCATE_IT1D( I2, IIJKU )
+II3 = MNH_ALLOCATE_IT1D( I3, IIJKU )
+#endif
+
+#ifndef MNH_OPENACC
+ALLOCATE( GMICRO(IIU,IJU,IKU) )
+ALLOCATE( ZRR (IIU,IJU,IKU) )
+ALLOCATE( ZRS (IIU,IJU,IKU) )
+ALLOCATE( ZRG (IIU,IJU,IKU) )
+ALLOCATE( ZT (IIU,IJU,IKU) )
+#else
+IGMICRO = MNH_ALLOCATE_GT3D( GMICRO, IIU,IJU,IKU )
+IZRR = MNH_ALLOCATE_ZT3D( ZRR, IIU,IJU,IKU )
+IZRS = MNH_ALLOCATE_ZT3D( ZRS, IIU,IJU,IKU )
+IZRG = MNH_ALLOCATE_ZT3D( ZRG, IIU,IJU,IKU )
+IZRS_ZERO = MNH_ALLOCATE_ZT3D( ZRS_ZERO,IIU,IJU,IKU )
+IZRG_ZERO = MNH_ALLOCATE_ZT3D( ZRG_ZERO,IIU,IJU,IKU )
+IZT = MNH_ALLOCATE_ZT3D( ZT, IIU,IJU,IKU )
#endif
-ALLOCATE( ZT (SIZE(PEXNREF,1),SIZE(PEXNREF,2),SIZE(PEXNREF,3)) )
-!$acc data create( I1, I2, I3, GMICRO, ZRR, ZRS, ZRG, ZRS_ZERO, ZRG_ZERO, ZT )
+!$acc data present( I1, I2, I3, GMICRO, ZRR, ZRS, ZRG, ZRS_ZERO, ZRG_ZERO, ZT )
!-------------------------------------------------------------------------------
!
@@ -492,6 +542,7 @@ IKTE=IKT-JPVEXT
!
ZINVTSTEP=1./PTSTEP
!
+GPDF_SIGM = ( HSUBG_AUCV == 'PDF ' .AND. CSUBG_PR_PDF == 'SIGM' )
!
!
!* 2. COMPUTES THE SLOW COLD PROCESS SOURCES
@@ -533,6 +584,7 @@ CALL COUNTJV_DEVICE(GMICRO(:,:,:),I1(:),I2(:),I3(:),IMICRO)
#endif
IF( IMICRO >= 0 ) THEN
+#ifndef MNH_OPENACC
ALLOCATE(ZRVT(IMICRO))
ALLOCATE(ZRCT(IMICRO))
ALLOCATE(ZRRT(IMICRO))
@@ -595,30 +647,96 @@ IF( IMICRO >= 0 ) THEN
ALLOCATE(ZCJ(IMICRO))
ALLOCATE(ZKA(IMICRO))
ALLOCATE(ZDV(IMICRO))
- IF ( KRR == 7 ) THEN
- ALLOCATE(ZZW1(IMICRO,7))
- ELSE IF( KRR == 6 ) THEN
- ALLOCATE(ZZW1(IMICRO,6))
- ENDIF
!
IF (LBU_ENABLE .OR. LLES_CALL .OR. LCHECK ) THEN
ALLOCATE(ZRHODJ(IMICRO))
ELSE
ALLOCATE(ZRHODJ(0))
END IF
+#else
+IZRVT = MNH_ALLOCATE_ZT1DP(ZRVT,IMICRO)
+IZRCT = MNH_ALLOCATE_ZT1DP(ZRCT,IMICRO)
+IZRRT = MNH_ALLOCATE_ZT1DP(ZRRT,IMICRO)
+IZRIT = MNH_ALLOCATE_ZT1DP(ZRIT,IMICRO)
+IZRST = MNH_ALLOCATE_ZT1DP(ZRST,IMICRO)
+IZRGT = MNH_ALLOCATE_ZT1DP(ZRGT,IMICRO)
+ IF ( KRR == 7 ) THEN
+IZRHT = MNH_ALLOCATE_ZT1DP(ZRHT,IMICRO)
+ ELSE
+IZRHT = MNH_ALLOCATE_ZT1DP(ZRHT,0)
+ END IF
+IZCIT = MNH_ALLOCATE_ZT1DP(ZCIT,IMICRO)
+IZRVS = MNH_ALLOCATE_ZT1DP(ZRVS,IMICRO)
+IZRCS = MNH_ALLOCATE_ZT1DP(ZRCS,IMICRO)
+IZRRS = MNH_ALLOCATE_ZT1DP(ZRRS,IMICRO)
+IZRIS = MNH_ALLOCATE_ZT1DP(ZRIS,IMICRO)
+IZRSS = MNH_ALLOCATE_ZT1DP(ZRSS,IMICRO)
+IZRGS = MNH_ALLOCATE_ZT1DP(ZRGS,IMICRO)
+ IF ( KRR == 7 ) THEN
+IZRHS = MNH_ALLOCATE_ZT1DP(ZRHS,IMICRO)
+ ELSE
+IZRHS = MNH_ALLOCATE_ZT1DP(ZRHS,0)
+ END IF
+IZTHS = MNH_ALLOCATE_ZT1DP(ZTHS,IMICRO)
+IZTHT = MNH_ALLOCATE_ZT1DP(ZTHT,IMICRO)
+IZTHLT = MNH_ALLOCATE_ZT1DP(ZTHLT,IMICRO)
+IZRHODREF = MNH_ALLOCATE_ZT1DP(ZRHODREF,IMICRO)
+IZZT = MNH_ALLOCATE_ZT1DP(ZZT,IMICRO)
+IZPRES = MNH_ALLOCATE_ZT1DP(ZPRES,IMICRO)
+IZEXNREF = MNH_ALLOCATE_ZT1DP(ZEXNREF,IMICRO)
+IZSIGMA_RC = MNH_ALLOCATE_ZT1DP(ZSIGMA_RC,IMICRO)
+IZCF = MNH_ALLOCATE_ZT1DP(ZCF,IMICRO)
+IZRF = MNH_ALLOCATE_ZT1DP(ZRF,IMICRO)
+IZHLC_HCF = MNH_ALLOCATE_ZT1DP(ZHLC_HCF,IMICRO)
+IZHLC_LCF = MNH_ALLOCATE_ZT1DP(ZHLC_LCF,IMICRO)
+IZHLC_HRC = MNH_ALLOCATE_ZT1DP(ZHLC_HRC,IMICRO)
+IZHLC_LRC = MNH_ALLOCATE_ZT1DP(ZHLC_LRC,IMICRO)
+IZHLC_RCMAX = MNH_ALLOCATE_ZT1DP(ZHLC_RCMAX,IMICRO)
+IZRCRAUTC = MNH_ALLOCATE_ZT1DP(ZRCRAUTC,IMICRO)
+IZHLC_HRCLOCAL = MNH_ALLOCATE_ZT1DP(ZHLC_HRCLOCAL,IMICRO)
+IZHLC_LRCLOCAL = MNH_ALLOCATE_ZT1DP(ZHLC_LRCLOCAL,IMICRO)
+!
+IZZW = MNH_ALLOCATE_ZT1DP(ZZW,IMICRO)
+IZLSFACT = MNH_ALLOCATE_ZT1DP(ZLSFACT,IMICRO)
+IZLVFACT = MNH_ALLOCATE_ZT1DP(ZLVFACT,IMICRO)
+IZUSW = MNH_ALLOCATE_ZT1DP(ZUSW,IMICRO)
+IZSSI = MNH_ALLOCATE_ZT1DP(ZSSI,IMICRO)
+IZLBDAR = MNH_ALLOCATE_ZT1DP(ZLBDAR,IMICRO)
+IZLBDAR_RF = MNH_ALLOCATE_ZT1DP(ZLBDAR_RF,IMICRO)
+IZLBDAS = MNH_ALLOCATE_ZT1DP(ZLBDAS,IMICRO)
+IZLBDAG = MNH_ALLOCATE_ZT1DP(ZLBDAG,IMICRO)
+ IF ( KRR == 7 ) THEN
+IZLBDAH = MNH_ALLOCATE_ZT1DP(ZLBDAH,IMICRO)
+ ELSE
+IZLBDAH = MNH_ALLOCATE_ZT1DP(ZLBDAH,0)
+ END IF
+IZRDRYG = MNH_ALLOCATE_ZT1DP(ZRDRYG,IMICRO)
+IZRWETG = MNH_ALLOCATE_ZT1DP(ZRWETG,IMICRO)
+IZAI = MNH_ALLOCATE_ZT1DP(ZAI,IMICRO)
+IZCJ = MNH_ALLOCATE_ZT1DP(ZCJ,IMICRO)
+IZKA = MNH_ALLOCATE_ZT1DP(ZKA,IMICRO)
+IZDV = MNH_ALLOCATE_ZT1DP(ZDV,IMICRO)
+!
+ IF (LBU_ENABLE .OR. LLES_CALL .OR. LCHECK ) THEN
+IZRHODJ = MNH_ALLOCATE_ZT1DP(ZRHODJ,IMICRO)
+ ELSE
+IZRHODJ = MNH_ALLOCATE_ZT1DP(ZRHODJ,0)
+ END IF
+#endif
+
-!$acc data create( ZRVT, ZRCT, ZRRT, ZRIT, ZRST, ZRGT, ZRHT, &
+!$acc data present( ZRVT, ZRCT, ZRRT, ZRIT, ZRST, ZRGT, ZRHT, &
!$acc & ZCIT, ZRVS, ZRCS, ZRRS, ZRIS, ZRSS, ZRGS, ZRHS, ZTHS, ZTHT, ZTHLT, &
!$acc & ZRHODREF, ZZT, ZPRES, ZEXNREF, ZSIGMA_RC, ZCF, ZRF, &
!$acc & ZHLC_HCF, ZHLC_LCF, ZHLC_HRC, ZHLC_LRC, ZHLC_RCMAX, ZRCRAUTC, &
!$acc & ZHLC_HRCLOCAL, ZHLC_LRCLOCAL, ZZW, ZLSFACT, ZLVFACT, ZUSW, ZSSI, &
!$acc & ZLBDAR, ZLBDAR_RF, ZLBDAS, ZLBDAG, ZLBDAH, ZRDRYG, ZRWETG, &
-!$acc & ZAI, ZCJ, ZKA, ZDV, ZZW1, ZRHODJ )
+!$acc & ZAI, ZCJ, ZKA, ZDV, ZRHODJ )
!
!$acc kernels
!$acc loop independent
- DO JL=1,IMICRO
+ DO CONCURRENT ( JL=1:IMICRO )
ZRVT(JL) = PRVT(I1(JL),I2(JL),I3(JL))
ZRCT(JL) = PRCT(I1(JL),I2(JL),I3(JL))
ZRRT(JL) = PRRT(I1(JL),I2(JL),I3(JL))
@@ -653,25 +771,36 @@ IF( IMICRO >= 0 ) THEN
ENDDO
ENDIF
!
- IF ( HSUBG_AUCV == 'PDF ' .AND. CSUBG_PR_PDF == 'SIGM' ) THEN
+ IF ( GPDF_SIGM ) THEN
!$acc loop independent
DO JL=1,IMICRO
ZSIGMA_RC(JL) = PSIGS(I1(JL),I2(JL),I3(JL)) * 2.
! ZSIGMA_RC(JL) = MAX(PSIGS(I1(JL),I2(JL),I3(JL)) * 2., 1.E-12)
END DO
END IF
-!
- ZZW(:) = ZEXNREF(:)*( XCPD+XCPV*ZRVT(:)+XCL*(ZRCT(:)+ZRRT(:)) &
- +XCI*(ZRIT(:)+ZRST(:)+ZRGT(:)) )
- ZLSFACT(:) = (XLSTT+(XCPV-XCI)*(ZZT(:)-XTT))/ZZW(:) ! L_s/(Pi_ref*C_ph)
- ZLVFACT(:) = (XLVTT+(XCPV-XCL)*(ZZT(:)-XTT))/ZZW(:) ! L_v/(Pi_ref*C_ph)
-
+ !
+ !$acc loop independent
+ DO CONCURRENT ( JL=1:IMICRO )
+ ZZW(JL) = ZEXNREF(JL)*( XCPD+XCPV*ZRVT(JL)+XCL*(ZRCT(JL)+ZRRT(JL)) &
+ +XCI*(ZRIT(JL)+ZRST(JL)+ZRGT(JL)) )
+ ZLSFACT(JL) = (XLSTT+(XCPV-XCI)*(ZZT(JL)-XTT))/ZZW(JL) ! L_s/(Pi_ref*C_ph)
+ ZLVFACT(JL) = (XLVTT+(XCPV-XCL)*(ZZT(JL)-XTT))/ZZW(JL) ! L_v/(Pi_ref*C_ph)
+ END DO
+
#ifndef MNH_BITREP
- ZZW(:) = EXP( XALPI - XBETAI/ZZT(:) - XGAMI*ALOG(ZZT(:) ) )
+ !$acc loop independent
+ DO CONCURRENT ( JL=1:IMICRO )
+ ZZW(JL) = EXP( XALPI - XBETAI/ZZT(JL) - XGAMI*BR_LOG(ZZT(JL) ) )
+ ZSSI(JL) = ZRVT(JL)*( ZPRES(JL)-ZZW(JL) ) / ( (XMV/XMD) * ZZW(JL) ) - 1.0
+ END DO
#else
- ZZW(:) = BR_EXP( XALPI - XBETAI/ZZT(:) - XGAMI*BR_LOG(ZZT(:) ) )
+ !$acc loop independent
+ DO CONCURRENT ( JL=1:IMICRO )
+ ZZW(JL) = BR_EXP( XALPI - XBETAI/ZZT(JL) - XGAMI*BR_LOG(ZZT(JL) ) )
+ ZSSI(JL) = ZRVT(JL)*( ZPRES(JL)-ZZW(JL) ) / ( (XMV/XMD) * ZZW(JL) ) - 1.0
+ END DO
#endif
- ZSSI(:) = ZRVT(:)*( ZPRES(:)-ZZW(:) ) / ( (XMV/XMD) * ZZW(:) ) - 1.0
+
! Supersaturation over ice
!
IF (LBU_ENABLE .OR. LLES_CALL) THEN
@@ -683,7 +812,10 @@ IF( IMICRO >= 0 ) THEN
!
!Cloud water split between high and low content part is done here
!according to autoconversion option
- ZRCRAUTC(:) = XCRIAUTC/ZRHODREF(:) ! Autoconversion rc threshold
+ !$acc loop independent
+ DO CONCURRENT ( JL=1:IMICRO )
+ ZRCRAUTC(JL) = XCRIAUTC/ZRHODREF(JL) ! Autoconversion rc threshold
+ END DO
!$acc end kernels
#ifdef MNH_OPENACC
IF (LBU_ENABLE .OR. LLES_CALL) THEN
@@ -694,7 +826,7 @@ IF( IMICRO >= 0 ) THEN
!$acc kernels
!Cloud water is entirely in low or high part
!$acc loop independent private(JL)
- DO JL=1,IMICRO
+ DO CONCURRENT ( JL=1:IMICRO )
IF (ZRCT(JL) > ZRCRAUTC(JL)) THEN
ZHLC_HCF(JL) = 1.
ZHLC_LCF(JL) = 0.0
@@ -924,26 +1056,45 @@ IF( IMICRO >= 0 ) THEN
!
!$acc kernels
!ZLBDAR will be used when we consider rain diluted over the grid box
- WHERE( ZRRT(:)>0.0 )
-#ifndef MNH_BITREP
- ZLBDAR(:) = XLBR*( ZRHODREF(:)*MAX( ZRRT(:),XRTMIN(3) ) )**XLBEXR
+#ifndef MNH_BITREP
+!$acc loop independent
+ DO CONCURRENT ( JL=1:IMICRO )
+ IF ( ZRRT(JL)>0.0 ) THEN
+ ZLBDAR(JL) = XLBR * ( ZRHODREF(JL) * MAX( ZRRT(JL), XRTMIN(3) ) )**XLBEXR
+ ELSE
+ ZLBDAR(JL) = 0.
+ END IF
+ END DO ! CONCURRENT
#else
- ZLBDAR(:) = XLBR * BR_POW( ZRHODREF(:) * MAX( ZRRT(:), XRTMIN(3) ), XLBEXR )
-#endif
- ELSEWHERE
- ZLBDAR(:) = 0.
- END WHERE
+!$acc loop independent
+ DO CONCURRENT ( JL=1:IMICRO )
+ IF ( ZRRT(JL)>0.0 ) THEN
+ ZLBDAR(JL) = XLBR * BR_POW( ZRHODREF(JL) * MAX( ZRRT(JL), XRTMIN(3) ), XLBEXR )
+ ELSE
+ ZLBDAR(JL) = 0.
+ END IF
+ END DO ! CONCURRENT
+#endif
!ZLBDAR_RF will be used when we consider rain concentrated in its fraction
- WHERE( ZRRT(:)>0.0 .AND. ZRF(:)>0.0 )
-#ifndef MNH_BITREP
- ZLBDAR_RF(:) = XLBR*( ZRHODREF(:) *MAX( ZRRT(:)/ZRF(:) , XRTMIN(3) ) )**XLBEXR
+#ifndef MNH_BITREP
+!$acc loop independent
+ DO CONCURRENT ( JL=1:IMICRO )
+ IF ( ZRRT(JL)>0.0 .AND. ZRF(JL)>0.0 ) THEN
+ ZLBDAR_RF(JL) = XLBR * ( ZRHODREF(JL) * MAX( ZRRT(JL)/ZRF(JL), XRTMIN(3) ) )**XLBEXR
+ ELSE
+ ZLBDAR_RF(JL) = 0.
+ END IF
+ END DO ! CONCURRENT
#else
- ZLBDAR_RF(:) = XLBR * BR_POW( ZRHODREF(:) * MAX( ZRRT(:)/ZRF(:), XRTMIN(3) ), XLBEXR )
-#endif
- ELSEWHERE
- ZLBDAR_RF(:) = 0.
- END WHERE
-
+!$acc loop independent
+ DO CONCURRENT ( JL=1:IMICRO )
+ IF ( ZRRT(JL)>0.0 .AND. ZRF(JL)>0.0 ) THEN
+ ZLBDAR_RF(JL) = XLBR * BR_POW( ZRHODREF(JL) * MAX( ZRRT(JL)/ZRF(JL), XRTMIN(3) ), XLBEXR )
+ ELSE
+ ZLBDAR_RF(JL) = 0.
+ END IF
+ END DO ! CONCURRENT
+#endif
!Not necessary but useful for verifications
ZUSW(:) = XNEGUNDEF
!$acc end kernels
@@ -1033,12 +1184,9 @@ IF( IMICRO >= 0 ) THEN
!$acc end kernels
!$acc end data
-
-
-!
!
!
- DEALLOCATE(ZZW1)
+#ifndef MNH_OPENACC
DEALLOCATE(ZDV)
DEALLOCATE(ZCJ)
DEALLOCATE(ZRDRYG)
@@ -1089,6 +1237,16 @@ IF( IMICRO >= 0 ) THEN
DEALLOCATE(ZRCRAUTC)
DEALLOCATE(ZHLC_HRCLOCAL)
DEALLOCATE(ZHLC_LRCLOCAL)
+#else
+ CALL MNH_REL_ZT1D(IZKA,IZDV,IZRHODJ)
+ CALL MNH_REL_ZT1D(IZLBDAS,IZLBDAG,IZLBDAH,IZRDRYG,IZRWETG,IZAI,IZCJ)
+ CALL MNH_REL_ZT1D(IZZW,IZLSFACT,IZLVFACT,IZUSW,IZSSI,IZLBDAR,IZLBDAR_RF)
+ CALL MNH_REL_ZT1D(IZRCRAUTC,IZHLC_HRCLOCAL,IZHLC_LRCLOCAL)
+ CALL MNH_REL_ZT1D(IZHLC_HCF,IZHLC_LCF,IZHLC_HRC,IZHLC_LRC,IZHLC_RCMAX)
+ CALL MNH_REL_ZT1D(IZRHODREF,IZZT,IZPRES,IZEXNREF,IZSIGMA_RC,IZCF,IZRF)
+ CALL MNH_REL_ZT1D(IZRVS,IZRCS,IZRRS,IZRIS,IZRSS,IZRGS,IZRHS,IZTHS,IZTHT,IZTHLT)
+ CALL MNH_REL_ZT1D(IZRVT,IZRCT,IZRRT,IZRIT,IZRST,IZRGT,IZRHT,IZCIT)
+#endif
END IF
!
!-------------------------------------------------------------------------------
@@ -1147,10 +1305,18 @@ IF (MPPDB_INITIALIZED) THEN
IF (PRESENT(PFPR)) CALL MPPDB_CHECK(PFPR,"RAIN_ICE end:PFPR")
END IF
!
-! !$acc end data
!$acc end data
+#ifndef MNH_OPENACC
+DEALLOCATE ( I1,I2,I3 )
+DEALLOCATE ( GMICRO, ZRR, ZRS, ZRG, ZT )
+#else
+CALL MNH_REL_IT1D(II1, II2, II3)
+CALL MNH_REL_GT3D ( IGMICRO )
+CALL MNH_REL_ZT3D ( IZRR, IZRS, IZRG, IZRS_ZERO, IZRG_ZERO, IZT )
+#endif
+
!$acc end data
!-------------------------------------------------------------------------------
diff --git a/src/MNH/rain_ice_fast_rg.f90 b/src/MNH/rain_ice_fast_rg.f90
index fbba910e7cac15307712dfb2b976de78938f722d..ffb7d664ef9c765ab734d14ffd1065152fc214af 100644
--- a/src/MNH/rain_ice_fast_rg.f90
+++ b/src/MNH/rain_ice_fast_rg.f90
@@ -9,6 +9,9 @@
! P. Wautelet 03/06/2019: remove PACK/UNPACK intrinsics (to get more performance and better OpenACC support)
! P. Wautelet 05/06/2019: optimisations
! P. Wautelet 02/2020: use the new data structures and subroutines for budgets
+! J. Escobar 11/08/2020: Bypass PGI/NVHPC OPENACC BUG, error 700: Illegal address during kernel execution => DO CONCURRENT
+! J. Escobar 12/08/2020: Bypass PGI/NVHPC OPENACC BUG data partially present => enter data in ini_rain_ce & DO CONCURRENT
+! J. Escobar 13/08/2020: Openacc PB , missing enter/update data rain_ice_fast_rs/g
!-----------------------------------------------------------------
MODULE MODE_RAIN_ICE_FAST_RG
@@ -100,6 +103,7 @@ REAL, DIMENSION(:), ALLOCATABLE :: ZVEC1,ZVEC2,ZVEC3 ! Work vectors for int
REAL, DIMENSION(:), ALLOCATABLE :: ZVECLBDAG, ZVECLBDAR, ZVECLBDAS
REAL, DIMENSION(:,:), ALLOCATABLE :: ZZW1 ! Work arrays
!
+INTEGER :: JLU
!-------------------------------------------------------------------------------
!
! IN variables
@@ -114,7 +118,11 @@ REAL, DIMENSION(:,:), ALLOCATABLE :: ZZW1 ! Work arrays
!
! OUT variables
!
-!$acc & PRDRYG, PRWETG )
+!$acc & PRDRYG, PRWETG, &
+!
+! use variables
+!
+!$acc & XKER_SDRYG,XKER_RDRYG )
IF (MPPDB_INITIALIZED) THEN
!Check all IN arrays
@@ -147,8 +155,13 @@ IF (MPPDB_INITIALIZED) THEN
CALL MPPDB_CHECK(PRHS,"RAIN_ICE_FAST_RG beg:PRHS")
CALL MPPDB_CHECK(PTHS,"RAIN_ICE_FAST_RG beg:PTHS")
CALL MPPDB_CHECK(PUSW,"RAIN_ICE_FAST_RG beg:PUSW")
+ !Check use variable
+ CALL MPPDB_CHECK(XKER_SDRYG,"RAIN_ICE_FAST_RG beg:XKER_SDRYG")
+ CALL MPPDB_CHECK(XKER_SDRYG,"RAIN_ICE_FAST_RG beg:XKER_RDRYG")
END IF
!
+JLU = size(PRHODREF)
+!
ALLOCATE( I1 (size(PRHODREF)) )
ALLOCATE( GWORK(size(PRHODREF)) )
ALLOCATE( ZZW (size(PRHODREF)) )
@@ -162,29 +175,45 @@ ALLOCATE( ZZW1 (size(PRHODREF),7) )
!$acc kernels
ZZW1(:,:) = 0.0
GWORK(:) = PRIT(:)>XRTMIN(4) .AND. PRRT(:)>XRTMIN(3) .AND. PRIS(:)>0.0 .AND. PRRS(:)>0.0
- WHERE( GWORK(:) )
#ifndef MNH_BITREP
- ZZW1(:,3) = MIN( PRIS(:),XICFRR * PRIT(:) & ! RICFRRG
- * PLBDAR(:)**XEXICFRR &
- * PRHODREF(:)**(-XCEXVT) )
- ZZW1(:,4) = MIN( PRRS(:),XRCFRI * PCIT(:) & ! RRCFRIG
- * PLBDAR(:)**XEXRCFRI &
- * PRHODREF(:)**(-XCEXVT-1.) )
+ !$acc loop independent
+ DO CONCURRENT ( JL=1:JLU )
+ IF ( GWORK(JL) ) THEN
+ ZZW1(JL,3) = MIN( PRIS(JL),XICFRR * PRIT(JL) & ! RICFRRG
+ * PLBDAR(JL)**XEXICFRR &
+ * PRHODREF(JL)**(-XCEXVT) )
+ ZZW1(JL,4) = MIN( PRRS(JL),XRCFRI * PCIT(JL) & ! RRCFRIG
+ * PLBDAR(JL)**XEXRCFRI &
+ * PRHODREF(JL)**(-XCEXVT-1.) )
+ PRIS(JL) = PRIS(JL) - ZZW1(JL,3)
+ PRRS(JL) = PRRS(JL) - ZZW1(JL,4)
+ PRGS(JL) = PRGS(JL) + ZZW1(JL,3)+ZZW1(JL,4)
+ PTHS(JL) = PTHS(JL) + ZZW1(JL,4)*(PLSFACT(JL)-PLVFACT(JL)) ! f(L_f*RRCFRIG)
+ END IF
+ END DO ! CONCURRENT
#else
- ZZW1(:,3) = MIN( PRIS(:),XICFRR * PRIT(:) & ! RICFRRG
- * BR_POW(PLBDAR(:),XEXICFRR) &
- * BR_POW(PRHODREF(:),-XCEXVT) )
- ZZW1(:,4) = MIN( PRRS(:),XRCFRI * PCIT(:) & ! RRCFRIG
- * BR_POW(PLBDAR(:),XEXRCFRI) &
- * BR_POW(PRHODREF(:),-XCEXVT-1.) )
-#endif
- PRIS(:) = PRIS(:) - ZZW1(:,3)
- PRRS(:) = PRRS(:) - ZZW1(:,4)
- PRGS(:) = PRGS(:) + ZZW1(:,3)+ZZW1(:,4)
- PTHS(:) = PTHS(:) + ZZW1(:,4)*(PLSFACT(:)-PLVFACT(:)) ! f(L_f*RRCFRIG)
- END WHERE
+ !$acc loop independent
+ DO CONCURRENT ( JL=1:JLU )
+ IF ( GWORK(JL) ) THEN
+ ZZW1(JL,3) = MIN( PRIS(JL),XICFRR * PRIT(JL) & ! RICFRRG
+ * BR_POW(PLBDAR(JL),XEXICFRR) &
+ * BR_POW(PRHODREF(JL),-XCEXVT) )
+ ZZW1(JL,4) = MIN( PRRS(JL),XRCFRI * PCIT(JL) & ! RRCFRIG
+ * BR_POW(PLBDAR(JL),XEXRCFRI) &
+ * BR_POW(PRHODREF(JL),-XCEXVT-1.) )
+ PRIS(JL) = PRIS(JL) - ZZW1(JL,3)
+ PRRS(JL) = PRRS(JL) - ZZW1(JL,4)
+ PRGS(JL) = PRGS(JL) + ZZW1(JL,3)+ZZW1(JL,4)
+ PTHS(JL) = PTHS(JL) + ZZW1(JL,4)*(PLSFACT(JL)-PLVFACT(JL)) ! f(L_f*RRCFRIG)
+ END IF
+ END DO ! CONCURRENT
+#endif
!$acc end kernels
+IF (MPPDB_INITIALIZED) THEN
+ CALL MPPDB_CHECK(PRRS,"RAIN_ICE_FAST_RG 6.1:PRRS")
+END IF
+
if ( lbudget_th ) call Budget_store_add( tbudgets(NBUDGET_TH), 'CFRZ', Unpack ( zzw1(:, 4) * ( plsfact(:) - plvfact(:) ) &
* prhodj(:), mask = omicro(:,:,:), field = 0. ) )
if ( lbudget_rr ) call Budget_store_add( tbudgets(NBUDGET_RR), 'CFRZ', Unpack ( -zzw1(:, 4) * prhodj(:), &
@@ -237,6 +266,9 @@ ALLOCATE( ZZW1 (size(PRHODREF),7) )
#endif
END WHERE
!$acc end kernels
+IF (MPPDB_INITIALIZED) THEN
+ CALL MPPDB_CHECK(ZZW1,"RAIN_ICE_FAST_RG 6.2:ZZW1")
+END IF
!
!* 6.2.1 accretion of aggregates on the graupeln
!
@@ -294,17 +326,17 @@ ALLOCATE( ZZW1 (size(PRHODREF),7) )
!* 6.2.5 perform the bilinear interpolation of the normalized
! SDRYG-kernel
!
-!$acc loop independent
- DO JJ = 1,IGDRY
+ !$acc loop independent
+ DO CONCURRENT ( JJ = 1:IGDRY )
ZVEC3(JJ) = ( XKER_SDRYG(IVEC1(JJ)+1,IVEC2(JJ)+1)* ZVEC2(JJ) &
- XKER_SDRYG(IVEC1(JJ)+1,IVEC2(JJ) )*(ZVEC2(JJ) - 1.0) ) &
* ZVEC1(JJ) &
- ( XKER_SDRYG(IVEC1(JJ) ,IVEC2(JJ)+1)* ZVEC2(JJ) &
- XKER_SDRYG(IVEC1(JJ) ,IVEC2(JJ) )*(ZVEC2(JJ) - 1.0) ) &
* (ZVEC1(JJ) - 1.0)
- END DO
+ END DO ! CONCURRENT
!
-!$acc loop independent
+ !$acc loop independent , private (JL)
DO JJ = 1, IGDRY
JL = I1(JJ)
#ifndef MNH_BITREP
@@ -326,7 +358,10 @@ ALLOCATE( ZZW1 (size(PRHODREF),7) )
#endif
END DO
!$acc end kernels
-
+IF (MPPDB_INITIALIZED) THEN
+ CALL MPPDB_CHECK(ZZW1,"RAIN_ICE_FAST_RG 6.2.5:ZZW1")
+ CALL MPPDB_CHECK(ZVEC3,"RAIN_ICE_FAST_RG 6.2.5:ZVEC3")
+END IF
!$acc end data
DEALLOCATE(ZVECLBDAS)
DEALLOCATE(ZVECLBDAG)
@@ -392,17 +427,17 @@ ALLOCATE( ZZW1 (size(PRHODREF),7) )
!* 6.2.10 perform the bilinear interpolation of the normalized
! RDRYG-kernel
!
-!$acc loop independent
- DO JJ = 1,IGDRY
+ !$acc loop independent
+ DO CONCURRENT (JJ = 1:IGDRY )
ZVEC3(JJ) = ( XKER_RDRYG(IVEC1(JJ)+1,IVEC2(JJ)+1)* ZVEC2(JJ) &
- XKER_RDRYG(IVEC1(JJ)+1,IVEC2(JJ) )*(ZVEC2(JJ) - 1.0) ) &
* ZVEC1(JJ) &
- ( XKER_RDRYG(IVEC1(JJ) ,IVEC2(JJ)+1)* ZVEC2(JJ) &
- XKER_RDRYG(IVEC1(JJ) ,IVEC2(JJ) )*(ZVEC2(JJ) - 1.0) ) &
* (ZVEC1(JJ) - 1.0)
- END DO
+ END DO ! CONCURRENT
!
-!$acc loop independent
+ !$acc loop independent , private (JL)
DO JJ = 1, IGDRY
JL = I1(JJ)
#ifndef MNH_BITREP
@@ -422,7 +457,10 @@ ALLOCATE( ZZW1 (size(PRHODREF),7) )
#endif
END DO
!$acc end kernels
-
+IF (MPPDB_INITIALIZED) THEN
+ CALL MPPDB_CHECK(ZZW1,"RAIN_ICE_FAST_RG 6.2.10:ZZW1")
+ CALL MPPDB_CHECK(ZVEC3,"RAIN_ICE_FAST_RG 6.2.10:ZVEC3")
+END IF
!$acc end data
DEALLOCATE(ZVECLBDAR)
DEALLOCATE(ZVECLBDAG)
@@ -440,38 +478,55 @@ ALLOCATE( ZZW1 (size(PRHODREF),7) )
!
PRWETG(:) = 0.0
GWORK(:) = PRGT(:)>XRTMIN(6)
- WHERE( GWORK(:) )
-#ifndef MNH_BITREP
- ZZW1(:,5) = MIN( PRIS(:), &
- ZZW1(:,2) / (XCOLIG*EXP(XCOLEXIG*(PZT(:)-XTT)) ) ) ! RIWETG
- ZZW1(:,6) = MIN( PRSS(:), &
- ZZW1(:,3) / (XCOLSG*EXP(XCOLEXSG*(PZT(:)-XTT)) ) ) ! RSWETG
-#else
- ZZW1(:,5) = MIN( PRIS(:), &
- ZZW1(:,2) / (XCOLIG*BR_EXP(XCOLEXIG*(PZT(:)-XTT)) ) ) ! RIWETG
- ZZW1(:,6) = MIN( PRSS(:), &
- ZZW1(:,3) / (XCOLSG*BR_EXP(XCOLEXSG*(PZT(:)-XTT)) ) ) ! RSWETG
-#endif
-!
- ZZW(:) = PRVT(:)*PPRES(:)/((XMV/XMD)+PRVT(:)) ! Vapor pressure
- ZZW(:) = PKA(:)*(XTT-PZT(:)) + &
- ( PDV(:)*(XLVTT + ( XCPV - XCL ) * ( PZT(:) - XTT )) &
- *(XESTT-ZZW(:))/(XRV*PZT(:)) )
-!
-! compute RWETG
-!
- PRWETG(:)=MAX( 0.0, &
-#ifndef MNH_BITREP
- ( ZZW(:) * ( X0DEPG* PLBDAG(:)**XEX0DEPG + &
- X1DEPG*PCJ(:)*PLBDAG(:)**XEX1DEPG ) + &
+#ifndef MNH_BITREP
+!$acc loop independent
+ DO CONCURRENT ( JL=1:JLU )
+ IF ( GWORK(JL) ) THEN
+ ZZW1(JL,5) = MIN( PRIS(JL), &
+ ZZW1(JL,2) / (XCOLIG*EXP(XCOLEXIG*(PZT(JL)-XTT)) ) ) ! RIWETG
+ ZZW1(JL,6) = MIN( PRSS(JL), &
+ ZZW1(JL,3) / (XCOLSG*EXP(XCOLEXSG*(PZT(JL)-XTT)) ) ) ! RSWETG
+ !
+ ZZW(JL) = PRVT(JL)*PPRES(JL)/((XMV/XMD)+PRVT(JL)) ! Vapor pressure
+ ZZW(JL) = PKA(JL)*(XTT-PZT(JL)) + &
+ ( PDV(JL)*(XLVTT + ( XCPV - XCL ) * ( PZT(JL) - XTT )) &
+ *(XESTT-ZZW(JL))/(XRV*PZT(JL)) )
+ !
+ ! compute RWETG
+ !
+ PRWETG(JL)=MAX( 0.0, &
+ ( ZZW(JL) * ( X0DEPG* PLBDAG(JL)**XEX0DEPG + &
+ X1DEPG*PCJ(JL)*PLBDAG(JL)**XEX1DEPG ) + &
+ ( ZZW1(JL,5)+ZZW1(JL,6) ) * &
+ ( PRHODREF(JL)*(XLMTT+(XCI-XCL)*(XTT-PZT(JL))) ) ) / &
+ ( PRHODREF(JL)*(XLMTT-XCL*(XTT-PZT(JL))) ) )
+ END IF
+ END DO ! CONCURRENT
#else
- ( ZZW(:) * ( X0DEPG* BR_POW(PLBDAG(:),XEX0DEPG) + &
- X1DEPG*PCJ(:)*BR_POW(PLBDAG(:),XEX1DEPG) ) + &
-#endif
- ( ZZW1(:,5)+ZZW1(:,6) ) * &
- ( PRHODREF(:)*(XLMTT+(XCI-XCL)*(XTT-PZT(:))) ) ) / &
- ( PRHODREF(:)*(XLMTT-XCL*(XTT-PZT(:))) ) )
- END WHERE
+!$acc loop independent
+ DO CONCURRENT ( JL=1:JLU )
+ IF ( GWORK(JL) ) THEN
+ ZZW1(JL,5) = MIN( PRIS(JL), &
+ ZZW1(JL,2) / (XCOLIG*BR_EXP(XCOLEXIG*(PZT(JL)-XTT)) ) ) ! RIWETG
+ ZZW1(JL,6) = MIN( PRSS(JL), &
+ ZZW1(JL,3) / (XCOLSG*BR_EXP(XCOLEXSG*(PZT(JL)-XTT)) ) ) ! RSWETG
+ !
+ ZZW(JL) = PRVT(JL)*PPRES(JL)/((XMV/XMD)+PRVT(JL)) ! Vapor pressure
+ ZZW(JL) = PKA(JL)*(XTT-PZT(JL)) + &
+ ( PDV(JL)*(XLVTT + ( XCPV - XCL ) * ( PZT(JL) - XTT )) &
+ *(XESTT-ZZW(JL))/(XRV*PZT(JL)) )
+ !
+ ! compute RWETG
+ !
+ PRWETG(JL)=MAX( 0.0, &
+ ( ZZW(JL) * ( X0DEPG* BR_POW(PLBDAG(JL),XEX0DEPG) + &
+ X1DEPG*PCJ(JL)*BR_POW(PLBDAG(JL),XEX1DEPG) ) + &
+ ( ZZW1(JL,5)+ZZW1(JL,6) ) * &
+ ( PRHODREF(JL)*(XLMTT+(XCI-XCL)*(XTT-PZT(JL))) ) ) / &
+ ( PRHODREF(JL)*(XLMTT-XCL*(XTT-PZT(JL))) ) )
+ END IF
+ END DO ! CONCURRENT
+#endif
!
!* 6.4 Select Wet or Dry case
!
@@ -518,6 +573,10 @@ ALLOCATE( ZZW1 (size(PRHODREF),7) )
END IF
!$acc end kernels
+IF (MPPDB_INITIALIZED) THEN
+ CALL MPPDB_CHECK(PRRS,"RAIN_ICE_FAST_RG 6.4:PRRS")
+END IF
+
if ( lbudget_th ) call Budget_store_end( tbudgets(NBUDGET_TH), 'WETG', Unpack ( pths(:) * prhodj(:), &
mask = omicro(:,:,:), field = 0. ) )
if ( lbudget_rc ) call Budget_store_end( tbudgets(NBUDGET_RC), 'WETG', Unpack ( prcs(:) * prhodj(:), &
@@ -561,6 +620,10 @@ ALLOCATE( ZZW1 (size(PRHODREF),7) )
END WHERE
!$acc end kernels
+IF (MPPDB_INITIALIZED) THEN
+ CALL MPPDB_CHECK(PRRS,"RAIN_ICE_FAST_RG 6.4b:PRRS")
+END IF
+
if ( lbudget_th ) call Budget_store_end( tbudgets(NBUDGET_TH), 'DRYG', Unpack ( pths(:) * prhodj(:), &
mask = omicro(:,:,:), field = 0. ) )
if ( lbudget_rc ) call Budget_store_end( tbudgets(NBUDGET_RC), 'DRYG', Unpack ( prcs(:) * prhodj(:), &
@@ -583,31 +646,57 @@ ALLOCATE( ZZW1 (size(PRHODREF),7) )
!
!$acc kernels
GWORK(:) = PRGT(:)>XRTMIN(6) .AND. PRGS(:)>0.0 .AND. PZT(:)>XTT
- WHERE( GWORK(:) )
- ZZW(:) = PRVT(:)*PPRES(:)/((XMV/XMD)+PRVT(:)) ! Vapor pressure
- ZZW(:) = PKA(:)*(XTT-PZT(:)) + &
- ( PDV(:)*(XLVTT + ( XCPV - XCL ) * ( PZT(:) - XTT )) &
- *(XESTT-ZZW(:))/(XRV*PZT(:)) )
+#ifndef MNH_BITREP
+ !$acc loop independent
+ DO CONCURRENT ( JL=1:JLU )
+ IF ( GWORK(JL) ) THEN
+ ZZW(JL) = PRVT(JL)*PPRES(JL)/((XMV/XMD)+PRVT(JL)) ! Vapor pressure
+ ZZW(JL) = PKA(JL)*(XTT-PZT(JL)) + &
+ ( PDV(JL)*(XLVTT + ( XCPV - XCL ) * ( PZT(JL) - XTT )) &
+ *(XESTT-ZZW(JL))/(XRV*PZT(JL)) )
!
! compute RGMLTR
!
- ZZW(:) = MIN( PRGS(:), MAX( 0.0,( -ZZW(:) * &
-#ifndef MNH_BITREP
- ( X0DEPG* PLBDAG(:)**XEX0DEPG + &
- X1DEPG*PCJ(:)*PLBDAG(:)**XEX1DEPG ) - &
+ ZZW(JL) = MIN( PRGS(JL), MAX( 0.0,( -ZZW(JL) * &
+ ( X0DEPG* PLBDAG(JL)**XEX0DEPG + &
+ X1DEPG*PCJ(JL)*PLBDAG(JL)**XEX1DEPG ) - &
+ ( ZZW1(JL,1)+ZZW1(JL,4) ) * &
+ ( PRHODREF(JL)*XCL*(XTT-PZT(JL))) ) / &
+ ( PRHODREF(JL)*XLMTT ) ) )
+ PRRS(JL) = PRRS(JL) + ZZW(JL)
+ PRGS(JL) = PRGS(JL) - ZZW(JL)
+ PTHS(JL) = PTHS(JL) - ZZW(JL)*(PLSFACT(JL)-PLVFACT(JL)) ! f(L_f*(-RGMLTR))
+ END IF
+ END DO ! CONCURRENT
#else
- ( X0DEPG* BR_POW(PLBDAG(:),XEX0DEPG) + &
- X1DEPG*PCJ(:)*BR_POW(PLBDAG(:),XEX1DEPG) ) - &
-#endif
- ( ZZW1(:,1)+ZZW1(:,4) ) * &
- ( PRHODREF(:)*XCL*(XTT-PZT(:))) ) / &
- ( PRHODREF(:)*XLMTT ) ) )
- PRRS(:) = PRRS(:) + ZZW(:)
- PRGS(:) = PRGS(:) - ZZW(:)
- PTHS(:) = PTHS(:) - ZZW(:)*(PLSFACT(:)-PLVFACT(:)) ! f(L_f*(-RGMLTR))
- END WHERE
+ !$acc loop independent
+ DO CONCURRENT ( JL=1:JLU )
+ IF ( GWORK(JL) ) THEN
+ ZZW(JL) = PRVT(JL)*PPRES(JL)/((XMV/XMD)+PRVT(JL)) ! Vapor pressure
+ ZZW(JL) = PKA(JL)*(XTT-PZT(JL)) + &
+ ( PDV(JL)*(XLVTT + ( XCPV - XCL ) * ( PZT(JL) - XTT )) &
+ *(XESTT-ZZW(JL))/(XRV*PZT(JL)) )
+ !
+ ! compute RGMLTR
+ !
+ ZZW(JL) = MIN( PRGS(JL), MAX( 0.0,( -ZZW(JL) * &
+ ( X0DEPG* BR_POW(PLBDAG(JL),XEX0DEPG) + &
+ X1DEPG*PCJ(JL)*BR_POW(PLBDAG(JL),XEX1DEPG) ) - &
+ ( ZZW1(JL,1)+ZZW1(JL,4) ) * &
+ ( PRHODREF(JL)*XCL*(XTT-PZT(JL))) ) / &
+ ( PRHODREF(JL)*XLMTT ) ) )
+ PRRS(JL) = PRRS(JL) + ZZW(JL)
+ PRGS(JL) = PRGS(JL) - ZZW(JL)
+ PTHS(JL) = PTHS(JL) - ZZW(JL)*(PLSFACT(JL)-PLVFACT(JL)) ! f(L_f*(-RGMLTR))
+ END IF
+ END DO ! CONCURRENT
+#endif
!$acc end kernels
+IF (MPPDB_INITIALIZED) THEN
+ CALL MPPDB_CHECK(PRRS,"RAIN_ICE_FAST_RG 6.5:PRRS")
+END IF
+
if ( lbudget_th ) call Budget_store_add( tbudgets(NBUDGET_TH), 'GMLT', Unpack ( -zzw(:) * ( plsfact(:) - plvfact(:) ) &
* prhodj(:), mask = omicro(:,:,:), field = 0. ) )
if ( lbudget_rr ) call Budget_store_add( tbudgets(NBUDGET_RR), 'GMLT', Unpack ( zzw(:) * prhodj(:), &
diff --git a/src/MNH/rain_ice_fast_ri.f90 b/src/MNH/rain_ice_fast_ri.f90
index ab6247526371ac8e96a74774ab31155988fba7d2..359c31e8a92246e442e3f18aef4d694cb2b9736d 100644
--- a/src/MNH/rain_ice_fast_ri.f90
+++ b/src/MNH/rain_ice_fast_ri.f90
@@ -61,7 +61,9 @@ REAL, DIMENSION(:), INTENT(INOUT) :: PTHS ! Theta source
!
LOGICAL, DIMENSION(:), ALLOCATABLE :: GWORK
REAL, DIMENSION(:), ALLOCATABLE :: ZZW ! Work array
+REAL, DIMENSION(:), ALLOCATABLE :: ZLBEXI
!
+INTEGER :: JL,JLU
!-------------------------------------------------------------------------------
!
! IN variables
@@ -97,10 +99,13 @@ IF (MPPDB_INITIALIZED) THEN
CALL MPPDB_CHECK(PTHS,"RAIN_ICE_FAST_RI beg:PTHS")
END IF
!
+JLU = size(PRHODREF)
+!
ALLOCATE( GWORK(size(PRHODREF)) )
ALLOCATE( ZZW (size(PRHODREF)) )
+ALLOCATE( ZLBEXI (size(PRHODREF)) )
-!$acc data create( GWORK, ZZW )
+!$acc data create( GWORK, ZZW , ZLBEXI )
!
!* 7.1 cloud ice melting
@@ -134,20 +139,41 @@ ALLOCATE( ZZW (size(PRHODREF)) )
!$acc kernels
zzw(:) = 0.
GWORK(:) = PRCS(:)>0.0 .AND. PSSI(:)>0.0 .AND. PRIT(:)>XRTMIN(4) .AND. PCIT(:)>0.0
- WHERE( GWORK(:) )
#ifndef MNH_BITREP
+ WHERE( GWORK(:) )
ZZW(:) = MIN(1.E8,XLBI*( PRHODREF(:)*PRIT(:)/PCIT(:) )**XLBEXI) ! Lbda_i
ZZW(:) = MIN( PRCS(:),( PSSI(:) / (PRHODREF(:)*PAI(:)) ) * PCIT(:) * &
( X0DEPI/ZZW(:) + X2DEPI*PCJ(:)*PCJ(:)/ZZW(:)**(XDI+2.0) ) )
+ PRCS(:) = PRCS(:) - ZZW(:)
+ PRIS(:) = PRIS(:) + ZZW(:)
+ PTHS(:) = PTHS(:) + ZZW(:)*(PLSFACT(:)-PLVFACT(:)) ! f(L_f*(RCBERI))
+ END WHERE
#else
- ZZW(:) = MIN(1.E8,XLBI*BR_POW( PRHODREF(:)*PRIT(:)/PCIT(:), XLBEXI ) ) ! Lbda_i
+
+!!$ Le DO concurrent n'est pas bit-reproductible BUG NVHPC 20.7
+!!$ DO CONCURRENT ( JL=1:JLU )
+!!$ ZLBEXI(JL) = XLBEXI
+!!$ IF ( GWORK(JL) ) THEN
+!!$ ZZW(JL) = MIN(1.E8,XLBI*BR_POW( PRHODREF(JL)*PRIT(JL)/PCIT(JL), ZLBEXI(JL) ) ) ! Lbda_i
+!!$ ZZW(JL) = MIN( PRCS(JL),( PSSI(JL) / (PRHODREF(JL)*PAI(JL)) ) * PCIT(JL) * &
+!!$ ( X0DEPI/ZZW(JL) + X2DEPI*PCJ(JL)*PCJ(JL)/BR_POW(ZZW(JL),XDI+2.0) ) )
+!!$ PRCS(JL) = PRCS(JL) - ZZW(JL)
+!!$ PRIS(JL) = PRIS(JL) + ZZW(JL)
+!!$ PTHS(JL) = PTHS(JL) + ZZW(JL)*(PLSFACT(JL)-PLVFACT(JL)) ! f(L_f*(RCBERI))
+!!$ END IF
+!!$ END DO ! CONCURRENT
+
+ WHERE( GWORK(:) )
+ ZLBEXI(:) = XLBEXI
+ ZZW(:) = MIN(1.E8,XLBI*BR_POW( PRHODREF(:)*PRIT(:)/PCIT(:), ZLBEXI(:) ) ) ! Lbda_i
ZZW(:) = MIN( PRCS(:),( PSSI(:) / (PRHODREF(:)*PAI(:)) ) * PCIT(:) * &
- ( X0DEPI/ZZW(:) + X2DEPI*PCJ(:)*PCJ(:)/BR_POW(ZZW(:),XDI+2.0) ) )
-#endif
+ ( X0DEPI/ZZW(:) + X2DEPI*PCJ(:)*PCJ(:)/BR_POW(ZZW(:),XDI+2.0) ) )
PRCS(:) = PRCS(:) - ZZW(:)
PRIS(:) = PRIS(:) + ZZW(:)
PTHS(:) = PTHS(:) + ZZW(:)*(PLSFACT(:)-PLVFACT(:)) ! f(L_f*(RCBERI))
- END WHERE
+ END WHERE
+
+#endif
!$acc end kernels
if ( lbudget_th ) call Budget_store_add( tbudgets(NBUDGET_TH), 'BERFI', Unpack ( zzw(:) * ( plsfact(:) - plvfact(:) ) &
diff --git a/src/MNH/rain_ice_fast_rs.f90 b/src/MNH/rain_ice_fast_rs.f90
index e12d8727eeb50f36a085f2289f1f753febfd6f7d..203fab9b8df1b7623feadedfe0d97d0c50b9f6eb 100644
--- a/src/MNH/rain_ice_fast_rs.f90
+++ b/src/MNH/rain_ice_fast_rs.f90
@@ -9,6 +9,9 @@
! P. Wautelet 03/06/2019: remove PACK/UNPACK intrinsics (to get more performance and better OpenACC support)
! P. Wautelet 05/06/2019: optimisations
! P. Wautelet 02/2020: use the new data structures and subroutines for budgets
+! J. Escobar 11/08/2020: Bypass PGI/NVHPC OPENACC BUG, error 700: Illegal address during kernel execution => DO CONCURRENT
+! J. Escobar 12/08/2020: Bypass PGI/NVHPC OPENACC BUG data partially present => enter data in ini_rain_ce & DO CONCURRENT
+! J. Escobar 13/08/2020: Openacc PB , missing enter/update data rain_ice_fast_rs/g
! P. Wautelet 19/02/2021: bugfix: RIM and ACC terms for budgets are now correctly stored
!-----------------------------------------------------------------
MODULE MODE_RAIN_ICE_FAST_RS
@@ -91,6 +94,8 @@ REAL, DIMENSION(:), ALLOCATABLE :: ZVEC1,ZVEC2,ZVEC3 ! Work vectors for inter
REAL, DIMENSION(:), ALLOCATABLE :: ZVECLBDAR, ZVECLBDAS
REAL, DIMENSION(:), ALLOCATABLE :: ZZW1, ZZW2, ZZW3, ZZW4 ! Work arrays
!
+INTEGER :: JJU
+!
!-------------------------------------------------------------------------------
!
! IN variables
@@ -101,12 +106,17 @@ REAL, DIMENSION(:), ALLOCATABLE :: ZZW1, ZZW2, ZZW3, ZZW4 ! Work arrays
!
! INOUT variables
!
-!$acc & PRCS, PRRS, PRSS, PRGS, PTHS )
+!$acc & PRCS, PRRS, PRSS, PRGS, PTHS , &
+!
+! use variable
+!$acc & XGAMINC_RIM1,XGAMINC_RIM2, &
+!$acc & XKER_RACCSS,XKER_RACCS,XKER_SACCRG )
!
! OUT variables
!
!NONE
-
+!
+!
IF (MPPDB_INITIALIZED) THEN
!Check all IN arrays
CALL MPPDB_CHECK(OMICRO,"RAIN_ICE_FAST_RS beg:OMICRO")
@@ -131,12 +141,16 @@ IF (MPPDB_INITIALIZED) THEN
CALL MPPDB_CHECK(PRSS,"RAIN_ICE_FAST_RS beg:PRSS")
CALL MPPDB_CHECK(PRGS,"RAIN_ICE_FAST_RS beg:PRGS")
CALL MPPDB_CHECK(PTHS,"RAIN_ICE_FAST_RS beg:PTHS")
+ !Check use variables
+ CALL MPPDB_CHECK(XKER_RACCSS,"RAIN_ICE_FAST_RS beg:XKER_RACCSS")
END IF
!
ALLOCATE( I1 (size(PRHODREF)) )
ALLOCATE( GWORK(size(PRHODREF)) )
ALLOCATE( ZZW (size(PRHODREF)) )
+JJU = size(PRHODREF)
+
!$acc data create( I1, GWORK, ZZW )
!
!* 5.1 cloud droplet riming of the aggregates
@@ -193,13 +207,21 @@ CALL COUNTJV_DEVICE( GWORK(:), I1(:), IGRIM )
! 5.1.3 perform the linear interpolation of the normalized
! "2+XDS"-moment of the incomplete gamma function
!
- ZVEC1(1:IGRIM) = XGAMINC_RIM1( IVEC2(1:IGRIM)+1 )* ZVEC2(1:IGRIM) &
- - XGAMINC_RIM1( IVEC2(1:IGRIM) )*(ZVEC2(1:IGRIM) - 1.0)
+ !$acc loop independent
+ DO CONCURRENT (JJ=1:IGRIM)
+ ZVEC1(JJ) = XGAMINC_RIM1( IVEC2(JJ)+1 )* ZVEC2(JJ) &
+ - XGAMINC_RIM1( IVEC2(JJ) )*(ZVEC2(JJ) - 1.0)
+ END DO ! CONCURRENT
!
! 5.1.4 riming of the small sized aggregates
!
-!$acc loop independent
- DO JJ = 1, IGRIM
+ !$acc loop independent , private (JL)
+ DO CONCURRENT ( JJ = 1:IGRIM ) &
+#if defined(MNH_OPENACC) && !defined(_FAKEOPENACC)
+ LOCAL(JL)
+#else
+ & ! LOCAL(JL)
+#endif
JL = I1(JJ)
#ifndef MNH_BITREP
ZZW1(JJ) = MIN( PRCS(JL), &
@@ -215,19 +237,37 @@ CALL COUNTJV_DEVICE( GWORK(:), I1(:), IGRIM )
PRCS(JL) = PRCS(JL) - ZZW1(JJ)
PRSS(JL) = PRSS(JL) + ZZW1(JJ)
PTHS(JL) = PTHS(JL) + ZZW1(JJ)*(PLSFACT(JL)-PLVFACT(JL)) ! f(L_f*(RCRIMSS))
- END DO
+ END DO ! CONCURRENT
+ !
+!$acc end kernels
+IF (MPPDB_INITIALIZED) THEN
+ CALL MPPDB_CHECK(ZZW1,"RAIN_ICE_FAST_RS 5.1.4:ZZW1")
+ CALL MPPDB_CHECK(PRCS,"RAIN_ICE_FAST_RS 5.1.4:PRCS")
+ CALL MPPDB_CHECK(PRSS,"RAIN_ICE_FAST_RS 5.1.4:PRSS")
+ CALL MPPDB_CHECK(PTHS,"RAIN_ICE_FAST_RS 5.1.4:PTHS")
+END IF
+!$acc kernels
!
! 5.1.5 perform the linear interpolation of the normalized
! "XBS"-moment of the incomplete gamma function
!
- ZVEC1(1:IGRIM) = XGAMINC_RIM2( IVEC2(1:IGRIM)+1 )* ZVEC2(1:IGRIM) &
- - XGAMINC_RIM2( IVEC2(1:IGRIM) )*(ZVEC2(1:IGRIM) - 1.0)
+ !$acc loop independent
+ DO CONCURRENT (JJ=1:IGRIM)
+ ZVEC1(JJ) = XGAMINC_RIM2( IVEC2(JJ)+1 )* ZVEC2(JJ) &
+ - XGAMINC_RIM2( IVEC2(JJ) )*(ZVEC2(JJ) - 1.0)
+ END DO ! CONCURRENT
!
! 5.1.6 riming-conversion of the large sized aggregates into graupeln
!
-!
-!$acc loop independent
- DO JJ = 1, IGRIM
+ !
+ !$acc loop independent , private (JL)
+ DO CONCURRENT (JJ = 1:IGRIM ) &
+#if defined(MNH_OPENACC) && !defined(_FAKEOPENACC)
+ LOCAL(JL)
+#else
+ & ! LOCAL(JL)
+#endif
+
JL = I1(JJ)
IF ( PRSS(JL) > 0.0 ) THEN
#ifndef MNH_BITREP
@@ -254,9 +294,18 @@ CALL COUNTJV_DEVICE( GWORK(:), I1(:), IGRIM )
PRGS(JL) = PRGS(JL) + ZZW2(JJ)+ZZW3(JJ)
PTHS(JL) = PTHS(JL) + ZZW2(JJ)*(PLSFACT(JL)-PLVFACT(JL)) ! f(L_f*(RCRIMSG))
END IF
- END DO
+ END DO ! CONCURRENT
!$acc end kernels
+IF (MPPDB_INITIALIZED) THEN
+ CALL MPPDB_CHECK(ZZW1,"RAIN_ICE_FAST_RS 5.1.5:ZZW1")
+ CALL MPPDB_CHECK(ZZW2,"RAIN_ICE_FAST_RS 5.1.5:ZZW2")
+ CALL MPPDB_CHECK(ZZW3,"RAIN_ICE_FAST_RS 5.1.5:ZZW3")
+ CALL MPPDB_CHECK(PRCS,"RAIN_ICE_FAST_RS 5.1.5:PRCS")
+ CALL MPPDB_CHECK(PRSS,"RAIN_ICE_FAST_RS 5.1.5:PRSS")
+ CALL MPPDB_CHECK(PRGS,"RAIN_ICE_FAST_RS 5.1.5:PRGS")
+ CALL MPPDB_CHECK(PTHS,"RAIN_ICE_FAST_RS 5.1.5:PTHS")
+END IF
!$acc end data
!Remark: not possible to use Budget_store_add here
@@ -346,19 +395,25 @@ CALL COUNTJV_DEVICE( GWORK(:), I1(:), IGRIM )
! RACCSS-kernel
!
!$acc loop independent
- DO JJ = 1,IGACC
+ DO CONCURRENT ( JJ = 1:IGACC )
ZVEC3(JJ) = ( XKER_RACCSS(IVEC1(JJ)+1,IVEC2(JJ)+1)* ZVEC2(JJ) &
- XKER_RACCSS(IVEC1(JJ)+1,IVEC2(JJ) )*(ZVEC2(JJ) - 1.0) ) &
* ZVEC1(JJ) &
- ( XKER_RACCSS(IVEC1(JJ) ,IVEC2(JJ)+1)* ZVEC2(JJ) &
- XKER_RACCSS(IVEC1(JJ) ,IVEC2(JJ) )*(ZVEC2(JJ) - 1.0) ) &
* (ZVEC1(JJ) - 1.0)
- END DO
+ END DO ! CONCURRENT
!
! 5.2.4 raindrop accretion on the small sized aggregates
!
-!$acc loop independent
- DO JJ = 1, IGACC
+!$acc loop independent , private (JL)
+ DO CONCURRENT ( JJ = 1:IGACC ) &
+#if defined(MNH_OPENACC) && !defined(_FAKEOPENACC)
+ LOCAL(JL)
+#else
+ & ! LOCAL(JL)
+#endif
+
JL = I1(JJ)
#ifndef MNH_BITREP
ZZW2(JJ) = & !! coef of RRACCS
@@ -377,43 +432,60 @@ CALL COUNTJV_DEVICE( GWORK(:), I1(:), IGRIM )
PRRS(JL) = PRRS(JL) - ZZW4(JJ)
PRSS(JL) = PRSS(JL) + ZZW4(JJ)
PTHS(JL) = PTHS(JL) + ZZW4(JJ)*(PLSFACT(JL)-PLVFACT(JL)) ! f(L_f*(RRACCSS))
- END DO
+ END DO ! CONCURRENT
+!$acc end kernels
+IF (MPPDB_INITIALIZED) THEN
+ CALL MPPDB_CHECK(ZVEC1,"RAIN_ICE_FAST_RS 5.2.4:IVEC1")
+ CALL MPPDB_CHECK(ZVEC2,"RAIN_ICE_FAST_RS 5.2.4:IVEC2")
+ CALL MPPDB_CHECK(ZVEC1,"RAIN_ICE_FAST_RS 5.2.4:ZVEC1")
+ CALL MPPDB_CHECK(ZVEC2,"RAIN_ICE_FAST_RS 5.2.4:ZVEC2")
+ CALL MPPDB_CHECK(ZVEC3,"RAIN_ICE_FAST_RS 5.2.4:ZVEC3")
+ CALL MPPDB_CHECK(ZZW2,"RAIN_ICE_FAST_RS 5.2.4:ZZW2")
+ CALL MPPDB_CHECK(ZZW4,"RAIN_ICE_FAST_RS 5.2.4:ZZW4")
+ CALL MPPDB_CHECK(PRRS,"RAIN_ICE_FAST_RS 5.2.4:PRRS")
+END IF
+!$acc kernels
!
! 5.2.4b perform the bilinear interpolation of the normalized
! RACCS-kernel
!
-!$acc loop independent
- DO JJ = 1,IGACC
+ !$acc loop independent
+ DO CONCURRENT (JJ = 1:IGACC )
ZVEC3(JJ) = ( XKER_RACCS(IVEC2(JJ)+1,IVEC1(JJ)+1)* ZVEC1(JJ) &
- XKER_RACCS(IVEC2(JJ)+1,IVEC1(JJ) )*(ZVEC1(JJ) - 1.0) ) &
* ZVEC2(JJ) &
- ( XKER_RACCS(IVEC2(JJ) ,IVEC1(JJ)+1)* ZVEC1(JJ) &
- XKER_RACCS(IVEC2(JJ) ,IVEC1(JJ) )*(ZVEC1(JJ) - 1.0) ) &
* (ZVEC2(JJ) - 1.0)
- END DO
-!$acc loop independent
+ END DO ! CONCURRENT
DO JJ = 1, IGACC
ZZW2(JJ) = ZZW2(JJ) * ZVEC3(JJ)
END DO
!! RRACCS!
! 5.2.5 perform the bilinear interpolation of the normalized
! SACCRG-kernel
-!
-!$acc loop independent
- DO JJ = 1,IGACC
+ !
+ !$acc loop independent
+ DO CONCURRENT (JJ = 1:IGACC )
ZVEC3(JJ) = ( XKER_SACCRG(IVEC2(JJ)+1,IVEC1(JJ)+1)* ZVEC1(JJ) &
- XKER_SACCRG(IVEC2(JJ)+1,IVEC1(JJ) )*(ZVEC1(JJ) - 1.0) ) &
* ZVEC2(JJ) &
- ( XKER_SACCRG(IVEC2(JJ) ,IVEC1(JJ)+1)* ZVEC1(JJ) &
- XKER_SACCRG(IVEC2(JJ) ,IVEC1(JJ) )*(ZVEC1(JJ) - 1.0) ) &
* (ZVEC2(JJ) - 1.0)
- END DO
+ END DO ! CONCURRENT
!
! 5.2.6 raindrop accretion-conversion of the large sized aggregates
! into graupeln
-!
-!$acc loop independent
- DO JJ = 1, IGACC
+ !
+ !$acc loop independent , private (JL)
+ DO CONCURRENT ( JJ = 1:IGACC ) &
+#if defined(MNH_OPENACC) && !defined(_FAKEOPENACC)
+ LOCAL(JL)
+#else
+ & ! LOCAL(JL)
+#endif
+
JL = I1(JJ)
IF ( PRSS(JL) > 0.0 ) THEN
ZZW2(JJ) = MAX( MIN( PRRS(JL),ZZW2(JJ)-ZZW4(JJ) ),0.0 ) ! RRACCSG
@@ -438,7 +510,7 @@ CALL COUNTJV_DEVICE( GWORK(:), I1(:), IGRIM )
! f(L_f*(RRACCSG))
END IF
END IF
- END DO
+ END DO ! CONCURRENT
!$acc end kernels
!$acc end data
@@ -471,32 +543,35 @@ CALL COUNTJV_DEVICE( GWORK(:), I1(:), IGRIM )
!$acc kernels
zzw(:) = 0.
GWORK(:) = PRST(:)>XRTMIN(5) .AND. PRSS(:)>0.0 .AND. PZT(:)>XTT
- WHERE( GWORK(:) )
- ZZW(:) = PRVT(:)*PPRES(:)/((XMV/XMD)+PRVT(:)) ! Vapor pressure
- ZZW(:) = PKA(:)*(XTT-PZT(:)) + &
- ( PDV(:)*(XLVTT + ( XCPV - XCL ) * ( PZT(:) - XTT )) &
- *(XESTT-ZZW(:))/(XRV*PZT(:)) )
+ !$acc loop independent
+ DO CONCURRENT (JJ=1:JJU)
+ IF ( GWORK(JJ) ) THEN
+ ZZW(JJ) = PRVT(JJ)*PPRES(JJ)/((XMV/XMD)+PRVT(JJ)) ! Vapor pressure
+ ZZW(JJ) = PKA(JJ)*(XTT-PZT(JJ)) + &
+ ( PDV(JJ)*(XLVTT + ( XCPV - XCL ) * ( PZT(JJ) - XTT )) &
+ *(XESTT-ZZW(JJ))/(XRV*PZT(JJ)) )
!
! compute RSMLT
!
#ifndef MNH_BITREP
- ZZW(:) = MIN( PRSS(:), XFSCVMG*MAX( 0.0,( -ZZW(:) * &
- ( X0DEPS* PLBDAS(:)**XEX0DEPS + &
- X1DEPS*PCJ(:)*PLBDAS(:)**XEX1DEPS ) ) / &
- ( PRHODREF(:)*XLMTT ) ) )
+ ZZW(JJ) = MIN( PRSS(JJ), XFSCVMG*MAX( 0.0,( -ZZW(JJ) * &
+ ( X0DEPS* PLBDAS(JJ)**XEX0DEPS + &
+ X1DEPS*PCJ(JJ)*PLBDAS(JJ)**XEX1DEPS ) ) / &
+ ( PRHODREF(JJ)*XLMTT ) ) )
#else
- ZZW(:) = MIN( PRSS(:), XFSCVMG*MAX( 0.0,( -ZZW(:) * &
- ( X0DEPS* BR_POW(PLBDAS(:),XEX0DEPS) + &
- X1DEPS*PCJ(:)*BR_POW(PLBDAS(:),XEX1DEPS) ) ) / &
- ( PRHODREF(:)*XLMTT ) ) )
+ ZZW(JJ) = MIN( PRSS(JJ), XFSCVMG*MAX( 0.0,( -ZZW(JJ) * &
+ ( X0DEPS* BR_POW(PLBDAS(JJ),XEX0DEPS) + &
+ X1DEPS*PCJ(JJ)*BR_POW(PLBDAS(JJ),XEX1DEPS) ) ) / &
+ ( PRHODREF(JJ)*XLMTT ) ) )
#endif
!
! note that RSCVMG = RSMLT*XFSCVMG but no heat is exchanged (at the rate RSMLT)
! because the graupeln produced by this process are still icy!!!
!
- PRSS(:) = PRSS(:) - ZZW(:)
- PRGS(:) = PRGS(:) + ZZW(:)
- END WHERE
+ PRSS(JJ) = PRSS(JJ) - ZZW(JJ)
+ PRGS(JJ) = PRGS(JJ) + ZZW(JJ)
+ END IF
+ END DO ! CONCURRENT
!$acc end kernels
if ( lbudget_rs ) call Budget_store_add( tbudgets(NBUDGET_RS), 'CMEL', &
diff --git a/src/MNH/rain_ice_nucleation.f90 b/src/MNH/rain_ice_nucleation.f90
index e98cbede16cfb6bb7033e9980efd1b3f258ffd00..330bbba3cf6d8c2a0915bbcf14b000c27fb37be2 100644
--- a/src/MNH/rain_ice_nucleation.f90
+++ b/src/MNH/rain_ice_nucleation.f90
@@ -45,6 +45,12 @@ use mode_tools, only: Countjv_device
use modi_bitrep
#endif
+#ifdef MNH_OPENACC
+USE MODE_MNH_ZWORK , ONLY : MNH_ALLOCATE_ZT3D , MNH_REL_ZT3D, MNH_ALLOCATE_ZT1DP , MNH_REL_ZT1D , &
+ MNH_ALLOCATE_GT3D , MNH_REL_GT3D, &
+ MNH_ALLOCATE_IT1D ,MNH_ALLOCATE_IT1DP , MNH_REL_IT1D
+#endif
+
IMPLICIT NONE
!
!* 0.1 Declarations of dummy arguments :
@@ -75,17 +81,33 @@ REAL, DIMENSION(:,:,:), OPTIONAL, INTENT(IN) :: PRHT ! Hail m.r. at t
!
INTEGER :: INEGT
INTEGER :: JL ! and PACK intrinsics
-INTEGER, DIMENSION(:), allocatable :: I1,I2,I3 ! Used to replace the COUNT
-LOGICAL, DIMENSION(:,:,:), allocatable :: GNEGT ! Test where to compute the HEN process
+INTEGER, DIMENSION(:), POINTER, CONTIGUOUS :: I1,I2,I3 ! Used to replace the COUNT
+#ifdef MNH_OPENACC
+INTEGER :: II1,II2,II3
+#endif
+LOGICAL, DIMENSION(:,:,:), POINTER, CONTIGUOUS :: GNEGT ! Test where to compute the HEN process
+#ifdef MNH_OPENACC
+INTEGER :: IGNEGT
+#endif
REAL :: ZZWMAX
-REAL, DIMENSION(:), ALLOCATABLE :: ZRVT ! Water vapor m.r. at t
-REAL, DIMENSION(:), ALLOCATABLE :: ZCIT ! Pristine ice conc. at t
-REAL, DIMENSION(:), ALLOCATABLE :: ZZT, & ! Temperature
+REAL, DIMENSION(:), POINTER, CONTIGUOUS :: ZRVT ! Water vapor m.r. at t
+REAL, DIMENSION(:), POINTER, CONTIGUOUS :: ZCIT ! Pristine ice conc. at t
+REAL, DIMENSION(:), POINTER, CONTIGUOUS :: ZZT, & ! Temperature
ZPRES, & ! Pressure
ZZW, & ! Work array
ZUSW, & ! Undersaturation over water
ZSSI ! Supersaturation over ice
-REAL, DIMENSION(:,:,:), allocatable :: ZW ! work array
+#ifdef MNH_OPENACC
+INTEGER :: IZRVT,IZCIT,IZZT,IZPRES,IZZW,IZUSW,IZSSI
+#endif
+REAL, DIMENSION(:,:,:), POINTER, CONTIGUOUS :: ZW ! work array
+#ifdef MNH_OPENACC
+INTEGER :: IZW
+#endif
+
+INTEGER :: JIU,JJU,JKU, JIJKU
+
+INTEGER :: JI,JJ,JK
!
!-------------------------------------------------------------------------------
!
@@ -123,13 +145,26 @@ IF (MPPDB_INITIALIZED) THEN
CALL MPPDB_CHECK(PRIS,"RAIN_ICE_NUCLEATION beg:PRIS")
END IF
-allocate( i1( size( pexnref ) ) )
-allocate( i2( size( pexnref ) ) )
-allocate( i3( size( pexnref ) ) )
-allocate( gnegt( size( pexnref, 1 ), size( pexnref, 2 ), size( pexnref, 3 ) ) )
-allocate( zw ( size( pexnref, 1 ), size( pexnref, 2 ), size( pexnref, 3 ) ) )
+JIU = size(PEXNREF, 1 )
+JJU = size(PEXNREF, 2 )
+JKU = size(PEXNREF, 3 )
+JIJKU = JIU * JJU * JKU
-!$acc data create( i1, i2, i3, gnegt, zw )
+#ifndef MNH_OPENACC
+allocate( i1( JIJKU ) )
+allocate( i2( JIJKU ) )
+allocate( i3( JIJKU ) )
+allocate( gnegt( JIU,JJU,JKU ) )
+allocate( zw ( JIU,JJU,JKU ) )
+#else
+II1 = MNH_ALLOCATE_IT1D( i1, JIJKU )
+II2 = MNH_ALLOCATE_IT1D( i2, JIJKU )
+II3 = MNH_ALLOCATE_IT1D( i3, JIJKU )
+IGNEGT = MNH_ALLOCATE_GT3D( gnegt, JIU,JJU,JKU )
+IZW = MNH_ALLOCATE_ZT3D( zw , JIU,JJU,JKU )
+#endif
+
+!$acc data present( i1, i2, i3, gnegt, zw )
if ( lbudget_th ) call Budget_store_init( tbudgets(NBUDGET_TH), 'HENU', pths(:, :, :) * prhodj(:, :, :) )
if ( lbudget_rv ) call Budget_store_init( tbudgets(NBUDGET_RV), 'HENU', prvs(:, :, :) * prhodj(:, :, :) )
@@ -141,7 +176,10 @@ if ( lbudget_ri ) call Budget_store_init( tbudgets(NBUDGET_RI), 'HENU', pris(:,
#ifndef MNH_BITREP
PT(:,:,:) = PTHT(:,:,:) * ( PPABST(:,:,:) / XP00 ) ** ( XRD / XCPD )
#else
-PT(:,:,:) = PTHT(:,:,:) * BR_POW( PPABST(:,:,:) / XP00, XRD / XCPD )
+!$acc loop independent collapse(3)
+DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ PT(JI,JJ,JK) = PTHT(JI,JJ,JK) * BR_POW( PPABST(JI,JJ,JK) / XP00, XRD / XCPD )
+END DO
#endif
!
! optimization by looking for locations where
@@ -156,73 +194,122 @@ INEGT = COUNTJV( GNEGT(:,:,:),I1(:),I2(:),I3(:))
CALL COUNTJV_DEVICE(GNEGT(:,:,:),I1(:),I2(:),I3(:),INEGT)
#endif
IF( INEGT >= 1 ) THEN
- ALLOCATE(ZRVT(INEGT)) ;
- ALLOCATE(ZCIT(INEGT)) ;
- ALLOCATE(ZZT(INEGT)) ;
- ALLOCATE(ZPRES(INEGT));
+#ifndef MNH_OPENACC
+ ALLOCATE(ZRVT(INEGT))
+ ALLOCATE(ZCIT(INEGT))
+ ALLOCATE(ZZT(INEGT))
+ ALLOCATE(ZPRES(INEGT))
ALLOCATE(ZZW(INEGT))
ALLOCATE(ZUSW(INEGT))
ALLOCATE(ZSSI(INEGT))
-!$acc data create( zrvt, zcit, zzt, zpres, zzw, zusw, zssi )
+#else
+ IZRVT = MNH_ALLOCATE_ZT1DP(ZRVT,INEGT)
+ IZCIT = MNH_ALLOCATE_ZT1DP(ZCIT,INEGT)
+ IZZT = MNH_ALLOCATE_ZT1DP(ZZT,INEGT)
+ IZPRES = MNH_ALLOCATE_ZT1DP(ZPRES,INEGT)
+ IZZW = MNH_ALLOCATE_ZT1DP(ZZW,INEGT)
+ IZUSW = MNH_ALLOCATE_ZT1DP(ZUSW,INEGT)
+ IZSSI = MNH_ALLOCATE_ZT1DP(ZSSI,INEGT)
+#endif
+
+!$acc data present( zrvt, zcit, zzt, zpres, zzw, zusw, zssi )
-!$acc kernels
- DO JL=1,INEGT
+ !$acc kernels
+ !$acc loop independent
+ DO CONCURRENT ( JL=1:INEGT )
ZRVT(JL) = PRVT (I1(JL),I2(JL),I3(JL))
ZCIT(JL) = PCIT (I1(JL),I2(JL),I3(JL))
ZZT(JL) = PT (I1(JL),I2(JL),I3(JL))
ZPRES(JL) = PPABST(I1(JL),I2(JL),I3(JL))
ENDDO
#ifndef MNH_BITREP
- ZZW(1:INEGT) = EXP( XALPI - XBETAI/ZZT(1:INEGT) - XGAMI*ALOG(ZZT(1:INEGT) ) ) ! es_i
+ !$acc loop independent
+ DO CONCURRENT ( JL=1:INEGT )
+ ZZW(JL) = EXP( XALPI - XBETAI/ZZT(JL) - XGAMI*BR_LOG(ZZT(JL) ) ) ! es_i
+ END DO
#else
- ZZW(1:INEGT) = BR_EXP( XALPI - XBETAI/ZZT(1:INEGT) - XGAMI*BR_LOG(ZZT(1:INEGT) ) ) ! es_i
+ !$acc loop independent
+ DO CONCURRENT ( JL=1:INEGT )
+ ZZW(JL) = BR_EXP( XALPI - XBETAI/ZZT(JL) - XGAMI*BR_LOG(ZZT(JL) ) ) ! es_i
+ END DO
#endif
- ZZW(1:INEGT) = MIN(ZPRES(1:INEGT)/2., ZZW(1:INEGT)) ! safety limitation
- ZSSI(1:INEGT) = ZRVT(1:INEGT)*( ZPRES(1:INEGT)-ZZW(1:INEGT) ) / ( (XMV/XMD) * ZZW(1:INEGT) ) - 1.0
- ! Supersaturation over ice
+ !$acc loop independent
+ DO CONCURRENT ( JL=1:INEGT )
+ ZZW(JL) = MIN(ZPRES(JL)/2., ZZW(JL)) ! safety limitation
+ ZSSI(JL) = ZRVT(JL)*( ZPRES(JL)-ZZW(JL) ) / ( (XMV/XMD) * ZZW(JL) ) - 1.0
+ ! Supersaturation over ice
+ END DO
#ifndef MNH_BITREP
- ZUSW(1:INEGT) = EXP( XALPW - XBETAW/ZZT(1:INEGT) - XGAMW*ALOG(ZZT(1:INEGT) ) ) ! es_w
+ !$acc loop independent
+ DO CONCURRENT ( JL=1:INEGT )
+ ZUSW(JL) = EXP( XALPW - XBETAW/ZZT(JL) - XGAMW*BR_LOG(ZZT(JL) ) ) ! es_w
+ ZUSW(JL) = MIN(ZPRES(JL)/2.,ZUSW(JL)) ! safety limitation
+ ZUSW(JL) = ( ZUSW(JL)/ZZW(JL) )*( (ZPRES(JL)-ZZW(JL))/(ZPRES(JL)-ZUSW(JL)) ) - 1.0
+ ! Supersaturation of saturated water vapor over ice
+ END DO
#else
- ZUSW(1:INEGT) = BR_EXP( XALPW - XBETAW/ZZT(1:INEGT) - XGAMW*BR_LOG(ZZT(1:INEGT) ) ) ! es_w
-#endif
- ZUSW(1:INEGT) = MIN(ZPRES(1:INEGT)/2.,ZUSW(1:INEGT)) ! safety limitation
- ZUSW(1:INEGT) = ( ZUSW(1:INEGT)/ZZW(1:INEGT) )*( (ZPRES(1:INEGT)-ZZW(1:INEGT))/(ZPRES(1:INEGT)-ZUSW(1:INEGT)) ) - 1.0
- ! Supersaturation of saturated water vapor over ice
+ !$acc loop independent
+ DO CONCURRENT ( JL=1:INEGT )
+ ZUSW(JL) = BR_EXP( XALPW - XBETAW/ZZT(JL) - XGAMW*BR_LOG(ZZT(JL) ) ) ! es_w
+ ZUSW(JL) = MIN(ZPRES(JL)/2.,ZUSW(JL)) ! safety limitation
+ ZUSW(JL) = ( ZUSW(JL)/ZZW(JL) )*( (ZPRES(JL)-ZZW(JL))/(ZPRES(JL)-ZUSW(JL)) ) - 1.0
+ ! Supersaturation of saturated water vapor over ice
+ END DO
+#endif
!
!* 3.1 compute the heterogeneous nucleation source: RVHENI
!
!* 3.1.1 compute the cloud ice concentration
!
- ZZW(1:INEGT) = 0.0
- ZSSI(1:INEGT) = MIN( ZSSI(1:INEGT), ZUSW(1:INEGT) ) ! limitation of SSi according to SSw=0
- WHERE( (ZZT(1:INEGT)<XTT-5.0) .AND. (ZSSI(1:INEGT)>0.0) )
+!$acc loop independent
+DO CONCURRENT ( JL=1:INEGT )
+ ZZW(JL) = 0.0
+ ZSSI(JL) = MIN( ZSSI(JL), ZUSW(JL) ) ! limitation of SSi according to SSw=0
+ IF ( (ZZT(JL)<XTT-5.0) .AND. (ZSSI(JL)>0.0) ) THEN
#ifndef MNH_BITREP
- ZZW(1:INEGT) = XNU20 * EXP( XALPHA2*ZSSI(1:INEGT)-XBETA2 )
+ ZZW(JL) = XNU20 * EXP( XALPHA2*ZSSI(JL)-XBETA2 )
#else
- ZZW(1:INEGT) = XNU20 * BR_EXP( XALPHA2*ZSSI(1:INEGT)-XBETA2 )
+ ZZW(JL) = XNU20 * BR_EXP( XALPHA2*ZSSI(JL)-XBETA2 )
#endif
- END WHERE
- WHERE( (ZZT(1:INEGT)<=XTT-2.0) .AND. (ZZT(1:INEGT)>=XTT-5.0) .AND. (ZSSI(1:INEGT)>0.0) )
+ END IF
+END DO
#ifndef MNH_BITREP
- ZZW(1:INEGT) = MAX( XNU20 * EXP( -XBETA2 ),XNU10 * EXP( -XBETA1*(ZZT(1:INEGT)-XTT) ) * &
- ( ZSSI(1:INEGT)/ZUSW(1:INEGT) )**XALPHA1 )
+ !$acc loop independent
+ DO CONCURRENT ( JL=1:INEGT )
+ IF ( (ZZT(JL)<=XTT-2.0) .AND. (ZZT(JL)>=XTT-5.0) .AND. (ZSSI(JL)>0.0) ) THEN
+ ZZW(JL) = MAX( XNU20 * EXP( -XBETA2 ),XNU10 * EXP( -XBETA1*(ZZT(JL)-XTT) ) * &
+ ( ZSSI(JL)/ZUSW(JL) )**XALPHA1 )
+ END IF
+ END DO ! CONCURRENT
#else
- ZZW(1:INEGT) = MAX( XNU20 * BR_EXP( -XBETA2 ),XNU10 * BR_EXP( -XBETA1*(ZZT(1:INEGT)-XTT) ) * &
- BR_POW( ZSSI(1:INEGT)/ZUSW(1:INEGT),XALPHA1 ) )
+ !$acc loop independent
+ DO CONCURRENT ( JL=1:INEGT )
+ IF ( (ZZT(JL)<=XTT-2.0) .AND. (ZZT(JL)>=XTT-5.0) .AND. (ZSSI(JL)>0.0) ) THEN
+ ZZW(JL) = MAX( XNU20 * BR_EXP( -XBETA2 ),XNU10 * BR_EXP( -XBETA1*(ZZT(JL)-XTT) ) * &
+ BR_POW( ZSSI(JL)/ZUSW(JL),XALPHA1 ) )
+ END IF
+ END DO ! CONCURRENT
#endif
- END WHERE
- ZZW(1:INEGT) = ZZW(1:INEGT) - ZCIT(1:INEGT)
+ ! WARNING COMPILER BUG NVHPC20.X/3 <-> if array syntaxe ZZW(1:INEGT) = ZZW(1:INEGT)
+ !$acc loop independent
+ DO CONCURRENT ( JL=1:INEGT )
+ ZZW(JL) = ZZW(JL) - ZCIT(JL)
+ END DO
ZZWMAX = MAXVAL(ZZW(1:INEGT))
!$acc end kernels
-!$acc kernels
+
IF( ZZWMAX > 0.0 ) THEN
+ !$acc kernels
!
!* 3.1.2 update the r_i and r_v mixing ratios
-!
- ZZW(1:INEGT) = MIN( ZZW(1:INEGT),50.E3 ) ! limitation provisoire a 50 l^-1
+ !
+ !$acc loop independent
+ DO CONCURRENT ( JL=1:INEGT )
+ ZZW(JL) = MIN( ZZW(JL),50.E3 ) ! limitation provisoire a 50 l^-1
+ END DO
ZW(:,:,:) = 0.0
-!$acc loop independent
- DO JL=1, INEGT
+ !$acc loop independent
+ DO CONCURRENT ( JL=1:INEGT )
ZW(I1(JL), I2(JL), I3(JL)) = ZZW( JL )
END DO
ZW(:,:,:) = MAX( ZW(:,:,:) ,0.0 ) *XMNU0/(PRHODREF(:,:,:)*PTSTEP)
@@ -238,16 +325,21 @@ IF( INEGT >= 1 ) THEN
+ XCI*(PRIT(:,:,:)+PRST(:,:,:)+PRGT(:,:,:)))*PEXNREF(:,:,:) )
END IF
! f(L_s*(RVHENI))
- ZZW(1:INEGT) = MAX( ZZW(1:INEGT)+ZCIT(1:INEGT),ZCIT(1:INEGT) )
+ !$acc loop independent
+ DO CONCURRENT ( JL=1:INEGT )
+ ZZW(JL) = MAX( ZZW(JL)+ZCIT(JL),ZCIT(JL) )
+ END DO
PCIT(:,:,:) = MAX( PCIT(:,:,:), 0.0 )
-!$acc loop independent
- DO JL = 1, INEGT
+ !$acc loop independent
+ DO CONCURRENT ( JL=1:INEGT )
PCIT(I1(JL), I2(JL), I3(JL)) = MAX( ZZW( JL ), PCIT(I1(JL), I2(JL), I3(JL)), 0.0 )
- END DO
- END IF
-!$acc end kernels
+ END DO
+ !$acc end kernels
+END IF
!$acc end data
+
+#ifndef MNH_OPENACC
DEALLOCATE(ZSSI)
DEALLOCATE(ZUSW)
DEALLOCATE(ZZW)
@@ -255,6 +347,10 @@ IF( INEGT >= 1 ) THEN
DEALLOCATE(ZZT)
DEALLOCATE(ZCIT)
DEALLOCATE(ZRVT)
+#else
+ CALL MNH_REL_ZT1D(izrvt, izcit, izzt, izpres, izzw, izusw, izssi)
+#endif
+
END IF
!
!* 3.1.3 budget storage
@@ -273,6 +369,13 @@ IF (MPPDB_INITIALIZED) THEN
CALL MPPDB_CHECK(PT,"RAIN_ICE_NUCLEATION end:PT")
END IF
+#ifndef MNH_OPENACC
+deallocate (i1, i2, i3, gnegt, zw )
+#else
+CALL MNH_REL_IT1D(ii1, ii2, ii3)
+CALL MNH_REL_GT3D(IGNEGT)
+CALL MNH_REL_ZT3D(IZW)
+#endif
!$acc end data
!$acc end data
diff --git a/src/MNH/rain_ice_sedimentation_split.f90 b/src/MNH/rain_ice_sedimentation_split.f90
index b826e9f75fa1bd0f5a6e983b4bd02ff2a4a8ed21..8fdf9a95d5a843f4e719e357e34e5d64de7e31f2 100644
--- a/src/MNH/rain_ice_sedimentation_split.f90
+++ b/src/MNH/rain_ice_sedimentation_split.f90
@@ -51,6 +51,12 @@ use mode_tools, only: Countjv_device
USE MODI_BITREP
#endif
+#ifdef MNH_OPENACC
+USE MODE_MNH_ZWORK , ONLY : MNH_ALLOCATE_ZT3D , MNH_ALLOCATE_ZT2D, MNH_REL_ZT3D, MNH_ALLOCATE_ZT1DP , MNH_REL_ZT1D , &
+ MNH_ALLOCATE_GT3D , MNH_ALLOCATE_GT2D, MNH_REL_GT3D, &
+ MNH_ALLOCATE_IT1D , MNH_REL_IT1D
+#endif
+
IMPLICIT NONE
!
!* 0.1 Declarations of dummy arguments :
@@ -99,21 +105,32 @@ INTEGER :: ISEDIMR, ISEDIMC, ISEDIMI, ISEDIMS, IS
INTEGER :: JI, JJ, JK ! Loop indices on grid
INTEGER :: JN ! Temporal loop index for the rain sedimentation
INTEGER :: JL
-INTEGER, DIMENSION(:), ALLOCATABLE :: IC1, IC2, IC3 ! Used to replace the COUNT
-INTEGER, DIMENSION(:), ALLOCATABLE :: IR1, IR2, IR3 ! Used to replace the COUNT
-INTEGER, DIMENSION(:), ALLOCATABLE :: IS1, IS2, IS3 ! Used to replace the COUNT
-INTEGER, DIMENSION(:), ALLOCATABLE :: II1, II2, II3 ! Used to replace the COUNT
-INTEGER, DIMENSION(:), ALLOCATABLE :: IG1, IG2, IG3 ! Used to replace the COUNT
-INTEGER, DIMENSION(:), ALLOCATABLE :: IH1, IH2, IH3 ! Used to replace the COUNT
+INTEGER, DIMENSION(:), POINTER, CONTIGUOUS :: IC1, IC2, IC3 ! Used to replace the COUNT
+INTEGER, DIMENSION(:), POINTER, CONTIGUOUS :: IR1, IR2, IR3 ! Used to replace the COUNT
+INTEGER, DIMENSION(:), POINTER, CONTIGUOUS :: IS1, IS2, IS3 ! Used to replace the COUNT
+#ifdef MNH_OPENACC
+INTEGER :: IIC1, IIC2, IIC3, IIR1, IIR2, IIR3, IIS1, IIS2, IIS3
+#endif
+INTEGER, DIMENSION(:), POINTER, CONTIGUOUS :: II1, II2, II3 ! Used to replace the COUNT
+INTEGER, DIMENSION(:), POINTER, CONTIGUOUS :: IG1, IG2, IG3 ! Used to replace the COUNT
+INTEGER, DIMENSION(:), POINTER, CONTIGUOUS :: IH1, IH2, IH3 ! Used to replace the COUNT
+#ifdef MNH_OPENACC
+INTEGER :: III1, III2, III3, IIG1, IIG2, IIG3, IIH1, IIH2, IIH3
+#endif
+
LOGICAL :: GPRESENT_PFPR, GPRESENT_PSEA
-LOGICAL, DIMENSION(:,:), ALLOCATABLE :: GDEP
-LOGICAL, DIMENSION(:,:,:), ALLOCATABLE :: GSEDIMR, GSEDIMC, GSEDIMI, GSEDIMS, GSEDIMG, GSEDIMH ! Where to compute the SED processes
+LOGICAL, DIMENSION(:,:), POINTER, CONTIGUOUS :: GDEP
+LOGICAL, DIMENSION(:,:,:), POINTER, CONTIGUOUS :: GSEDIMR, GSEDIMC, GSEDIMI, GSEDIMS, GSEDIMG, GSEDIMH ! Where to compute the SED processes
+#ifdef MNH_OPENACC
+INTEGER :: IGDEP,IGSEDIMR, IGSEDIMC, IGSEDIMI, IGSEDIMS, IGSEDIMG, IGSEDIMH
+#endif
REAL :: ZINVTSTEP
REAL :: ZTSPLITR ! Small time step for rain sedimentation
REAL :: ZTMP1, ZTMP2, ZTMP3 ! Intermediate variables
REAL :: ZRHODREFLOC ! RHO Dry REFerence
REAL :: ZRSLOC, ZRTLOC ! Intermediate variables
-REAL, DIMENSION(:), ALLOCATABLE :: ZRTMIN
+REAL, DIMENSION(:), POINTER, CONTIGUOUS :: ZRTMIN
+
! XRTMIN = Minimum value for the mixing ratio
! ZRTMIN = Minimum value for the source (tendency)
REAL :: ZCC, & ! terminal velocity
@@ -124,15 +141,24 @@ REAL :: ZCC, & ! terminal velocity
ZWLBDA, & ! Free mean path
ZZT, & ! Temperature
ZPRES ! Pressure
-REAL, DIMENSION(:,:), ALLOCATABLE :: ZCONC_TMP ! Weighted concentration
-REAL, DIMENSION(:,:,:), ALLOCATABLE :: ZCONC3D ! Doplet condensation
-REAL, DIMENSION(:,:), ALLOCATABLE :: ZOMPSEA,ZTMP1_2D,ZTMP2_2D,ZTMP3_2D,ZTMP4_2D !Work arrays
-REAL, DIMENSION(:,:,:), ALLOCATABLE :: ZRAY, & ! Cloud Mean radius
+REAL, DIMENSION(:,:), POINTER, CONTIGUOUS :: ZCONC_TMP ! Weighted concentration
+REAL, DIMENSION(:,:,:), POINTER, CONTIGUOUS :: ZCONC3D ! Doplet condensation
+REAL, DIMENSION(:,:), POINTER, CONTIGUOUS :: ZOMPSEA,ZTMP1_2D,ZTMP2_2D,ZTMP3_2D,ZTMP4_2D !Work arrays
+REAL, DIMENSION(:,:,:), POINTER, CONTIGUOUS :: ZRAY, & ! Cloud Mean radius
ZLBC, & ! XLBC weighted by sea fraction
ZFSEDC
-REAL, DIMENSION(:,:,:), ALLOCATABLE :: ZPRCS,ZPRRS,ZPRSS,ZPRGS,ZPRHS ! Mixing ratios created during the time step
-REAL, DIMENSION(:,:,:), ALLOCATABLE :: ZW ! Work array
-REAL, DIMENSION(:,:,:), ALLOCATABLE :: ZWSED ! sedimentation fluxes
+#ifdef MNH_OPENACC
+INTEGER :: IZCONC_TMP,IZCONC3D,IZOMPSEA,IZTMP1_2D,IZTMP2_2D,IZTMP3_2D,IZTMP4_2D,IZRAY,IZLBC,IZFSEDC
+#endif
+
+REAL, DIMENSION(:,:,:), POINTER, CONTIGUOUS :: ZPRCS,ZPRRS,ZPRSS,ZPRGS,ZPRHS ! Mixing ratios created during the time step
+REAL, DIMENSION(:,:,:), POINTER, CONTIGUOUS :: ZW ! Work array
+REAL, DIMENSION(:,:,:), POINTER, CONTIGUOUS :: ZWSED ! sedimentation fluxes
+#ifdef MNH_OPENACC
+INTEGER :: IZPRCS,IZPRRS,IZPRSS,IZPRGS,IZPRHS,IZW,IZWSED
+#endif
+
+INTEGER :: IIU,IJU,IKU, IIJKU
!
!-------------------------------------------------------------------------------
!
@@ -176,45 +202,103 @@ IF (MPPDB_INITIALIZED) THEN
CALL MPPDB_CHECK(PRGS,"RAIN_ICE_SEDIMENTATION_SPLIT beg:PRGS")
IF (PRESENT(PRHS)) CALL MPPDB_CHECK(PRHS,"RAIN_ICE_SEDIMENTATION_SPLIT beg:PRHS")
END IF
+
+IIU = size(PRCS, 1 )
+IJU = size(PRCS, 2 )
+IKU = size(PRCS, 3 )
+IIJKU = IIU * IJU * IKU
+
!
-ALLOCATE( IC1(size(PRCS)), IC2(size(PRCS)), IC3(size(PRCS)) )
-ALLOCATE( IR1(size(PRCS)), IR2(size(PRCS)), IR3(size(PRCS)) )
-ALLOCATE( IS1(size(PRCS)), IS2(size(PRCS)), IS3(size(PRCS)) )
-ALLOCATE( II1(size(PRCS)), II2(size(PRCS)), II3(size(PRCS)) )
-ALLOCATE( IG1(size(PRCS)), IG2(size(PRCS)), IG3(size(PRCS)) )
-ALLOCATE( IH1(size(PRCS)), IH2(size(PRCS)), IH3(size(PRCS)) )
-ALLOCATE( GDEP(SIZE(PRCS,1),SIZE(PRCS,2)) )
-ALLOCATE( GSEDIMR(SIZE(PRCS,1),SIZE(PRCS,2),SIZE(PRCS,3)) )
-ALLOCATE( GSEDIMC(SIZE(PRCS,1),SIZE(PRCS,2),SIZE(PRCS,3)) )
-ALLOCATE( GSEDIMI(SIZE(PRCS,1),SIZE(PRCS,2),SIZE(PRCS,3)) )
-ALLOCATE( GSEDIMS(SIZE(PRCS,1),SIZE(PRCS,2),SIZE(PRCS,3)) )
-ALLOCATE( GSEDIMG(SIZE(PRCS,1),SIZE(PRCS,2),SIZE(PRCS,3)) )
-ALLOCATE( GSEDIMH(SIZE(PRCS,1),SIZE(PRCS,2),SIZE(PRCS,3)) )
+#ifndef MNH_OPENACC
+ALLOCATE( IC1(IIJKU), IC2(IIJKU), IC3(IIJKU) )
+ALLOCATE( IR1(IIJKU), IR2(IIJKU), IR3(IIJKU) )
+ALLOCATE( IS1(IIJKU), IS2(IIJKU), IS3(IIJKU) )
+ALLOCATE( II1(IIJKU), II2(IIJKU), II3(IIJKU) )
+ALLOCATE( IG1(IIJKU), IG2(IIJKU), IG3(IIJKU) )
+ALLOCATE( IH1(IIJKU), IH2(IIJKU), IH3(IIJKU) )
+#else
+IIC1 = MNH_ALLOCATE_IT1D(IC1,IIJKU)
+IIC2 = MNH_ALLOCATE_IT1D(IC2,IIJKU)
+IIC3 = MNH_ALLOCATE_IT1D(IC3,IIJKU)
+IIR1 = MNH_ALLOCATE_IT1D(IR1,IIJKU)
+IIR2 = MNH_ALLOCATE_IT1D(IR2,IIJKU)
+IIR3 = MNH_ALLOCATE_IT1D(IR3,IIJKU)
+IIS1 = MNH_ALLOCATE_IT1D(IS1,IIJKU)
+IIS2 = MNH_ALLOCATE_IT1D(IS2,IIJKU)
+IIS3 = MNH_ALLOCATE_IT1D(IS3,IIJKU)
+III1 = MNH_ALLOCATE_IT1D(II1,IIJKU)
+III2 = MNH_ALLOCATE_IT1D(II2,IIJKU)
+III3 = MNH_ALLOCATE_IT1D(II3,IIJKU)
+IIG1 = MNH_ALLOCATE_IT1D(IG1,IIJKU)
+IIG2 = MNH_ALLOCATE_IT1D(IG2,IIJKU)
+IIG3 = MNH_ALLOCATE_IT1D(IG3,IIJKU)
+IIH1 = MNH_ALLOCATE_IT1D(IH1,IIJKU)
+IIH2 = MNH_ALLOCATE_IT1D(IH2,IIJKU)
+IIH3 = MNH_ALLOCATE_IT1D(IH3,IIJKU)
+#endif
+#ifndef MNH_OPENACC
+ALLOCATE( GDEP(IIU,IJU) )
+ALLOCATE( GSEDIMR(IIU,IJU,IKU) )
+ALLOCATE( GSEDIMC(IIU,IJU,IKU) )
+ALLOCATE( GSEDIMI(IIU,IJU,IKU) )
+ALLOCATE( GSEDIMS(IIU,IJU,IKU) )
+ALLOCATE( GSEDIMG(IIU,IJU,IKU) )
+ALLOCATE( GSEDIMH(IIU,IJU,IKU) )
+#else
+IGDEP = MNH_ALLOCATE_GT2D( GDEP,IIU,IJU )
+IGSEDIMR = MNH_ALLOCATE_GT3D( GSEDIMR,IIU,IJU,IKU )
+IGSEDIMC = MNH_ALLOCATE_GT3D( GSEDIMC,IIU,IJU,IKU )
+IGSEDIMI = MNH_ALLOCATE_GT3D( GSEDIMI,IIU,IJU,IKU )
+IGSEDIMS = MNH_ALLOCATE_GT3D( GSEDIMS,IIU,IJU,IKU )
+IGSEDIMG = MNH_ALLOCATE_GT3D( GSEDIMG,IIU,IJU,IKU )
+IGSEDIMH = MNH_ALLOCATE_GT3D( GSEDIMH,IIU,IJU,IKU )
+#endif
ALLOCATE( ZRTMIN(SIZE(XRTMIN)) )
-ALLOCATE( ZCONC_TMP(SIZE(PRCS,1),SIZE(PRCS,2)) )
-ALLOCATE( ZOMPSEA (SIZE(PRCS,1),SIZE(PRCS,2)) )
-ALLOCATE( ZTMP1_2D (SIZE(PRCS,1),SIZE(PRCS,2)) )
-ALLOCATE( ZTMP2_2D (SIZE(PRCS,1),SIZE(PRCS,2)) )
-ALLOCATE( ZTMP3_2D (SIZE(PRCS,1),SIZE(PRCS,2)) )
-ALLOCATE( ZTMP4_2D (SIZE(PRCS,1),SIZE(PRCS,2)) )
-ALLOCATE( ZCONC3D(SIZE(PRCS,1),SIZE(PRCS,2),SIZE(PRCS,3)) )
-ALLOCATE( ZRAY (SIZE(PRCS,1),SIZE(PRCS,2),SIZE(PRCS,3)) )
-ALLOCATE( ZLBC (SIZE(PRCS,1),SIZE(PRCS,2),SIZE(PRCS,3)) )
-ALLOCATE( ZFSEDC (SIZE(PRCS,1),SIZE(PRCS,2),SIZE(PRCS,3)) )
-ALLOCATE( ZPRCS (SIZE(PRCS,1),SIZE(PRCS,2),SIZE(PRCS,3)) )
-ALLOCATE( ZPRRS (SIZE(PRCS,1),SIZE(PRCS,2),SIZE(PRCS,3)) )
-ALLOCATE( ZPRSS (SIZE(PRCS,1),SIZE(PRCS,2),SIZE(PRCS,3)) )
-ALLOCATE( ZPRGS (SIZE(PRCS,1),SIZE(PRCS,2),SIZE(PRCS,3)) )
-ALLOCATE( ZPRHS (SIZE(PRCS,1),SIZE(PRCS,2),SIZE(PRCS,3)) )
-ALLOCATE( ZW (SIZE(PRCS,1),SIZE(PRCS,2),SIZE(PRCS,3)) )
-ALLOCATE( ZWSED (SIZE(PRCS,1),SIZE(PRCS,2),0:SIZE(PRCS,3)+1) )
-
-!$acc data create( IC1, IC2, IC3, IR1, IR2, IR3, IS1, IS2, IS3, II1, II2, II3, IG1, IG2, IG3, IH1, IH2, IH3, &
-!$acc & GDEP, GSEDIMR, GSEDIMC, GSEDIMI, GSEDIMS, GSEDIMG, GSEDIMH, &
-!$acc & ZRTMIN, ZCONC_TMP, &
+#ifndef MNH_OPENACC
+ALLOCATE( ZCONC_TMP(IIU,IJU) )
+ALLOCATE( ZOMPSEA (IIU,IJU) )
+ALLOCATE( ZTMP1_2D (IIU,IJU) )
+ALLOCATE( ZTMP2_2D (IIU,IJU) )
+ALLOCATE( ZTMP3_2D (IIU,IJU) )
+ALLOCATE( ZTMP4_2D (IIU,IJU) )
+ALLOCATE( ZCONC3D(IIU,IJU,IKU) )
+ALLOCATE( ZRAY (IIU,IJU,IKU) )
+ALLOCATE( ZLBC (IIU,IJU,IKU) )
+ALLOCATE( ZFSEDC (IIU,IJU,IKU) )
+ALLOCATE( ZPRCS (IIU,IJU,IKU) )
+ALLOCATE( ZPRRS (IIU,IJU,IKU) )
+ALLOCATE( ZPRSS (IIU,IJU,IKU) )
+ALLOCATE( ZPRGS (IIU,IJU,IKU) )
+ALLOCATE( ZPRHS (IIU,IJU,IKU) )
+ALLOCATE( ZW (IIU,IJU,IKU) )
+ALLOCATE( ZWSED (IIU,IJU,0:IKU+1) )
+#else
+IZCONC_TMP = MNH_ALLOCATE_ZT2D( ZCONC_TMP,IIU,IJU )
+IZOMPSEA = MNH_ALLOCATE_ZT2D( ZOMPSEA ,IIU,IJU )
+IZTMP1_2D = MNH_ALLOCATE_ZT2D( ZTMP1_2D ,IIU,IJU )
+IZTMP2_2D = MNH_ALLOCATE_ZT2D( ZTMP2_2D ,IIU,IJU )
+IZTMP3_2D = MNH_ALLOCATE_ZT2D( ZTMP3_2D ,IIU,IJU )
+IZTMP4_2D = MNH_ALLOCATE_ZT2D( ZTMP4_2D ,IIU,IJU )
+IZCONC3D = MNH_ALLOCATE_ZT3D( ZCONC3D,IIU,IJU,IKU )
+IZRAY = MNH_ALLOCATE_ZT3D( ZRAY ,IIU,IJU,IKU )
+IZLBC = MNH_ALLOCATE_ZT3D( ZLBC ,IIU,IJU,IKU )
+IZFSEDC = MNH_ALLOCATE_ZT3D( ZFSEDC ,IIU,IJU,IKU )
+IZPRCS = MNH_ALLOCATE_ZT3D( ZPRCS ,IIU,IJU,IKU )
+IZPRRS = MNH_ALLOCATE_ZT3D( ZPRRS ,IIU,IJU,IKU )
+IZPRSS = MNH_ALLOCATE_ZT3D( ZPRSS ,IIU,IJU,IKU )
+IZPRGS = MNH_ALLOCATE_ZT3D( ZPRGS ,IIU,IJU,IKU )
+IZPRHS = MNH_ALLOCATE_ZT3D( ZPRHS ,IIU,IJU,IKU )
+IZW = MNH_ALLOCATE_ZT3D( ZW ,IIU,IJU,IKU )
+ALLOCATE( ZWSED (IIU,IJU,0:IKU+1) )
+#endif
+
+!$acc data present( IC1, IC2, IC3, IR1, IR2, IR3, IS1, IS2, IS3, II1, II2, II3, IG1, IG2, IG3, IH1, IH2, IH3,&
+!$acc & GDEP, GSEDIMR, GSEDIMC, GSEDIMI, GSEDIMS, GSEDIMG, GSEDIMH ) &
+!$acc & create( ZRTMIN , ZWSED ) &
+!$acc & present(ZCONC_TMP, &
!$acc & ZOMPSEA, ZTMP1_2D, ZTMP2_2D, ZTMP3_2D, ZTMP4_2D, ZCONC3D, &
!$acc & ZRAY, ZLBC, ZFSEDC, &
-!$acc & ZPRCS, ZPRRS, ZPRSS, ZPRGS, ZPRHS, ZW, ZWSED )
+!$acc & ZPRCS, ZPRRS, ZPRSS, ZPRGS, ZPRHS, ZW )
IF ( PRESENT( PFPR ) ) THEN
GPRESENT_PFPR = .TRUE.
@@ -369,18 +453,21 @@ DO JN = 1 , KSPLITR
IF ( KRR == 7 ) PRHS(:,:,:) = PRHS(:,:,:) + ZPRHS(:,:,:) * ZTSPLITR
END IF
!
- IF ( OSEDIC ) GSEDIMC(KIB:KIE,KJB:KJE,KKTB:KKTE) = &
- PRCS(KIB:KIE,KJB:KJE,KKTB:KKTE) > ZRTMIN(2)
- GSEDIMR(KIB:KIE,KJB:KJE,KKTB:KKTE) = &
- PRRS(KIB:KIE,KJB:KJE,KKTB:KKTE) > ZRTMIN(3)
- GSEDIMI(KIB:KIE,KJB:KJE,KKTB:KKTE) = &
- PRIS(KIB:KIE,KJB:KJE,KKTB:KKTE) > ZRTMIN(4)
- GSEDIMS(KIB:KIE,KJB:KJE,KKTB:KKTE) = &
- PRSS(KIB:KIE,KJB:KJE,KKTB:KKTE) > ZRTMIN(5)
- GSEDIMG(KIB:KIE,KJB:KJE,KKTB:KKTE) = &
- PRGS(KIB:KIE,KJB:KJE,KKTB:KKTE) > ZRTMIN(6)
- IF ( KRR == 7 ) GSEDIMH(KIB:KIE,KJB:KJE,KKTB:KKTE) = &
- PRHS(KIB:KIE,KJB:KJE,KKTB:KKTE) > ZRTMIN(7)
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=KIB:KIE,JJ=KJB:KJE,JK=KKTB:KKTE )
+ IF ( OSEDIC ) GSEDIMC(JI,JJ,JK) = &
+ PRCS(JI,JJ,JK) > ZRTMIN(2)
+ GSEDIMR(JI,JJ,JK) = &
+ PRRS(JI,JJ,JK) > ZRTMIN(3)
+ GSEDIMI(JI,JJ,JK) = &
+ PRIS(JI,JJ,JK) > ZRTMIN(4)
+ GSEDIMS(JI,JJ,JK) = &
+ PRSS(JI,JJ,JK) > ZRTMIN(5)
+ GSEDIMG(JI,JJ,JK) = &
+ PRGS(JI,JJ,JK) > ZRTMIN(6)
+ IF ( KRR == 7 ) GSEDIMH(JI,JJ,JK) = &
+ PRHS(JI,JJ,JK) > ZRTMIN(7)
+ END DO ! CONCURRENT
!$acc end kernels
!
#ifndef MNH_OPENACC
@@ -673,6 +760,27 @@ END IF
!$acc end data
+#ifndef MNH_OPENACC
+DEALLOCATE(IC1, IC2, IC3, IR1, IR2, IR3, IS1, IS2, IS3, II1, II2, II3, IG1, IG2, IG3, IH1, IH2, IH3)
+#else
+CALL MNH_REL_IT1D(IIC1, IIC2, IIC3, IIR1, IIR2, IIR3, IIS1, IIS2, IIS3,&
+ III1, III2, III3, IIG1, IIG2, IIG3, IIH1, IIH2, IIH3)
+#endif
+#ifndef MNH_OPENACC
+DEALLOCATE(GDEP, GSEDIMR, GSEDIMC, GSEDIMI, GSEDIMS, GSEDIMG, GSEDIMH)
+#else
+CALL MNH_REL_GT3D(IGDEP, IGSEDIMR, IGSEDIMC, IGSEDIMI, IGSEDIMS, IGSEDIMG, IGSEDIMH)
+#endif
+DEALLOCATE(ZRTMIN)
+#ifndef MNH_OPENACC
+DEALLOCATE(ZCONC_TMP,ZOMPSEA, ZTMP1_2D, ZTMP2_2D, ZTMP3_2D, ZTMP4_2D, ZCONC3D)
+DEALLOCATE(ZRAY, ZLBC, ZFSEDC,ZPRCS, ZPRRS, ZPRSS, ZPRGS, ZPRHS, ZW)
+#else
+CALL MNH_REL_ZT3D(IZRAY, IZLBC, IZFSEDC,IZPRCS, IZPRRS, IZPRSS, IZPRGS, IZPRHS, IZW)
+CALL MNH_REL_ZT3D(IZCONC_TMP,IZOMPSEA, IZTMP1_2D, IZTMP2_2D, IZTMP3_2D, IZTMP4_2D, IZCONC3D)
+#endif
+DEALLOCATE(ZWSED)
+
!$acc end data
END SUBROUTINE RAIN_ICE_SEDIMENTATION_SPLIT
diff --git a/src/MNH/rain_ice_slow.f90 b/src/MNH/rain_ice_slow.f90
index 2e4375102be35f9325762b62c581de6d8dbb34ed..3f54aa8877adf7b4b9d4cca8750bdecaedc26119 100644
--- a/src/MNH/rain_ice_slow.f90
+++ b/src/MNH/rain_ice_slow.f90
@@ -80,6 +80,7 @@ REAL, DIMENSION(:), ALLOCATABLE :: ZCRIAUTI ! Snow-to-ice autoconversion thre
REAL, DIMENSION(:), ALLOCATABLE :: ZZW ! Work array
real, dimension(:), ALLOCATABLE :: zz_diff
!
+INTEGER :: JL,JLU
!-------------------------------------------------------------------------------
!
! IN variables
@@ -119,6 +120,8 @@ IF (MPPDB_INITIALIZED) THEN
CALL MPPDB_CHECK(PTHS,"RAIN_ICE_SLOW beg:PTHS")
END IF
!
+JLU = size(PRHODREF)
+!
ALLOCATE( GWORK (size(PRHODREF)) )
ALLOCATE( ZZW (size(PRHODREF)) )
ALLOCATE( ZCRIAUTI(size(PRHODREF)) )
@@ -212,33 +215,37 @@ ALLOCATE( zz_diff (size(PLSFACT)) )
!* 3.4.3 compute the deposition on r_s: RVDEPS
!
GWORK(:) = PRST(:)>0.0
- WHERE ( GWORK(:) )
-#ifndef MNH_BITREP
- PLBDAS(:) = MIN( XLBDAS_MAX, &
- XLBS*( PRHODREF(:)*MAX( PRST(:),XRTMIN(5) ) )**XLBEXS )
+ !$acc loop independent
+ DO CONCURRENT ( JL=1:JLU )
+ IF ( GWORK(JL) ) THEN
+ PLBDAS(JL) = MIN( XLBDAS_MAX, &
+#ifndef MNH_BITREP
+ XLBS*( PRHODREF(JL)*MAX( PRST(JL),XRTMIN(5) ) )**XLBEXS )
#else
- PLBDAS(:) = MIN( XLBDAS_MAX, &
- XLBS*BR_POW( PRHODREF(:)*MAX( PRST(:),XRTMIN(5) ),XLBEXS ) )
+ XLBS*BR_POW( PRHODREF(JL)*MAX( PRST(JL),XRTMIN(5) ),XLBEXS ) )
#endif
- ELSEWHERE
- PLBDAS(:) = 0.
- END WHERE
+ ELSE
+ PLBDAS(JL) = 0.
+ END IF
+ END DO ! CONCURRENT
ZZW(:) = 0.0
GWORK(:) = (PRST(:)>XRTMIN(5)) .AND. (PRSS(:)>0.0)
- WHERE ( GWORK(:) )
-#ifndef MNH_BITREP
- ZZW(:) = ( PSSI(:)/(PRHODREF(:)*PAI(:)) ) * &
- ( X0DEPS*PLBDAS(:)**XEX0DEPS + X1DEPS*PCJ(:)*PLBDAS(:)**XEX1DEPS )
+ !$acc loop independent
+ DO CONCURRENT ( JL=1:JLU )
+ IF ( GWORK(JL) ) THEN
+ ZZW(JL) = ( PSSI(JL)/(PRHODREF(JL)*PAI(JL)) ) * &
+#ifndef MNH_BITREP
+ ( X0DEPS*PLBDAS(JL)**XEX0DEPS + X1DEPS*PCJ(JL)*PLBDAS(JL)**XEX1DEPS )
#else
- ZZW(:) = ( PSSI(:)/(PRHODREF(:)*PAI(:)) ) * &
- ( X0DEPS*BR_POW(PLBDAS(:),XEX0DEPS) + X1DEPS*PCJ(:)*BR_POW(PLBDAS(:),XEX1DEPS) )
+ ( X0DEPS*BR_POW(PLBDAS(JL),XEX0DEPS) + X1DEPS*PCJ(JL)*BR_POW(PLBDAS(JL),XEX1DEPS) )
#endif
- ZZW(:) = MIN( PRVS(:),ZZW(:) )*(0.5+SIGN(0.5,ZZW(:))) &
- - MIN( PRSS(:),ABS(ZZW(:)) )*(0.5-SIGN(0.5,ZZW(:)))
- PRSS(:) = PRSS(:) + ZZW(:)
- PRVS(:) = PRVS(:) - ZZW(:)
- PTHS(:) = PTHS(:) + ZZW(:)*PLSFACT(:)
- END WHERE
+ ZZW(JL) = MIN( PRVS(JL),ZZW(JL) )*(0.5+SIGN(0.5,ZZW(JL))) &
+ - MIN( PRSS(JL),ABS(ZZW(JL)) )*(0.5-SIGN(0.5,ZZW(JL)))
+ PRSS(JL) = PRSS(JL) + ZZW(JL)
+ PRVS(JL) = PRVS(JL) - ZZW(JL)
+ PTHS(JL) = PTHS(JL) + ZZW(JL)*PLSFACT(JL)
+ END IF
+ END DO
!$acc end kernels
if ( lbudget_th ) call Budget_store_add( tbudgets(NBUDGET_TH), 'DEPS', &
@@ -253,21 +260,24 @@ ALLOCATE( zz_diff (size(PLSFACT)) )
!$acc kernels
ZZW(:) = 0.0
GWORK(:) = PRIT(:)>XRTMIN(4) .AND. PRST(:)>XRTMIN(5) .AND. PRIS(:)>0.0
- WHERE ( GWORK(:) )
-#ifndef MNH_BITREP
- ZZW(:) = MIN( PRIS(:),XFIAGGS * EXP( XCOLEXIS*(PZT(:)-XTT) ) &
- * PRIT(:) &
- * PLBDAS(:)**XEXIAGGS &
- * PRHODREF(:)**(-XCEXVT) )
+ !$acc loop independent
+ DO CONCURRENT ( JL=1:JLU )
+ IF ( GWORK(JL) ) THEN
+#ifndef MNH_BITREP
+ ZZW(JL) = MIN( PRIS(JL),XFIAGGS * EXP( XCOLEXIS*(PZT(JL)-XTT) ) &
+ * PRIT(JL) &
+ * PLBDAS(JL)**XEXIAGGS &
+ * PRHODREF(JL)**(-XCEXVT) )
#else
- ZZW(:) = MIN( PRIS(:),XFIAGGS * BR_EXP( XCOLEXIS*(PZT(:)-XTT) ) &
- * PRIT(:) &
- * BR_POW(PLBDAS(:),XEXIAGGS) &
- * BR_POW(PRHODREF(:),-XCEXVT) )
+ ZZW(JL) = MIN( PRIS(JL),XFIAGGS * BR_EXP( XCOLEXIS*(PZT(JL)-XTT) ) &
+ * PRIT(JL) &
+ * BR_POW(PLBDAS(JL),XEXIAGGS) &
+ * BR_POW(PRHODREF(JL),-XCEXVT) )
#endif
- PRSS(:) = PRSS(:) + ZZW(:)
- PRIS(:) = PRIS(:) - ZZW(:)
- END WHERE
+ PRSS(JL) = PRSS(JL) + ZZW(JL)
+ PRIS(JL) = PRIS(JL) - ZZW(JL)
+ END IF
+ END DO ! CONCURRENT
!$acc end kernels
if ( lbudget_ri ) call Budget_store_add( tbudgets(NBUDGET_RI), 'AGGS', &
@@ -308,31 +318,36 @@ ALLOCATE( zz_diff (size(PLSFACT)) )
!
!$acc kernels
GWORK(:) = PRGT(:)>0.0
- WHERE ( GWORK(:) )
-#ifndef MNH_BITREP
- PLBDAG(:) = XLBG*( PRHODREF(:)*MAX( PRGT(:),XRTMIN(6) ) )**XLBEXG
+ !$acc loop independent
+ DO CONCURRENT ( JL=1:JLU )
+ IF ( GWORK(JL) ) THEN
+#ifndef MNH_BITREP
+ PLBDAG(JL) = XLBG*( PRHODREF(JL)*MAX( PRGT(JL),XRTMIN(6) ) )**XLBEXG
#else
- PLBDAG(:) = XLBG*BR_POW( PRHODREF(:)*MAX( PRGT(:),XRTMIN(6) ), XLBEXG)
+ PLBDAG(JL) = XLBG*BR_POW( PRHODREF(JL)*MAX( PRGT(JL),XRTMIN(6) ), XLBEXG)
#endif
- ELSEWHERE
- PLBDAG(:) = 0.
- END WHERE
+ ELSE
+ PLBDAG(JL) = 0.
+ END IF
+ END DO ! CONCURRENT
ZZW(:) = 0.0
GWORK(:) = PRGT(:)>XRTMIN(6) .AND. PRGS(:)>0.0
- WHERE ( GWORK(:) )
-#ifndef MNH_BITREP
- ZZW(:) = ( PSSI(:)/(PRHODREF(:)*PAI(:)) ) * &
- ( X0DEPG*PLBDAG(:)**XEX0DEPG + X1DEPG*PCJ(:)*PLBDAG(:)**XEX1DEPG )
+ !$acc loop independent
+ DO CONCURRENT ( JL=1:JLU )
+ IF ( GWORK(JL) ) THEN
+ ZZW(JL) = ( PSSI(JL)/(PRHODREF(JL)*PAI(JL)) ) * &
+#ifndef MNH_BITREP
+ ( X0DEPG*PLBDAG(JL)**XEX0DEPG + X1DEPG*PCJ(JL)*PLBDAG(JL)**XEX1DEPG )
#else
- ZZW(:) = ( PSSI(:)/(PRHODREF(:)*PAI(:)) ) * &
- ( X0DEPG*BR_POW(PLBDAG(:),XEX0DEPG) + X1DEPG*PCJ(:)*BR_POW(PLBDAG(:),XEX1DEPG) )
+ ( X0DEPG*BR_POW(PLBDAG(JL),XEX0DEPG) + X1DEPG*PCJ(JL)*BR_POW(PLBDAG(JL),XEX1DEPG) )
#endif
- ZZW(:) = MIN( PRVS(:),ZZW(:) )*(0.5+SIGN(0.5,ZZW(:))) &
- - MIN( PRGS(:),ABS(ZZW(:)) )*(0.5-SIGN(0.5,ZZW(:)))
- PRGS(:) = PRGS(:) + ZZW(:)
- PRVS(:) = PRVS(:) - ZZW(:)
- PTHS(:) = PTHS(:) + ZZW(:)*PLSFACT(:)
- END WHERE
+ ZZW(JL) = MIN( PRVS(JL),ZZW(JL) )*(0.5+SIGN(0.5,ZZW(JL))) &
+ - MIN( PRGS(JL),ABS(ZZW(JL)) )*(0.5-SIGN(0.5,ZZW(JL)))
+ PRGS(JL) = PRGS(JL) + ZZW(JL)
+ PRVS(JL) = PRVS(JL) - ZZW(JL)
+ PTHS(JL) = PTHS(JL) + ZZW(JL)*PLSFACT(JL)
+ END IF
+ END DO ! CONCURRENT
!$acc end kernels
if ( lbudget_th ) call Budget_store_add( tbudgets(NBUDGET_TH), 'DEPG', &
diff --git a/src/MNH/rain_ice_warm.f90 b/src/MNH/rain_ice_warm.f90
index 714d6a9659894772ced2711f5cb1543de290b2ba..4dbce215476eab85e53f8c1e702e31136fb9678a 100644
--- a/src/MNH/rain_ice_warm.f90
+++ b/src/MNH/rain_ice_warm.f90
@@ -90,6 +90,8 @@ REAL, DIMENSION(:), ALLOCATABLE :: ZZW2 ! Work array
REAL, DIMENSION(:), ALLOCATABLE :: ZZW3 ! Work array
REAL, DIMENSION(:), ALLOCATABLE :: ZZW4 ! Work array
!
+INTEGER :: JLU
+!
!-------------------------------------------------------------------------------
!
! IN variables
@@ -140,6 +142,8 @@ IF (MPPDB_INITIALIZED) THEN
CALL MPPDB_CHECK(PEVAP3D,"RAIN_ICE_WARM beg:PEVAP3D")
END IF
!
+JLU = size(PRHODREF)
+!
ALLOCATE( GWORK(size(PRHODREF)) )
ALLOCATE( ZZW (size(PRHODREF)) )
ALLOCATE( ZZW2 (size(PRHODREF)) )
@@ -173,20 +177,21 @@ ALLOCATE( ZZW4 (size(PRHODREF)) )
!$acc kernels
!CLoud water and rain are diluted over the grid box
GWORK(:) = PRCT(:)>XRTMIN(2) .AND. PRRT(:)>XRTMIN(3) .AND. PRCS(:)>0.0
- WHERE( GWORK(:) )
-#ifndef MNH_BITREP
- ZZW(:) = MIN( PRCS(:), XFCACCR * PRCT(:) &
- * PLBDAR(:)**XEXCACCR &
- * PRHODREF(:)**(-XCEXVT) )
+ !$acc loop independent
+ DO CONCURRENT ( JL=1:JLU )
+ IF ( GWORK(JL) ) THEN
+ ZZW(JL) = MIN( PRCS(JL), XFCACCR * PRCT(JL) &
+#ifndef MNH_BITREP
+ * PLBDAR(JL)**XEXCACCR &
+ * PRHODREF(JL)**(-XCEXVT) )
#else
- ZZW(:) = MIN( PRCS(:), XFCACCR * PRCT(:) &
- * BR_POW(PLBDAR(:),XEXCACCR) &
- * BR_POW(PRHODREF(:),-XCEXVT) )
-
+ * BR_POW(PLBDAR(JL),XEXCACCR) &
+ * BR_POW(PRHODREF(JL),-XCEXVT) )
#endif
- PRCS(:) = PRCS(:) - ZZW(:)
- PRRS(:) = PRRS(:) + ZZW(:)
- END WHERE
+ PRCS(JL) = PRCS(JL) - ZZW(JL)
+ PRRS(JL) = PRRS(JL) + ZZW(JL)
+ END IF
+ END DO ! CONCURRENT
!$acc end kernels
ELSEIF (CSUBG_RC_RR_ACCR=='PRFR') THEN
@@ -203,38 +208,42 @@ ALLOCATE( ZZW4 (size(PRHODREF)) )
! => min(PCF, PRF)-PHLC_HCF
ZZW(:) = 0.
GWORK(:) = PHLC_HRC(:)>XRTMIN(2) .AND. PRRT(:)>XRTMIN(3) .AND. PRCS(:)>0.0 .AND. PHLC_HCF(:)>0
- WHERE( GWORK(:) )
- !Accretion due to rain falling in high cloud content
-#ifndef MNH_BITREP
- ZZW(:) = XFCACCR * ( PHLC_HRC(:)/PHLC_HCF(:) ) &
- * PLBDAR_RF(:)**XEXCACCR &
- * PRHODREF(:)**(-XCEXVT) &
- * PHLC_HCF
+ !$acc loop independent
+ DO CONCURRENT ( JL=1:JLU )
+ IF ( GWORK(JL) ) THEN
+ !Accretion due to rain falling in high cloud content
+ ZZW(JL) = XFCACCR * ( PHLC_HRC(JL)/PHLC_HCF(JL) ) &
+#ifndef MNH_BITREP
+ * PLBDAR_RF(JL)**XEXCACCR &
+ * PRHODREF(JL)**(-XCEXVT) &
#else
- ZZW(:) = XFCACCR * ( PHLC_HRC(:)/PHLC_HCF(:) ) &
- * BR_POW(PLBDAR_RF(:),XEXCACCR) &
- * BR_POW(PRHODREF(:),-XCEXVT) &
- * PHLC_HCF
+ * BR_POW(PLBDAR_RF(JL),XEXCACCR) &
+ * BR_POW(PRHODREF(JL),-XCEXVT) &
#endif
- END WHERE
- GWORK(:) = PHLC_LRC(:)>XRTMIN(2) .AND. PRRT(:)>XRTMIN(3) .AND. PRCS(:)>0.0 .AND. PHLC_LCF(:)>0
- WHERE( GWORK(:) )
+ * PHLC_HCF(JL)
+ END IF
+ END DO ! CONCURRENT
+ GWORK(:) = PHLC_LRC(:)>XRTMIN(2) .AND. PRRT(:)>XRTMIN(3) .AND. PRCS(:)>0.0 .AND. PHLC_LCF(:)>0
+ !$acc loop independent
+ DO CONCURRENT ( JL=1:JLU )
+ IF ( GWORK(JL) ) THEN
!We add acrretion due to rain falling in low cloud content
#ifndef MNH_BITREP
- ZZW(:) = ZZW(:) + XFCACCR * ( PHLC_LRC(:)/PHLC_LCF(:) ) &
- * PLBDAR_RF(:)**XEXCACCR &
- * PRHODREF(:)**(-XCEXVT) &
- * (MIN(PCF(:), PRF(:))-PHLC_HCF(:))
+ ZZW(JL) = ZZW(JL) + XFCACCR * ( PHLC_LRC(JL)/PHLC_LCF(JL) ) &
+ * PLBDAR_RF(JL)**XEXCACCR &
+ * PRHODREF(JL)**(-XCEXVT) &
+ * (MIN(PCF(JL), PRF(JL))-PHLC_HCF(JL))
#else
- ZZW(:) = ZZW(:) + XFCACCR * ( PHLC_LRC(:)/PHLC_LCF(:) ) &
- * BR_POW(PLBDAR_RF(:),XEXCACCR) &
- * BR_POW(PRHODREF(:),-XCEXVT) &
- * (MIN(PCF(:), PRF(:))-PHLC_HCF(:))
+ ZZW(JL) = ZZW(JL) + XFCACCR * ( PHLC_LRC(JL)/PHLC_LCF(JL) ) &
+ * BR_POW(PLBDAR_RF(JL),XEXCACCR) &
+ * BR_POW(PRHODREF(JL),-XCEXVT) &
+ * (MIN(PCF(JL), PRF(JL))-PHLC_HCF(JL))
#endif
- END WHERE
- ZZW(:)=MIN(PRCS(:), ZZW(:))
- PRCS(:) = PRCS(:) - ZZW(:)
- PRRS(:) = PRRS(:) + ZZW(:)
+ END IF
+ ZZW(JL)=MIN(PRCS(JL), ZZW(JL))
+ PRCS(JL) = PRCS(JL) - ZZW(JL)
+ PRRS(JL) = PRRS(JL) + ZZW(JL)
+ END DO ! CONCURRENT
!$acc end kernels
ELSE
@@ -254,31 +263,50 @@ ALLOCATE( ZZW4 (size(PRHODREF)) )
IF (CSUBG_RR_EVAP=='NONE') THEN
!$acc kernels
- !Evaporation only when there's no cloud (RC must be 0)
+ !Evaporation only when there's no cloud (RC must be 0)
GWORK(:) = PRRT(:)>XRTMIN(3) .AND. PRCT(:)<=XRTMIN(2)
+#ifndef MNH_BITREP
WHERE( GWORK(:) )
-#ifndef MNH_BITREP
ZZW(:) = EXP( XALPW - XBETAW/PZT(:) - XGAMW*ALOG(PZT(:) ) ) ! es_w
-#else
- ZZW(:) = BR_EXP( XALPW - XBETAW/PZT(:) - XGAMW*BR_LOG(PZT(:) ) ) ! es_w
-#endif
PUSW(:) = 1.0 - PRVT(:)*( PPRES(:)-ZZW(:) ) / ( (XMV/XMD) * ZZW(:) )
! Undersaturation over water
-#ifndef MNH_BITREP
ZZW(:) = ( XLVTT+(XCPV-XCL)*(PZT(:)-XTT) )**2 / ( PKA(:)*XRV*PZT(:)**2 ) &
+ ( XRV*PZT(:) ) / ( PDV(:)*ZZW(:) )
ZZW(:) = MIN( PRRS(:),( MAX( 0.0,PUSW(:) )/(PRHODREF(:)*ZZW(:)) ) * &
( X0EVAR*PLBDAR(:)**XEX0EVAR+X1EVAR*PCJ(:)*PLBDAR(:)**XEX1EVAR ) )
-#else
- ZZW(:) = BR_P2( XLVTT+(XCPV-XCL)*(PZT(:)-XTT) ) / ( PKA(:)*XRV*BR_P2(PZT(:)) ) &
- + ( XRV*PZT(:) ) / ( PDV(:)*ZZW(:) )
- ZZW(:) = MIN( PRRS(:),( MAX( 0.0,PUSW(:) )/(PRHODREF(:)*ZZW(:)) ) * &
- ( X0EVAR*BR_POW(PLBDAR(:),XEX0EVAR)+X1EVAR*PCJ(:)*BR_POW(PLBDAR(:),XEX1EVAR) ) )
-#endif
PRRS(:) = PRRS(:) - ZZW(:)
PRVS(:) = PRVS(:) + ZZW(:)
PTHS(:) = PTHS(:) - ZZW(:)*PLVFACT(:)
END WHERE
+#else
+ !$acc loop independent
+ DO CONCURRENT ( JL=1:JLU )
+ IF ( GWORK(JL) ) THEN
+#ifndef MNH_BITREP
+ ZZW(JL) = EXP( XALPW - XBETAW/PZT(JL) - XGAMW*LOG(PZT(JL) ) ) ! es_w
+#else
+ ZZW(JL) = BR_EXP( XALPW - XBETAW/PZT(JL) - XGAMW*BR_LOG(PZT(JL) ) ) ! es_w
+#endif
+ PUSW(JL) = 1.0 - PRVT(JL)*( PPRES(JL)-ZZW(JL) ) / ( (XMV/XMD) * ZZW(JL) )
+ ! Undersaturation over water
+#ifndef MNH_BITREP
+ ZZW(JL) = ( XLVTT+(XCPV-XCL)*(PZT(JL)-XTT) )**2 / ( PKA(JL)*XRV*PZT(JL)**2 ) &
+#else
+ ZZW(JL) = BR_P2( XLVTT+(XCPV-XCL)*(PZT(JL)-XTT) ) / ( PKA(JL)*XRV*BR_P2(PZT(JL)) ) &
+#endif
+ + ( XRV*PZT(JL) ) / ( PDV(JL)*ZZW(JL) )
+ ZZW(JL) = MIN( PRRS(JL),( MAX( 0.0,PUSW(JL) )/(PRHODREF(JL)*ZZW(JL)) ) * &
+#ifndef MNH_BITREP
+ ( X0EVAR*PLBDAR(JL)**XEX0EVAR+X1EVAR*PCJ(JL)*PLBDAR(JL)**XEX1EVAR ) )
+#else
+ ( X0EVAR*BR_POW(PLBDAR(JL),XEX0EVAR)+X1EVAR*PCJ(JL)*BR_POW(PLBDAR(JL),XEX1EVAR) ) )
+#endif
+ PRRS(JL) = PRRS(JL) - ZZW(JL)
+ PRVS(JL) = PRVS(JL) + ZZW(JL)
+ PTHS(JL) = PTHS(JL) - ZZW(JL)*PLVFACT(JL)
+ END IF
+ END DO ! CONCURRENT
+#endif
!$acc end kernels
ELSEIF (CSUBG_RR_EVAP=='CLFR' .OR. CSUBG_RR_EVAP=='PRFR') THEN
#ifdef MNH_OPENACC
@@ -304,43 +332,46 @@ ALLOCATE( ZZW4 (size(PRHODREF)) )
!On utiliserait la bonne version suivant l'option NONE, CLFR... dans l'évaporation et ailleurs
GWORK(:) = PRRT(:)>XRTMIN(3) .AND. ZZW4(:)>PCF(:)
- WHERE( GWORK(:) )
+ !$acc loop independent
+ DO CONCURRENT ( JL=1:JLU )
+ IF ( GWORK(JL) ) THEN
! outside the cloud (environment) the use of T^u (unsaturated) instead of T
! Bechtold et al. 1993
!
! T^u = T_l = theta_l * (T/theta)
- ZZW2(:) = PTHLT(:) * PZT(:) / PTHT(:)
+ ZZW2(JL) = PTHLT(JL) * PZT(JL) / PTHT(JL)
!
! es_w with new T^u
#ifndef MNH_BITREP
- ZZW(:) = EXP( XALPW - XBETAW/ZZW2(:) - XGAMW*ALOG(ZZW2(:) ) )
+ ZZW(JL) = EXP( XALPW - XBETAW/ZZW2(JL) - XGAMW*ALOG(ZZW2(JL) ) )
#else
- ZZW(:) = BR_EXP( XALPW - XBETAW/ZZW2(:) - XGAMW*BR_LOG(ZZW2(:) ) )
+ ZZW(JL) = BR_EXP( XALPW - XBETAW/ZZW2(JL) - XGAMW*BR_LOG(ZZW2(JL) ) )
#endif
!
! S, Undersaturation over water (with new theta^u)
- PUSW(:) = 1.0 - PRVT(:)*( PPRES(:)-ZZW(:) ) / ( (XMV/XMD) * ZZW(:) )
+ PUSW(JL) = 1.0 - PRVT(JL)*( PPRES(JL)-ZZW(JL) ) / ( (XMV/XMD) * ZZW(JL) )
!
#ifndef MNH_BITREP
- ZZW(:) = ( XLVTT+(XCPV-XCL)*(ZZW2(:)-XTT) )**2 / ( PKA(:)*XRV*ZZW2(:)**2 ) &
- + ( XRV*ZZW2(:) ) / ( PDV(:)*ZZW(:) )
+ ZZW(JL) = ( XLVTT+(XCPV-XCL)*(ZZW2(JL)-XTT) )**2 / ( PKA(JL)*XRV*ZZW2(JL)**2 ) &
+ + ( XRV*ZZW2(JL) ) / ( PDV(JL)*ZZW(JL) )
!
- ZZW(:) = MAX( 0.0,PUSW(:) )/(PRHODREF(:)*ZZW(:)) * &
- ( X0EVAR*ZZW3(:)**XEX0EVAR+X1EVAR*PCJ(:)*ZZW3(:)**XEX1EVAR )
+ ZZW(JL) = MAX( 0.0,PUSW(JL) )/(PRHODREF(JL)*ZZW(JL)) * &
+ ( X0EVAR*ZZW3(JL)**XEX0EVAR+X1EVAR*PCJ(JL)*ZZW3(JL)**XEX1EVAR )
#else
- ZZW(:) = BR_P2( XLVTT+(XCPV-XCL)*(ZZW2(:)-XTT) ) / ( PKA(:)*XRV*BR_P2(ZZW2(:)) ) &
- + ( XRV*ZZW2(:) ) / ( PDV(:)*ZZW(:) )
+ ZZW(JL) = BR_P2( XLVTT+(XCPV-XCL)*(ZZW2(JL)-XTT) ) / ( PKA(JL)*XRV*BR_P2(ZZW2(JL)) ) &
+ + ( XRV*ZZW2(JL) ) / ( PDV(JL)*ZZW(JL) )
!
- ZZW(:) = MAX( 0.0,PUSW(:) )/(PRHODREF(:)*ZZW(:)) * &
- ( X0EVAR*BR_POW(ZZW3(:),XEX0EVAR)+X1EVAR*PCJ(:)*BR_POW(ZZW3(:),XEX1EVAR) )
+ ZZW(JL) = MAX( 0.0,PUSW(JL) )/(PRHODREF(JL)*ZZW(JL)) * &
+ ( X0EVAR*BR_POW(ZZW3(JL),XEX0EVAR)+X1EVAR*PCJ(JL)*BR_POW(ZZW3(JL),XEX1EVAR) )
#endif
!
- ZZW(:) = MIN( PRRS(:), ZZW(:) *( ZZW4(:) - PCF(:) ) )
+ ZZW(JL) = MIN( PRRS(JL), ZZW(JL) *( ZZW4(JL) - PCF(JL) ) )
!
- PRRS(:) = PRRS(:) - ZZW(:)
- PRVS(:) = PRVS(:) + ZZW(:)
- PTHS(:) = PTHS(:) - ZZW(:)*PLVFACT(:)
- END WHERE
+ PRRS(JL) = PRRS(JL) - ZZW(JL)
+ PRVS(JL) = PRVS(JL) + ZZW(JL)
+ PTHS(JL) = PTHS(JL) - ZZW(JL)*PLVFACT(JL)
+ END IF
+ END DO ! CONCURRENT
!$acc end kernels
ELSE
diff --git a/src/MNH/resolved_cloud.f90 b/src/MNH/resolved_cloud.f90
index 97e4c00d98fde746fbf0bd180ca9cfc80877865c..0872d6db517852e8c35dc4c19a369bed6885e7d5 100644
--- a/src/MNH/resolved_cloud.f90
+++ b/src/MNH/resolved_cloud.f90
@@ -338,6 +338,10 @@ USE MODI_SHUMAN
USE MODI_SHUMAN_DEVICE
#endif
USE MODI_SLOW_TERMS
+#ifdef MNH_OPENACC
+USE MODE_MNH_ZWORK , ONLY : MNH_ALLOCATE_ZT3D , MNH_REL_ZT3D, MNH_ALLOCATE_ZT4D , MNH_REL_ZT4D , MNH_ALLOCATE_ZT2D , &
+ MNH_ALLOCATE_GT3D , MNH_REL_GT3D
+#endif
!
IMPLICIT NONE
!
@@ -469,9 +473,12 @@ INTEGER :: IKL
INTEGER :: IINFO_ll ! return code of parallel routine
INTEGER :: JI,JJ,JK,JL
!
-REAL, DIMENSION(:,:,:), ALLOCATABLE :: ZDZZ
-REAL, DIMENSION(:,:,:), ALLOCATABLE :: ZEXN
-REAL, DIMENSION(:,:,:), ALLOCATABLE :: ZZZ
+REAL, DIMENSION(:,:,:), POINTER , CONTIGUOUS :: ZDZZ
+REAL, DIMENSION(:,:,:), POINTER , CONTIGUOUS :: ZEXN
+REAL, DIMENSION(:,:,:), POINTER , CONTIGUOUS :: ZZZ
+#ifdef MNH_OPENACC
+INTEGER :: IZDZZ, IZEXN, IZZZ
+#endif
! model layer height
! REAL :: ZMASSTOT ! total mass for one water category
! ! including the negative values
@@ -481,18 +488,26 @@ REAL, DIMENSION(:,:,:), ALLOCATABLE :: ZZZ
!
INTEGER :: ISVBEG ! first scalar index for microphysics
INTEGER :: ISVEND ! last scalar index for microphysics
-REAL, DIMENSION(:), ALLOCATABLE :: ZRSMIN ! Minimum value for tendencies
-LOGICAL, DIMENSION(:,:,:), ALLOCATABLE :: LLMICRO ! mask to limit computation
-REAL, DIMENSION(:,:,:,:), ALLOCATABLE :: ZFPR
+REAL, DIMENSION(:), ALLOCATABLE :: ZRSMIN ! Minimum value for tendencies
+LOGICAL, DIMENSION(:,:,:), POINTER , CONTIGUOUS :: LLMICRO ! mask to limit computation
+REAL, DIMENSION(:,:,:,:), POINTER , CONTIGUOUS :: ZFPR
+#ifdef MNH_OPENACC
+INTEGER :: ILLMICRO, IZFPR
+#endif
!
INTEGER :: JMOD, JMOD_IFN
LOGICAL :: GWEST,GEAST,GNORTH,GSOUTH
! BVIE work array waiting for PINPRI
-REAL, DIMENSION(:,:), ALLOCATABLE :: ZINPRI
-REAL, DIMENSION(:,:,:), ALLOCATABLE :: ZICEFR
-REAL, DIMENSION(:,:,:), ALLOCATABLE :: ZPRCFR
-REAL, DIMENSION(:,:,:), ALLOCATABLE :: ZTHSSTEP
-REAL, DIMENSION(:,:,:,:), ALLOCATABLE :: ZRSSTEP
+REAL, DIMENSION(:,:), POINTER , CONTIGUOUS :: ZINPRI
+REAL, DIMENSION(:,:,:), POINTER , CONTIGUOUS :: ZICEFR
+REAL, DIMENSION(:,:,:), POINTER , CONTIGUOUS :: ZPRCFR
+REAL, DIMENSION(:,:,:), POINTER , CONTIGUOUS :: ZTHSSTEP
+REAL, DIMENSION(:,:,:,:), POINTER , CONTIGUOUS :: ZRSSTEP
+#ifdef MNH_OPENACC
+INTEGER :: IZINPRI, IZICEFR, IZPRCFR, IZTHSSTEP, IZRSSTEP
+#endif
+!
+INTEGER :: JIU,JJU,JKU
!
!------------------------------------------------------------------------------
!
@@ -566,28 +581,62 @@ IF (MPPDB_INITIALIZED) THEN
CALL MPPDB_CHECK(PHLI_HCF,"RESOLVED_CLOUD beg:PHLI_HCF")
END IF
!
-allocate ( LLMICRO ( SIZE(PZZ,1), SIZE(PZZ,2), SIZE(PZZ,3) ) )
-allocate ( ZDZZ ( SIZE(PZZ,1), SIZE(PZZ,2), SIZE(PZZ,3) ) )
-allocate ( ZZZ ( SIZE(PZZ,1), SIZE(PZZ,2), SIZE(PZZ,3) ) )
-allocate ( ZINPRI ( SIZE(PZZ,1), SIZE(PZZ,2) ) )
+JIU = size(PZZ, 1 )
+JJU = size(PZZ, 2 )
+JKU = size(PZZ, 3 )
+!
+#ifndef MNH_OPENACC
+allocate ( LLMICRO ( JIU,JJU,JKU ) )
+allocate ( ZDZZ ( JIU,JJU,JKU ) )
+
+if ( hcloud == 'ICE3' .or. hcloud == 'ICE4' ) then
+ allocate ( ZEXN ( JIU,JJU,JKU ) )
+ allocate ( ZFPR ( JIU,JJU,JKU,KRR ) )
+else
+ allocate ( ZEXN ( 0,0,0 ) )
+ allocate ( ZFPR ( 0,0,0,0 ) )
+end if
+
+if ( hcloud == 'LIMA' .and. lptsplit ) then
+ allocate( ZICEFR ( JIU,JJU,JKU ) )
+ allocate( ZPRCFR ( JIU,JJU,JKU ) )
+else
+ allocate( ZICEFR (0, 0, 0) )
+ allocate( ZPRCFR (0, 0, 0) )
+end if
+
+allocate ( ZZZ ( JIU,JJU,JKU ) )
+allocate ( ZINPRI ( JIU,JJU ) )
allocate ( ZTHSSTEP ( SIZE(PTHS,1), SIZE(PTHS,2), SIZE(PTHS,3) ) )
allocate ( ZRSSTEP ( SIZE(PRS,1), SIZE(PRS,2), SIZE(PRS,3), SIZE(PRS,4) ) )
+#else
+ILLMICRO = MNH_ALLOCATE_GT3D ( LLMICRO ,JIU,JJU,JKU )
+IZDZZ = MNH_ALLOCATE_ZT3D ( ZDZZ ,JIU,JJU,JKU )
-IF ( HCLOUD == 'ICE3' .OR. HCLOUD == 'ICE4' ) THEN
- ALLOCATE( ZFPR( SIZE(PZZ,1), SIZE(PZZ,2), SIZE(PZZ,3), KRR ) )
-ELSE
- ALLOCATE( ZFPR(0, 0, 0, 0) )
-END IF
+if ( hcloud == 'ICE3' .or. hcloud == 'ICE4' ) then
+ IZEXN = MNH_ALLOCATE_ZT3D ( ZEXN ,JIU,JJU,JKU )
+ IZFPR = MNH_ALLOCATE_ZT3D ( ZFPR ,JIU,JJU,JKU )
+else
+ IZEXN = MNH_ALLOCATE_ZT3D ( ZEXN ,0,0,0 )
+ IZFPR = MNH_ALLOCATE_ZT3D ( ZFPR ,0,0,0 )
+end if
+
+if ( hcloud == 'LIMA' .and. lptsplit ) then
+ IZICEFR = MNH_ALLOCATE_ZT3D ( ZICEFR ,JIU,JJU,JKU )
+ IZPRCFR = MNH_ALLOCATE_ZT3D ( ZPRCFR ,JIU,JJU,JKU )
+else
+ IZICEFR = MNH_ALLOCATE_ZT3D ( ZICEFR ,0,0,0 )
+ IZPRCFR = MNH_ALLOCATE_ZT3D ( ZPRCFR ,0,0,0 )
+end if
+
+IZZZ = MNH_ALLOCATE_ZT3D ( ZZZ ,JIU,JJU,JKU )
+IZINPRI = MNH_ALLOCATE_ZT2D ( ZINPRI ,JIU,JJU )
+IZTHSSTEP = MNH_ALLOCATE_ZT3D ( ZTHSSTEP , SIZE(PTHS,1), SIZE(PTHS,2), SIZE(PTHS,3) )
+IZRSSTEP = MNH_ALLOCATE_ZT4D ( ZRSSTEP , SIZE(PRS,1), SIZE(PRS,2), SIZE(PRS,3), SIZE(PRS,4) )
+#endif
-IF ( HCLOUD == 'LIMA' .and. LPTSPLIT ) THEN
- ALLOCATE( ZICEFR( SIZE(PZZ,1), SIZE(PZZ,2), SIZE(PZZ,3) ) )
- ALLOCATE( ZPRCFR( SIZE(PZZ,1), SIZE(PZZ,2), SIZE(PZZ,3) ) )
-ELSE
- ALLOCATE( ZICEFR(0, 0, 0) )
- ALLOCATE( ZPRCFR(0, 0, 0) )
-END IF
-!$acc data create(LLMICRO,ZDZZ,ZZZ,ZINPRI,ZTHSSTEP,ZRSSTEP, ZFPR, ZICEFR, ZPRCFR)
+!$acc data present( LLMICRO, ZDZZ, ZEXN, ZFPR, ZICEFR, ZPRCFR, ZZZ, ZINPRI, ZTHSSTEP, ZRSSTEP )
CALL GET_INDICE_ll (IIB,IJB,IIE,IJE)
IKA=1
@@ -627,11 +676,12 @@ END IF
!* 2. TRANSFORMATION INTO PHYSICAL TENDENCIES
! ---------------------------------------
!
-!$acc kernels present(PTHS,PRS,PRHODJ,PPABST)
+!$acc kernels ! present(PTHS,PRS,PRHODJ,PPABST,ZEXN,ZLV,ZLS,ZCPH)
PTHS(:,:,:) = PTHS(:,:,:) / PRHODJ(:,:,:)
-DO JRR = 1,KRR
- PRS(:,:,:,JRR) = PRS(:,:,:,JRR) / PRHODJ(:,:,:)
-END DO
+!
+DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU ,JRR = 1:KRR )
+ PRS(JI,JJ,JK,JRR) = PRS(JI,JJ,JK,JRR) / PRHODJ(JI,JJ,JK)
+END DO ! CONCURRENT
!
IF (HCLOUD=='C2R2' .OR. HCLOUD=='C3R5' .OR. HCLOUD=='KHKO' .OR. HCLOUD=='LIMA') THEN
DO JSV = ISVBEG, ISVEND
@@ -1196,10 +1246,17 @@ call Sources_neg_correct( hcloud, 'NECON', krr, ptstep, ppabst, ptht, prt, pths,
! ---------------------------------------
!
!$acc kernels
-PTHS(:,:,:) = PTHS(:,:,:) * PRHODJ(:,:,:)
+DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ PTHS(JI,JJ,JK) = PTHS(JI,JJ,JK) * PRHODJ(JI,JJ,JK)
+END DO ! CONCURRENT
+!$acc end kernels
!
-DO JRR = 1,KRR
- PRS(:,:,:,JRR) = PRS(:,:,:,JRR) * PRHODJ(:,:,:)
+!$acc kernels
+!$acc loop seq
+DO JRR=1,KRR
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU )
+ PRS(JI,JJ,JK,JRR) = PRS(JI,JJ,JK,JRR) * PRHODJ(JI,JJ,JK)
+ END DO ! CONCURRENT
END DO
!$acc end kernels
!
@@ -1243,6 +1300,23 @@ END IF
!$acc end data
+#ifndef MNH_OPENACC
+deallocate (LLMICRO)
+deallocate (ZDZZ,ZEXN,ZZZ)
+deallocate (ZINPRI)
+deallocate (ZTHSSTEP)
+deallocate (ZRSSTEP)
+#else
+CALL MNH_REL_ZT4D(SIZE(PRS,4) , IZRSSTEP )
+CALL MNH_REL_ZT3D ( IZTHSSTEP )
+CALL MNH_REL_ZT3D ( IZINPRI )
+CALL MNH_REL_ZT3D ( IZDZZ,IZZZ )
+CALL MNH_REL_ZT3D ( IZEXN, IZFPR )
+CALL MNH_REL_ZT3D ( IZICEFR, IZPRCFR )
+
+CALL MNH_REL_GT3D ( ILLMICRO )
+#endif
+
!$acc end data
!-------------------------------------------------------------------------------
diff --git a/src/MNH/set_ref.f90 b/src/MNH/set_ref.f90
index 3fbd530b720dad8acead062a8a9854cfbc3950a0..2fbb25ee08b0c3fffee800db82afdbb494f5c00d 100644
--- a/src/MNH/set_ref.f90
+++ b/src/MNH/set_ref.f90
@@ -167,6 +167,9 @@ USE MODE_IO_FIELD_READ, only: IO_Field_read
USE MODE_ll
USE MODE_MPPDB
USE MODE_REPRO_SUM
+#ifdef MNH_BITREP
+USE MODI_BITREP
+#endif
!
IMPLICIT NONE
!
@@ -415,7 +418,11 @@ ZCVD_O_RD = (XCPD / XRD) - 1.
IF (LBOUSS) THEN
ZRHOREF(:,:,:) = PRHODREF(:,:,:)
ELSE
- ZRHOREF(:,:,:) = PEXNREF(:,:,:) ** ZCVD_O_RD * XP00 / ( XRD * PTHVREF(:,:,:) )
+#ifndef MNH_BITREP
+ ZRHOREF(:,:,:) = PEXNREF(:,:,:) ** ZCVD_O_RD * XP00 / ( XRD * PTHVREF(:,:,:) )
+#else
+ ZRHOREF(:,:,:) = BR_POW ( PEXNREF(:,:,:) , ZCVD_O_RD ) * XP00 / ( XRD * PTHVREF(:,:,:) )
+#endif
ZRHOREF(:,:,1)=ZRHOREF(:,:,2) ! this avoids to obtain erroneous values for
! rv at this last point
END IF
diff --git a/src/MNH/shuman_device.f90 b/src/MNH/shuman_device.f90
index 380868f8cc95d982977a15fcdba51f6fc462e987..0ca7755d45e1c1a13b5a8fdd76e592e27413fd53 100644
--- a/src/MNH/shuman_device.f90
+++ b/src/MNH/shuman_device.f90
@@ -167,6 +167,7 @@ IKU = SIZE(PA,3)
!
#ifndef _OPT_LINEARIZED_LOOPS
!$acc kernels present(PMXF,PA)
+!$acc loop independent collapse(3)
DO JK = 1, IKU
DO JJ = 1, IJU
DO JI = 1 + 1, IIU
@@ -292,6 +293,7 @@ IKU = SIZE(PA,3)
!
#ifndef _OPT_LINEARIZED_LOOPS
!$acc kernels present(PA,PMXM)
+!$acc loop independent collapse(3)
DO JK = 1, IKU
DO JJ = 1, IJU
DO JI = 1 + 1, IIU
@@ -300,6 +302,7 @@ DO JK = 1, IKU
ENDDO
ENDDO
!
+!$acc loop independent collapse(2)
DO JK = 1, IKU
DO JJ=1,IJU
PMXM(1,JJ,JK) = PMXM(IIU-2*JPHEXT+1,JJ,JK) !TODO: voir si ce n'est pas plutot JPHEXT+1
@@ -418,6 +421,7 @@ IKU = SIZE(PA,3)
!
!$acc kernels present(PA,PMYF)
#ifndef _OPT_LINEARIZED_LOOPS
+!$acc loop independent collapse(3)
DO JK=1,IKU
DO JJ=1,IJU-1
DO JI=1,IIU !TODO: remplacer le 1 par JPHEXT ?
@@ -534,6 +538,7 @@ IKU = SIZE(PA,3)
!
#ifndef _OPT_LINEARIZED_LOOPS
!$acc kernels present(PA,PMYM)
+!$acc loop independent collapse(3)
DO JK=1,IKU
DO JJ=2,IJU !TODO: remplacer le 1+1 par 1+JPHEXT ?
DO JI=1,IIU
@@ -870,6 +875,7 @@ IKU = SIZE(PA,3)
!
#ifndef _OPT_LINEARIZED_LOOPS
!$acc kernels present(PA,PDXF)
+!$acc loop independent collapse(3)
DO JK=1,IKU
DO JJ=1,IJU
DO JI=1+1,IIU
@@ -878,6 +884,7 @@ DO JK=1,IKU
END DO
END DO
!
+!$acc loop independent collapse(2)
DO JK=1,IKU
DO JJ=1,IJU
PDXF(IIU,JJ,JK) = PDXF(2*JPHEXT,JJ,JK)
@@ -994,6 +1001,7 @@ IKU = SIZE(PA,3)
!
#ifndef _OPT_LINEARIZED_LOOPS
!$acc kernels present(PA,PDXM)
+!$acc loop independent collapse(3)
DO JK=1,IKU
DO JJ=1,IJU
DO JI=1+1,IIU !TODO: remplacer le 1 par JPHEXT ?
@@ -1002,6 +1010,7 @@ DO JK=1,IKU
END DO
END DO
!
+!$acc loop independent collapse(2)
DO JK=1,IKU
DO JJ=1,IJU
PDXM(1,JJ,JK) = PDXM(IIU-2*JPHEXT+1,JJ,JK) !TODO: remplacer -2*JPHEXT+1 par -JPHEXT ?
@@ -1119,6 +1128,7 @@ IKU = SIZE(PA,3)
!
!$acc kernels present(PA,PDYF)
#ifndef _OPT_LINEARIZED_LOOPS
+!$acc loop independent collapse(3)
DO JK=1,IKU
DO JJ=1,IJU-1 !TODO: remplacer le 1 par JPHEXT ?
DO JI=1,IIU
@@ -1232,6 +1242,7 @@ IKU=SIZE(PA,3)
!
#ifndef _OPT_LINEARIZED_LOOPS
!$acc kernels present(PA,PDYM)
+!$acc loop independent collapse(3)
DO JK=1,IKU
DO JJ=2,IJU !TODO: remplacer le 2 par JPHEXT+1 ?
DO JI=1,IIU
@@ -1240,9 +1251,6 @@ DO JK=1,IKU
END DO
END DO
!
-DO JJ=1,JPHEXT
- PDYM(:,JJ,:) = PDYM(:,IJU-2*JPHEXT+JJ,:) ! for reprod JPHEXT <> 1
-END DO
#else
JIJKOR = 1 + IIU
JIJKEND = IIU*IJU*IKU
@@ -1345,6 +1353,7 @@ IKU = SIZE(PA,3)
!
#ifndef _OPT_LINEARIZED_LOOPS
!$acc kernels present(PA,PDZF)
+!$acc loop independent collapse(3)
DO JK=1,IKU-1 !TODO: remplacer le 1 par JPHEXT ?
DO JJ=1,IJU
DO JI=1,IIU
@@ -1459,6 +1468,7 @@ IKU = SIZE(PA,3)
!
#ifndef _OPT_LINEARIZED_LOOPS
!$acc kernels present(PA,PDZM)
+!$acc loop independent collapse(3)
DO JK=2,IKU !TODO: remplacer le 1+1 par 1+JPHEXT ?
DO JJ=1,IJU
DO JI=1,IIU
diff --git a/src/MNH/tke_eps_sources.f90 b/src/MNH/tke_eps_sources.f90
index ce2489c2675f766fefa4f0f034fafb09e8e89539..ea34bc2e164c9f09804156174ed51520d79469c6 100644
--- a/src/MNH/tke_eps_sources.f90
+++ b/src/MNH/tke_eps_sources.f90
@@ -186,6 +186,9 @@ USE MODE_ARGSLIST_ll, ONLY: ADD3DFIELD_ll, CLEANLIST_ll
use mode_budget, only: Budget_store_add, Budget_store_end, Budget_store_init
USE MODE_EXCHANGE_ll, ONLY: UPDATE_HALO_ll
USE MODE_IO_FIELD_WRITE, only: IO_Field_write
+#ifdef MNH_OPENACC
+USE MODE_MNH_ZWORK, ONLY: MNH_ALLOCATE_ZT3D, MNH_REL_ZT3D
+#endif
use mode_mppdb
!
#ifdef MNH_BITREP
@@ -243,7 +246,7 @@ REAL, DIMENSION(:,:,:), INTENT(OUT) :: PDISS ! Dissipati prod. of TKE
!
!* 0.2 declaration of local variables
!
-REAL, DIMENSION(:,:,:), allocatable :: &
+REAL, DIMENSION(:,:,:), pointer , contiguous :: &
ZA, & ! under diagonal elements of the tri-diagonal matrix involved
! in the temporal implicit scheme
ZRES, & ! treated variable at t+ deltat when the turbu-
@@ -253,6 +256,9 @@ REAL, DIMENSION(:,:,:), allocatable :: &
ZFLX, & ! horizontal or vertical flux of the treated variable
ZSOURCE, & ! source of evolution for the treated variable
ZKEFF ! effectif diffusion coeff = LT * SQRT( TKE )
+#ifdef MNH_OPENACC
+INTEGER :: IZA,IZRES,IZFLX,IZSOURCE,IZKEFF
+#endif
INTEGER :: IIB,IIE,IJB,IJE,IKB,IKE
! Index values for the Beginning and End
! mass points of the domain
@@ -263,8 +269,12 @@ INTEGER :: IINFO_ll ! return code of parallel routine
TYPE(TFIELDDATA) :: TZFIELD
!
#ifdef MNH_OPENACC
-REAL, DIMENSION(:,:,:), allocatable :: ZTMP1_DEVICE, ZTMP2_DEVICE, ZTMP3_DEVICE, ZTMP4_DEVICE
+REAL, DIMENSION(:,:,:), pointer , contiguous :: ZTMP1_DEVICE, ZTMP2_DEVICE, ZTMP3_DEVICE, ZTMP4_DEVICE
+INTEGER :: IZTMP1_DEVICE, IZTMP2_DEVICE, IZTMP3_DEVICE, IZTMP4_DEVICE
#endif
+!
+INTEGER :: JIU,JJU,JKU
+INTEGER :: JI,JJ,JK
!----------------------------------------------------------------------------
!$acc data present( PTKEM, PLM, PLEPS, PDP, PTRH, &
@@ -294,20 +304,32 @@ if ( mppdb_initialized ) then
call Mppdb_check( prthls, "Tke_eps_sources beg:prthls" )
end if
-allocate( za (size( ptkem, 1 ), size( ptkem, 2 ), size( ptkem, 3 ) ) )
-allocate( zres (size( ptkem, 1 ), size( ptkem, 2 ), size( ptkem, 3 ) ) )
-allocate( zflx (size( ptkem, 1 ), size( ptkem, 2 ), size( ptkem, 3 ) ) )
-allocate( zsource(size( ptkem, 1 ), size( ptkem, 2 ), size( ptkem, 3 ) ) )
-allocate( zkeff (size( ptkem, 1 ), size( ptkem, 2 ), size( ptkem, 3 ) ) )
+JIU = size(ptkem, 1 )
+JJU = size(ptkem, 2 )
+JKU = size(ptkem, 3 )
+
+#ifndef MNH_OPENACC
+allocate( za (JIU,JJU,JKU ) )
+allocate( zres (JIU,JJU,JKU ) )
+allocate( zflx (JIU,JJU,JKU ) )
+allocate( zsource(JIU,JJU,JKU ) )
+allocate( zkeff (JIU,JJU,JKU ) )
+#else
+iza = MNH_ALLOCATE_ZT3D( za ,JIU,JJU,JKU)
+izres = MNH_ALLOCATE_ZT3D( zres ,JIU,JJU,JKU)
+izflx = MNH_ALLOCATE_ZT3D( zflx ,JIU,JJU,JKU)
+izsource = MNH_ALLOCATE_ZT3D( zsource,JIU,JJU,JKU)
+izkeff = MNH_ALLOCATE_ZT3D( zkeff ,JIU,JJU,JKU)
+#endif
#ifdef MNH_OPENACC
-allocate( ztmp1_device(size( ptkem, 1 ), size( ptkem, 2 ), size( ptkem, 3 ) ) )
-allocate( ztmp2_device(size( ptkem, 1 ), size( ptkem, 2 ), size( ptkem, 3 ) ) )
-allocate( ztmp3_device(size( ptkem, 1 ), size( ptkem, 2 ), size( ptkem, 3 ) ) )
-allocate( ztmp4_device(size( ptkem, 1 ), size( ptkem, 2 ), size( ptkem, 3 ) ) )
+iztmp1_device = MNH_ALLOCATE_ZT3D( ztmp1_device,JIU,JJU,JKU)
+iztmp2_device = MNH_ALLOCATE_ZT3D( ztmp2_device,JIU,JJU,JKU)
+iztmp3_device = MNH_ALLOCATE_ZT3D( ztmp3_device,JIU,JJU,JKU)
+iztmp4_device = MNH_ALLOCATE_ZT3D( ztmp4_device,JIU,JJU,JKU)
#endif
-!$acc data create( ZA, ZRES, ZFLX, ZSOURCE, ZKEFF, ZTMP1_DEVICE, ZTMP2_DEVICE, ZTMP3_DEVICE, ZTMP4_DEVICE )
+!$acc data present( ZA, ZRES, ZFLX, ZSOURCE, ZKEFF, ZTMP1_DEVICE, ZTMP2_DEVICE, ZTMP3_DEVICE, ZTMP4_DEVICE )
NULLIFY(TZFIELDDISS_ll)
!
@@ -325,7 +347,10 @@ IKE=KKU-JPVEXT_TURB*KKL
#ifndef MNH_BITREP
ZKEFF(:,:,:) = PLM(:,:,:) * SQRT(PTKEM(:,:,:))
#else
-ZKEFF(:,:,:) = PLM(:,:,:) * BR_POW(PTKEM(:,:,:),0.5)
+!$acc loop independent collapse(3)
+DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZKEFF(JI,JJ,JK) = PLM(JI,JJ,JK) * BR_POW(PTKEM(JI,JJ,JK),0.5)
+END DO
#endif
!
!$acc end kernels
@@ -361,11 +386,17 @@ PDP(:,:,IKB) = PDP(:,:,IKB) * (1. + PDZZ(:,:,IKB+KKL)/PDZZ(:,:,IKB))
#ifndef MNH_BITREP
ZFLX(:,:,:) = XCED * SQRT(PTKEM(:,:,:)) / PLEPS(:,:,:)
#else
-ZFLX(:,:,:) = XCED * BR_POW(PTKEM(:,:,:),0.5) / PLEPS(:,:,:)
+!$acc loop independent collapse(3)
+DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZFLX(JI,JJ,JK) = XCED * BR_POW(PTKEM(JI,JJ,JK),0.5) / PLEPS(JI,JJ,JK)
+END DO
#endif
-ZSOURCE(:,:,:) = ( PRTKES(:,:,:) + PRTKESM(:,:,:) ) / PRHODJ(:,:,:) &
- - PTKEM(:,:,:) / PTSTEP &
- + PDP(:,:,:) + PTP(:,:,:) + PTR(:,:,:) - PEXPL * ZFLX(:,:,:) * PTKEM(:,:,:)
+!$acc loop independent collapse(3)
+DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZSOURCE(JI,JJ,JK) = ( PRTKES(JI,JJ,JK) + PRTKESM(JI,JJ,JK) ) / PRHODJ(JI,JJ,JK) &
+ - PTKEM(JI,JJ,JK) / PTSTEP &
+ + PDP(JI,JJ,JK) + PTP(JI,JJ,JK) + PTR(JI,JJ,JK) - PEXPL * ZFLX(JI,JJ,JK) * PTKEM(JI,JJ,JK)
+END DO !CONCURRENT
!$acc end kernels
!
!* 2.2 implicit vertical TKE transport
@@ -388,7 +419,10 @@ CALL MZM_DEVICE(PRHODJ,ZTMP2_DEVICE) !Warning: re-used later
#ifndef MNH_BITREP
ZA(:,:,:) = - PTSTEP * XCET * ZTMP1_DEVICE(:,:,:) * ZTMP2_DEVICE(:,:,:) / PDZZ(:,:,:)**2
#else
-ZA(:,:,:) = - PTSTEP * XCET * ZTMP1_DEVICE(:,:,:) * ZTMP2_DEVICE(:,:,:) / BR_P2(PDZZ(:,:,:))
+!$acc loop independent collapse(3)
+DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZA(JI,JJ,JK) = - PTSTEP * XCET * ZTMP1_DEVICE(JI,JJ,JK) * ZTMP2_DEVICE(JI,JJ,JK) / BR_P2(PDZZ(JI,JJ,JK))
+END DO !CONCURRENT
#endif
!$acc end kernels
#endif
@@ -401,13 +435,16 @@ CALL TRIDIAG_TKE(KKA,KKU,KKL,PTKEM,ZA,PTSTEP,PEXPL,PIMPL,PRHODJ,&
CALL GET_HALO(ZRES)
#else
!$acc kernels
-ZTMP3_DEVICE(:,:,:) = PTSTEP*ZFLX(:,:,:)
+!$acc loop independent collapse(3)
+DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP3_DEVICE(JI,JJ,JK) = PTSTEP*ZFLX(JI,JJ,JK)
+END DO !CONCURRENT
!$acc end kernels
CALL TRIDIAG_TKE(KKA,KKU,KKL,PTKEM,ZA,PTSTEP,PEXPL,PIMPL,PRHODJ,&
& ZSOURCE,ZTMP3_DEVICE,ZRES)
-!$acc update self(ZRES)
-CALL GET_HALO(ZRES)
-!$acc update device(ZRES)
+! acc update self(ZRES)
+CALL GET_HALO_D(ZRES)
+! acc update device(ZRES)
#endif
!
!* diagnose the dissipation
@@ -625,6 +662,12 @@ end if
!$acc end data
+#ifndef MNH_OPENACC
+deallocate( ZA, ZRES, ZFLX, ZSOURCE, ZKEFF )
+#else
+CALL MNH_REL_ZT3D( IZA, IZRES, IZFLX, IZSOURCE, IZKEFF, IZTMP1_DEVICE, IZTMP2_DEVICE, IZTMP3_DEVICE, IZTMP4_DEVICE )
+#endif
+
!$acc end data
END SUBROUTINE TKE_EPS_SOURCES
diff --git a/src/MNH/tools.f90 b/src/MNH/tools.f90
index 2a3b27f35497530e954db5e2cdfb29fe4581d9d9..0899dea5f2e1855711ab6b32b47f6fe9436c0ce6 100644
--- a/src/MNH/tools.f90
+++ b/src/MNH/tools.f90
@@ -1,4 +1,4 @@
-!MNH_LIC Copyright 2019-2020 CNRS, Meteo-France and Universite Paul Sabatier
+!MNH_LIC Copyright 2019-2021 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.
@@ -22,6 +22,7 @@ module mode_tools
! P. Wautelet 05/06/2019: add Countjv_device
! P. Wautelet 20/06/2019: add Countjv1d, Countjv1d_device and Countjv2d_device subroutines
! P. Wautelet 17/01/2020: move Quicksort to tools.f90
+! J. Escobar 25/08/2021: nvhpc21.X bug on 'atomic' in host -> switch to version without atomic on HOST
implicit none
@@ -110,6 +111,9 @@ end function Countjv3d
#ifdef MNH_OPENACC
subroutine Countjv1d_device(ltab, i1,ic)
use mode_mppdb, only: mppdb_initialized
+#ifndef _FAKEOPENACC
+ use MODE_OPENACC_SET_DEVICE, only : mnh_idevice_type_current, acc_device_nvidia
+#endif
logical, dimension(:), intent(in) :: ltab ! Mask
integer, dimension(:), intent(out) :: i1 ! Positions of elements with 'true' value
@@ -120,15 +124,20 @@ subroutine Countjv1d_device(ltab, i1,ic)
!$acc data present( ltab, i1 )
-if ( .not. mppdb_initialized ) then
-!$acc kernels
+#ifndef _FAKEOPENACC
+if ( (.not. mppdb_initialized ) .and. (mnh_idevice_type_current .eq. acc_device_nvidia ) ) then
+#else
+if (.not. mppdb_initialized ) then
+#endif
+ic = 0
+
+!$acc kernels
+
!To allow comparisons... (i1 is not fully used)
!Can be removed in production
! i1(:) = -999
-
- ic = 0
-
+
!Warning: if "independent" is set, content of i1, i2 and i3 can vary between 2
! different runs of this subroutine BUT final result should be the same
!Comment the following line + atomic directives to have consistent values for debugging
@@ -146,13 +155,13 @@ if ( .not. mppdb_initialized ) then
!$acc end kernels
else
-
+
+ic = 0
+
!$acc kernels
!To allow comparisons... (i1 is not fully used)
- i1(:) = -999
-
- ic = 0
+!!$ i1(:) = -999
do ji = 1, size( ltab, 1 )
if ( ltab(ji ) ) then
@@ -172,6 +181,9 @@ end subroutine Countjv1d_device
subroutine Countjv2d_device(ltab, i1, i2, ic)
use mode_mppdb, only: mppdb_initialized
+#ifndef _FAKEOPENACC
+ use MODE_OPENACC_SET_DEVICE, only : mnh_idevice_type_current, acc_device_nvidia
+#endif
logical, dimension(:,:), intent(in) :: ltab ! Mask
integer, dimension(:), intent(out) :: i1, i2 ! Positions of elements with 'true' value
@@ -182,7 +194,14 @@ subroutine Countjv2d_device(ltab, i1, i2, ic)
!$acc data present( ltab, i1, i2 )
-if ( .not. mppdb_initialized ) then
+#ifndef _FAKEOPENACC
+if ( (.not. mppdb_initialized ) .and. (mnh_idevice_type_current .eq. acc_device_nvidia ) ) then
+#else
+if (.not. mppdb_initialized ) then
+#endif
+
+ic = 0
+
!$acc kernels
!To allow comparisons... (i1/i2 are not fully used)
@@ -190,8 +209,6 @@ if ( .not. mppdb_initialized ) then
! i1(:) = -999
! i2(:) = -999
- ic = 0
-
!Warning: if "independent" is set, content of i1, i2 and i3 can vary between 2
! different runs of this subroutine BUT final result should be the same
!Comment the following line + atomic directives to have consistent values for debugging
@@ -213,14 +230,14 @@ if ( .not. mppdb_initialized ) then
else
+ic = 0
+
!$acc kernels
!To allow comparisons... (i1/i2 are not fully used)
i1(:) = -999
i2(:) = -999
- ic = 0
-
do jj = 1, size( ltab, 2 )
do ji = 1, size( ltab, 1 )
if ( ltab(ji, jj ) ) then
@@ -242,6 +259,9 @@ end subroutine Countjv2d_device
subroutine Countjv3d_device(ltab, i1, i2, i3, ic)
use mode_mppdb, only: mppdb_initialized
+#ifndef _FAKEOPENACC
+ use MODE_OPENACC_SET_DEVICE, only : mnh_idevice_type_current, acc_device_nvidia
+#endif
logical, dimension(:,:,:), intent(in) :: ltab ! Mask
integer, dimension(:), intent(out) :: i1, i2, i3 ! Positions of elements with 'true' value
@@ -252,7 +272,14 @@ subroutine Countjv3d_device(ltab, i1, i2, i3, ic)
!$acc data present( ltab, i1, i2, i3 )
-if ( .not. mppdb_initialized ) then
+#ifndef _FAKEOPENACC
+if ( (.not. mppdb_initialized ) .and. (mnh_idevice_type_current .eq. acc_device_nvidia ) ) then
+#else
+if (.not. mppdb_initialized ) then
+#endif
+
+ic = 0
+
!$acc kernels
!To allow comparisons... (i1/i2/i3 are not fully used)
@@ -261,8 +288,6 @@ if ( .not. mppdb_initialized ) then
! i2(:) = -999
! i3(:) = -999
- ic = 0
-
!Warning: if "independent" is set, content of i1, i2 and i3 can vary between 2
! different runs of this subroutine BUT final result should be the same
!Comment the following line + atomic directives to have consistent values for debugging
@@ -287,14 +312,14 @@ if ( .not. mppdb_initialized ) then
else
+ic = 0
+
!$acc kernels
!To allow comparisons... (i1/i2/i3 are not fully used)
- i1(:) = -999
- i2(:) = -999
- i3(:) = -999
-
- ic = 0
+!!$ i1(:) = -999
+!!$ i2(:) = -999
+!!$ i3(:) = -999
do jk = 1, size( ltab, 3 )
do jj = 1, size( ltab, 2 )
diff --git a/src/MNH/tridiag_thermo.f90 b/src/MNH/tridiag_thermo.f90
index ff79d84bbfa90beb40c23634c906b798af4aa4a9..d3d3c1b005602a7341eabb34f704bd9b7f7567ae 100644
--- a/src/MNH/tridiag_thermo.f90
+++ b/src/MNH/tridiag_thermo.f90
@@ -6,8 +6,9 @@
! ###################
MODULE MODI_TRIDIAG_THERMO
! ###################
+!
INTERFACE
-!
+!
SUBROUTINE TRIDIAG_THERMO(KKA,KKU,KKL,PVARM,PF,PDFDDTDZ,PTSTEP,PIMPL, &
PDZZ,PRHODJ,PVARP )
!
@@ -30,9 +31,6 @@ END INTERFACE
!
END MODULE MODI_TRIDIAG_THERMO
!
-!
-!
-
! #################################################
SUBROUTINE TRIDIAG_THERMO(KKA,KKU,KKL,PVARM,PF,PDFDDTDZ,PTSTEP,PIMPL, &
PDZZ,PRHODJ,PVARP )
@@ -159,6 +157,11 @@ USE MODI_SHUMAN_DEVICE
USE MODI_BITREP
#endif
!
+#ifdef MNH_OPENACC
+USE MODE_MNH_ZWORK , ONLY : MNH_ALLOCATE_ZT3D , MNH_REL_ZT3D , MNH_ALLOCATE_ZT2D, &
+ MNH_CHECK_IN_ZT3D,MNH_CHECK_OUT_ZT3D
+#endif
+!
IMPLICIT NONE
!
!
@@ -179,12 +182,18 @@ REAL, DIMENSION(:,:,:), INTENT(OUT):: PVARP ! variable at t+1 at mass poi
!
!* 0.2 declarations of local variables
!
-REAL, DIMENSION(:,:,:), allocatable :: ZRHODJ_DFDDTDZ_O_DZ2
-REAL, DIMENSION(:,:,:), allocatable :: ZMZM_RHODJ
-REAL, DIMENSION(:,:,:), allocatable :: ZA, ZB, ZC
-REAL, DIMENSION(:,:,:), allocatable :: ZY ,ZGAM
+REAL, DIMENSION(:,:,:), pointer , contiguous :: ZRHODJ_DFDDTDZ_O_DZ2
+REAL, DIMENSION(:,:,:), pointer , contiguous :: ZMZM_RHODJ
+REAL, DIMENSION(:,:,:), pointer , contiguous :: ZA, ZB, ZC
+REAL, DIMENSION(:,:,:), pointer , contiguous :: ZY ,ZGAM
! RHS of the equation, 3D work array
-REAL, DIMENSION(:,:), allocatable :: ZBET
+#ifdef MNH_OPENACC
+INTEGER :: IZRHODJ_DFDDTDZ_O_DZ2,IZMZM_RHODJ,IZA,IZB,IZC,IZY,IZGAM
+#endif
+REAL, DIMENSION(:,:), pointer , contiguous :: ZBET
+#ifdef MNH_OPENACC
+INTEGER :: IZBET
+#endif
! 2D work array
INTEGER :: JI,JJ,JK ! loop counter
INTEGER :: IKB,IKE ! inner vertical limits
@@ -193,8 +202,12 @@ INTEGER :: IKTB,IKTE ! start, end of k loops in physical domain
!
!
#ifdef MNH_OPENACC
-REAL, DIMENSION(:,:,:), allocatable :: ZTMP1_DEVICE
+REAL, DIMENSION(:,:,:), pointer , contiguous :: ZTMP1_DEVICE
+INTEGER :: IZTMP1_DEVICE
#endif
+
+INTEGER :: JIU,JJU,JKU
+
! ---------------------------------------------------------------------------
!$acc data present( PVARM, PF, PDFDDTDZ, PDZZ, PRHODJ, PVARP )
@@ -208,20 +221,36 @@ if ( mppdb_initialized ) then
call Mppdb_check( prhodj, "Tridiag_thermo beg:prhodj" )
end if
-allocate( zrhodj_dfddtdz_o_dz2(size( pvarm, 1 ), size( pvarm, 2 ), size( pvarm, 3 ) ) )
-allocate( zmzm_rhodj (size( pvarm, 1 ), size( pvarm, 2 ), size( pvarm, 3 ) ) )
-allocate( za (size( pvarm, 1 ), size( pvarm, 2 ), size( pvarm, 3 ) ) )
-allocate( zb (size( pvarm, 1 ), size( pvarm, 2 ), size( pvarm, 3 ) ) )
-allocate( zc (size( pvarm, 1 ), size( pvarm, 2 ), size( pvarm, 3 ) ) )
-allocate( zy (size( pvarm, 1 ), size( pvarm, 2 ), size( pvarm, 3 ) ) )
-allocate( zgam (size( pvarm, 1 ), size( pvarm, 2 ), size( pvarm, 3 ) ) )
-allocate( zbet (size( pvarm, 1 ), size( pvarm, 2 ) ) )
+JIU = size( pvarm, 1 )
+JJU = size( pvarm, 2 )
+JKU = size( pvarm, 3 )
+
+#ifndef MNH_OPENACC
+allocate( zrhodj_dfddtdz_o_dz2(JIU,JJU,JKU ) )
+allocate( zmzm_rhodj (JIU,JJU,JKU ) )
+allocate( za (JIU,JJU,JKU ) )
+allocate( zb (JIU,JJU,JKU ) )
+allocate( zc (JIU,JJU,JKU ) )
+allocate( zy (JIU,JJU,JKU ) )
+allocate( zgam (JIU,JJU,JKU ) )
+allocate( zbet (JIU,JJU ) )
+#else
+CALL MNH_CHECK_IN_ZT3D("TRIDIAG_THERMO")
+izrhodj_dfddtdz_o_dz2 = MNH_ALLOCATE_ZT3D( zrhodj_dfddtdz_o_dz2,JIU,JJU,JKU )
+izmzm_rhodj = MNH_ALLOCATE_ZT3D( zmzm_rhodj ,JIU,JJU,JKU )
+iza = MNH_ALLOCATE_ZT3D( za ,JIU,JJU,JKU )
+izb = MNH_ALLOCATE_ZT3D( zb ,JIU,JJU,JKU )
+izc = MNH_ALLOCATE_ZT3D( zc ,JIU,JJU,JKU )
+izy = MNH_ALLOCATE_ZT3D( zy ,JIU,JJU,JKU )
+izgam = MNH_ALLOCATE_ZT3D( zgam ,JIU,JJU,JKU )
+izbet = MNH_ALLOCATE_ZT2D( zbet ,JIU,JJU )
+#endif
#ifdef MNH_OPENACC
-allocate( ztmp1_device(size( pvarm, 1 ), size( pvarm, 2 ), size( pvarm, 3 ) ) )
+iztmp1_device = MNH_ALLOCATE_ZT3D( ztmp1_device,JIU,JJU,JKU )
#endif
-!$acc data create( zrhodj_dfddtdz_o_dz2, zmzm_rhodj, za, zb, zc, zy, zgam, zbet, ztmp1_device )
+!$acc data present( zrhodj_dfddtdz_o_dz2, zmzm_rhodj, za, zb, zc, zy, zgam, zbet, ztmp1_device )
!
!* 1. Preliminaries
! -------------
@@ -231,60 +260,71 @@ IKTB=1+JPVEXT_TURB
IKTE=IKT-JPVEXT_TURB
IKB=KKA+JPVEXT_TURB*KKL
IKE=KKU-JPVEXT_TURB*KKL
-
!
#ifndef MNH_OPENACC
ZMZM_RHODJ = MZM(PRHODJ)
#else
CALL MZM_DEVICE(PRHODJ,ZMZM_RHODJ)
#endif
-!$acc kernels async
+!$acc kernels ! async
#ifndef MNH_BITREP
ZRHODJ_DFDDTDZ_O_DZ2 = ZMZM_RHODJ*PDFDDTDZ/PDZZ**2
#else
-ZRHODJ_DFDDTDZ_O_DZ2 = ZMZM_RHODJ*PDFDDTDZ/BR_P2(PDZZ)
+!$acc loop independent collapse(3)
+DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZRHODJ_DFDDTDZ_O_DZ2(JI,JJ,JK) = ZMZM_RHODJ(JI,JJ,JK)*PDFDDTDZ(JI,JJ,JK)/BR_P2(PDZZ(JI,JJ,JK))
+END DO !CONCURRENT
#endif
!$acc end kernels
!
-!$acc kernels async
+!$acc kernels ! async
ZA=0.
ZB=0.
ZC=0.
ZY=0.
!$acc end kernels
-!$acc wait
+! acc wait
!
!
!* 2. COMPUTE THE RIGHT HAND SIDE
! ---------------------------
!
-!$acc kernels async
-ZY(:,:,IKB) = PRHODJ(:,:,IKB)*PVARM(:,:,IKB)/PTSTEP &
- - ZMZM_RHODJ(:,:,IKB+KKL) * PF(:,:,IKB+KKL)/PDZZ(:,:,IKB+KKL) &
- + ZMZM_RHODJ(:,:,IKB ) * PF(:,:,IKB )/PDZZ(:,:,IKB ) &
- + ZRHODJ_DFDDTDZ_O_DZ2(:,:,IKB+KKL) * PIMPL * PVARM(:,:,IKB+KKL) &
- - ZRHODJ_DFDDTDZ_O_DZ2(:,:,IKB+KKL) * PIMPL * PVARM(:,:,IKB )
+!$acc kernels ! async
+!$acc loop independent collapse(2)
+DO CONCURRENT ( JI=1:JIU,JJ=1:JJU)
+ZY(JI,JJ,IKB) = PRHODJ(JI,JJ,IKB)*PVARM(JI,JJ,IKB)/PTSTEP &
+ - ZMZM_RHODJ(JI,JJ,IKB+KKL) * PF(JI,JJ,IKB+KKL)/PDZZ(JI,JJ,IKB+KKL) &
+ + ZMZM_RHODJ(JI,JJ,IKB ) * PF(JI,JJ,IKB )/PDZZ(JI,JJ,IKB ) &
+ + ZRHODJ_DFDDTDZ_O_DZ2(JI,JJ,IKB+KKL) * PIMPL * PVARM(JI,JJ,IKB+KKL) &
+ - ZRHODJ_DFDDTDZ_O_DZ2(JI,JJ,IKB+KKL) * PIMPL * PVARM(JI,JJ,IKB )
+END DO !CONCURRENT
!$acc end kernels
!
-!$acc kernels async
- ZY(:,:,IKTB+1:IKTE-1) = PRHODJ(:,:,IKTB+1:IKTE-1)*PVARM(:,:,IKTB+1:IKTE-1)/PTSTEP &
- - ZMZM_RHODJ(:,:,IKTB+1+KKL:IKTE-1+KKL) * PF(:,:,IKTB+1+KKL:IKTE-1+KKL)/PDZZ(:,:,IKTB+1+KKL:IKTE-1+KKL) &
- + ZMZM_RHODJ(:,:,IKTB+1:IKTE-1 ) * PF(:,:,IKTB+1:IKTE-1 )/PDZZ(:,:,IKTB+1:IKTE-1 ) &
- + ZRHODJ_DFDDTDZ_O_DZ2(:,:,IKTB+1+KKL:IKTE-1+KKL) * PIMPL * PVARM(:,:,IKTB+1+KKL:IKTE-1+KKL) &
- - ZRHODJ_DFDDTDZ_O_DZ2(:,:,IKTB+1+KKL:IKTE-1+KKL) * PIMPL * PVARM(:,:,IKTB+1:IKTE-1 ) &
- - ZRHODJ_DFDDTDZ_O_DZ2(:,:,IKTB+1:IKTE-1 ) * PIMPL * PVARM(:,:,IKTB+1:IKTE-1 ) &
- + ZRHODJ_DFDDTDZ_O_DZ2(:,:,IKTB+1:IKTE-1 ) * PIMPL * PVARM(:,:,IKTB+1-KKL:IKTE-1-KKL)
+!$acc kernels ! async
+!$acc loop independent collapse(3)
+DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=IKTB+1:IKTE-1)
+ ZY(JI,JJ,JK) = PRHODJ(JI,JJ,JK)*PVARM(JI,JJ,JK)/PTSTEP &
+ - ZMZM_RHODJ(JI,JJ,JK+KKL) * PF(JI,JJ,JK+KKL)/PDZZ(JI,JJ,JK+KKL) &
+ + ZMZM_RHODJ(JI,JJ,JK ) * PF(JI,JJ,JK )/PDZZ(JI,JJ,JK ) &
+ + ZRHODJ_DFDDTDZ_O_DZ2(JI,JJ,JK+KKL) * PIMPL * PVARM(JI,JJ,JK+KKL) &
+ - ZRHODJ_DFDDTDZ_O_DZ2(JI,JJ,JK+KKL) * PIMPL * PVARM(JI,JJ,JK ) &
+ - ZRHODJ_DFDDTDZ_O_DZ2(JI,JJ,JK ) * PIMPL * PVARM(JI,JJ,JK ) &
+ + ZRHODJ_DFDDTDZ_O_DZ2(JI,JJ,JK ) * PIMPL * PVARM(JI,JJ,JK-KKL)
+END DO !CONCURRENT
!$acc end kernels
!
-!$acc kernels async
-ZY(:,:,IKE) = PRHODJ(:,:,IKE)*PVARM(:,:,IKE)/PTSTEP &
- - ZMZM_RHODJ(:,:,IKE+KKL) * PF(:,:,IKE+KKL)/PDZZ(:,:,IKE+KKL) &
- + ZMZM_RHODJ(:,:,IKE ) * PF(:,:,IKE )/PDZZ(:,:,IKE ) &
- - ZRHODJ_DFDDTDZ_O_DZ2(:,:,IKE ) * PIMPL * PVARM(:,:,IKE ) &
- + ZRHODJ_DFDDTDZ_O_DZ2(:,:,IKE ) * PIMPL * PVARM(:,:,IKE-KKL)
+!$acc kernels ! async
+!$acc loop independent collapse(2)
+DO CONCURRENT ( JI=1:JIU,JJ=1:JJU)
+ZY(JI,JJ,IKE) = PRHODJ(JI,JJ,IKE)*PVARM(JI,JJ,IKE)/PTSTEP &
+ - ZMZM_RHODJ(JI,JJ,IKE+KKL) * PF(JI,JJ,IKE+KKL)/PDZZ(JI,JJ,IKE+KKL) &
+ + ZMZM_RHODJ(JI,JJ,IKE ) * PF(JI,JJ,IKE )/PDZZ(JI,JJ,IKE ) &
+ - ZRHODJ_DFDDTDZ_O_DZ2(JI,JJ,IKE ) * PIMPL * PVARM(JI,JJ,IKE ) &
+ + ZRHODJ_DFDDTDZ_O_DZ2(JI,JJ,IKE ) * PIMPL * PVARM(JI,JJ,IKE-KKL)
+END DO !CONCURRENT
!$acc end kernels
!
-!$acc wait
+! acc wait
!
!* 3. INVERSION OF THE TRIDIAGONAL SYSTEM
! -----------------------------------
@@ -294,77 +334,102 @@ IF ( PIMPL > 1.E-10 ) THEN
!* 3.1 arrays A, B, C
! --------------
!
-!$acc kernels async
- ZB(:,:,IKB) = PRHODJ(:,:,IKB)/PTSTEP &
- - ZRHODJ_DFDDTDZ_O_DZ2(:,:,IKB+KKL) * PIMPL
+!$acc kernels ! async
+!$acc loop independent collapse(2)
+DO CONCURRENT ( JI=1:JIU,JJ=1:JJU)
+ ZB(JI,JJ,IKB) = PRHODJ(JI,JJ,IKB)/PTSTEP &
+ - ZRHODJ_DFDDTDZ_O_DZ2(JI,JJ,IKB+KKL) * PIMPL
+END DO !CONCURRENT
!$acc end kernels
!
-!$acc kernels async
- ZC(:,:,IKB) = ZRHODJ_DFDDTDZ_O_DZ2(:,:,IKB+KKL) * PIMPL
+!$acc kernels ! async
+!$acc loop independent collapse(2)
+DO CONCURRENT ( JI=1:JIU,JJ=1:JJU)
+ ZC(JI,JJ,IKB) = ZRHODJ_DFDDTDZ_O_DZ2(JI,JJ,IKB+KKL) * PIMPL
+END DO !CONCURRENT
!$acc end kernels
!
-!$acc kernels async
- ZA(:,:,IKTB+1:IKTE-1) = ZRHODJ_DFDDTDZ_O_DZ2(:,:,IKTB+1:IKTE-1) * PIMPL
- ZB(:,:,IKTB+1:IKTE-1) = PRHODJ(:,:,IKTB+1:IKTE-1)/PTSTEP &
- - ZRHODJ_DFDDTDZ_O_DZ2(:,:,IKTB+1+KKL:IKTE-1+KKL) * PIMPL &
- - ZRHODJ_DFDDTDZ_O_DZ2(:,:,IKTB+1:IKTE-1) * PIMPL
- ZC(:,:,IKTB+1:IKTE-1) = ZRHODJ_DFDDTDZ_O_DZ2(:,:,IKTB+1+KKL:IKTE-1+KKL) * PIMPL
+!$acc kernels ! async
+!$acc loop independent collapse(3)
+DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=IKTB+1:IKTE-1)
+ ZA(JI,JJ,JK) = ZRHODJ_DFDDTDZ_O_DZ2(JI,JJ,JK) * PIMPL
+ ZB(JI,JJ,JK) = PRHODJ(JI,JJ,JK)/PTSTEP &
+ - ZRHODJ_DFDDTDZ_O_DZ2(JI,JJ,JK+KKL) * PIMPL &
+ - ZRHODJ_DFDDTDZ_O_DZ2(JI,JJ,JK) * PIMPL
+ ZC(JI,JJ,JK) = ZRHODJ_DFDDTDZ_O_DZ2(JI,JJ,JK+KKL) * PIMPL
+END DO !CONCURRENT
!$acc end kernels
!
-!$acc kernels async
- ZA(:,:,IKE) = ZRHODJ_DFDDTDZ_O_DZ2(:,:,IKE ) * PIMPL
- ZB(:,:,IKE) = PRHODJ(:,:,IKE)/PTSTEP &
- - ZRHODJ_DFDDTDZ_O_DZ2(:,:,IKE ) * PIMPL
+!$acc kernels ! async
+!$acc loop independent collapse(2)
+DO CONCURRENT ( JI=1:JIU,JJ=1:JJU)
+ ZA(JI,JJ,IKE) = ZRHODJ_DFDDTDZ_O_DZ2(JI,JJ,IKE ) * PIMPL
+ ZB(JI,JJ,IKE) = PRHODJ(JI,JJ,IKE)/PTSTEP &
+ - ZRHODJ_DFDDTDZ_O_DZ2(JI,JJ,IKE ) * PIMPL
+END DO !CONCURRENT
!$acc end kernels
!
-!$acc wait
+! acc wait
!
!
!* 3.2 going up
! --------
!
!$acc kernels
- ZBET(:,:) = ZB(:,:,IKB) ! bet = b(ikb)
- PVARP(:,:,IKB) = ZY(:,:,IKB) / ZBET(:,:)
-
- !
- DO JK = IKB+KKL,IKE-KKL,KKL
-!$acc loop collapse(2) independent
- DO JJ=1,SIZE(ZGAM,2)
- DO JI=1,SIZE(ZGAM,1)
- ZGAM(JI,JJ,JK) = ZC(JI,JJ,JK-KKL) / ZBET(JI,JJ)
- ! gam(k) = c(k-1) / bet
- ZBET(JI,JJ) = ZB(JI,JJ,JK) - ZA(JI,JJ,JK) * ZGAM(JI,JJ,JK)
- ! bet = b(k) - a(k)* gam(k)
- PVARP(JI,JJ,JK)= ( ZY(JI,JJ,JK) - ZA(JI,JJ,JK) * PVARP(JI,JJ,JK-KKL) ) / ZBET(JI,JJ)
- ! res(k) = (y(k) -a(k)*res(k-1))/ bet
- END DO
- END DO
- END DO
- ! special treatment for the last level
- DO JJ=1,SIZE(ZGAM,2)
- DO JI=1,SIZE(ZGAM,1)
+!$acc loop independent collapse(2)
+DO CONCURRENT ( JI=1:JIU,JJ=1:JJU)
+ ZBET(JI,JJ) = ZB(JI,JJ,IKB) ! bet = b(ikb)
+ PVARP(JI,JJ,IKB) = ZY(JI,JJ,IKB) / ZBET(JI,JJ)
+END DO !CONCURRENT
+!
+!$acc loop seq
+DO JK = IKB+KKL,IKE-KKL,KKL
+ !$acc loop independent collapse(2)
+ ! acc loop gang, vector collapse(2)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU)
+ !DO JJ=1,JJU
+ ! DO JI=1,JIU
+ ZGAM(JI,JJ,JK) = ZC(JI,JJ,JK-KKL) / ZBET(JI,JJ)
+ ! gam(k) = c(k-1) / bet
+ ZBET(JI,JJ) = ZB(JI,JJ,JK) - ZA(JI,JJ,JK) * ZGAM(JI,JJ,JK)
+ ! bet = b(k) - a(k)* gam(k)
+ PVARP(JI,JJ,JK)= ( ZY(JI,JJ,JK) - ZA(JI,JJ,JK) * PVARP(JI,JJ,JK-KKL) ) / ZBET(JI,JJ)
+ ! res(k) = (y(k) -a(k)*res(k-1))/ bet
+ ! END DO
+ !END DO
+ END DO !CONCURRENT
+END DO
+! special treatment for the last level
+!$acc loop independent collapse(2)
+DO CONCURRENT ( JI=1:JIU,JJ=1:JJU)
ZGAM(JI,JJ,IKE) = ZC(JI,JJ,IKE-KKL) / ZBET(JI,JJ)
- ! gam(k) = c(k-1) / bet
+ ! gam(k) = c(k-1) / bet
ZBET(JI,JJ) = ZB(JI,JJ,IKE) - ZA(JI,JJ,IKE) * ZGAM(JI,JJ,IKE)
- ! bet = b(k) - a(k)* gam(k)
+ ! bet = b(k) - a(k)* gam(k)
PVARP(JI,JJ,IKE)= ( ZY(JI,JJ,IKE) - ZA(JI,JJ,IKE) * PVARP(JI,JJ,IKE-KKL) ) / ZBET(JI,JJ)
- ! res(k) = (y(k) -a(k)*res(k-1))/ bet
- END DO
- END DO
+ ! res(k) = (y(k) -a(k)*res(k-1))/ bet
+END DO !CONCURRENT
!
!* 3.3 going down
! ----------
!
- DO JK = IKE-KKL,IKB,-1*KKL
- PVARP(:,:,JK) = PVARP(:,:,JK) - ZGAM(:,:,JK+KKL) * PVARP(:,:,JK+KKL)
- END DO
+!$acc loop seq
+DO JK = IKE-KKL,IKB,-1*KKL
+ !$acc loop independent collapse(2)
+ ! acc loop gang, vector collapse(2)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU)
+ PVARP(JI,JJ,JK) = PVARP(JI,JJ,JK) - ZGAM(JI,JJ,JK+KKL) * PVARP(JI,JJ,JK+KKL)
+ END DO !CONCURRENT
+END DO
!$acc end kernels
!
ELSE
!
!$acc kernels
- PVARP(:,:,IKTB:IKTE) = ZY(:,:,IKTB:IKTE) * PTSTEP / PRHODJ(:,:,IKTB:IKTE)
+!$acc loop independent collapse(3)
+DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=IKTB:IKTE)
+ PVARP(JI,JJ,JK) = ZY(JI,JJ,JK) * PTSTEP / PRHODJ(JI,JJ,JK)
+END DO !CONCURRENT
!$acc end kernels
!
END IF
@@ -374,8 +439,11 @@ END IF
! ----------------------------------------
!
!$acc kernels
-PVARP(:,:,KKA)=PVARP(:,:,IKB)
-PVARP(:,:,KKU)=PVARP(:,:,IKE)
+!$acc loop independent collapse(2)
+DO CONCURRENT ( JI=1:JIU,JJ=1:JJU)
+ PVARP(JI,JJ,KKA)=PVARP(JI,JJ,IKB)
+ PVARP(JI,JJ,KKU)=PVARP(JI,JJ,IKE)
+END DO !CONCURRENT
!$acc end kernels
if ( mppdb_initialized ) then
@@ -385,6 +453,14 @@ end if
!$acc end data
+#ifndef MNH_OPENACC
+deallocate (zrhodj_dfddtdz_o_dz2,zmzm_rhodj,za,zb,zc,zy,zgam,zbet)
+#else
+CALL MNH_REL_ZT3D(IZRHODJ_DFDDTDZ_O_DZ2,IZMZM_RHODJ,IZA,IZB,IZC,IZY,IZGAM,&
+ IZBET,iztmp1_device)
+CALL MNH_CHECK_OUT_ZT3D("TRIDIAG_THERMO")
+#endif
+
!$acc end data
!-------------------------------------------------------------------------------
diff --git a/src/MNH/tridiag_tke.f90 b/src/MNH/tridiag_tke.f90
index 9c9fb543957c150bcd05263d679b19adc4c318fa..516196038b1b51e932a07528317f72cadac6fa32 100644
--- a/src/MNH/tridiag_tke.f90
+++ b/src/MNH/tridiag_tke.f90
@@ -142,6 +142,11 @@ END MODULE MODI_TRIDIAG_TKE
USE MODD_PARAMETERS
USE MODE_MPPDB
!
+#ifdef MNH_OPENACC
+USE MODE_MNH_ZWORK , ONLY : MNH_ALLOCATE_ZT3D , MNH_REL_ZT3D , MNH_ALLOCATE_ZT2D, &
+ MNH_CHECK_IN_ZT3D,MNH_CHECK_OUT_ZT3D
+#endif
+!
IMPLICIT NONE
!
!
@@ -167,9 +172,13 @@ INTEGER :: JI,JJ,JK ! loop counters
INTEGER :: IKB,IKE ! inner vertical limits
INTEGER :: IKT ! array size in k direction
INTEGER :: IKTB,IKTE ! start, end of k loops in physical domain
-REAL, DIMENSION(:,:,:), allocatable :: ZY ,ZGAM ! RHS of the equation, 3D work array
-REAL, DIMENSION(:,:), allocatable :: ZBET ! 2D work array
+REAL, DIMENSION(:,:,:), pointer , contiguous :: ZY ,ZGAM ! RHS of the equation, 3D work array
+REAL, DIMENSION(:,:), pointer , contiguous :: ZBET ! 2D work array
+#ifdef MNH_OPENACC
+INTEGER :: IZY ,IZGAM, IZBET
+#endif
!
+INTEGER :: JIU,JJU,JKU
! ---------------------------------------------------------------------------
!$acc data present( PVARM, PA, PRHODJ, PSOURCE, PDIAG, PVARP )
@@ -183,11 +192,22 @@ if ( mppdb_initialized ) then
call Mppdb_check( pdiag, "Tridiag_tke beg:pdiag" )
end if
-allocate( zy (size( pvarm, 1 ), size( pvarm, 2 ), size( pvarm, 3 ) ) )
-allocate( zgam(size( pvarm, 1 ), size( pvarm, 2 ), size( pvarm, 3 ) ) )
-allocate( zbet(size( pvarm, 1 ), size( pvarm, 2 ) ) )
+JIU = size( pvarm, 1 )
+JJU = size( pvarm, 2 )
+JKU = size( pvarm, 3 )
+
+#ifndef MNH_OPENACC
+allocate( zy (JIU,JJU,JKU ) )
+allocate( zgam(JIU,JJU,JKU ) )
+allocate( zbet(JIU,JJU ) )
+#else
+CALL MNH_CHECK_IN_ZT3D("TRIDIAG_TKE")
+izy = MNH_ALLOCATE_ZT3D( zy ,JIU,JJU,JKU )
+izgam = MNH_ALLOCATE_ZT3D( zgam,JIU,JJU,JKU )
+izbet = MNH_ALLOCATE_ZT2D( zbet,JIU,JJU )
+#endif
-!$acc data create( ZY, ZGAM, ZBET )
+!$acc data present( ZY, ZGAM, ZBET )
!
!* 1. COMPUTE THE RIGHT HAND SIDE
@@ -202,20 +222,29 @@ IKE=KKU-JPVEXT_TURB*KKL
!
!
-ZY(:,:,IKB) = PVARM(:,:,IKB) + PTSTEP*PSOURCE(:,:,IKB) - &
- PEXPL / PRHODJ(:,:,IKB) * PA(:,:,IKB+KKL) * (PVARM(:,:,IKB+KKL) - PVARM(:,:,IKB))
+!$acc loop independent collapse(2)
+DO CONCURRENT ( JI=1:JIU,JJ=1:JJU)
+ ZY(JI,JJ,IKB) = PVARM(JI,JJ,IKB) + PTSTEP*PSOURCE(JI,JJ,IKB) - &
+ PEXPL / PRHODJ(JI,JJ,IKB) * PA(JI,JJ,IKB+KKL) * (PVARM(JI,JJ,IKB+KKL) - PVARM(JI,JJ,IKB))
+END DO !CONCURRENT
!
DO JK=IKTB+1,IKTE-1
- ZY(:,:,JK)= PVARM(:,:,JK) + PTSTEP*PSOURCE(:,:,JK) - &
- PEXPL / PRHODJ(:,:,JK) * &
- ( PVARM(:,:,JK-KKL)*PA(:,:,JK) &
- -PVARM(:,:,JK)*(PA(:,:,JK)+PA(:,:,JK+KKL)) &
- +PVARM(:,:,JK+KKL)*PA(:,:,JK+KKL) &
- )
+ !$acc loop independent collapse(2)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU)
+ ZY(JI,JJ,JK)= PVARM(JI,JJ,JK) + PTSTEP*PSOURCE(JI,JJ,JK) - &
+ PEXPL / PRHODJ(JI,JJ,JK) * &
+ ( PVARM(JI,JJ,JK-KKL)*PA(JI,JJ,JK) &
+ -PVARM(JI,JJ,JK)*(PA(JI,JJ,JK)+PA(JI,JJ,JK+KKL)) &
+ +PVARM(JI,JJ,JK+KKL)*PA(JI,JJ,JK+KKL) &
+ )
+ END DO !CONCURRENT
END DO
-!
-ZY(:,:,IKE)= PVARM(:,:,IKE) + PTSTEP*PSOURCE(:,:,IKE) + &
- PEXPL / PRHODJ(:,:,IKE) * PA(:,:,IKE) * (PVARM(:,:,IKE)-PVARM(:,:,IKE-KKL))
+!
+!$acc loop independent collapse(2)
+DO CONCURRENT ( JI=1:JIU,JJ=1:JJU)
+ ZY(JI,JJ,IKE)= PVARM(JI,JJ,IKE) + PTSTEP*PSOURCE(JI,JJ,IKE) + &
+ PEXPL / PRHODJ(JI,JJ,IKE) * PA(JI,JJ,IKE) * (PVARM(JI,JJ,IKE)-PVARM(JI,JJ,IKE-KKL))
+END DO !CONCURRENT
!
!
!* 2. INVERSION OF THE TRIDIAGONAL SYSTEM
@@ -225,15 +254,19 @@ IF ( PIMPL > 1.E-10 ) THEN
!
!
! going up
+ !
+ !$acc loop independent collapse(2)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU)
+ ZBET(JI,JJ) = 1. + PIMPL * (PDIAG(JI,JJ,IKB)-PA(JI,JJ,IKB+KKL) / PRHODJ(JI,JJ,IKB))
+ ! bet = b(ikb)
+ PVARP(JI,JJ,IKB) = ZY(JI,JJ,IKB) / ZBET(JI,JJ)
+ END DO !CONCURRENT
!
- ZBET(:,:) = 1. + PIMPL * (PDIAG(:,:,IKB)-PA(:,:,IKB+KKL) / PRHODJ(:,:,IKB))
- ! bet = b(ikb)
- PVARP(:,:,IKB) = ZY(:,:,IKB) / ZBET(:,:)
- !
+ !$acc loop seq
DO JK = IKB+KKL,IKE-KKL,KKL
-!$acc loop collapse(2) independent
- DO JJ=1,SIZE(ZGAM,2)
- DO JI=1,SIZE(ZGAM,1)
+ !$acc loop gang, vector collapse(2) independent
+ DO JJ=1,JJU
+ DO JI=1,JIU
ZGAM(JI,JJ,JK) = PIMPL * PA(JI,JJ,JK) / PRHODJ(JI,JJ,JK-KKL) / ZBET(JI,JJ)
! gam(k) = c(k-1) / bet
ZBET(JI,JJ) = 1. + PIMPL * ( PDIAG(JI,JJ,JK) - &
@@ -249,26 +282,36 @@ IF ( PIMPL > 1.E-10 ) THEN
END DO
END DO
! special treatment for the last level
- ZGAM(:,:,IKE) = PIMPL * PA(:,:,IKE) / PRHODJ(:,:,IKE-KKL) / ZBET(:,:)
- ! gam(k) = c(k-1) / bet
- ZBET(:,:) = 1. + PIMPL * ( PDIAG(:,:,IKE) - &
- ( PA(:,:,IKE) * (1. + ZGAM(:,:,IKE)) ) / PRHODJ(:,:,IKE) &
- )
- ! bet = b(k) - a(k)* gam(k)
- PVARP(:,:,IKE)= ( ZY(:,:,IKE) - PIMPL * PA(:,:,IKE) / PRHODJ(:,:,IKE) &
- * PVARP(:,:,IKE-KKL) &
- ) / ZBET(:,:)
- ! res(k) = (y(k) -a(k)*res(k-1))/ bet
+ !$acc loop independent collapse(2)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU)
+ ZGAM(JI,JJ,IKE) = PIMPL * PA(JI,JJ,IKE) / PRHODJ(JI,JJ,IKE-KKL) / ZBET(JI,JJ)
+ ! gam(k) = c(k-1) / bet
+ ZBET(JI,JJ) = 1. + PIMPL * ( PDIAG(JI,JJ,IKE) - &
+ ( PA(JI,JJ,IKE) * (1. + ZGAM(JI,JJ,IKE)) ) / PRHODJ(JI,JJ,IKE) &
+ )
+ ! bet = b(k) - a(k)* gam(k)
+ PVARP(JI,JJ,IKE)= ( ZY(JI,JJ,IKE) - PIMPL * PA(JI,JJ,IKE) / PRHODJ(JI,JJ,IKE) &
+ * PVARP(JI,JJ,IKE-KKL) &
+ ) / ZBET(JI,JJ)
+ ! res(k) = (y(k) -a(k)*res(k-1))/ bet
+ END DO !CONCURRENT
!
! going down
!
+ !$acc loop seq
DO JK = IKE-KKL,IKB,-1*KKL
- PVARP(:,:,JK) = PVARP(:,:,JK) - ZGAM(:,:,JK+KKL) * PVARP(:,:,JK+KKL)
+ !$acc loop gang, vector collapse(2)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU)
+ PVARP(JI,JJ,JK) = PVARP(JI,JJ,JK) - ZGAM(JI,JJ,JK+KKL) * PVARP(JI,JJ,JK+KKL)
+ END DO !CONCURRENT
END DO
!
ELSE
-!
- PVARP(:,:,IKTB:IKTE) = ZY(:,:,IKTB:IKTE)
+ !
+ !$acc loop independent collapse(2)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU)
+ PVARP(JI,JJ,IKTB:IKTE) = ZY(JI,JJ,IKTB:IKTE)
+ END DO !CONCURRENT
!
END IF
!
@@ -276,8 +319,11 @@ END IF
!* 3. FILL THE UPPER AND LOWER EXTERNAL VALUES
! ----------------------------------------
!
-PVARP(:,:,KKA)=PVARP(:,:,IKB)
-PVARP(:,:,KKU)=PVARP(:,:,IKE)
+!$acc loop independent collapse(2)
+DO CONCURRENT ( JI=1:JIU,JJ=1:JJU)
+ PVARP(JI,JJ,KKA)=PVARP(JI,JJ,IKB)
+ PVARP(JI,JJ,KKU)=PVARP(JI,JJ,IKE)
+END DO !CONCURRENT
!$acc end kernels
if ( mppdb_initialized ) then
@@ -287,6 +333,13 @@ end if
!$acc end data
+#ifndef MNH_OPENACC
+deallocate( ZY, ZGAM, ZBET )
+#else
+CALL MNH_REL_ZT3D( IZY, IZGAM, IZBET )
+CALL MNH_CHECK_OUT_ZT3D("TRIDIAG_TKE")
+#endif
+
!$acc end data
!-------------------------------------------------------------------------------
diff --git a/src/MNH/tridiag_w.f90 b/src/MNH/tridiag_w.f90
index 74d7775d5a4cad97fd039d7fde96f85575ee4f0b..5a62150367d5d5db1ae4195f3977aef71b9319b9 100644
--- a/src/MNH/tridiag_w.f90
+++ b/src/MNH/tridiag_w.f90
@@ -161,6 +161,10 @@ USE MODI_SHUMAN_DEVICE
USE MODI_BITREP
#endif
!
+#ifdef MNH_OPENACC
+USE MODE_MNH_ZWORK , ONLY : MNH_ALLOCATE_ZT3D , MNH_REL_ZT3D , MNH_ALLOCATE_ZT2D
+#endif
+!
IMPLICIT NONE
!
!
@@ -177,15 +181,20 @@ REAL, DIMENSION(:,:,:), INTENT(OUT):: PVARP ! variable at t+1 at flux poi
!
!* 0.2 declarations of local variables
!
-REAL, DIMENSION(:,:,:), allocatable :: ZRHODJ_DFDDWDZ_O_DZ2
-REAL, DIMENSION(:,:,:), allocatable :: ZMZM_RHODJ
-REAL, DIMENSION(:,:,:), allocatable :: ZA, ZB, ZC
-REAL, DIMENSION(:,:,:), allocatable :: ZY ,ZGAM ! RHS of the equation, 3D work array
-REAL, DIMENSION(:,:), allocatable :: ZBET ! 2D work array
+REAL, DIMENSION(:,:,:), pointer , contiguous :: ZRHODJ_DFDDWDZ_O_DZ2
+REAL, DIMENSION(:,:,:), pointer , contiguous :: ZMZM_RHODJ
+REAL, DIMENSION(:,:,:), pointer , contiguous :: ZA, ZB, ZC
+REAL, DIMENSION(:,:,:), pointer , contiguous :: ZY ,ZGAM ! RHS of the equation, 3D work array
+REAL, DIMENSION(:,:), pointer , contiguous :: ZBET ! 2D work array
+#ifdef MNH_OPENACC
+INTEGER :: IZRHODJ_DFDDWDZ_O_DZ2,IZMZM_RHODJ,IZA, IZB, IZC,IZY ,IZGAM,IZBET
+#endif
!
INTEGER :: JK ! loop counter
INTEGER :: IKB,IKE ! inner vertical limits
!
+INTEGER :: JIU,JJU,JKU
+INTEGER :: JI,JJ
! ---------------------------------------------------------------------------
!$acc data present( PVARM, PF, PDFDDWDZ, PMZF_DZZ, PRHODJ, PVARP )
@@ -199,16 +208,31 @@ if ( mppdb_initialized ) then
call Mppdb_check( prhodj, "Tridiag_w beg:prhodj" )
end if
-allocate( zrhodj_dfddwdz_o_dz2(size( pvarm, 1 ), size( pvarm, 2 ), size( pvarm, 3 ) ) )
-allocate( zmzm_rhodj (size( pvarm, 1 ), size( pvarm, 2 ), size( pvarm, 3 ) ) )
-allocate( za (size( pvarm, 1 ), size( pvarm, 2 ), size( pvarm, 3 ) ) )
-allocate( zb (size( pvarm, 1 ), size( pvarm, 2 ), size( pvarm, 3 ) ) )
-allocate( zc (size( pvarm, 1 ), size( pvarm, 2 ), size( pvarm, 3 ) ) )
-allocate( zy (size( pvarm, 1 ), size( pvarm, 2 ), size( pvarm, 3 ) ) )
-allocate( zgam (size( pvarm, 1 ), size( pvarm, 2 ), size( pvarm, 3 ) ) )
-allocate( zbet (size( pvarm, 1 ), size( pvarm, 2 ) ) )
+JIU = size( pvarm, 1 )
+JJU = size( pvarm, 2 )
+JKU = size( pvarm, 3 )
+
+#ifndef MNH_OPENACC
+allocate( zrhodj_dfddwdz_o_dz2(JIU,JJU,JKU ) )
+allocate( zmzm_rhodj (JIU,JJU,JKU ) )
+allocate( za (JIU,JJU,JKU ) )
+allocate( zb (JIU,JJU,JKU ) )
+allocate( zc (JIU,JJU,JKU ) )
+allocate( zy (JIU,JJU,JKU ) )
+allocate( zgam (JIU,JJU,JKU ) )
+allocate( zbet (JIU,JJU ) )
+#else
+izrhodj_dfddwdz_o_dz2 = MNH_ALLOCATE_ZT3D( zrhodj_dfddwdz_o_dz2,JIU,JJU,JKU )
+izmzm_rhodj = MNH_ALLOCATE_ZT3D( zmzm_rhodj ,JIU,JJU,JKU )
+iza = MNH_ALLOCATE_ZT3D( za ,JIU,JJU,JKU )
+izb = MNH_ALLOCATE_ZT3D( zb ,JIU,JJU,JKU )
+izc = MNH_ALLOCATE_ZT3D( zc ,JIU,JJU,JKU )
+izy = MNH_ALLOCATE_ZT3D( zy ,JIU,JJU,JKU )
+izgam = MNH_ALLOCATE_ZT3D( zgam ,JIU,JJU,JKU )
+izbet = MNH_ALLOCATE_ZT2D( zbet ,JIU,JJU )
+#endif
-!$acc data create( ZRHODJ_DFDDWDZ_O_DZ2, ZMZM_RHODJ, ZA, ZB, ZC, ZY, ZGAM, ZBET )
+!$acc data present( ZRHODJ_DFDDWDZ_O_DZ2, ZMZM_RHODJ, ZA, ZB, ZC, ZY, ZGAM, ZBET )
!
!* 1. Preliminaries
@@ -222,22 +246,24 @@ ZMZM_RHODJ = MZM(PRHODJ)
#else
CALL MZM_DEVICE(PRHODJ,ZMZM_RHODJ)
#endif
-!$acc kernels async
+!$acc kernels ! async
#ifndef MNH_BITREP
ZRHODJ_DFDDWDZ_O_DZ2 = PRHODJ*PDFDDWDZ/PMZF_DZZ**2
#else
-ZRHODJ_DFDDWDZ_O_DZ2 = PRHODJ*PDFDDWDZ/BR_P2(PMZF_DZZ)
+DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZRHODJ_DFDDWDZ_O_DZ2(JI,JJ,JK) = PRHODJ(JI,JJ,JK)*PDFDDWDZ(JI,JJ,JK)/BR_P2(PMZF_DZZ(JI,JJ,JK))
+END DO !CONCURRENT
#endif
!$acc end kernels
!
-!$acc kernels async
+!$acc kernels ! async
ZA=0.
ZB=0.
ZC=0.
ZY=0.
!$acc end kernels
!
-!$acc wait
+! acc wait
!
!
!* 2. COMPUTE THE RIGHT HAND SIDE
@@ -258,31 +284,40 @@ ZY=0.
!! + PRHODJ(k-1) * PDFDDWDZ(k-1) * PVARM(k-1)/BR_P2(PMZF_DZZ(k-1))
!!#endif
!
-!$acc kernels async
-ZY(:,:,IKB) = ZMZM_RHODJ(:,:,IKB)*PVARM(:,:,IKB)/PTSTEP &
- - PRHODJ(:,:,IKB ) * PF(:,:,IKB )/PMZF_DZZ(:,:,IKB ) &
- + PRHODJ(:,:,IKB-1) * PF(:,:,IKB-1)/PMZF_DZZ(:,:,IKB-1) &
- + ZRHODJ_DFDDWDZ_O_DZ2(:,:,IKB) * PVARM(:,:,IKB+1)&
- - ZRHODJ_DFDDWDZ_O_DZ2(:,:,IKB) * PVARM(:,:,IKB )
+!$acc kernels ! async
+!$acc loop independent collapse(2)
+DO CONCURRENT ( JI=1:JIU,JJ=1:JJU)
+ ZY(JI,JJ,IKB) = ZMZM_RHODJ(JI,JJ,IKB)*PVARM(JI,JJ,IKB)/PTSTEP &
+ - PRHODJ(JI,JJ,IKB ) * PF(JI,JJ,IKB )/PMZF_DZZ(JI,JJ,IKB ) &
+ + PRHODJ(JI,JJ,IKB-1) * PF(JI,JJ,IKB-1)/PMZF_DZZ(JI,JJ,IKB-1) &
+ + ZRHODJ_DFDDWDZ_O_DZ2(JI,JJ,IKB) * PVARM(JI,JJ,IKB+1)&
+ - ZRHODJ_DFDDWDZ_O_DZ2(JI,JJ,IKB) * PVARM(JI,JJ,IKB )
+END DO !CONCURRENT
!$acc end kernels
!
-!$acc kernels async
- ZY(:,:,IKB+1:IKE-1) = ZMZM_RHODJ(:,:,IKB+1:IKE-1)*PVARM(:,:,IKB+1:IKE-1)/PTSTEP &
- - PRHODJ(:,:,IKB+1:IKE-1 ) * PF(:,:,IKB+1:IKE-1 )/PMZF_DZZ(:,:,IKB+1:IKE-1 ) &
- + PRHODJ(:,:,IKB:IKE-2) * PF(:,:,IKB:IKE-2)/PMZF_DZZ(:,:,IKB:IKE-2) &
- + ZRHODJ_DFDDWDZ_O_DZ2(:,:,IKB+1:IKE-1 ) * PVARM(:,:,IKB+2:IKE) &
- - ZRHODJ_DFDDWDZ_O_DZ2(:,:,IKB+1:IKE-1 ) * PVARM(:,:,IKB+1:IKE-1 ) &
- - ZRHODJ_DFDDWDZ_O_DZ2(:,:,IKB:IKE-2) * PVARM(:,:,IKB+1:IKE-1 ) &
- + ZRHODJ_DFDDWDZ_O_DZ2(:,:,IKB:IKE-2) * PVARM(:,:,IKB:IKE-2)
+!$acc kernels ! async
+!$acc loop independent collapse(3)
+DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=IKB+1:IKE-1)
+ ZY(JI,JJ,JK) = ZMZM_RHODJ(JI,JJ,JK)*PVARM(JI,JJ,JK)/PTSTEP &
+ - PRHODJ(JI,JJ,JK ) * PF(JI,JJ,JK )/PMZF_DZZ(JI,JJ,JK ) &
+ + PRHODJ(JI,JJ,JK-1) * PF(JI,JJ,JK-1)/PMZF_DZZ(JI,JJ,JK-1) &
+ + ZRHODJ_DFDDWDZ_O_DZ2(JI,JJ,JK ) * PVARM(JI,JJ,JK+1) &
+ - ZRHODJ_DFDDWDZ_O_DZ2(JI,JJ,JK ) * PVARM(JI,JJ,JK ) &
+ - ZRHODJ_DFDDWDZ_O_DZ2(JI,JJ,JK-1) * PVARM(JI,JJ,JK ) &
+ + ZRHODJ_DFDDWDZ_O_DZ2(JI,JJ,JK-1) * PVARM(JI,JJ,JK-1)
+END DO !CONCURRENT
!$acc end kernels
!
-!$acc kernels async
-ZY(:,:,IKE) = ZMZM_RHODJ(:,:,IKE)*PVARM(:,:,IKE)/PTSTEP &
- - PRHODJ(:,:,IKE ) * PF(:,:,IKE )/PMZF_DZZ(:,:,IKE ) &
- + PRHODJ(:,:,IKE-1) * PF(:,:,IKE-1)/PMZF_DZZ(:,:,IKE-1) &
- - ZRHODJ_DFDDWDZ_O_DZ2(:,:,IKE ) * PVARM(:,:,IKE ) &
- - ZRHODJ_DFDDWDZ_O_DZ2(:,:,IKE-1) * PVARM(:,:,IKE ) &
- + ZRHODJ_DFDDWDZ_O_DZ2(:,:,IKE-1) * PVARM(:,:,IKE-1)
+!$acc kernels ! async
+!$acc loop independent collapse(2)
+DO CONCURRENT ( JI=1:JIU,JJ=1:JJU)
+ ZY(JI,JJ,IKE) = ZMZM_RHODJ(JI,JJ,IKE)*PVARM(JI,JJ,IKE)/PTSTEP &
+ - PRHODJ(JI,JJ,IKE ) * PF(JI,JJ,IKE )/PMZF_DZZ(JI,JJ,IKE ) &
+ + PRHODJ(JI,JJ,IKE-1) * PF(JI,JJ,IKE-1)/PMZF_DZZ(JI,JJ,IKE-1) &
+ - ZRHODJ_DFDDWDZ_O_DZ2(JI,JJ,IKE ) * PVARM(JI,JJ,IKE ) &
+ - ZRHODJ_DFDDWDZ_O_DZ2(JI,JJ,IKE-1) * PVARM(JI,JJ,IKE ) &
+ + ZRHODJ_DFDDWDZ_O_DZ2(JI,JJ,IKE-1) * PVARM(JI,JJ,IKE-1)
+END DO !CONCURRENT
!$acc end kernels
!
!* 3. INVERSION OF THE TRIDIAGONAL SYSTEM
@@ -298,71 +333,101 @@ ZY(:,:,IKE) = ZMZM_RHODJ(:,:,IKE)*PVARM(:,:,IKE)/PTSTEP &
!! - PRHODJ(k-1) * PDFDDWDZ(k-1)/PMZF_DZZ(k-1)**2
!! c(k) = + PRHODJ(k) * PDFDDWDZ(k)/PMZF_DZZ(k)**2
!
-!$acc kernels async
- ZB(:,:,IKB) = ZMZM_RHODJ(:,:,IKB)/PTSTEP &
- - ZRHODJ_DFDDWDZ_O_DZ2(:,:,IKB)
+!$acc kernels ! async
+!$acc loop independent collapse(2)
+DO CONCURRENT ( JI=1:JIU,JJ=1:JJU)
+ ZB(JI,JJ,IKB) = ZMZM_RHODJ(JI,JJ,IKB)/PTSTEP &
+ - ZRHODJ_DFDDWDZ_O_DZ2(JI,JJ,IKB)
+END DO !CONCURRENT
!$acc end kernels
-!$acc kernels async
- ZC(:,:,IKB) = ZRHODJ_DFDDWDZ_O_DZ2(:,:,IKB)
+!$acc kernels ! async
+!$acc loop independent collapse(2)
+DO CONCURRENT ( JI=1:JIU,JJ=1:JJU)
+ ZC(JI,JJ,IKB) = ZRHODJ_DFDDWDZ_O_DZ2(JI,JJ,IKB)
+END DO !CONCURRENT
!$acc end kernels
-!$acc kernels async
- ZA(:,:,IKB+1:IKE-1) = ZRHODJ_DFDDWDZ_O_DZ2(:,:,IKB:IKE-2)
- ZB(:,:,IKB+1:IKE-1) = ZMZM_RHODJ(:,:,IKB+1:IKE-1)/PTSTEP &
- - ZRHODJ_DFDDWDZ_O_DZ2(:,:,IKB+1:IKE-1 ) &
- - ZRHODJ_DFDDWDZ_O_DZ2(:,:,IKB:IKE-2)
- ZC(:,:,IKB+1:IKE-1) = ZRHODJ_DFDDWDZ_O_DZ2(:,:,IKB+1:IKE-1 )
+!$acc kernels ! async
+!$acc loop independent collapse(3)
+DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=IKB+1:IKE-1)
+ ZA(JI,JJ,JK) = ZRHODJ_DFDDWDZ_O_DZ2(JI,JJ,JK-1)
+ ZB(JI,JJ,JK) = ZMZM_RHODJ(JI,JJ,JK)/PTSTEP &
+ - ZRHODJ_DFDDWDZ_O_DZ2(JI,JJ,JK ) &
+ - ZRHODJ_DFDDWDZ_O_DZ2(JI,JJ,JK-1)
+ ZC(JI,JJ,JK) = ZRHODJ_DFDDWDZ_O_DZ2(JI,JJ,JK )
+END DO !CONCURRENT
!$acc end kernels
-!$acc kernels async
- ZA(:,:,IKE) = ZRHODJ_DFDDWDZ_O_DZ2(:,:,IKE-1)
+!$acc kernels ! async
+!$acc loop independent collapse(2)
+DO CONCURRENT ( JI=1:JIU,JJ=1:JJU)
+ ZA(JI,JJ,IKE) = ZRHODJ_DFDDWDZ_O_DZ2(JI,JJ,IKE-1)
+END DO !CONCURRENT
!$acc end kernels
-!$acc kernels async
- ZB(:,:,IKE) = ZMZM_RHODJ(:,:,IKE)/PTSTEP &
- - ZRHODJ_DFDDWDZ_O_DZ2(:,:,IKE ) &
- - ZRHODJ_DFDDWDZ_O_DZ2(:,:,IKE-1)
+!$acc kernels ! async
+!$acc loop independent collapse(2)
+DO CONCURRENT ( JI=1:JIU,JJ=1:JJU)
+ ZB(JI,JJ,IKE) = ZMZM_RHODJ(JI,JJ,IKE)/PTSTEP &
+ - ZRHODJ_DFDDWDZ_O_DZ2(JI,JJ,IKE ) &
+ - ZRHODJ_DFDDWDZ_O_DZ2(JI,JJ,IKE-1)
+END DO !CONCURRENT
!$acc end kernels
!
!
-!$acc wait
+! acc wait
!
!* 3.2 going up
! --------
!
!$acc kernels
- ZBET(:,:) = ZB(:,:,IKB) ! bet = b(ikb)
- PVARP(:,:,IKB) = ZY(:,:,IKB) / ZBET(:,:)
-
- !
- DO JK = IKB+1,IKE-1
- ZGAM(:,:,JK) = ZC(:,:,JK-1) / ZBET(:,:)
- ! gam(k) = c(k-1) / bet
- ZBET(:,:) = ZB(:,:,JK) - ZA(:,:,JK) * ZGAM(:,:,JK)
- ! bet = b(k) - a(k)* gam(k)
- PVARP(:,:,JK)= ( ZY(:,:,JK) - ZA(:,:,JK) * PVARP(:,:,JK-1) ) / ZBET(:,:)
- ! res(k) = (y(k) -a(k)*res(k-1))/ bet
- END DO
- ! special treatment for the last level
- ZGAM(:,:,IKE) = ZC(:,:,IKE-1) / ZBET(:,:)
- ! gam(k) = c(k-1) / bet
- ZBET(:,:) = ZB(:,:,IKE) - ZA(:,:,IKE) * ZGAM(:,:,IKE)
- ! bet = b(k) - a(k)* gam(k)
- PVARP(:,:,IKE)= ( ZY(:,:,IKE) - ZA(:,:,IKE) * PVARP(:,:,IKE-1) ) / ZBET(:,:)
- ! res(k) = (y(k) -a(k)*res(k-1))/ bet
+!$acc loop independent collapse(2)
+DO CONCURRENT ( JI=1:JIU,JJ=1:JJU)
+ ZBET(JI,JJ) = ZB(JI,JJ,IKB) ! bet = b(ikb)
+ PVARP(JI,JJ,IKB) = ZY(JI,JJ,IKB) / ZBET(JI,JJ)
+END DO !CONCURRENT
+!
+!$acc loop seq
+DO JK = IKB+1,IKE-1
+ !$acc loop independent collapse(2)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU)
+ ZGAM(JI,JJ,JK) = ZC(JI,JJ,JK-1) / ZBET(JI,JJ)
+ ! gam(k) = c(k-1) / bet
+ ZBET(JI,JJ) = ZB(JI,JJ,JK) - ZA(JI,JJ,JK) * ZGAM(JI,JJ,JK)
+ ! bet = b(k) - a(k)* gam(k)
+ PVARP(JI,JJ,JK)= ( ZY(JI,JJ,JK) - ZA(JI,JJ,JK) * PVARP(JI,JJ,JK-1) ) / ZBET(JI,JJ)
+ ! res(k) = (y(k) -a(k)*res(k-1))/ bet
+ END DO !CONCURRENT
+END DO
+! special treatment for the last level
+!$acc loop independent collapse(2)
+DO CONCURRENT ( JI=1:JIU,JJ=1:JJU)
+ ZGAM(JI,JJ,IKE) = ZC(JI,JJ,IKE-1) / ZBET(JI,JJ)
+ ! gam(k) = c(k-1) / bet
+ ZBET(JI,JJ) = ZB(JI,JJ,IKE) - ZA(JI,JJ,IKE) * ZGAM(JI,JJ,IKE)
+ ! bet = b(k) - a(k)* gam(k)
+ PVARP(JI,JJ,IKE)= ( ZY(JI,JJ,IKE) - ZA(JI,JJ,IKE) * PVARP(JI,JJ,IKE-1) ) / ZBET(JI,JJ)
+ ! res(k) = (y(k) -a(k)*res(k-1))/ bet
+END DO !CONCURRENT
!
!* 3.3 going down
! ----------
!
- DO JK = IKE-1,IKB,-1
- PVARP(:,:,JK) = PVARP(:,:,JK) - ZGAM(:,:,JK+1) * PVARP(:,:,JK+1)
- END DO
+!$acc loop seq
+DO JK = IKE-1,IKB,-1
+ !$acc loop independent collapse(2)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU)
+ PVARP(JI,JJ,JK) = PVARP(JI,JJ,JK) - ZGAM(JI,JJ,JK+1) * PVARP(JI,JJ,JK+1)
+ END DO !CONCURRENT
+END DO
!
!
!* 4. FILL THE UPPER AND LOWER EXTERNAL VALUES
! ----------------------------------------
!
-PVARP(:,:,IKB-1)=PVARP(:,:,IKB)
-PVARP(:,:,IKE+1)=0.
+DO CONCURRENT ( JI=1:JIU,JJ=1:JJU)
+ PVARP(JI,JJ,IKB-1)=PVARP(JI,JJ,IKB)
+ PVARP(JI,JJ,IKE+1)=0.
+END DO !CONCURRENT
!$acc end kernels
if ( mppdb_initialized ) then
@@ -372,6 +437,13 @@ end if
!$acc end data
+#ifndef MNH_OPENACC
+deallocate (ZRHODJ_DFDDWDZ_O_DZ2, ZMZM_RHODJ, ZA, ZB, ZC, ZY, ZGAM, ZBET)
+#else
+CALL MNH_REL_ZT3D(IZRHODJ_DFDDWDZ_O_DZ2, IZMZM_RHODJ, IZA, IZB, IZC, IZY, IZGAM, IZBET)
+#endif
+
+
!$acc end data
!-------------------------------------------------------------------------------
diff --git a/src/MNH/tridiag_wind.f90 b/src/MNH/tridiag_wind.f90
index b7819835b38b0caf679e27ab10b1e7f32bba5c09..e0f6a1e417f7f3917388eec58d4dac7a2d8d45dc 100644
--- a/src/MNH/tridiag_wind.f90
+++ b/src/MNH/tridiag_wind.f90
@@ -32,7 +32,6 @@ END INTERFACE
END MODULE MODI_TRIDIAG_WIND
!
!
-!
! #############################################################
SUBROUTINE TRIDIAG_WIND(KKA,KKU,KKL,PVARM,PA,PCOEFS,PTSTEP,PEXPL,PIMPL, &
PRHODJA,PSOURCE,PVARP )
@@ -149,6 +148,11 @@ USE MODD_PARAMETERS
use mode_mppdb
+#ifdef MNH_OPENACC
+USE MODE_MNH_ZWORK , ONLY : MNH_ALLOCATE_ZT3D , MNH_REL_ZT3D , MNH_ALLOCATE_ZT2D, &
+ MNH_CHECK_IN_ZT3D,MNH_CHECK_OUT_ZT3D
+#endif
+
IMPLICIT NONE
!
!
@@ -174,8 +178,13 @@ INTEGER :: JI,JJ,JK ! loop counters
INTEGER :: IKB,IKE ! inner vertical limits
INTEGER :: IKT ! array size in k direction
INTEGER :: IKTB,IKTE ! start, end of k loops in physical domain
-REAL, DIMENSION(:,:,:), allocatable :: ZY ,ZGAM ! RHS of the equation, 3D work array
-REAL, DIMENSION(:,:), allocatable :: ZBET ! 2D work array
+REAL, DIMENSION(:,:,:), pointer , contiguous :: ZY ,ZGAM ! RHS of the equation, 3D work array
+REAL, DIMENSION(:,:), pointer , contiguous :: ZBET ! 2D work array
+#ifdef MNH_OPENACC
+INTEGER :: IZY ,IZGAM, IZBET
+#endif
+!
+INTEGER :: JIU,JJU,JKU
!
! ---------------------------------------------------------------------------
@@ -190,11 +199,22 @@ if ( mppdb_initialized ) then
call Mppdb_check( psource, "Tridiag_wind beg:psource" )
end if
-allocate( zy (size( pvarm, 1 ), size( pvarm, 2 ), size( pvarm, 3 ) ) )
-allocate( zgam(size( pvarm, 1 ), size( pvarm, 2 ), size( pvarm, 3 ) ) )
-allocate( zbet(size( pvarm, 1 ), size( pvarm, 2 ) ) )
+JIU = size( pvarm, 1 )
+JJU = size( pvarm, 2 )
+JKU = size( pvarm, 3 )
+
+#ifndef MNH_OPENACC
+allocate( zy (JIU,JJU,JKU ) )
+allocate( zgam(JIU,JJU,JKU ) )
+allocate( zbet(JIU,JJU ) )
+#else
+CALL MNH_CHECK_IN_ZT3D("TRIDIAG_WIND")
+izy = MNH_ALLOCATE_ZT3D( zy ,JIU,JJU,JKU )
+izgam = MNH_ALLOCATE_ZT3D( zgam,JIU,JJU,JKU )
+izbet = MNH_ALLOCATE_ZT2D( zbet,JIU,JJU )
+#endif
-!$acc data create( ZY, ZGAM, ZBET )
+!$acc data present( ZY, ZGAM, ZBET )
!
!* 1. COMPUTE THE RIGHT HAND SIDE
@@ -208,26 +228,32 @@ IKE=KKU-JPVEXT_TURB*KKL
!
!
-!$acc kernels async
-ZY(:,:,IKB) = PVARM(:,:,IKB) + PTSTEP*PSOURCE(:,:,IKB) - &
- PEXPL / PRHODJA(:,:,IKB) * PA(:,:,IKB+KKL) * (PVARM(:,:,IKB+KKL) - PVARM(:,:,IKB))
+!$acc kernels ! async
+DO CONCURRENT ( JI=1:JIU,JJ=1:JJU)
+ZY(JI,JJ,IKB) = PVARM(JI,JJ,IKB) + PTSTEP*PSOURCE(JI,JJ,IKB) - &
+ PEXPL / PRHODJA(JI,JJ,IKB) * PA(JI,JJ,IKB+KKL) * (PVARM(JI,JJ,IKB+KKL) - PVARM(JI,JJ,IKB))
+END DO !CONCURRENT
!$acc end kernels
!
-!$acc kernels async
- ZY(:,:,IKTB+1:IKTE-1)= PVARM(:,:,IKTB+1:IKTE-1) + PTSTEP*PSOURCE(:,:,IKTB+1:IKTE-1) - &
- PEXPL / PRHODJA(:,:,IKTB+1:IKTE-1) * &
- ( PVARM(:,:,IKTB+1-KKL:IKTE-1-KKL)*PA(:,:,IKTB+1:IKTE-1) &
- -PVARM(:,:,IKTB+1:IKTE-1)*(PA(:,:,IKTB+1:IKTE-1)+PA(:,:,IKTB+1+KKL:IKTE-1+KKL)) &
- +PVARM(:,:,IKTB+1+KKL:IKTE-1+KKL)*PA(:,:,IKTB+1+KKL:IKTE-1+KKL) &
- )
+!$acc kernels ! async
+DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=IKTB+1:IKTE-1)
+ ZY(JI,JJ,JK)= PVARM(JI,JJ,JK) + PTSTEP*PSOURCE(JI,JJ,JK) - &
+ PEXPL / PRHODJA(JI,JJ,JK) * &
+ ( PVARM(JI,JJ,JK-KKL)*PA(JI,JJ,JK) &
+ -PVARM(JI,JJ,JK)*(PA(JI,JJ,JK)+PA(JI,JJ,JK+KKL)) &
+ +PVARM(JI,JJ,JK+KKL)*PA(JI,JJ,JK+KKL) &
+ )
+END DO !CONCURRENT
!$acc end kernels
!
-!$acc kernels async
-ZY(:,:,IKE)= PVARM(:,:,IKE) + PTSTEP*PSOURCE(:,:,IKE) + &
- PEXPL / PRHODJA(:,:,IKE) * PA(:,:,IKE) * (PVARM(:,:,IKE)-PVARM(:,:,IKE-KKL))
+!$acc kernels ! async
+DO CONCURRENT ( JI=1:JIU,JJ=1:JJU)
+ZY(JI,JJ,IKE)= PVARM(JI,JJ,IKE) + PTSTEP*PSOURCE(JI,JJ,IKE) + &
+ PEXPL / PRHODJA(JI,JJ,IKE) * PA(JI,JJ,IKE) * (PVARM(JI,JJ,IKE)-PVARM(JI,JJ,IKE-KKL))
+END DO !CONCURRENT
!$acc end kernels
!
-!$acc wait
+! acc wait
!
!
!* 2. INVERSION OF THE TRIDIAGONAL SYSTEM
@@ -238,50 +264,61 @@ IF ( PIMPL > 1.E-10 ) THEN
!
! going up
!
-!$acc kernels
- ZBET(:,:) = 1. - PIMPL * ( PA(:,:,IKB+KKL) / PRHODJA(:,:,IKB) &
- + PCOEFS(:,:) * PTSTEP ) ! bet = b(ikb)
- PVARP(:,:,IKB) = ZY(:,:,IKB) / ZBET(:,:)
+ !$acc kernels
+ !$acc loop independent collapse(2)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU)
+ ZBET(JI,JJ) = 1. - PIMPL * ( PA(JI,JJ,IKB+KKL) / PRHODJA(JI,JJ,IKB) &
+ + PCOEFS(JI,JJ) * PTSTEP ) ! bet = b(ikb)
+ PVARP(JI,JJ,IKB) = ZY(JI,JJ,IKB) / ZBET(JI,JJ)
+ END DO !CONCURRENT
!
+ !$acc loop seq
DO JK = IKB+KKL,IKE-KKL,KKL
-!$acc loop collapse(2) independent
- DO JJ=1,SIZE(ZGAM,2)
- DO JI=1,SIZE(ZGAM,1)
+ !$acc loop independent gang, vector collapse(2)
+ DO CONCURRENT ( JJ=1:JJU , JI=1:JIU )
ZGAM(JI,JJ,JK) = PIMPL * PA(JI,JJ,JK) / PRHODJA(JI,JJ,JK-KKL) / ZBET(JI,JJ)
- ! gam(k) = c(k-1) / bet
+ ! gam(k) = c(k-1) / bet
ZBET(JI,JJ) = 1. - PIMPL * ( PA(JI,JJ,JK) * (1. + ZGAM(JI,JJ,JK)) &
- + PA(JI,JJ,JK+KKL) &
- ) / PRHODJA(JI,JJ,JK)
- ! bet = b(k) - a(k)* gam(k)
+ + PA(JI,JJ,JK+KKL) &
+ ) / PRHODJA(JI,JJ,JK)
+ ! bet = b(k) - a(k)* gam(k)
PVARP(JI,JJ,JK)= ( ZY(JI,JJ,JK) - PIMPL * PA(JI,JJ,JK) / PRHODJA(JI,JJ,JK) &
- * PVARP(JI,JJ,JK-KKL) &
- ) / ZBET(JI,JJ)
- ! res(k) = (y(k) -a(k)*res(k-1))/ bet
- END DO
- END DO
+ * PVARP(JI,JJ,JK-KKL) &
+ ) / ZBET(JI,JJ)
+ ! res(k) = (y(k) -a(k)*res(k-1))/ bet
+ END DO ! CONCURRENT
END DO
! special treatment for the last level
- ZGAM(:,:,IKE) = PIMPL * PA(:,:,IKE) / PRHODJA(:,:,IKE-KKL) / ZBET(:,:)
- ! gam(k) = c(k-1) / bet
- ZBET(:,:) = 1. - PIMPL * ( PA(:,:,IKE) * (1. + ZGAM(:,:,IKE)) &
- ) / PRHODJA(:,:,IKE)
- ! bet = b(k) - a(k)* gam(k)
- PVARP(:,:,IKE)= ( ZY(:,:,IKE) - PIMPL * PA(:,:,IKE) / PRHODJA(:,:,IKE) &
- * PVARP(:,:,IKE-KKL) &
- ) / ZBET(:,:)
- ! res(k) = (y(k) -a(k)*res(k-1))/ bet
+ !$acc loop independent gang, vector collapse(2)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU)
+ ZGAM(JI,JJ,IKE) = PIMPL * PA(JI,JJ,IKE) / PRHODJA(JI,JJ,IKE-KKL) / ZBET(JI,JJ)
+ ! gam(k) = c(k-1) / bet
+ ZBET(JI,JJ) = 1. - PIMPL * ( PA(JI,JJ,IKE) * (1. + ZGAM(JI,JJ,IKE)) &
+ ) / PRHODJA(JI,JJ,IKE)
+ ! bet = b(k) - a(k)* gam(k)
+ PVARP(JI,JJ,IKE)= ( ZY(JI,JJ,IKE) - PIMPL * PA(JI,JJ,IKE) / PRHODJA(JI,JJ,IKE) &
+ * PVARP(JI,JJ,IKE-KKL) &
+ ) / ZBET(JI,JJ)
+ ! res(k) = (y(k) -a(k)*res(k-1))/ bet
+ END DO !CONCURRENT
!
! going down
!
+ !$acc loop seq
DO JK = IKE-KKL,IKB,-1*KKL
- PVARP(:,:,JK) = PVARP(:,:,JK) - ZGAM(:,:,JK+KKL) * PVARP(:,:,JK+KKL)
+ !$acc loop gang, vector collapse(2)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU)
+ PVARP(JI,JJ,JK) = PVARP(JI,JJ,JK) - ZGAM(JI,JJ,JK+KKL) * PVARP(JI,JJ,JK+KKL)
+ END DO !CONCURRENT
END DO
!$acc end kernels
!
ELSE
!
-!$acc kernels
- PVARP(:,:,IKTB:IKTE) = ZY(:,:,IKTB:IKTE)
+ !$acc kernels
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=IKTB:IKTE)
+ PVARP(JI,JJ,JK) = ZY(JI,JJ,JK)
+ END DO !CONCURRENT
!$acc end kernels
!
END IF
@@ -291,8 +328,10 @@ END IF
! ----------------------------------------
!
!$acc kernels
-PVARP(:,:,KKA)=PVARP(:,:,IKB)
-PVARP(:,:,KKU)=PVARP(:,:,IKE)
+DO CONCURRENT ( JI=1:JIU,JJ=1:JJU)
+ PVARP(JI,JJ,KKA)=PVARP(JI,JJ,IKB)
+ PVARP(JI,JJ,KKU)=PVARP(JI,JJ,IKE)
+END DO !CONCURRENT
!$acc end kernels
if ( mppdb_initialized ) then
@@ -302,6 +341,13 @@ end if
!$acc end data
+#ifndef MNH_OPENACC
+deallocate ( zy,zgam,zbet )
+#else
+CALL MNH_REL_ZT3D( izy,izgam,izbet )
+CALL MNH_CHECK_OUT_ZT3D("TRIDIAG_WIND")
+#endif
+
!$acc end data
!-------------------------------------------------------------------------------
diff --git a/src/MNH/turb.f90 b/src/MNH/turb.f90
index 115e9ce588ed13373c02869c843631d8b5da27ac..d431deaed59e82d4bcd614d31637a9bc66120750 100644
--- a/src/MNH/turb.f90
+++ b/src/MNH/turb.f90
@@ -8,7 +8,10 @@ module mode_turb
!###############
#ifdef MNH_OPENACC
-use mode_msg
+ use mode_msg
+ USE MODE_MNH_ZWORK , ONLY : MNH_ALLOCATE_ZT3D , MNH_REL_ZT3D, MNH_ALLOCATE_ZT3DP , MNH_ALLOCATE_ZT2D, &
+ MNH_ALLOCATE_ZT4D , MNH_REL_ZT4D , &
+ MNH_CHECK_IN_ZT3D,MNH_CHECK_OUT_ZT3D
#endif
#ifdef MNH_BITREP
@@ -403,7 +406,7 @@ REAL, DIMENSION(:,:,:), INTENT(OUT) :: PLEM ! Mixing length
!
! 0.2 declaration of local variables
!
-REAL, ALLOCATABLE, DIMENSION(:,:,:) ::&
+REAL, POINTER , CONTIGUOUS, DIMENSION(:,:,:) ::&
ZCP, & ! Cp at t-1
ZEXN, & ! EXN at t-1
ZT, & ! T at t-1
@@ -417,10 +420,15 @@ REAL, ALLOCATABLE, DIMENSION(:,:,:) ::&
ZMWTH,ZMWR,ZMTH2,ZMR2,ZMTHR,& ! 3rd order moments
ZFWTH,ZFWR,ZFTH2,ZFR2,ZFTHR,& ! opposite of verticale derivate of 3rd order moments
ZTHLM ! initial potential temp.
+#ifdef MNH_OPENACC
+INTEGER :: IZCP,IZEXN,IZT,IZLOCPEXNM,IZLEPS,IZTRH,IZATHETA,IZAMOIST &
+ ,IZCOEF_DISS,IZFRAC_ICE,IZMWTH,IZMWR,IZMTH2,IZMR2,IZMTHR &
+ ,IZFWTH,IZFWR,IZFTH2,IZFR2,IZFTHR,IZTHLM
+#endif
!
-REAL, ALLOCATABLE, DIMENSION(:,:,:,:) :: &
+REAL, POINTER , CONTIGUOUS, DIMENSION(:,:,:,:) :: &
ZRM ! initial mixing ratio
-REAL, ALLOCATABLE, DIMENSION(:,:) :: ZTAU11M,ZTAU12M, &
+REAL, POINTER , CONTIGUOUS, DIMENSION(:,:) :: ZTAU11M,ZTAU12M, &
ZTAU22M,ZTAU33M, &
! tangential surface fluxes in the axes following the orography
ZUSLOPE,ZVSLOPE, &
@@ -435,9 +443,16 @@ REAL, ALLOCATABLE, DIMENSION(:,:) :: ZTAU11M,ZTAU12M, &
!
! Virtual Potential Temp. used
! in the Deardorff mixing length computation
-REAL, DIMENSION(:,:,:), ALLOCATABLE :: &
+#ifdef MNH_OPENACC
+INTEGER :: IZRM,IZTAU11M,IZTAU12M,IZTAU22M,IZTAU33M,IZUSLOPE,IZVSLOPE &
+ ,IZCDUEFF,IZUSTAR,IZLMO,IZRVM,IZSFRV
+#endif
+REAL, DIMENSION(:,:,:), POINTER , CONTIGUOUS :: &
ZLVOCPEXNM,ZLSOCPEXNM, & ! Lv/Cp/EXNREF and Ls/Cp/EXNREF at t-1
ZATHETA_ICE,ZAMOIST_ICE ! coefficients for s = f (Thetal,Rnp)
+#ifdef MNH_OPENACC
+INTEGER :: IZLVOCPEXNM,IZLSOCPEXNM,IZATHETA_ICE,IZAMOIST_ICE
+#endif
!
REAL :: ZEXPL ! 1-PIMPL deg of expl.
REAL :: ZRVORD ! RV/RD
@@ -454,14 +469,21 @@ REAL :: ZALPHA ! work coefficient :
! ! BL89 mixing length near the surface
!
REAL :: ZTIME1, ZTIME2
-REAL, DIMENSION(:,:,:), allocatable :: ZTT,ZEXNE,ZLV,ZCPH
-REAL, DIMENSION(:,:,:), allocatable :: ZSHEAR, ZDUDZ, ZDVDZ
+REAL, DIMENSION(:,:,:), pointer , contiguous :: ZTT,ZEXNE,ZLV,ZCPH
+REAL, DIMENSION(:,:,:), pointer , contiguous :: ZSHEAR, ZDUDZ, ZDVDZ
+#ifdef MNH_OPENACC
+INTEGER :: IZTT,IZEXNE,IZLV,IZCPH,IZSHEAR, IZDUDZ, IZDVDZ
+#endif
TYPE(TFIELDDATA) :: TZFIELD
!
#ifdef MNH_OPENACC
-REAL, DIMENSION(:,:,:), allocatable :: ZTMP1_DEVICE,ZTMP2_DEVICE,ZTMP3_DEVICE
+REAL, DIMENSION(:,:,:), pointer , contiguous :: ZTMP1_DEVICE,ZTMP2_DEVICE,ZTMP3_DEVICE
+INTEGER :: IZTMP1_DEVICE,IZTMP2_DEVICE,IZTMP3_DEVICE
#endif
!
+INTEGER :: JIU,JJU,JKU
+INTEGER :: JLU_ZRM, JLU_TURB, JJU_ORMC01, JKU_CLOUD, JKU_TURB
+!
!------------------------------------------------------------------------------------------
!
! IN variables
@@ -528,70 +550,144 @@ if ( mppdb_initialized ) then
call Mppdb_check( prsvs, "Turb beg:prsvs" )
end if
-ALLOCATE (ZCP (SIZE(PTHLT,1),SIZE(PTHLT,2),SIZE(PTHLT,3)) )
-ALLOCATE (ZEXN (SIZE(PTHLT,1),SIZE(PTHLT,2),SIZE(PTHLT,3)) )
-ALLOCATE (ZT (SIZE(PTHLT,1),SIZE(PTHLT,2),SIZE(PTHLT,3)) )
-ALLOCATE (ZLOCPEXNM (SIZE(PTHLT,1),SIZE(PTHLT,2),SIZE(PTHLT,3)) )
-ALLOCATE (ZLEPS (SIZE(PTHLT,1),SIZE(PTHLT,2),SIZE(PTHLT,3)) )
-ALLOCATE (ZTRH (SIZE(PTHLT,1),SIZE(PTHLT,2),SIZE(PTHLT,3)) )
-ALLOCATE (ZATHETA (SIZE(PTHLT,1),SIZE(PTHLT,2),SIZE(PTHLT,3)) )
-ALLOCATE (ZAMOIST (SIZE(PTHLT,1),SIZE(PTHLT,2),SIZE(PTHLT,3)) )
-ALLOCATE (ZCOEF_DISS(SIZE(PTHLT,1),SIZE(PTHLT,2),SIZE(PTHLT,3)) )
-ALLOCATE (ZFRAC_ICE (SIZE(PTHLT,1),SIZE(PTHLT,2),SIZE(PTHLT,3)) )
-
-ALLOCATE (ZMWTH (SIZE(PTHLT,1),SIZE(PTHLT,2),SIZE(PTHLT,3)) )
-ALLOCATE (ZMWR (SIZE(PTHLT,1),SIZE(PTHLT,2),SIZE(PTHLT,3)) )
-ALLOCATE (ZMTH2 (SIZE(PTHLT,1),SIZE(PTHLT,2),SIZE(PTHLT,3)) )
-ALLOCATE (ZMR2 (SIZE(PTHLT,1),SIZE(PTHLT,2),SIZE(PTHLT,3)) )
-ALLOCATE (ZMTHR (SIZE(PTHLT,1),SIZE(PTHLT,2),SIZE(PTHLT,3)) )
-
-ALLOCATE (ZFWTH (SIZE(PTHLT,1),SIZE(PTHLT,2),SIZE(PTHLT,3)) )
-ALLOCATE (ZFWR (SIZE(PTHLT,1),SIZE(PTHLT,2),SIZE(PTHLT,3)) )
-ALLOCATE (ZFTH2 (SIZE(PTHLT,1),SIZE(PTHLT,2),SIZE(PTHLT,3)) )
-ALLOCATE (ZFR2 (SIZE(PTHLT,1),SIZE(PTHLT,2),SIZE(PTHLT,3)) )
-ALLOCATE (ZFTHR (SIZE(PTHLT,1),SIZE(PTHLT,2),SIZE(PTHLT,3)) )
-ALLOCATE (ZTHLM (SIZE(PTHLT,1),SIZE(PTHLT,2),SIZE(PTHLT,3)) )
-
-IF ( HTURBLEN == 'BL89' .OR. HTURBLEN == 'RM17' .OR. HTURBLEN == 'ADAP' .OR. ORMC01 ) &
- ALLOCATE ( ZRM(SIZE(PRT,1),SIZE(PRT,2),SIZE(PRT,3),SIZE(PRT,4)) )
-
-ALLOCATE ( ZTAU11M(SIZE(PTHLT,1),SIZE(PTHLT,2)) )
-ALLOCATE ( ZTAU12M(SIZE(PTHLT,1),SIZE(PTHLT,2)) )
-ALLOCATE ( ZTAU22M(SIZE(PTHLT,1),SIZE(PTHLT,2)) )
-ALLOCATE ( ZTAU33M(SIZE(PTHLT,1),SIZE(PTHLT,2)) )
-ALLOCATE ( ZUSLOPE(SIZE(PTHLT,1),SIZE(PTHLT,2)) )
-ALLOCATE ( ZVSLOPE(SIZE(PTHLT,1),SIZE(PTHLT,2)) )
-ALLOCATE ( ZCDUEFF(SIZE(PTHLT,1),SIZE(PTHLT,2)) )
-ALLOCATE ( ZLMO (SIZE(PTHLT,1),SIZE(PTHLT,2)) )
-IF (ORMC01) then
- ALLOCATE ( ZUSTAR (SIZE(PTHLT,1),SIZE(PTHLT,2)) )
- ALLOCATE ( ZRVM (SIZE(PTHLT,1),SIZE(PTHLT,2)) )
- ALLOCATE ( ZSFRV (SIZE(PTHLT,1),SIZE(PTHLT,2)) )
-end if
+JIU = size(pthlt, 1 )
+JJU = size(pthlt, 2 )
+JKU = size(pthlt, 3 )
-IF ( HCLOUD == 'KHKO' .OR. HCLOUD == 'C2R2' ) then
- allocate( ztt (size( put, 1 ), size( put, 2 ), size( put, 3 ) ) )
- allocate( zexne (size( put, 1 ), size( put, 2 ), size( put, 3 ) ) )
- allocate( zlv (size( put, 1 ), size( put, 2 ), size( put, 3 ) ) )
- allocate( zcph (size( put, 1 ), size( put, 2 ), size( put, 3 ) ) )
-end if
-IF ( HTURBLEN == 'BL89' .OR. HTURBLEN == 'RM17' .OR. HTURBLEN == 'ADAP' ) then
- allocate( zshear(size( put, 1 ), size( put, 2 ), size( put, 3 ) ) )
-end if
-IF ( HTURBLEN == 'RM17' .OR. HTURBLEN == 'ADAP' ) then
- allocate( zdudz (size( put, 1 ), size( put, 2 ), size( put, 3 ) ) )
- allocate( zdvdz (size( put, 1 ), size( put, 2 ), size( put, 3 ) ) )
-end if
+#ifndef MNH_OPENACC
+ALLOCATE (ZCP (JIU,JJU,JKU) )
+ALLOCATE (ZEXN (JIU,JJU,JKU) )
+ALLOCATE (ZT (JIU,JJU,JKU) )
+ALLOCATE (ZLOCPEXNM (JIU,JJU,JKU) )
+ALLOCATE (ZLEPS (JIU,JJU,JKU) )
+ALLOCATE (ZTRH (JIU,JJU,JKU) )
+ALLOCATE (ZATHETA (JIU,JJU,JKU) )
+ALLOCATE (ZAMOIST (JIU,JJU,JKU) )
+ALLOCATE (ZCOEF_DISS(JIU,JJU,JKU) )
+ALLOCATE (ZFRAC_ICE (JIU,JJU,JKU) )
+
+ALLOCATE (ZMWTH (JIU,JJU,JKU) )
+ALLOCATE (ZMWR (JIU,JJU,JKU) )
+ALLOCATE (ZMTH2 (JIU,JJU,JKU) )
+ALLOCATE (ZMR2 (JIU,JJU,JKU) )
+ALLOCATE (ZMTHR (JIU,JJU,JKU) )
+
+ALLOCATE (ZFWTH (JIU,JJU,JKU) )
+ALLOCATE (ZFWR (JIU,JJU,JKU) )
+ALLOCATE (ZFTH2 (JIU,JJU,JKU) )
+ALLOCATE (ZFR2 (JIU,JJU,JKU) )
+ALLOCATE (ZFTHR (JIU,JJU,JKU) )
+ALLOCATE (ZTHLM (JIU,JJU,JKU) )
+
+JLU_TURB = 0
+IF ( HTURBLEN == 'BL89' .OR. HTURBLEN == 'RM17' .OR. ORMC01 ) JLU_TURB = SIZE(PRT,4)
+ALLOCATE ( ZRM(JIU,JJU,JKU, JLU_TURB ) )
+
+ALLOCATE ( ZTAU11M(JIU,JJU) )
+ALLOCATE ( ZTAU12M(JIU,JJU) )
+ALLOCATE ( ZTAU22M(JIU,JJU) )
+ALLOCATE ( ZTAU33M(JIU,JJU) )
+ALLOCATE ( ZUSLOPE(JIU,JJU) )
+ALLOCATE ( ZVSLOPE(JIU,JJU) )
+ALLOCATE ( ZCDUEFF(JIU,JJU) )
+ALLOCATE ( ZLMO (JIU,JJU) )
+
+JJU_ORMC01 = 0
+IF (ORMC01) JJU_ORMC01 = SIZE(PTHLT,2)
+ALLOCATE ( ZUSTAR (JIU,JJU_ORMC01) )
+ALLOCATE ( ZRVM (JIU,JJU_ORMC01) )
+ALLOCATE ( ZSFRV (JIU,JJU_ORMC01) )
+
+JKU_CLOUD = 0
+IF ( HCLOUD == 'KHKO' .OR. HCLOUD == 'C2R2' ) JKU_CLOUD = size( put, 3 )
+allocate( ztt (JIU,JJU, JKU_CLOUD ) )
+allocate( zexne (JIU,JJU, JKU_CLOUD ) )
+allocate( zlv (JIU,JJU, JKU_CLOUD ) )
+allocate( zcph (JIU,JJU, JKU_CLOUD ) )
+
+JKU_TURB = 0
+IF ( HTURBLEN == 'BL89' .OR. HTURBLEN == 'RM17' ) JKU_TURB = size( put, 3 )
+allocate( zshear(JIU,JJU, JKU_TURB ) )
+
+JKU_TURB = 0
+IF ( HTURBLEN == 'RM17' ) JKU_TURB = size( put, 3 )
+allocate( zdudz (JIU,JJU, JKU_TURB ) )
+allocate( zdvdz (JIU,JJU, JKU_TURB ) )
+
+#else
+CALL MNH_CHECK_IN_ZT3D("TURB")
+IZCP = MNH_ALLOCATE_ZT3D (ZCP ,JIU,JJU,JKU )
+IZEXN = MNH_ALLOCATE_ZT3D (ZEXN ,JIU,JJU,JKU )
+IZT = MNH_ALLOCATE_ZT3D (ZT ,JIU,JJU,JKU )
+IZLOCPEXNM = MNH_ALLOCATE_ZT3D (ZLOCPEXNM ,JIU,JJU,JKU )
+IZLEPS = MNH_ALLOCATE_ZT3D (ZLEPS ,JIU,JJU,JKU )
+IZTRH = MNH_ALLOCATE_ZT3D (ZTRH ,JIU,JJU,JKU )
+IZATHETA = MNH_ALLOCATE_ZT3D (ZATHETA ,JIU,JJU,JKU )
+IZAMOIST = MNH_ALLOCATE_ZT3D (ZAMOIST ,JIU,JJU,JKU )
+IZCOEF_DISS = MNH_ALLOCATE_ZT3D (ZCOEF_DISS,JIU,JJU,JKU )
+IZFRAC_ICE = MNH_ALLOCATE_ZT3D (ZFRAC_ICE ,JIU,JJU,JKU )
+
+IZMWTH = MNH_ALLOCATE_ZT3D (ZMWTH ,JIU,JJU,JKU )
+IZMWR = MNH_ALLOCATE_ZT3D (ZMWR ,JIU,JJU,JKU )
+IZMTH2 = MNH_ALLOCATE_ZT3D (ZMTH2 ,JIU,JJU,JKU )
+IZMR2 = MNH_ALLOCATE_ZT3D (ZMR2 ,JIU,JJU,JKU )
+IZMTHR = MNH_ALLOCATE_ZT3D (ZMTHR ,JIU,JJU,JKU )
+
+IZFWTH = MNH_ALLOCATE_ZT3D (ZFWTH ,JIU,JJU,JKU )
+IZFWR = MNH_ALLOCATE_ZT3D (ZFWR ,JIU,JJU,JKU )
+IZFTH2 = MNH_ALLOCATE_ZT3D (ZFTH2 ,JIU,JJU,JKU )
+IZFR2 = MNH_ALLOCATE_ZT3D (ZFR2 ,JIU,JJU,JKU )
+IZFTHR = MNH_ALLOCATE_ZT3D (ZFTHR ,JIU,JJU,JKU )
+IZTHLM = MNH_ALLOCATE_ZT3D (ZTHLM ,JIU,JJU,JKU )
+
+JLU_ZRM = 0
+IF ( HTURBLEN == 'BL89' .OR. HTURBLEN == 'RM17' .OR. ORMC01 ) JLU_ZRM = SIZE(PRT,4)
+IZRM = MNH_ALLOCATE_ZT4D ( ZRM,JIU,JJU,JKU, JLU_ZRM )
+
+IZTAU11M = MNH_ALLOCATE_ZT2D ( ZTAU11M,JIU,JJU )
+IZTAU12M = MNH_ALLOCATE_ZT2D ( ZTAU12M,JIU,JJU )
+IZTAU22M = MNH_ALLOCATE_ZT2D ( ZTAU22M,JIU,JJU )
+IZTAU33M = MNH_ALLOCATE_ZT2D ( ZTAU33M,JIU,JJU )
+IZUSLOPE = MNH_ALLOCATE_ZT2D ( ZUSLOPE,JIU,JJU )
+IZVSLOPE = MNH_ALLOCATE_ZT2D ( ZVSLOPE,JIU,JJU )
+IZCDUEFF = MNH_ALLOCATE_ZT2D ( ZCDUEFF,JIU,JJU )
+IZLMO = MNH_ALLOCATE_ZT2D ( ZLMO ,JIU,JJU )
+
+JJU_ORMC01 = 0
+IF (ORMC01) JJU_ORMC01 = SIZE(PTHLT,2)
+IZUSTAR = MNH_ALLOCATE_ZT2D ( ZUSTAR ,JIU,JJU_ORMC01 )
+IZRVM = MNH_ALLOCATE_ZT2D ( ZRVM ,JIU,JJU_ORMC01 )
+IZSFRV = MNH_ALLOCATE_ZT2D ( ZSFRV ,JIU,JJU_ORMC01 )
+
+JKU_CLOUD = 0
+IF ( HCLOUD == 'KHKO' .OR. HCLOUD == 'C2R2' ) JKU_CLOUD = size( put, 3 )
+iztt = MNH_ALLOCATE_ZT3D( ztt ,JIU,JJU,JKU_CLOUD )
+izexne = MNH_ALLOCATE_ZT3D( zexne ,JIU,JJU,JKU_CLOUD )
+izlv = MNH_ALLOCATE_ZT3D( zlv ,JIU,JJU,JKU_CLOUD )
+izcph = MNH_ALLOCATE_ZT3D( zcph ,JIU,JJU,JKU_CLOUD )
+
+JKU_TURB = 0
+IF ( HTURBLEN == 'BL89' .OR. HTURBLEN == 'RM17' ) JKU_TURB = size( put, 3 )
+izshear = MNH_ALLOCATE_ZT3D( zshear,JIU,JJU, JKU_TURB )
+
+JKU_TURB = 0
+IF ( HTURBLEN == 'RM17' ) JKU_TURB = size( put, 3 )
+izdudz = MNH_ALLOCATE_ZT3D( zdudz ,JIU,JJU, JKU_TURB )
+izdvdz = MNH_ALLOCATE_ZT3D( zdvdz ,JIU,JJU, JKU_TURB )
+
+#endif
#ifdef MNH_OPENACC
-allocate( ztmp1_device(size( pthlt, 1 ), size( pthlt, 2 ), size( pthlt, 3 ) ) )
-IF (HTURBDIM=="1DIM") then
- allocate( ztmp2_device(size( pthlt, 1 ), size( pthlt, 2 ), size( pthlt, 3 ) ) )
- allocate( ztmp3_device(size( pthlt, 1 ), size( pthlt, 2 ), size( pthlt, 3 ) ) )
-end if
+iztmp1_device = MNH_ALLOCATE_ZT3D( ztmp1_device,JIU,JJU,JKU )
+
+JKU_TURB = 0
+IF (HTURBDIM=="1DIM") JKU_TURB = size( pthlt, 3 )
+iztmp2_device = MNH_ALLOCATE_ZT3D( ztmp2_device,JIU,JJU, JKU_TURB )
+iztmp3_device = MNH_ALLOCATE_ZT3D( ztmp3_device,JIU,JJU, JKU_TURB )
+
#endif
-!$acc data create( zcp, zexn, zt, zlocpexnm, zleps, ztrh, &
+!$acc data present( zcp, zexn, zt, zlocpexnm, zleps, ztrh, &
!$acc & zatheta, zamoist, zcoef_diss, zfrac_ice, &
!$acc & zmwth, zmwr, zmth2, zmr2, zmthr, &
!$acc & zfwth, zfwr, zfth2, zfr2, zfthr, zthlm, &
@@ -640,10 +736,13 @@ ZTRH(:, :, : ) = XUNDEF
ZCP(:,:,:)=XCPD
!
IF (KRR > 0) ZCP(:,:,:) = ZCP(:,:,:) + XCPV * PRT(:,:,:,1)
+! PGI20.5 BUG or reproductibility problem , with pointer this loop on JRR parallelize whitout reduction
+!$acc loop seq
DO JRR = 2,1+KRRL ! loop on the liquid components
ZCP(:,:,:) = ZCP(:,:,:) + XCL * PRT(:,:,:,JRR)
END DO
!
+!$acc loop seq
DO JRR = 2+KRRL,1+KRRL+KRRI ! loop on the solid components
ZCP(:,:,:) = ZCP(:,:,:) + XCI * PRT(:,:,:,JRR)
END DO
@@ -684,10 +783,10 @@ IF (KRRL >=1) THEN
!* 2.5 Lv/Cph/Exn
!
IF ( KRRI >= 1 ) THEN
- ALLOCATE(ZLVOCPEXNM(SIZE(PTHLT,1),SIZE(PTHLT,2),SIZE(PTHLT,3)))
- ALLOCATE(ZLSOCPEXNM(SIZE(PTHLT,1),SIZE(PTHLT,2),SIZE(PTHLT,3)))
- ALLOCATE(ZAMOIST_ICE(SIZE(PTHLT,1),SIZE(PTHLT,2),SIZE(PTHLT,3)))
- ALLOCATE(ZATHETA_ICE(SIZE(PTHLT,1),SIZE(PTHLT,2),SIZE(PTHLT,3)))
+ ALLOCATE(ZLVOCPEXNM(JIU,JJU,JKU))
+ ALLOCATE(ZLSOCPEXNM(JIU,JJU,JKU))
+ ALLOCATE(ZAMOIST_ICE(JIU,JJU,JKU))
+ ALLOCATE(ZATHETA_ICE(JIU,JJU,JKU))
!$acc enter data create( zlvocpexnm, zlsocpexnm )
!$acc data create( zamoist_ice, zatheta_ice )
@@ -958,8 +1057,11 @@ ENDIF
ZCDUEFF(:,:) =-SQRT ( (PSFU(:,:)**2 + PSFV(:,:)**2) / &
(XMNH_TINY + ZUSLOPE(:,:)**2 + ZVSLOPE(:,:)**2 ) )
#else
- ZCDUEFF(:,:) =-SQRT ( (BR_P2(PSFU(:,:)) + BR_P2(PSFV(:,:))) / &
- (XMNH_TINY + BR_P2(ZUSLOPE(:,:)) + BR_P2(ZVSLOPE(:,:)) ) )
+ !$acc loop independent collapse(2)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU )
+ ZCDUEFF(JI,JJ) =-SQRT ( (BR_P2(PSFU(JI,JJ)) + BR_P2(PSFV(JI,JJ))) / &
+ (XMNH_TINY + BR_P2(ZUSLOPE(JI,JJ)) + BR_P2(ZVSLOPE(JI,JJ)) ) )
+ END DO
#endif
!$acc end kernels
!
@@ -1488,6 +1590,36 @@ end if
!$acc end data
+#ifndef MNH_OPENACC
+deallocate( zcp, zexn, zt, zlocpexnm, zleps, ztrh, &
+ zatheta, zamoist, zcoef_diss, zfrac_ice, &
+ zmwth, zmwr, zmth2, zmr2, zmthr, &
+ zfwth, zfwr, zfth2, zfr2, zfthr, zthlm, &
+ zrm, &
+ ztau11m, ztau12m, ztau22m, ztau33m, &
+ zuslope, zvslope, zcdueff, zlmo, &
+ zustar, zrvm, zsfrv, &
+ ztt, zexne, zlv, zcph, zshear, zdudz, zdvdz )
+#else
+
+CALL MNH_REL_ZT3D ( iztt, izexne, izlv, izcph, izshear, izdudz, izdvdz, &
+ iztmp1_device, iztmp2_device, iztmp3_device )
+
+CALL MNH_REL_ZT3D ( iztau11m, iztau12m, iztau22m, iztau33m, &
+ izuslope, izvslope, izcdueff, izlmo, &
+ izustar, izrvm, izsfrv )
+
+CALL MNH_REL_ZT3D ( izrm)
+
+CALL MNH_REL_ZT3D ( izmwth, izmwr, izmth2, izmr2, izmthr, &
+ izfwth, izfwr, izfth2, izfr2, izfthr, izthlm )
+
+CALL MNH_REL_ZT3D ( izcp, izexn, izt, izlocpexnm, izleps, iztrh, &
+ izatheta, izamoist, izcoef_diss, izfrac_ice )
+
+CALL MNH_CHECK_OUT_ZT3D("TURB")
+#endif
+
!$acc end data
!----------------------------------------------------------------------------
@@ -1629,8 +1761,11 @@ REAL, DIMENSION(:,:,:), INTENT(OUT) :: PAMOIST,PATHETA
!* 0.2 Declarations of local variables
!
REAL :: ZEPS ! XMV / XMD
-real, dimension(:,:,:), allocatable :: zrvsat
-real, dimension(:,:,:), allocatable :: zdrvsatdt
+real, dimension(:,:,:), pointer , contiguous :: zrvsat
+real, dimension(:,:,:), pointer , contiguous :: zdrvsatdt
+#ifdef MNH_OPENACC
+INTEGER :: izrvsat, izdrvsatdt
+#endif
!
!-------------------------------------------------------------------------------
@@ -1643,10 +1778,15 @@ real, dimension(:,:,:), allocatable :: zdrvsatdt
call Mppdb_check( pcp, "Compute_function_thermo beg:pcp" )
end if
+#ifndef MNH_OPENACC
allocate( zrvsat ( size( pexn, 1 ), size( pexn, 2 ), size( pexn, 3 ) ) )
allocate( zdrvsatdt( size( pexn, 1 ), size( pexn, 2 ), size( pexn, 3 ) ) )
+#else
+izrvsat = MNH_ALLOCATE_ZT3D( zrvsat , size( pexn, 1 ), size( pexn, 2 ), size( pexn, 3 ) )
+izdrvsatdt = MNH_ALLOCATE_ZT3D( zdrvsatdt, size( pexn, 1 ), size( pexn, 2 ), size( pexn, 3 ) )
+#endif
-!$acc data create( zrvsat, zdrvsatdt )
+!$acc data present( zrvsat, zdrvsatdt )
ZEPS = XMV / XMD
!
@@ -1663,7 +1803,9 @@ real, dimension(:,:,:), allocatable :: zdrvsatdt
#ifndef MNH_BITREP
ZRVSAT(:,:,:) = EXP( PALP - PBETA/PT(:,:,:) - PGAM*ALOG( PT(:,:,:) ) )
#else
- ZRVSAT(:,:,:) = BR_EXP( PALP - PBETA/PT(:,:,:) - PGAM*BR_LOG( PT(:,:,:) ) )
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZRVSAT(JI,JJ,JK) = BR_EXP( PALP - PBETA/PT(JI,JJ,JK) - PGAM*BR_LOG( PT(JI,JJ,JK) ) )
+ END DO
#endif
!
!* 1.3 saturation mixing ratio at t
@@ -1702,7 +1844,7 @@ real, dimension(:,:,:), allocatable :: zdrvsatdt
PLOCPEXN(:,:,:) = PLOCPEXN(:,:,:) / PEXN(:,:,:)
!$acc end kernels
- deallocate( zrvsat, zdrvsatdt )
+
if ( mppdb_initialized ) then
!Check all out arrays
@@ -1713,6 +1855,12 @@ real, dimension(:,:,:), allocatable :: zdrvsatdt
!$acc end data
+#ifndef MNH_OPENACC
+ deallocate( zrvsat, zdrvsatdt )
+#else
+ CALL MNH_REL_ZT3D(izrvsat, izdrvsatdt )
+#endif
+
!$acc end data
END SUBROUTINE COMPUTE_FUNCTION_THERMO
@@ -1772,10 +1920,10 @@ IMPLICIT NONE
REAL :: ZPENTE ! Slope of the amplification straight line
REAL :: ZCOEF_AMPL_CEI_NUL! Ordonnate at the origin of the
! amplification straight line
-real, dimension(:,:,:), allocatable :: zcoef_ampl
+real, dimension(:,:,:), pointer , contiguous :: zcoef_ampl
! Amplification coefficient of the mixing length
! when the instability criterium is verified
-real, dimension(:,:,:), allocatable :: zlm_cloud
+real, dimension(:,:,:), pointer , contiguous :: zlm_cloud
! Turbulent mixing length in the clouds
!
!-------------------------------------------------------------------------------
@@ -1966,7 +2114,7 @@ REAL :: ZALPHA ! proportionnality constant between Dz/2 and
! ! BL89 mixing length near the surface
REAL :: ZD ! distance to the surface
#ifdef MNH_OPENACC
-real, dimension(:,:,:), allocatable :: ztmp1_device, ztmp2_device
+real, dimension(:,:,:), pointer , contiguous :: ztmp1_device, ztmp2_device
#endif
!
!-------------------------------------------------------------------------------
@@ -2192,16 +2340,21 @@ REAL :: ZALPHA ! proportionnality constant between Dz/2 and
! ! BL89 mixing length near the surface
REAL :: ZD ! distance to the surface
REAL :: ZVAR ! Intermediary variable
-REAL, DIMENSION(:,:), ALLOCATABLE :: ZWORK2D
+REAL, DIMENSION(:,:), POINTER , CONTIGUOUS :: ZWORK2D
!
-REAL, DIMENSION(:,:,:), ALLOCATABLE :: &
+REAL, DIMENSION(:,:,:), POINTER , CONTIGUOUS :: &
ZDTHLDZ,ZDRTDZ, &!dtheta_l/dz, drt_dz used for computing the stablity
! ! criterion
ZETHETA,ZEMOIST !coef ETHETA and EMOIST
+#ifdef MNH_OPENACC
+INTEGER :: IZWORK2D,IZDTHLDZ,IZDRTDZ,IZETHETA,IZEMOIST
+#endif
!
#ifdef MNH_OPENACC
-REAL, DIMENSION(:,:,:), ALLOCATABLE :: ZTMP1_DEVICE,ZTMP2_DEVICE
+REAL, DIMENSION(:,:,:), POINTER , CONTIGUOUS :: ZTMP1_DEVICE,ZTMP2_DEVICE
+INTEGER :: IZTMP1_DEVICE,IZTMP2_DEVICE
#endif
+INTEGER :: JIU,JJU,JKU
!----------------------------------------------------------------------------
!$acc data present( PDXX, PDYY, PDZZ, PZZ, PDIRCOSZW, PTHLT, PTHVREF, PTKET, PSRCT, PRT, PLOCPEXNM, PATHETA, PAMOIST, PLM )
@@ -2223,18 +2376,31 @@ if ( mppdb_initialized ) then
call Mppdb_check( pamoist, "Dear beg:pamoist" )
end if
+JIU = size(pthlt, 1 )
+JJU = size(pthlt, 2 )
+JKU = size(pthlt, 3 )
+
!-------------------------------------------------------------------------------
-allocate( ZWORK2D(SIZE(PLM,1),SIZE(PLM,2)) )
-allocate( ZDTHLDZ(SIZE(PTHLT,1),SIZE(PTHLT,2),SIZE(PTHLT,3)) )
-allocate( ZDRTDZ (SIZE(PTHLT,1),SIZE(PTHLT,2),SIZE(PTHLT,3)) )
-allocate( ZETHETA(SIZE(PTHLT,1),SIZE(PTHLT,2),SIZE(PTHLT,3)) )
-allocate( ZEMOIST(SIZE(PTHLT,1),SIZE(PTHLT,2),SIZE(PTHLT,3)) )
+#ifndef MNH_OPENACC
+allocate( ZWORK2D(JIU,JJU) )
+allocate( ZDTHLDZ(JIU,JJU,JKU) )
+allocate( ZDRTDZ (JIU,JJU,JKU) )
+allocate( ZETHETA(JIU,JJU,JKU) )
+allocate( ZEMOIST(JIU,JJU,JKU) )
+#else
+IZWORK2D = MNH_ALLOCATE_ZT2D( ZWORK2D,JIU,JJU)
+IZDTHLDZ = MNH_ALLOCATE_ZT3D( ZDTHLDZ,JIU,JJU,JKU)
+IZDRTDZ = MNH_ALLOCATE_ZT3D( ZDRTDZ ,JIU,JJU,JKU)
+IZETHETA = MNH_ALLOCATE_ZT3D( ZETHETA,JIU,JJU,JKU)
+IZEMOIST = MNH_ALLOCATE_ZT3D( ZEMOIST,JIU,JJU,JKU)
+#endif
+
#ifdef MNH_OPENACC
-allocate( ZTMP1_DEVICE(SIZE(PTHLT,1),SIZE(PTHLT,2),SIZE(PTHLT,3)) )
-allocate( ZTMP2_DEVICE(SIZE(PTHLT,1),SIZE(PTHLT,2),SIZE(PTHLT,3)) )
+IZTMP1_DEVICE = MNH_ALLOCATE_ZT3D( ZTMP1_DEVICE,JIU,JJU,JKU)
+IZTMP2_DEVICE = MNH_ALLOCATE_ZT3D( ZTMP2_DEVICE,JIU,JJU,JKU)
#endif
-!$acc data create( zwork2d, zdthldz, zdrtdz, zetheta, zemoist, &
+!$acc data present(zwork2d, zdthldz, zdrtdz, zetheta, zemoist, &
!$acc & ztmp1_device, ztmp2_device )
!
@@ -2254,6 +2420,10 @@ IF ( HTURBDIM /= '1DIM' ) THEN ! 3D turbulence scheme
!$acc kernels
PLM(:,:,:) = SQRT( PLM(:,:,:)*ZTMP1_DEVICE )
!$acc end kernels
+ if ( mppdb_initialized ) then
+ call Mppdb_check( ZTMP1_DEVICE , "Dear mid: ZTMP1_DEVICE=Mxf" )
+ call Mppdb_check( plm, "Dear mid:plm" )
+ end if
#endif
ELSE
!PW: "BUG" PGI : results different on CPU and GPU due to the power function
@@ -2269,6 +2439,11 @@ IF ( HTURBDIM /= '1DIM' ) THEN ! 3D turbulence scheme
!$acc kernels
PLM(:,:,:) = (PLM(:,:,:)*ZTMP1_DEVICE*ZTMP2_DEVICE ) ** (1./3.)
!$acc end kernels
+ if ( mppdb_initialized ) then
+ call Mppdb_check( ZTMP1_DEVICE , "Dear mid: ZTMP1_DEVICE=Mxf" )
+ call Mppdb_check( ZTMP2_DEVICE , "Dear mid: ZTMP2_DEVICE=Myf" )
+ call Mppdb_check( plm, "Dear mid:plm" )
+ end if
#endif
!
#else
@@ -2278,9 +2453,17 @@ IF ( HTURBDIM /= '1DIM' ) THEN ! 3D turbulence scheme
#else
CALL MXF_DEVICE(PDXX,ZTMP1_DEVICE)
CALL MYF_DEVICE(PDYY,ZTMP2_DEVICE)
+ if ( mppdb_initialized ) then
+ call Mppdb_check( ZTMP1_DEVICE , "Dear mid: ZTMP1_DEVICE=Mxf" )
+ call Mppdb_check( ZTMP2_DEVICE , "Dear mid: ZTMP2_DEVICE=Myf" )
+ call Mppdb_check( plm, "Dear mid1:plm" )
+ end if
!$acc kernels
PLM(:,:,:) = BR_POW( PLM(:,:,:)*ZTMP1_DEVICE *ZTMP2_DEVICE , 1./3. )
!$acc end kernels
+ if ( mppdb_initialized ) then
+ call Mppdb_check( plm, "Dear mid2:plm" )
+ end if
#endif
#endif
END IF
@@ -2403,6 +2586,13 @@ end if
!$acc end data
+#ifndef MNH_OPENACC
+deallocate(zwork2d, zdthldz, zdrtdz, zetheta, zemoist )
+#else
+CALL MNH_REL_ZT3D(izwork2d, izdthldz, izdrtdz, izetheta, izemoist, &
+ iztmp1_device, iztmp2_device )
+#endif
+
!$acc end data
END SUBROUTINE DEAR
diff --git a/src/MNH/turb_hor_dyn_corr.f90 b/src/MNH/turb_hor_dyn_corr.f90
index 469bc39ba71a7d941b431d41b612f7887dd2c3ac..6104f0aa88f7488563e6aa6f6171ed1664d79d76 100644
--- a/src/MNH/turb_hor_dyn_corr.f90
+++ b/src/MNH/turb_hor_dyn_corr.f90
@@ -134,6 +134,7 @@ END MODULE MODI_TURB_HOR_DYN_CORR
!! M.Moge 04/2016 Use openACC directives to port the TURB part of Meso-NH on GPU
!! Philippe Wautelet: 05/2016-04/2018: new data structures and calls for I/O
! P. Wautelet 20/05/2019: add name argument to ADDnFIELD_ll + new ADD4DFIELD_ll subroutine
+! J.Escobar 13/08/2020: PGI/NVHPC BUG , extend DO CONCURRENT to 3D indexes
!! --------------------------------------------------------------------------
!
!* 0. DECLARATIONS
@@ -171,6 +172,9 @@ USE MODE_MPPDB
#ifdef MNH_BITREP
USE MODI_BITREP
#endif
+#ifdef MNH_OPENACC
+USE MODE_MNH_ZWORK , ONLY : MNH_ALLOCATE_ZT3D , MNH_REL_ZT3D, MNH_ALLOCATE_ZT3DP , MNH_ALLOCATE_ZT2D
+#endif
!
IMPLICIT NONE
!
@@ -225,30 +229,40 @@ REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PDP,PTP ! TKE production terms
!
!* 0.2 declaration of local variables
!
-REAL, DIMENSION(:,:,:), allocatable :: ZFLX,ZWORK ! work arrays, PK is the turb. mixing coef.
+REAL, DIMENSION(:,:,:), pointer , contiguous :: ZFLX,ZWORK ! work arrays, PK is the turb. mixing coef.
!
-REAL, DIMENSION(:,:), allocatable ::ZDIRSINZW
+REAL, DIMENSION(:,:), pointer , contiguous :: ZDIRSINZW
! sinus of the angle between the vertical and the normal to the orography
+#ifdef MNH_OPENACC
+INTEGER :: IZFLX,IZWORK,IZDIRSINZW
+#endif
INTEGER :: IKB,IKE
! Index values for the Beginning and End
! mass points of the domain
INTEGER :: IKU
INTEGER :: JSV ! scalar loop counter
!
-REAL, DIMENSION(:,:,:), allocatable :: GX_U_M_PUM
-REAL, DIMENSION(:,:,:), allocatable :: GY_V_M_PVM
-REAL, DIMENSION(:,:,:), allocatable :: GZ_W_M_PWM
-REAL, DIMENSION(:,:,:), allocatable :: GZ_W_M_ZWP
-REAL, DIMENSION(:,:,:), allocatable :: ZMZF_DZZ ! MZF(PDZZ)
-REAL, DIMENSION(:,:,:), allocatable :: ZDFDDWDZ ! formal derivative of the
+REAL, DIMENSION(:,:,:), pointer , contiguous :: GX_U_M_PUM
+REAL, DIMENSION(:,:,:), pointer , contiguous :: GY_V_M_PVM
+REAL, DIMENSION(:,:,:), pointer , contiguous :: GZ_W_M_PWM
+REAL, DIMENSION(:,:,:), pointer , contiguous :: GZ_W_M_ZWP
+#ifdef MNH_OPENACC
+INTEGER :: IGX_U_M_PUM,IGY_V_M_PVM,IGZ_W_M_PWM,IGZ_W_M_ZWP
+#endif
+REAL, DIMENSION(:,:,:), pointer , contiguous :: ZMZF_DZZ ! MZF(PDZZ)
+REAL, DIMENSION(:,:,:), pointer , contiguous :: ZDFDDWDZ ! formal derivative of the
! ! flux (variable: dW/dz)
-REAL, DIMENSION(:,:,:), allocatable :: ZWP ! W at future time-step
+REAL, DIMENSION(:,:,:), pointer , contiguous :: ZWP ! W at future time-step
!
-REAL, DIMENSION(:,:,:), allocatable :: ZDU_DZ_DZS_DX ! du/dz*dzs/dx surf
-REAL, DIMENSION(:,:,:), allocatable :: ZDV_DZ_DZS_DY ! dv/dz*dzs/dy surf
-REAL, DIMENSION(:,:,:), allocatable :: ZDU_DX ! du/dx surf
-REAL, DIMENSION(:,:,:), allocatable :: ZDV_DY ! dv/dy surf
-REAL, DIMENSION(:,:,:), allocatable :: ZDW_DZ ! dw/dz surf
+REAL, DIMENSION(:,:,:), pointer , contiguous :: ZDU_DZ_DZS_DX ! du/dz*dzs/dx surf
+REAL, DIMENSION(:,:,:), pointer , contiguous :: ZDV_DZ_DZS_DY ! dv/dz*dzs/dy surf
+REAL, DIMENSION(:,:,:), pointer , contiguous :: ZDU_DX ! du/dx surf
+REAL, DIMENSION(:,:,:), pointer , contiguous :: ZDV_DY ! dv/dy surf
+REAL, DIMENSION(:,:,:), pointer , contiguous :: ZDW_DZ ! dw/dz surf
+#ifdef MNH_OPENACC
+INTEGER :: IZMZF_DZZ,IZDFDDWDZ,IZWP,IZDU_DZ_DZS_DX,IZDV_DZ_DZS_DY &
+ ,IZDU_DX,IZDV_DY,IZDW_DZ
+#endif
!
INTEGER :: IINFO_ll ! return code of parallel routine
TYPE(LIST_ll), POINTER :: TZFIELDS_ll ! list of fields to exchange
@@ -256,14 +270,21 @@ TYPE(LIST_ll), POINTER :: TZFIELDS_ll ! list of fields to exchange
REAL :: ZTIME1, ZTIME2
-REAL, DIMENSION(:,:,:), allocatable :: ZCOEFF , ZDZZ
+REAL, DIMENSION(:,:,:), pointer , contiguous :: ZCOEFF , ZDZZ
! coefficients for the uncentred gradient
! computation near the ground
+#ifdef MNH_OPENACC
+INTEGER :: IZCOEFF , IZDZZ
+#endif
!
#ifdef MNH_OPENACC
-REAL, DIMENSION(:,:,:), allocatable :: ZTMP1_DEVICE, ZTMP2_DEVICE, ZTMP3_DEVICE, ZTMP4_DEVICE
+REAL, DIMENSION(:,:,:), pointer , contiguous :: ZTMP1_DEVICE, ZTMP2_DEVICE, ZTMP3_DEVICE, ZTMP4_DEVICE
+INTEGER :: IZTMP1_DEVICE, IZTMP2_DEVICE, IZTMP3_DEVICE, IZTMP4_DEVICE
#endif
TYPE(TFIELDDATA) :: TZFIELD
+!
+INTEGER :: JIU,JJU,JKU
+INTEGER :: JI,JJ,JK
! --------------------------------------------------------------------------
!$acc data present( PK, PINV_PDZZ, PDXX, PDYY, PDZZ, PDZX, PDZY, PZZ, PDIRCOSZW, &
@@ -309,36 +330,64 @@ if ( mppdb_initialized ) then
call Mppdb_check( ptp, "Turb_hor_dyn_corr beg:ptp" )
end if
-allocate( zflx (size( pum, 1 ), size( pum, 2 ), size( pum, 3 ) ) )
-allocate( zwork(size( pum, 1 ), size( pum, 2 ), size( pum, 3 ) ) )
+JIU = size(pum, 1 )
+JJU = size(pum, 2 )
+JKU = size(pum, 3 )
-allocate( zdirsinzw(size( pum, 1 ), size( pum, 2 ) ) )
+#ifndef MNH_OPENACC
+allocate( zflx (JIU,JJU,JKU ) )
+allocate( zwork(JIU,JJU,JKU ) )
+
+allocate( zdirsinzw(JIU,JJU ) )
+
+allocate( gx_u_m_pum(JIU,JJU,JKU ) )
+allocate( gy_v_m_pvm(JIU,JJU,JKU ) )
+allocate( gz_w_m_pwm(JIU,JJU,JKU ) )
+allocate( gz_w_m_zwp(JIU,JJU,JKU ) )
+allocate( zmzf_dzz (JIU,JJU,JKU ) )
+allocate( zdfddwdz (JIU,JJU,JKU ) )
+allocate( zwp (JIU,JJU,JKU ) )
+
+allocate( zdu_dz_dzs_dx(JIU,JJU, 1 ) )
+allocate( zdv_dz_dzs_dy(JIU,JJU, 1 ) )
+allocate( zdu_dx (JIU,JJU, 1 ) )
+allocate( zdv_dy (JIU,JJU, 1 ) )
+allocate( zdw_dz (JIU,JJU, 1 ) )
+
+allocate( zcoeff(JIU,JJU, 1 + jpvext : 3 + jpvext ) )
+allocate( zdzz (JIU,JJU, 1 + jpvext : 3 + jpvext ) )
+#else
+izflx = MNH_ALLOCATE_ZT3D( zflx ,JIU,JJU,JKU )
+izwork = MNH_ALLOCATE_ZT3D( zwork,JIU,JJU,JKU )
+
+izdirsinzw = MNH_ALLOCATE_ZT2D( zdirsinzw,JIU,JJU )
-allocate( gx_u_m_pum(size( pum, 1 ), size( pum, 2 ), size( pum, 3 ) ) )
-allocate( gy_v_m_pvm(size( pvm, 1 ), size( pvm, 2 ), size( pvm, 3 ) ) )
-allocate( gz_w_m_pwm(size( pwm, 1 ), size( pwm, 2 ), size( pwm, 3 ) ) )
-allocate( gz_w_m_zwp(size( pwm, 1 ), size( pwm, 2 ), size( pwm, 3 ) ) )
-allocate( zmzf_dzz (size( pwm, 1 ), size( pwm, 2 ), size( pwm, 3 ) ) )
-allocate( zdfddwdz (size( pwm, 1 ), size( pwm, 2 ), size( pwm, 3 ) ) )
-allocate( zwp (size( pwm, 1 ), size( pwm, 2 ), size( pwm, 3 ) ) )
+igx_u_m_pum = MNH_ALLOCATE_ZT3D( gx_u_m_pum,JIU,JJU,JKU )
+igy_v_m_pvm = MNH_ALLOCATE_ZT3D( gy_v_m_pvm,JIU,JJU,JKU )
+igz_w_m_pwm = MNH_ALLOCATE_ZT3D( gz_w_m_pwm,JIU,JJU,JKU )
+igz_w_m_zwp = MNH_ALLOCATE_ZT3D( gz_w_m_zwp,JIU,JJU,JKU )
+izmzf_dzz = MNH_ALLOCATE_ZT3D( zmzf_dzz ,JIU,JJU,JKU )
+izdfddwdz = MNH_ALLOCATE_ZT3D( zdfddwdz ,JIU,JJU,JKU )
+izwp = MNH_ALLOCATE_ZT3D( zwp ,JIU,JJU,JKU )
-allocate( zdu_dz_dzs_dx(size( pwm, 1 ), size( pwm, 2 ), 1 ) )
-allocate( zdv_dz_dzs_dy(size( pwm, 1 ), size( pwm, 2 ), 1 ) )
-allocate( zdu_dx (size( pwm, 1 ), size( pwm, 2 ), 1 ) )
-allocate( zdv_dy (size( pwm, 1 ), size( pwm, 2 ), 1 ) )
-allocate( zdw_dz (size( pwm, 1 ), size( pwm, 2 ), 1 ) )
+izdu_dz_dzs_dx = MNH_ALLOCATE_ZT3DP( zdu_dz_dzs_dx,JIU,JJU, 1 , 1 )
+izdv_dz_dzs_dy = MNH_ALLOCATE_ZT3DP( zdv_dz_dzs_dy,JIU,JJU, 1 , 1 )
+izdu_dx = MNH_ALLOCATE_ZT3DP( zdu_dx ,JIU,JJU, 1 , 1 )
+izdv_dy = MNH_ALLOCATE_ZT3DP( zdv_dy ,JIU,JJU, 1 , 1 )
+izdw_dz = MNH_ALLOCATE_ZT3DP( zdw_dz ,JIU,JJU, 1 , 1 )
-allocate( zcoeff(size( pdzz, 1 ), size( pdzz, 2 ), 1 + jpvext : 3 + jpvext ) )
-allocate( zdzz (size( pdzz, 1 ), size( pdzz, 2 ), 1 + jpvext : 3 + jpvext ) )
+izcoeff = MNH_ALLOCATE_ZT3DP( zcoeff,JIU,JJU, 1 + jpvext , 3 + jpvext )
+izdzz = MNH_ALLOCATE_ZT3DP( zdzz ,JIU,JJU, 1 + jpvext , 3 + jpvext )
+#endif
#ifdef MNH_OPENACC
-allocate( ztmp1_device(size( pthlm, 1 ), size( pthlm, 2 ), size( pthlm, 3 ) ) )
-allocate( ztmp2_device(size( pthlm, 1 ), size( pthlm, 2 ), size( pthlm, 3 ) ) )
-allocate( ztmp3_device(size( pthlm, 1 ), size( pthlm, 2 ), size( pthlm, 3 ) ) )
-allocate( ztmp4_device(size( pthlm, 1 ), size( pthlm, 2 ), size( pthlm, 3 ) ) )
+iztmp1_device = MNH_ALLOCATE_ZT3D( ztmp1_device,JIU,JJU,JKU )
+iztmp2_device = MNH_ALLOCATE_ZT3D( ztmp2_device,JIU,JJU,JKU )
+iztmp3_device = MNH_ALLOCATE_ZT3D( ztmp3_device,JIU,JJU,JKU )
+iztmp4_device = MNH_ALLOCATE_ZT3D( ztmp4_device,JIU,JJU,JKU )
#endif
-!$acc data create( ZFLX, ZWORK, ZDIRSINZW, ZCOEFF, ZDZZ, &
+!$acc data present(ZFLX, ZWORK, ZDIRSINZW, ZCOEFF, ZDZZ, &
!$acc & GX_U_M_PUM, GY_V_M_PVM, GZ_W_M_PWM, GZ_W_M_ZWP, &
!$acc & ZMZF_DZZ, ZDFDDWDZ, ZWP, &
!$acc & ZDU_DZ_DZS_DX, ZDV_DZ_DZS_DY, ZDU_DX, ZDV_DY, ZDW_DZ, &
@@ -358,7 +407,10 @@ IKU = SIZE(PUM,3)
#ifndef MNH_BITREP
ZDIRSINZW(:,:) = SQRT( 1. - PDIRCOSZW(:,:)**2 )
#else
-ZDIRSINZW(:,:) = SQRT( 1. - BR_P2(PDIRCOSZW(:,:)) )
+!$acc loop independent collapse(2)
+DO CONCURRENT ( JI=1:JIU,JJ=1:JJU )
+ ZDIRSINZW(JI,JJ) = SQRT( 1. - BR_P2(PDIRCOSZW(JI,JJ)) )
+END DO
#endif
!$acc end kernels
!
@@ -391,13 +443,16 @@ CALL ADD3DFIELD_ll( TZFIELDS_ll, ZFLX, 'TURB_HOR_DYN_CORR::ZFLX' )
!
! Computes the U variance
IF (.NOT. L2D) THEN
- !$acc kernels async(2)
- ZFLX(:,:,:)= (2./3.) * PTKEM &
- - XCMFS * PK *( (4./3.) * GX_U_M_PUM &
- -(2./3.) * ( GY_V_M_PVM &
- +GZ_W_M_PWM ) )
- !$acc end kernels
- !! & to be tested later
+ !$acc kernels async(2)
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZFLX(JI,JJ,JK)= (2./3.) * PTKEM(JI,JJ,JK) &
+ - XCMFS * PK(JI,JJ,JK) *( (4./3.) * GX_U_M_PUM(JI,JJ,JK) &
+ -(2./3.) * ( GY_V_M_PVM(JI,JJ,JK) &
+ +GZ_W_M_PWM(JI,JJ,JK) ) )
+ END DO !CONCURRENT
+ !$acc end kernels
+ !! & to be tested later
!! + XCMFB * PLM / SQRT(PTKEM) * (-2./3.) * PTP
ELSE
!$acc kernels async(2)
@@ -566,14 +621,17 @@ ZFLX(:,:,IKB-1) = &
PVSLOPEM(:,:) * PCOSSLOPE(:,:) * PSINSLOPE(:,:) * ZDIRSINZW(:,:) &
- PUSLOPEM(:,:) * PCOSSLOPE(:,:)**2 * ZDIRSINZW(:,:) * PDIRCOSZW(:,:) )
#else
-ZFLX(:,:,IKB-1) = &
- PTAU11M(:,:) * BR_P2(PCOSSLOPE(:,:)) * BR_P2(PDIRCOSZW(:,:)) &
- -2. * PTAU12M(:,:) * PCOSSLOPE(:,:)* PSINSLOPE(:,:) * PDIRCOSZW(:,:) &
- + PTAU22M(:,:) * BR_P2(PSINSLOPE(:,:)) &
- + PTAU33M(:,:) * BR_P2(PCOSSLOPE(:,:)) * BR_P2(ZDIRSINZW(:,:)) &
- +2. * PCDUEFF(:,:) * ( &
- PVSLOPEM(:,:) * PCOSSLOPE(:,:) * PSINSLOPE(:,:) * ZDIRSINZW(:,:) &
- - PUSLOPEM(:,:) * BR_P2(PCOSSLOPE(:,:)) * ZDIRSINZW(:,:) * PDIRCOSZW(:,:) )
+!$acc loop independent collapse(2)
+DO CONCURRENT ( JI=1:JIU,JJ=1:JJU )
+ZFLX(JI,JJ,IKB-1) = &
+ PTAU11M(JI,JJ) * BR_P2(PCOSSLOPE(JI,JJ)) * BR_P2(PDIRCOSZW(JI,JJ)) &
+ -2. * PTAU12M(JI,JJ) * PCOSSLOPE(JI,JJ)* PSINSLOPE(JI,JJ) * PDIRCOSZW(JI,JJ) &
+ + PTAU22M(JI,JJ) * BR_P2(PSINSLOPE(JI,JJ)) &
+ + PTAU33M(JI,JJ) * BR_P2(PCOSSLOPE(JI,JJ)) * BR_P2(ZDIRSINZW(JI,JJ)) &
+ +2. * PCDUEFF(JI,JJ) * ( &
+ PVSLOPEM(JI,JJ) * PCOSSLOPE(JI,JJ) * PSINSLOPE(JI,JJ) * ZDIRSINZW(JI,JJ) &
+ - PUSLOPEM(JI,JJ) * BR_P2(PCOSSLOPE(JI,JJ)) * ZDIRSINZW(JI,JJ) * PDIRCOSZW(JI,JJ) )
+END DO ! CONCURRENT
#endif
!$acc end kernels
!
@@ -636,7 +694,10 @@ END IF
#else
CALL MXF_DEVICE(PDXX, ZTMP1_DEVICE)
!$acc kernels async(10)
-ZTMP2_DEVICE = PRHODJ * ZFLX / ZTMP1_DEVICE
+!$acc loop independent collapse(3)
+DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP2_DEVICE(JI,JJ,JK) = PRHODJ(JI,JJ,JK) * ZFLX(JI,JJ,JK) / ZTMP1_DEVICE(JI,JJ,JK)
+END DO !CONCURRENT
!$acc end kernels
!
!!! wait for the computation of ZTMP2_DEVICE and the update of ZFLX
@@ -646,33 +707,45 @@ CALL DXM_DEVICE(ZTMP2_DEVICE, ZTMP3_DEVICE)
IF (.NOT. LFLAT) THEN
CALL MZM_DEVICE(PDXX,ZTMP1_DEVICE)
!$acc kernels
- ZTMP2_DEVICE = PRHODJ * ZFLX
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP2_DEVICE(JI,JJ,JK) = PRHODJ(JI,JJ,JK) * ZFLX(JI,JJ,JK)
+ END DO !CONCURRENT
!$acc end kernels
CALL MZM_DEVICE(ZTMP2_DEVICE,ZTMP4_DEVICE)
!$acc kernels
- ZTMP2_DEVICE = ZTMP4_DEVICE * PINV_PDZZ
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP2_DEVICE(JI,JJ,JK) = ZTMP4_DEVICE(JI,JJ,JK) * PINV_PDZZ(JI,JJ,JK)
+ END DO !CONCURRENT
!$acc end kernels
CALL MXM_DEVICE( ZTMP2_DEVICE, ZTMP4_DEVICE )
!$acc kernels
- ZTMP2_DEVICE = PDZX / ZTMP1_DEVICE * ZTMP4_DEVICE
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP2_DEVICE(JI,JJ,JK) = PDZX(JI,JJ,JK) / ZTMP1_DEVICE(JI,JJ,JK) * ZTMP4_DEVICE(JI,JJ,JK)
+ END DO !CONCURRENT
!$acc end kernels
CALL DZF_DEVICE(1,IKU,1,ZTMP2_DEVICE,ZTMP1_DEVICE)
!$acc kernels async(1)
- PRUS(:,:,:)=PRUS &
- -ZTMP3_DEVICE &
- +ZTMP1_DEVICE
+ PRUS(:,:,:)=PRUS(:,:,:) &
+ -ZTMP3_DEVICE(:,:,:) &
+ +ZTMP1_DEVICE(:,:,:)
!$acc end kernels
ELSE
!$acc kernels async(1)
- PRUS(:,:,:)=PRUS - ZTMP3_DEVICE
+ PRUS(:,:,:)=PRUS(:,:,:) - ZTMP3_DEVICE(:,:,:)
!$acc end kernels
END IF
#endif
!
IF (KSPLT==1) THEN
! Contribution to the dynamic production of TKE:
- !$acc kernels async(2)
- ZWORK(:,:,:) = - ZFLX(:,:,:) * GX_U_M_PUM
+ !$acc kernels async(2)
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZWORK(JI,JJ,JK) = - ZFLX(JI,JJ,JK) * GX_U_M_PUM(JI,JJ,JK)
+ END DO !CONCURRENT
!$acc end kernels
!
! evaluate the dynamic production at w(IKB+1) in PDP(IKB)
@@ -719,12 +792,15 @@ END IF
!
! Computes the V variance
IF (.NOT. L2D) THEN
- !$acc kernels async(3)
- ZFLX(:,:,:)= (2./3.) * PTKEM &
- - XCMFS * PK *( (4./3.) * GY_V_M_PVM &
- -(2./3.) * ( GX_U_M_PUM &
- +GZ_W_M_PWM ) )
- !$acc end kernels
+ !$acc kernels async(3)
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZFLX(JI,JJ,JK)= (2./3.) * PTKEM(JI,JJ,JK) &
+ - XCMFS * PK(JI,JJ,JK) *( (4./3.) * GY_V_M_PVM(JI,JJ,JK) &
+ -(2./3.) * ( GX_U_M_PUM(JI,JJ,JK) &
+ +GZ_W_M_PWM(JI,JJ,JK) ) )
+ END DO !CONCURRENT
+ !$acc end kernels
!! & to be tested
!! + XCMFB * PLM / SQRT(PTKEM) * (-2./3.) * PTP
!
@@ -768,14 +844,17 @@ ZFLX(:,:,IKB-1) = &
PUSLOPEM(:,:) * PSINSLOPE(:,:)**2 * ZDIRSINZW(:,:) * PDIRCOSZW(:,:) &
+ PVSLOPEM(:,:) * PCOSSLOPE(:,:) * PSINSLOPE(:,:) * ZDIRSINZW(:,:) )
#else
-ZFLX(:,:,IKB-1) = &
- PTAU11M(:,:) * BR_P2(PSINSLOPE(:,:)) * BR_P2(PDIRCOSZW(:,:)) &
- +2. * PTAU12M(:,:) * PCOSSLOPE(:,:)* PSINSLOPE(:,:) * PDIRCOSZW(:,:) &
- + PTAU22M(:,:) * BR_P2(PCOSSLOPE(:,:)) &
- + PTAU33M(:,:) * BR_P2(PSINSLOPE(:,:)) * BR_P2(ZDIRSINZW(:,:)) &
- -2. * PCDUEFF(:,:)* ( &
- PUSLOPEM(:,:) * BR_P2(PSINSLOPE(:,:)) * ZDIRSINZW(:,:) * PDIRCOSZW(:,:) &
- + PVSLOPEM(:,:) * PCOSSLOPE(:,:) * PSINSLOPE(:,:) * ZDIRSINZW(:,:) )
+!$acc loop independent collapse(2)
+DO CONCURRENT ( JI=1:JIU,JJ=1:JJU )
+ZFLX(JI,JJ,IKB-1) = &
+ PTAU11M(JI,JJ) * BR_P2(PSINSLOPE(JI,JJ)) * BR_P2(PDIRCOSZW(JI,JJ)) &
+ +2. * PTAU12M(JI,JJ) * PCOSSLOPE(JI,JJ)* PSINSLOPE(JI,JJ) * PDIRCOSZW(JI,JJ) &
+ + PTAU22M(JI,JJ) * BR_P2(PCOSSLOPE(JI,JJ)) &
+ + PTAU33M(JI,JJ) * BR_P2(PSINSLOPE(JI,JJ)) * BR_P2(ZDIRSINZW(JI,JJ)) &
+ -2. * PCDUEFF(JI,JJ)* ( &
+ PUSLOPEM(JI,JJ) * BR_P2(PSINSLOPE(JI,JJ)) * ZDIRSINZW(JI,JJ) * PDIRCOSZW(JI,JJ) &
+ + PVSLOPEM(JI,JJ) * PCOSSLOPE(JI,JJ) * PSINSLOPE(JI,JJ) * ZDIRSINZW(JI,JJ) )
+END DO ! CONCURRENT
#endif
!$acc end kernels
!
@@ -833,7 +912,10 @@ IF (.NOT. L2D) THEN
#else
CALL MYF_DEVICE(PDYY, ZTMP1_DEVICE)
!$acc kernels async(10)
- ZTMP2_DEVICE = PRHODJ * ZFLX / ZTMP1_DEVICE
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP2_DEVICE(JI,JJ,JK) = PRHODJ(JI,JJ,JK) * ZFLX(JI,JJ,JK) / ZTMP1_DEVICE(JI,JJ,JK)
+ END DO !CONCURRENT
!$acc end kernels
!
!!! wait for the computation of ZTMP2_DEVICE and the update of ZFLX
@@ -843,31 +925,46 @@ IF (.NOT. L2D) THEN
IF (.NOT. LFLAT) THEN
CALL MZM_DEVICE(PDYY,ZTMP1_DEVICE)
!$acc kernels
- ZTMP2_DEVICE = PRHODJ * ZFLX
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP2_DEVICE(JI,JJ,JK) = PRHODJ(JI,JJ,JK) * ZFLX(JI,JJ,JK)
+ END DO !CONCURRENT
!$acc end kernels
CALL MZM_DEVICE(ZTMP2_DEVICE,ZTMP4_DEVICE)
!$acc kernels
- ZTMP2_DEVICE = ZTMP4_DEVICE * PINV_PDZZ
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP2_DEVICE(JI,JJ,JK) = ZTMP4_DEVICE(JI,JJ,JK) * PINV_PDZZ(JI,JJ,JK)
+ END DO !CONCURRENT
!$acc end kernels
CALL MYM_DEVICE( ZTMP2_DEVICE,ZTMP4_DEVICE )
!$acc kernels
- ZTMP2_DEVICE = PDZY / ZTMP1_DEVICE * ZTMP4_DEVICE
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP2_DEVICE(JI,JJ,JK) = PDZY(JI,JJ,JK) / ZTMP1_DEVICE(JI,JJ,JK) * ZTMP4_DEVICE(JI,JJ,JK)
+ END DO !CONCURRENT
!$acc end kernels
CALL DZF_DEVICE(1,IKU,1,ZTMP2_DEVICE,ZTMP4_DEVICE )
!$acc kernels async(1)
- PRVS(:,:,:)=PRVS &
- -ZTMP3_DEVICE &
- +ZTMP4_DEVICE
+ PRVS(:,:,:)=PRVS(:,:,:) &
+ -ZTMP3_DEVICE(:,:,:) &
+ +ZTMP4_DEVICE(:,:,:)
!$acc end kernels
ELSE
- !$acc kernels async(1)
- PRVS(:,:,:)=PRVS - ZTMP3_DEVICE
+ !$acc kernels async(1)
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ PRVS(JI,JJ,JK)=PRVS(JI,JJ,JK) - ZTMP3_DEVICE(JI,JJ,JK)
+ END DO !CONCURRENT
!$acc end kernels
END IF
! Contribution to the dynamic production of TKE:
IF (KSPLT==1) THEN
- !$acc kernels async(2)
- ZWORK(:,:,:) = - ZFLX(:,:,:) * GY_V_M_PVM
+ !$acc kernels async(2)
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZWORK(JI,JJ,JK) = - ZFLX(JI,JJ,JK) * GY_V_M_PVM(JI,JJ,JK)
+ END DO !CONCURRENT
!$acc end kernels
ENDIF
#endif
@@ -919,11 +1016,14 @@ END IF
!
! Computes the W variance
IF (.NOT. L2D) THEN
- !$acc kernels async(2)
- ZFLX(:,:,:)= (2./3.) * PTKEM &
- - XCMFS * PK *( (4./3.) * GZ_W_M_PWM &
- -(2./3.) * ( GX_U_M_PUM &
- +GY_V_M_PVM ) )
+ !$acc kernels async(2)
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZFLX(JI,JJ,JK) = (2./3.) * PTKEM(JI,JJ,JK) &
+ - XCMFS * PK(JI,JJ,JK) *( (4./3.) * GZ_W_M_PWM(JI,JJ,JK) &
+ -(2./3.) * ( GX_U_M_PUM(JI,JJ,JK) &
+ +GY_V_M_PVM(JI,JJ,JK) ) )
+ END DO !CONCURRENT
!$acc end kernels
!! & to be tested
!! -2.* XCMFB * PLM / SQRT(PTKEM) * (-2./3.) * PTP
@@ -956,15 +1056,20 @@ ZFLX(:,:,IKB) = (2./3.) * PTKEM(:,:,IKB) &
! (-2./3.) * PTP(:,:,IKB:IKB)
! extrapolates this flux under the ground with the surface flux
!$acc kernels async(3)
-ZFLX(:,:,IKB-1) = &
#ifndef MNH_BITREP
+ZFLX(:,:,IKB-1) = &
PTAU11M(:,:) * ZDIRSINZW(:,:)**2 &
+ PTAU33M(:,:) * PDIRCOSZW(:,:)**2 &
+ +2. * PCDUEFF(:,:)* PUSLOPEM(:,:) * ZDIRSINZW(:,:) * PDIRCOSZW(:,:)
#else
- PTAU11M(:,:) * BR_P2(ZDIRSINZW(:,:)) &
- + PTAU33M(:,:) * BR_P2(PDIRCOSZW(:,:)) &
+!$acc loop independent collapse(2)
+DO CONCURRENT ( JI=1:JIU,JJ=1:JJU )
+ZFLX(JI,JJ,IKB-1) = &
+ PTAU11M(JI,JJ) * BR_P2(ZDIRSINZW(JI,JJ)) &
+ + PTAU33M(JI,JJ) * BR_P2(PDIRCOSZW(JI,JJ)) &
+ +2. * PCDUEFF(JI,JJ)* PUSLOPEM(JI,JJ) * ZDIRSINZW(JI,JJ) * PDIRCOSZW(JI,JJ)
+END DO ! CONCURRENT
#endif
- +2. * PCDUEFF(:,:)* PUSLOPEM(:,:) * ZDIRSINZW(:,:) * PDIRCOSZW(:,:)
!$acc end kernels
!
!
@@ -1031,15 +1136,21 @@ GZ_W_M_ZWP = GZ_W_M(ZWP,PDZZ)
CALL GZ_W_M_DEVICE(1,IKU,1,ZWP,PDZZ,GZ_W_M_ZWP)
#endif
!$acc kernels async(2)
-ZFLX(:,:,IKB+1:)=ZFLX(:,:,IKB+1:) &
- - XCMFS * PK(:,:,IKB+1:) * (4./3.) * (GZ_W_M_ZWP(:,:,IKB+1:) - GZ_W_M_PWM(:,:,IKB+1:))
+!$acc loop independent collapse(3)
+DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=IKB+1:JKU)
+ ZFLX(JI,JJ,JK)=ZFLX(JI,JJ,JK) &
+ - XCMFS * PK(JI,JJ,JK) * (4./3.) * (GZ_W_M_ZWP(JI,JJ,JK) - GZ_W_M_PWM(JI,JJ,JK))
+END DO !CONCURRENT
!$acc end kernels
!
IF (KSPLT==1) THEN
- !Contribution to the dynamic production of TKE:
- !$acc kernels async(2)
- ZWORK(:,:,:) = - ZFLX(:,:,:) * GZ_W_M_ZWP
- !$acc end kernels
+ !Contribution to the dynamic production of TKE:
+ !$acc kernels async(2)
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZWORK(JI,JJ,JK) = - ZFLX(JI,JJ,JK) * GZ_W_M_ZWP(JI,JJ,JK)
+ END DO !CONCURRENT
+ !$acc end kernels
!
! evaluate the dynamic production at w(IKB+1) in PDP(IKB)
!
@@ -1169,6 +1280,22 @@ end if
!$acc end data
+#ifndef MNH_OPENACC
+DEALLOCATE (ZFLX, ZWORK, ZDIRSINZW, ZCOEFF, ZDZZ, &
+ GX_U_M_PUM, GY_V_M_PVM, GZ_W_M_PWM, GZ_W_M_ZWP, &
+ ZMZF_DZZ, ZDFDDWDZ, ZWP, &
+ ZDU_DZ_DZS_DX, ZDV_DZ_DZS_DY, ZDU_DX, ZDV_DY, ZDW_DZ )
+#else
+CALL MNH_REL_ZT3D(IZTMP1_DEVICE, IZTMP2_DEVICE, IZTMP3_DEVICE, IZTMP4_DEVICE )
+CALL MNH_REL_ZT3D(IZFLX, IZWORK, IZDIRSINZW, &
+ IGX_U_M_PUM, IGY_V_M_PVM, IGZ_W_M_PWM, IGZ_W_M_ZWP, &
+ IZMZF_DZZ, IZDFDDWDZ, IZWP, &
+ IZDU_DZ_DZS_DX, IZDV_DZ_DZS_DY, IZDU_DX, IZDV_DY, IZDW_DZ, &
+ IZCOEFF, IZDZZ )
+
+#endif
+
+
!$acc end data
END SUBROUTINE TURB_HOR_DYN_CORR
diff --git a/src/MNH/turb_hor_splt.f90 b/src/MNH/turb_hor_splt.f90
index e0bf14aa321c9fd93648b616e02303cbdde96d88..cee813251d9d999bb434389f18290fa654caff4c 100644
--- a/src/MNH/turb_hor_splt.f90
+++ b/src/MNH/turb_hor_splt.f90
@@ -268,6 +268,10 @@ USE MODI_SHUMAN_DEVICE
USE MODI_TURB_HOR
USE MODI_TURB_HOR_TKE
!
+#ifdef MNH_OPENACC
+USE MODE_MNH_ZWORK , ONLY : MNH_ALLOCATE_ZT3D , MNH_REL_ZT3D, MNH_ALLOCATE_ZT3DP , MNH_ALLOCATE_ZT2D, &
+ MNH_ALLOCATE_ZT4D , MNH_REL_ZT4D
+#endif
!
IMPLICIT NONE
!
@@ -343,12 +347,15 @@ REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PSIGS
!
!* 0.2 declaration of local variables
!
-REAL,ALLOCATABLE,DIMENSION(:,:,:) :: ZK ! Turbulent diffusion doef.
+REAL,POINTER , CONTIGUOUS,DIMENSION(:,:,:) :: ZK ! Turbulent diffusion doef.
! ZK = PLM * SQRT(PTKEM)
-REAL,ALLOCATABLE,DIMENSION(:,:,:) :: ZINV_PDXX ! 1./PDXX
-REAL,ALLOCATABLE,DIMENSION(:,:,:) :: ZINV_PDYY ! 1./PDYY
-REAL,ALLOCATABLE,DIMENSION(:,:,:) :: ZINV_PDZZ ! 1./PDZZ
-REAL,ALLOCATABLE,DIMENSION(:,:,:) :: ZMZM_PRHODJ ! MZM(PRHODJ)
+REAL,POINTER , CONTIGUOUS,DIMENSION(:,:,:) :: ZINV_PDXX ! 1./PDXX
+REAL,POINTER , CONTIGUOUS,DIMENSION(:,:,:) :: ZINV_PDYY ! 1./PDYY
+REAL,POINTER , CONTIGUOUS,DIMENSION(:,:,:) :: ZINV_PDZZ ! 1./PDZZ
+REAL,POINTER , CONTIGUOUS,DIMENSION(:,:,:) :: ZMZM_PRHODJ ! MZM(PRHODJ)
+#ifdef MNH_OPENACC
+INTEGER :: IZK,IZINV_PDXX,IZINV_PDYY,IZINV_PDZZ,IZMZM_PRHODJ
+#endif
!
INTEGER :: JSPLT ! current split
!
@@ -358,15 +365,23 @@ INTEGER :: JRR, JSV
INTEGER :: ISV
INTEGER :: IINFO_ll
!
-REAL,ALLOCATABLE,DIMENSION(:,:,:) :: ZUM, ZVM, ZWM, ZTHLM, ZTKEM
-REAL,ALLOCATABLE,DIMENSION(:,:,:,:) :: ZRM, ZSVM
-REAL,ALLOCATABLE,DIMENSION(:,:,:) :: ZRUS, ZRVS, ZRWS, ZRTHLS
-REAL,ALLOCATABLE,DIMENSION(:,:,:,:) :: ZRRS, ZRSVS
+INTEGER :: JIU,JJU,JKU
+INTEGER :: JI,JJ,JK
+!
+REAL,POINTER , CONTIGUOUS,DIMENSION(:,:,:) :: ZUM, ZVM, ZWM, ZTHLM, ZTKEM
+REAL,POINTER , CONTIGUOUS,DIMENSION(:,:,:,:) :: ZRM, ZSVM
+REAL,POINTER , CONTIGUOUS,DIMENSION(:,:,:) :: ZRUS, ZRVS, ZRWS, ZRTHLS
+REAL,POINTER , CONTIGUOUS,DIMENSION(:,:,:,:) :: ZRRS, ZRSVS
+#ifdef MNH_OPENACC
+INTEGER :: IZUM, IZVM, IZWM, IZTHLM, IZTKEM, IZRM, IZSVM &
+ , IZRUS, IZRVS, IZRWS, IZRTHLS, IZRRS, IZRSVS
+#endif
!
TYPE(LIST_ll), POINTER, SAVE :: TZFIELDS_ll
!
#ifdef MNH_OPENACC
-REAL, DIMENSION(:,:,:), ALLOCATABLE :: ZTMP1_DEVICE,ZTMP2_DEVICE
+REAL, DIMENSION(:,:,:), POINTER , CONTIGUOUS :: ZTMP1_DEVICE,ZTMP2_DEVICE
+INTEGER :: IZTMP1_DEVICE,IZTMP2_DEVICE
#endif
! ---------------------------------------------------------------------------
@@ -441,17 +456,30 @@ IKE = SIZE(PUM,3) - JPVEXT
CALL GET_INDICE_ll (IIB,IJB,IIE,IJE)
ISV=SIZE(PSVM,4)
!
-ALLOCATE(ZK(SIZE(PTHLM,1),SIZE(PTHLM,2),SIZE(PTHLM,3)))
-ALLOCATE(ZINV_PDXX(SIZE(PDXX,1),SIZE(PDXX,2),SIZE(PDXX,3)))
-ALLOCATE(ZINV_PDYY(SIZE(PDYY,1),SIZE(PDYY,2),SIZE(PDYY,3)))
-ALLOCATE(ZINV_PDZZ(SIZE(PDZZ,1),SIZE(PDZZ,2),SIZE(PDZZ,3)))
-ALLOCATE(ZMZM_PRHODJ(SIZE(PRHODJ,1),SIZE(PRHODJ,2),SIZE(PRHODJ,3)))
+JIU = size(pthlm, 1 )
+JJU = size(pthlm, 2 )
+JKU = size(pthlm, 3 )
+!
+#ifndef MNH_OPENACC
+ALLOCATE(ZK(JIU,JJU,JKU))
+ALLOCATE(ZINV_PDXX(JIU,JJU,JKU))
+ALLOCATE(ZINV_PDYY(JIU,JJU,JKU))
+ALLOCATE(ZINV_PDZZ(JIU,JJU,JKU))
+ALLOCATE(ZMZM_PRHODJ(JIU,JJU,JKU))
+#else
+IZK = MNH_ALLOCATE_ZT3D(ZK, JIU,JJU,JKU)
+IZINV_PDXX = MNH_ALLOCATE_ZT3D(ZINV_PDXX, JIU,JJU,JKU)
+IZINV_PDYY = MNH_ALLOCATE_ZT3D(ZINV_PDYY, JIU,JJU,JKU)
+IZINV_PDZZ = MNH_ALLOCATE_ZT3D(ZINV_PDZZ, JIU,JJU,JKU)
+IZMZM_PRHODJ = MNH_ALLOCATE_ZT3D(ZMZM_PRHODJ, JIU,JJU,JKU)
+#endif
+
#ifdef MNH_OPENACC
-allocate( ZTMP1_DEVICE( SIZE( PTHLM, 1 ), SIZE( PTHLM, 2 ), SIZE( PTHLM, 3 ) ) )
-allocate( ZTMP2_DEVICE( SIZE( PTHLM, 1 ), SIZE( PTHLM, 2 ), SIZE( PTHLM, 3 ) ) )
+IZTMP1_DEVICE = MNH_ALLOCATE_ZT3D( ZTMP1_DEVICE, JIU,JJU,JKU )
+IZTMP2_DEVICE = MNH_ALLOCATE_ZT3D( ZTMP2_DEVICE, JIU,JJU,JKU )
#endif
-!$acc data create( ZK, ZINV_PDXX, ZINV_PDYY, ZINV_PDZZ, ZMZM_PRHODJ, &
+!$acc data present( ZK, ZINV_PDXX, ZINV_PDYY, ZINV_PDZZ, ZMZM_PRHODJ, &
!$acc & ZTMP1_DEVICE, ZTMP2_DEVICE )
!$acc kernels
@@ -478,7 +506,8 @@ IF (KSPLIT>1 .AND. CPROGRAM=='MESONH') THEN
!
!* 2.1 allocations
! -----------
-!
+ !
+#ifndef MNH_OPENACC
ALLOCATE(ZUM(SIZE(PUM,1),SIZE(PUM,2),SIZE(PUM,3)))
ALLOCATE(ZVM(SIZE(PVM,1),SIZE(PVM,2),SIZE(PVM,3)))
ALLOCATE(ZWM(SIZE(PWM,1),SIZE(PWM,2),SIZE(PWM,3)))
@@ -492,7 +521,28 @@ IF (KSPLIT>1 .AND. CPROGRAM=='MESONH') THEN
ALLOCATE(ZRSVS(SIZE(PRSVS,1),SIZE(PRSVS,2),SIZE(PRSVS,3),SIZE(PRSVS,4)))
ALLOCATE(ZRTHLS(SIZE(PRTHLS,1),SIZE(PRTHLS,2),SIZE(PRTHLS,3)))
ALLOCATE(ZRRS(SIZE(PRRS,1),SIZE(PRRS,2),SIZE(PRRS,3),SIZE(PRRS,4)))
-!$acc data create( zum, zvm, zwm, zsvm, zthlm, ztkem, zrm, zrus, zrvs, zrws, zrsvs, zrthls, zrrs )
+#else
+ IZUM = MNH_ALLOCATE_ZT3D(ZUM,JIU,JJU,JKU)
+ IZVM = MNH_ALLOCATE_ZT3D(ZVM,JIU,JJU,JKU)
+ IZWM = MNH_ALLOCATE_ZT3D(ZWM,JIU,JJU,JKU)
+
+ IZTHLM = MNH_ALLOCATE_ZT3D(ZTHLM,JIU,JJU,JKU)
+ IZTKEM = MNH_ALLOCATE_ZT3D(ZTKEM,JIU,JJU,JKU)
+
+ IZRUS = MNH_ALLOCATE_ZT3D(ZRUS,JIU,JJU,JKU)
+ IZRVS = MNH_ALLOCATE_ZT3D(ZRVS,JIU,JJU,JKU)
+ IZRWS = MNH_ALLOCATE_ZT3D(ZRWS,JIU,JJU,JKU)
+
+ IZRTHLS = MNH_ALLOCATE_ZT3D(ZRTHLS,JIU,JJU,JKU)
+
+ IZSVM = MNH_ALLOCATE_ZT4D(ZSVM,JIU,JJU,JKU, SIZE(PSVM,4) )
+ IZRM = MNH_ALLOCATE_ZT4D(ZRM,JIU,JJU,JKU, SIZE(PRM,4) )
+ IZRSVS = MNH_ALLOCATE_ZT4D(ZRSVS,JIU,JJU,JKU, SIZE(PRSVS,4) )
+ IZRRS = MNH_ALLOCATE_ZT4D(ZRRS,JIU,JJU,JKU, SIZE(PRRS,4) )
+
+#endif
+
+!$acc data present( zum, zvm, zwm, zsvm, zthlm, ztkem, zrm, zrus, zrvs, zrws, zrsvs, zrthls, zrrs )
!
!
!* 2.2 list for parallel exchanges
@@ -698,6 +748,7 @@ IF (KSPLIT>1 .AND. CPROGRAM=='MESONH') THEN
! -------------
!
!$acc end data
+#ifndef MNH_OPENACC
DEALLOCATE(ZUM)
DEALLOCATE(ZVM)
DEALLOCATE(ZWM)
@@ -711,6 +762,14 @@ IF (KSPLIT>1 .AND. CPROGRAM=='MESONH') THEN
DEALLOCATE(ZRSVS)
DEALLOCATE(ZRTHLS)
DEALLOCATE(ZRRS)
+#else
+ CALL MNH_REL_ZT4D (SIZE(PRRS,4) , IZRRS )
+ CALL MNH_REL_ZT4D (SIZE(PRSVS,4) , IZRSVS )
+ CALL MNH_REL_ZT4D (SIZE(PRM,4) , IZRM )
+ CALL MNH_REL_ZT4D (SIZE(PSVM,4) , IZSVM )
+ CALL MNH_REL_ZT3D ( izum, izvm, izwm, izthlm, iztkem, izrus, izrvs, izrws, izrthls)
+#endif
+
!
CALL CLEANLIST_ll(TZFIELDS_ll)
!
@@ -751,14 +810,15 @@ END IF
!
!$acc end data
+#ifndef MNH_OPENACC
DEALLOCATE(ZK)
DEALLOCATE(ZINV_PDXX)
DEALLOCATE(ZINV_PDYY)
DEALLOCATE(ZINV_PDZZ)
DEALLOCATE(ZMZM_PRHODJ)
-#ifdef MNH_OPENACC
-deallocate( ZTMP1_DEVICE )
-deallocate( ZTMP2_DEVICE )
+#else
+CALL MNH_REL_ZT3D(IZK, IZINV_PDXX, IZINV_PDYY, IZINV_PDZZ, IZMZM_PRHODJ, &
+ IZTMP1_DEVICE, IZTMP2_DEVICE )
#endif
if ( mppdb_initialized ) then
diff --git a/src/MNH/turb_hor_sv_flux.f90 b/src/MNH/turb_hor_sv_flux.f90
index 723c8d56727e5c205015d5ea9c4fa0225ca15028..e49e71fe1c8671c5eb1014e64463bc027f178f9e 100644
--- a/src/MNH/turb_hor_sv_flux.f90
+++ b/src/MNH/turb_hor_sv_flux.f90
@@ -136,6 +136,10 @@ USE MODI_LES_MEAN_SUBGRID
!
USE MODI_SECOND_MNH
!
+#ifdef MNH_OPENACC
+USE MODE_MNH_ZWORK , ONLY : MNH_ALLOCATE_ZT3D , MNH_REL_ZT3D, MNH_ALLOCATE_ZT3DP , MNH_ALLOCATE_ZT2D
+#endif
+!
IMPLICIT NONE
!
!
@@ -171,8 +175,8 @@ REAL, DIMENSION(:,:,:,:), INTENT(INOUT) :: PRSVS ! var. at t+1 -split-
!
!* 0.2 declaration of local variables
!
-REAL, DIMENSION(:,:,:), allocatable :: ZFLXX, ZFLXY ! work arrays
-REAL, DIMENSION(:,:,:), allocatable :: ZWORK2D
+REAL, DIMENSION(:,:,:), pointer , contiguous :: ZFLXX, ZFLXY ! work arrays
+REAL, DIMENSION(:,:,:), pointer , contiguous :: ZWORK2D
!
REAL :: ZCSV !constant for the scalar flux
@@ -181,7 +185,10 @@ INTEGER :: IKB,IKE
! mass points of the domain
INTEGER :: JSV ! loop counter
INTEGER :: ISV ! number of scalar var.
-REAL, DIMENSION(:,:,:), allocatable :: ZCOEFF
+REAL, DIMENSION(:,:,:), pointer , contiguous :: ZCOEFF
+#ifdef MNH_OPENACC
+INTEGER :: IZFLXX, IZFLXY, IZWORK2D, IZCOEFF
+#endif
! coefficients for the uncentred gradient
! computation near the ground
!
@@ -190,9 +197,13 @@ TYPE(TFIELDDATA) :: TZFIELD
REAL :: ZTIME1, ZTIME2
!
#ifdef MNH_OPENACC
-REAL, DIMENSION(:,:,:), allocatable :: ZTMP1_DEVICE, ZTMP2_DEVICE, ZTMP3_DEVICE, &
- ZTMP4_DEVICE, ZTMP5_DEVICE
+REAL, DIMENSION(:,:,:), pointer , contiguous :: ZTMP1_DEVICE, ZTMP2_DEVICE, ZTMP3_DEVICE, &
+ ZTMP4_DEVICE, ZTMP5_DEVICE
+INTEGER :: IZTMP1_DEVICE, IZTMP2_DEVICE, IZTMP3_DEVICE, IZTMP4_DEVICE, IZTMP5_DEVICE
#endif
+!
+INTEGER :: JIU,JJU,JKU
+INTEGER :: JI,JJ,JK
! ---------------------------------------------------------------------------
!$acc data present( PK, PINV_PDXX, PINV_PDYY, PINV_PDZZ, PMZM_PRHODJ, &
@@ -225,22 +236,35 @@ if ( mppdb_initialized ) then
call Mppdb_check( prsvs, "Turb_hor_sv_flux beg:prsvs" )
end if
-allocate( zflxx(size( psvm, 1 ), size( psvm, 2 ), size( psvm, 3 ) ) )
-allocate( zflxy(size( psvm, 1 ), size( psvm, 2 ), size( psvm, 3 ) ) )
+JIU = size(psvm, 1 )
+JJU = size(psvm, 2 )
+JKU = size(psvm, 3 )
+
+#ifndef MNH_OPENACC
+allocate( zflxx(JIU,JJU,JKU ) )
+allocate( zflxy(JIU,JJU,JKU ) )
+
+allocate( zwork2d(JIU,JJU, 1 ) )
+
+allocate( zcoeff(JIU,JJU, 1 + jpvext : 3 + jpvext ) )
+#else
+izflxx = MNH_ALLOCATE_ZT3D( zflxx,JIU,JJU,JKU)
+izflxy = MNH_ALLOCATE_ZT3D( zflxy,JIU,JJU,JKU)
-allocate( zwork2d(size( psvm, 1 ), size( psvm, 2 ), 1 ) )
+izwork2d = MNH_ALLOCATE_ZT3DP( zwork2d,JIU,JJU, 1 , 1 )
-allocate( zcoeff(size( pdzz, 1 ), size( pdzz, 2 ), 1 + jpvext : 3 + jpvext ) )
+izcoeff = MNH_ALLOCATE_ZT3DP( zcoeff,JIU,JJU, 1 + jpvext , 3 + jpvext )
+#endif
#ifdef MNH_OPENACC
-allocate( ztmp1_device(size( psvm, 1 ), size( psvm, 2 ), size( psvm, 3 ) ) )
-allocate( ztmp2_device(size( psvm, 1 ), size( psvm, 2 ), size( psvm, 3 ) ) )
-allocate( ztmp3_device(size( psvm, 1 ), size( psvm, 2 ), size( psvm, 3 ) ) )
-allocate( ztmp4_device(size( psvm, 1 ), size( psvm, 2 ), size( psvm, 3 ) ) )
-allocate( ztmp5_device(size( psvm, 1 ), size( psvm, 2 ), size( psvm, 3 ) ) )
+iztmp1_device = MNH_ALLOCATE_ZT3D( ztmp1_device,JIU,JJU,JKU)
+iztmp2_device = MNH_ALLOCATE_ZT3D( ztmp2_device,JIU,JJU,JKU)
+iztmp3_device = MNH_ALLOCATE_ZT3D( ztmp3_device,JIU,JJU,JKU)
+iztmp4_device = MNH_ALLOCATE_ZT3D( ztmp4_device,JIU,JJU,JKU)
+iztmp5_device = MNH_ALLOCATE_ZT3D( ztmp5_device,JIU,JJU,JKU)
#endif
-!$acc data create( ZFLXX, ZFLXY, ZWORK2D, ZCOEFF, &
+!$acc data present( ZFLXX, ZFLXY, ZWORK2D, ZCOEFF, &
!$acc & ZTMP1_DEVICE, ZTMP2_DEVICE, ZTMP3_DEVICE, ZTMP4_DEVICE, ZTMP5_DEVICE )
!
@@ -615,6 +639,13 @@ end if
!$acc end data
+#ifndef MNH_OPENACC
+deallocate( ZFLXX, ZFLXY, ZWORK2D, ZCOEFF )
+#else
+CALL MNH_REL_ZT3D ( IZFLXX, IZFLXY, IZWORK2D, IZCOEFF, &
+ IZTMP1_DEVICE, IZTMP2_DEVICE, IZTMP3_DEVICE, IZTMP4_DEVICE, IZTMP5_DEVICE )
+#endif
+
!$acc end data
END SUBROUTINE TURB_HOR_SV_FLUX
diff --git a/src/MNH/turb_hor_thermo_corr.f90 b/src/MNH/turb_hor_thermo_corr.f90
index 400520860235aa1634cc874ac880e242244386cc..bc9c94a5ce33e0cbd1a1eb7814f1f4d0e61e6062 100644
--- a/src/MNH/turb_hor_thermo_corr.f90
+++ b/src/MNH/turb_hor_thermo_corr.f90
@@ -150,6 +150,11 @@ USE MODI_SECOND_MNH
USE MODI_BITREP
#endif
!
+#ifdef MNH_OPENACC
+USE MODE_MNH_ZWORK , ONLY : MNH_ALLOCATE_ZT3D , MNH_REL_ZT3D, MNH_ALLOCATE_ZT3DP , MNH_ALLOCATE_ZT2D, &
+ MNH_ALLOCATE_ZT4D , MNH_REL_ZT4D
+#endif
+!
IMPLICIT NONE
!
!
@@ -196,12 +201,15 @@ REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PSIGS
!
!* 0.2 declaration of local variables
!
-REAL, DIMENSION(:,:,:), allocatable :: ZFLX,ZWORK,ZA ! work arrays
+REAL, DIMENSION(:,:,:), pointer , contiguous :: ZFLX,ZWORK,ZA ! work arrays
!
INTEGER :: IKB,IKE
! Index values for the Beginning and End
! mass points of the domain
-REAL, DIMENSION(:,:,:), allocatable :: ZCOEFF
+REAL, DIMENSION(:,:,:), pointer , contiguous :: ZCOEFF
+#ifdef MNH_OPENACC
+INTEGER :: IZFLX,IZWORK,IZA,IZCOEFF
+#endif
! coefficients for the uncentred gradient
! computation near the ground
REAL :: ZTIME1, ZTIME2
@@ -209,10 +217,14 @@ TYPE(TFIELDDATA) :: TZFIELD
!
#ifdef MNH_OPENACC
INTEGER :: IKU
-REAL, DIMENSION(:,:,:), allocatable :: ZTMP1_DEVICE, ZTMP2_DEVICE, ZTMP3_DEVICE, ZTMP4_DEVICE
-REAL, DIMENSION(:,:,:), allocatable :: ZTMP5_DEVICE, ZTMP6_DEVICE, ZTMP7_DEVICE, ZTMP8_DEVICE
+REAL, DIMENSION(:,:,:), pointer , contiguous :: ZTMP1_DEVICE, ZTMP2_DEVICE, ZTMP3_DEVICE, ZTMP4_DEVICE
+REAL, DIMENSION(:,:,:), pointer , contiguous :: ZTMP5_DEVICE, ZTMP6_DEVICE, ZTMP7_DEVICE, ZTMP8_DEVICE
+INTEGER :: IZTMP1_DEVICE, IZTMP2_DEVICE, IZTMP3_DEVICE, IZTMP4_DEVICE ,&
+ IZTMP5_DEVICE, IZTMP6_DEVICE, IZTMP7_DEVICE, IZTMP8_DEVICE
#endif
!
+INTEGER :: JIU,JJU,JKU
+INTEGER :: JI,JJ,JK
! ---------------------------------------------------------------------------
!$acc data present( PINV_PDXX, PINV_PDYY, &
@@ -247,24 +259,36 @@ if ( mppdb_initialized ) then
call Mppdb_check( psigs, "Turb_hor_thermo_corr beg:psigs" )
end if
-allocate( zflx (size( pthlm, 1 ), size( pthlm, 2 ), size( pthlm, 3 ) ) )
-allocate( zwork(size( pthlm, 1 ), size( pthlm, 2 ), size( pthlm, 3 ) ) )
-allocate( za (size( pthlm, 1 ), size( pthlm, 2 ), size( pthlm, 3 ) ) )
+JIU = size(pthlm, 1 )
+JJU = size(pthlm, 2 )
+JKU = size(pthlm, 3 )
+
+#ifndef MNH_OPENACC
+allocate( zflx (JIU,JJU,JKU ) )
+allocate( zwork(JIU,JJU,JKU ) )
+allocate( za (JIU,JJU,JKU ) )
-allocate( zcoeff(size( pdzz, 1 ), size( pdzz, 2 ), 1 + jpvext : 3 + jpvext ) )
+allocate( zcoeff(JIU,JJU, 1 + jpvext : 3 + jpvext ) )
+#else
+izflx = MNH_ALLOCATE_ZT3D( zflx ,JIU,JJU,JKU )
+izwork = MNH_ALLOCATE_ZT3D( zwork ,JIU,JJU,JKU )
+iza = MNH_ALLOCATE_ZT3D( za ,JIU,JJU,JKU )
+
+izcoeff= MNH_ALLOCATE_ZT3DP( zcoeff,JIU,JJU, 1 + jpvext , 3 + jpvext )
+#endif
#ifdef MNH_OPENACC
-allocate( ztmp1_device(size( pthlm, 1 ), size( pthlm, 2 ), size( pthlm, 3 ) ) )
-allocate( ztmp2_device(size( pthlm, 1 ), size( pthlm, 2 ), size( pthlm, 3 ) ) )
-allocate( ztmp3_device(size( pthlm, 1 ), size( pthlm, 2 ), size( pthlm, 3 ) ) )
-allocate( ztmp4_device(size( pthlm, 1 ), size( pthlm, 2 ), size( pthlm, 3 ) ) )
-allocate( ztmp5_device(size( pthlm, 1 ), size( pthlm, 2 ), size( pthlm, 3 ) ) )
-allocate( ztmp6_device(size( pthlm, 1 ), size( pthlm, 2 ), size( pthlm, 3 ) ) )
-allocate( ztmp7_device(size( pthlm, 1 ), size( pthlm, 2 ), size( pthlm, 3 ) ) )
-allocate( ztmp8_device(size( pthlm, 1 ), size( pthlm, 2 ), size( pthlm, 3 ) ) )
+iztmp1_device= MNH_ALLOCATE_ZT3D( ztmp1_device,JIU,JJU,JKU )
+iztmp2_device= MNH_ALLOCATE_ZT3D( ztmp2_device,JIU,JJU,JKU )
+iztmp3_device= MNH_ALLOCATE_ZT3D( ztmp3_device,JIU,JJU,JKU )
+iztmp4_device= MNH_ALLOCATE_ZT3D( ztmp4_device,JIU,JJU,JKU )
+iztmp5_device= MNH_ALLOCATE_ZT3D( ztmp5_device,JIU,JJU,JKU )
+iztmp6_device= MNH_ALLOCATE_ZT3D( ztmp6_device,JIU,JJU,JKU )
+iztmp7_device= MNH_ALLOCATE_ZT3D( ztmp7_device,JIU,JJU,JKU )
+iztmp8_device= MNH_ALLOCATE_ZT3D( ztmp8_device,JIU,JJU,JKU )
#endif
-!$acc data create( ZFLX, ZWORK, ZA, ZCOEFF, &
+!$acc data present( ZFLX, ZWORK, ZA, ZCOEFF, &
!$acc & ZTMP1_DEVICE, ZTMP2_DEVICE, ZTMP3_DEVICE, ZTMP4_DEVICE, &
!$acc & ZTMP5_DEVICE, ZTMP6_DEVICE, ZTMP7_DEVICE, ZTMP8_DEVICE )
@@ -460,7 +484,9 @@ IF ( ( KRRL > 0 .AND. OSUBG_COND) .OR. ( OTURB_FLX .AND. tpfile%lopened ) &
CALL LES_MEAN_SUBGRID( ZTMP1_DEVICE, X_LES_SUBGRID_ThlPz, .TRUE. )
!
!$acc end data
+
#endif
+
CALL SECOND_MNH(ZTIME2)
XTIME_LES = XTIME_LES + ZTIME2 - ZTIME1
END IF
@@ -491,7 +517,8 @@ IF ( ( KRRL > 0 .AND. OSUBG_COND) .OR. ( OTURB_FLX .AND. tpfile%lopened ) &
CALL GY_M_M_DEVICE(1,IKU,1,PTHLM ,PDYY,PDZZ,PDZY,ZTMP3_DEVICE)
CALL GY_M_M_DEVICE(1,IKU,1,PRM(:,:,:,1),PDYY,PDZZ,PDZY,ZTMP4_DEVICE)
!$acc kernels
- ZFLX(:,:,:)=PLM(:,:,:) * PLEPS(:,:,:) * (ZTMP1_DEVICE(:,:,:)*ZTMP2_DEVICE(:,:,:)+ZTMP3_DEVICE(:,:,:)*ZTMP4_DEVICE(:,:,:) ) * (XCHT1+XCHT2)
+ ZFLX(:,:,:)=PLM(:,:,:) * PLEPS(:,:,:) * (ZTMP1_DEVICE(:,:,:)*ZTMP2_DEVICE(:,:,:) &
+ +ZTMP3_DEVICE(:,:,:)*ZTMP4_DEVICE(:,:,:) ) * (XCHT1+XCHT2)
!$acc end kernels
ELSE
CALL GX_M_M_DEVICE(1,IKU,1,PTHLM ,PDXX,PDZZ,PDZX,ZTMP1_DEVICE)
@@ -861,6 +888,14 @@ end if
!$acc end data
+#ifndef MNH_OPENACC
+deallocate (zflx,zwork,za,zcoeff)
+#else
+CALL MNH_REL_ZT3D ( IZFLX, IZWORK, IZA, IZCOEFF, &
+ IZTMP1_DEVICE, IZTMP2_DEVICE, IZTMP3_DEVICE, IZTMP4_DEVICE, &
+ IZTMP5_DEVICE, IZTMP6_DEVICE, IZTMP7_DEVICE, IZTMP8_DEVICE )
+#endif
+
!$acc end data
END SUBROUTINE TURB_HOR_THERMO_CORR
diff --git a/src/MNH/turb_hor_thermo_flux.f90 b/src/MNH/turb_hor_thermo_flux.f90
index 17c3b5324093d83448177426c2e1e14f8218445a..768eade63a9c16ffe0aa0015e0495a0c5bd6acd8 100644
--- a/src/MNH/turb_hor_thermo_flux.f90
+++ b/src/MNH/turb_hor_thermo_flux.f90
@@ -151,6 +151,12 @@ USE MODI_LES_MEAN_SUBGRID
!
USE MODI_SECOND_MNH
!
+#ifdef MNH_OPENACC
+USE MODE_MNH_ZWORK , ONLY : MNH_ALLOCATE_ZT3D , MNH_REL_ZT3D, MNH_ALLOCATE_ZT3DP , MNH_ALLOCATE_ZT2D, &
+ MNH_ALLOCATE_ZT4D , MNH_REL_ZT4D, &
+ MNH_CHECK_IN_ZT3D,MNH_CHECK_OUT_ZT3D
+#endif
+!
IMPLICIT NONE
!
!
@@ -203,23 +209,32 @@ REAL, DIMENSION(:,:,:,:), INTENT(INOUT) :: PRRS ! var. at t+1 -split-
!
!* 0.2 declaration of local variables
!
-REAL, DIMENSION(:,:,:), allocatable :: ZFLX,ZFLXC ! work arrays
-!! REAL, DIMENSION(:,:,:), allocatable :: ZVPTV
+REAL, DIMENSION(:,:,:), pointer , contiguous :: ZFLX,ZFLXC ! work arrays
+!! REAL, DIMENSION(:,:,:), pointer , contiguous :: ZVPTV
INTEGER :: IKB,IKE,IKU
! Index values for the Beginning and End
! mass points of the domain
-REAL, DIMENSION(:,:,:), allocatable :: ZCOEFF
+REAL, DIMENSION(:,:,:), pointer , contiguous :: ZCOEFF
! coefficients for the uncentred gradient
! computation near the ground
+#ifdef MNH_OPENACC
+INTEGER :: IZFLX,IZFLXC,IZCOEFF
+#endif
!
REAL :: ZTIME1, ZTIME2
!
#ifdef MNH_OPENACC
-REAL, DIMENSION(:,:,:), allocatable :: ZTMP1_DEVICE, ZTMP2_DEVICE, ZTMP3_DEVICE, ZTMP4_DEVICE
-REAL, DIMENSION(:,:,:), allocatable :: ZTMP5_DEVICE, ZTMP6_DEVICE, ZTMP7_DEVICE, ZTMP8_DEVICE
+REAL, DIMENSION(:,:,:), pointer , contiguous :: ZTMP1_DEVICE, ZTMP2_DEVICE, ZTMP3_DEVICE, ZTMP4_DEVICE
+REAL, DIMENSION(:,:,:), pointer , contiguous :: ZTMP5_DEVICE, ZTMP6_DEVICE, ZTMP7_DEVICE, ZTMP8_DEVICE
+INTEGER :: IZTMP1_DEVICE, IZTMP2_DEVICE, IZTMP3_DEVICE, IZTMP4_DEVICE, &
+ IZTMP5_DEVICE, IZTMP6_DEVICE, IZTMP7_DEVICE, IZTMP8_DEVICE
#endif
!
TYPE(TFIELDDATA) :: TZFIELD
+!
+INTEGER :: JIU,JJU,JKU
+INTEGER :: JI,JJ,JK
+!
! ---------------------------------------------------------------------------
!$acc data present( PK, PINV_PDXX, PINV_PDYY, PINV_PDZZ, PMZM_PRHODJ, &
@@ -259,24 +274,38 @@ if ( mppdb_initialized ) then
call Mppdb_check( prrs, "Turb_hor_thermo_flux beg:prrs" )
end if
-allocate( zflx (size( pthlm, 1 ), size( pthlm, 2 ), size( pthlm, 3 ) ) )
-allocate( zflxc(size( pthlm, 1 ), size( pthlm, 2 ), size( pthlm, 3 ) ) )
-! allocate( zvptv(size( pthlm, 1 ), size( pthlm, 2 ), size( pthlm, 3 ) ) )
+JIU = size(pthlm, 1 )
+JJU = size(pthlm, 2 )
+JKU = size(pthlm, 3 )
-allocate( zcoeff(size( pdzz, 1 ), size( pdzz, 2 ), 1 + jpvext : 3 + jpvext ) )
+#ifndef MNH_OPENACC
+allocate( zflx (JIU,JJU,JKU) )
+allocate( zflxc(JIU,JJU,JKU) )
+! allocate( zvptv(JIU,JJU,JKU) )
+
+allocate( zcoeff(JIU,JJU, 1 + jpvext : 3 + jpvext ) )
+#else
+CALL MNH_CHECK_IN_ZT3D("TURB_HOR_THERMO_FLUX")
+izflx = MNH_ALLOCATE_ZT3D( zflx ,JIU,JJU,JKU )
+izflxc = MNH_ALLOCATE_ZT3D( zflxc,JIU,JJU,JKU )
+! izvptv= MNH_ALLOCATE_ZT3D( zvptv,JIU,JJU,JKU )
+
+izcoeff= MNH_ALLOCATE_ZT3DP( zcoeff,JIU,JJU, 1 + jpvext , 3 + jpvext )
+
+#endif
#ifdef MNH_OPENACC
-allocate( ztmp1_device(size( pthlm, 1 ), size( pthlm, 2 ), size( pthlm, 3 ) ) )
-allocate( ztmp2_device(size( pthlm, 1 ), size( pthlm, 2 ), size( pthlm, 3 ) ) )
-allocate( ztmp3_device(size( pthlm, 1 ), size( pthlm, 2 ), size( pthlm, 3 ) ) )
-allocate( ztmp4_device(size( pthlm, 1 ), size( pthlm, 2 ), size( pthlm, 3 ) ) )
-allocate( ztmp5_device(size( pthlm, 1 ), size( pthlm, 2 ), size( pthlm, 3 ) ) )
-allocate( ztmp6_device(size( pthlm, 1 ), size( pthlm, 2 ), size( pthlm, 3 ) ) )
-allocate( ztmp7_device(size( pthlm, 1 ), size( pthlm, 2 ), size( pthlm, 3 ) ) )
-allocate( ztmp8_device(size( pthlm, 1 ), size( pthlm, 2 ), size( pthlm, 3 ) ) )
+iztmp1_device= MNH_ALLOCATE_ZT3D( ztmp1_device,JIU,JJU,JKU )
+iztmp2_device= MNH_ALLOCATE_ZT3D( ztmp2_device,JIU,JJU,JKU )
+iztmp3_device= MNH_ALLOCATE_ZT3D( ztmp3_device,JIU,JJU,JKU )
+iztmp4_device= MNH_ALLOCATE_ZT3D( ztmp4_device,JIU,JJU,JKU )
+iztmp5_device= MNH_ALLOCATE_ZT3D( ztmp5_device,JIU,JJU,JKU )
+iztmp6_device= MNH_ALLOCATE_ZT3D( ztmp6_device,JIU,JJU,JKU )
+iztmp7_device= MNH_ALLOCATE_ZT3D( ztmp7_device,JIU,JJU,JKU )
+iztmp8_device= MNH_ALLOCATE_ZT3D( ztmp8_device,JIU,JJU,JKU )
#endif
-!$acc data create( ZFLX, ZFLXC, ZCOEFF, &
+!$acc data present( ZFLX, ZFLXC, ZCOEFF, &
!$acc & ZTMP1_DEVICE, ZTMP2_DEVICE, ZTMP3_DEVICE, ZTMP4_DEVICE, &
!$acc & ZTMP5_DEVICE, ZTMP6_DEVICE, ZTMP7_DEVICE, ZTMP8_DEVICE )
@@ -311,7 +340,10 @@ ZFLX(:,:,IKE+1) = ZFLX(:,:,IKE)
CALL MXM_DEVICE( PK, ZTMP1_DEVICE )
CALL GX_M_U_DEVICE(1,IKU,1,PTHLM,PDXX,PDZZ,PDZX,ZTMP2_DEVICE)
!$acc kernels
-ZFLX(:,:,:) = -XCSHF * ZTMP1_DEVICE(:,:,:) * ZTMP2_DEVICE(:,:,:)
+!$acc loop independent collapse(3)
+DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZFLX(JI,JJ,JK) = -XCSHF * ZTMP1_DEVICE(JI,JJ,JK) * ZTMP2_DEVICE(JI,JJ,JK)
+END DO
ZFLX(:,:,IKE+1) = ZFLX(:,:,IKE)
!$acc end kernels
#endif
@@ -350,7 +382,10 @@ ZFLX(:,:,IKB-1:IKB-1) = 2. * MXM( SPREAD( PSFTHM(:,:)* PDIRCOSXW(:,:), 3,1) )
- ZFLX(:,:,IKB:IKB)
#else
!$acc kernels
- ZTMP1_DEVICE(:,:,1) = PSFTHM(:,:)* PDIRCOSXW(:,:)
+!$acc loop independent collapse(2)
+DO CONCURRENT ( JI=1:JIU,JJ=1:JJU )
+ ZTMP1_DEVICE(JI,JJ,1) = PSFTHM(JI,JJ)* PDIRCOSXW(JI,JJ)
+END DO
!$acc end kernels
CALL MXM_DEVICE( ZTMP1_DEVICE(:,:,1:1), ZTMP2_DEVICE(:,:,1:1) )
!$acc kernels
@@ -371,20 +406,32 @@ END IF
#else
IF (.NOT. LFLAT) THEN
CALL MXM_DEVICE(PRHODJ, ZTMP1_DEVICE)
-!$acc kernels
- ZTMP2_DEVICE(:,:,:) = ZTMP1_DEVICE(:,:,:) * ZFLX(:,:,:) * PINV_PDXX(:,:,:)
-!$acc end kernels
+ !$acc kernels
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP2_DEVICE(JI,JJ,JK) = ZTMP1_DEVICE(JI,JJ,JK) * ZFLX(JI,JJ,JK) * PINV_PDXX(JI,JJ,JK)
+ END DO
+ !$acc end kernels
CALL DXF_DEVICE(ZTMP2_DEVICE, ZTMP3_DEVICE)
-!$acc kernels
- ZTMP2_DEVICE(:,:,:) = ZFLX(:,:,:) * PINV_PDXX(:,:,:)
-!$acc end kernels
+ !$acc kernels
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP2_DEVICE(JI,JJ,JK) = ZFLX(JI,JJ,JK) * PINV_PDXX(JI,JJ,JK)
+ END DO
+ !$acc end kernels
CALL MZM_DEVICE(ZTMP2_DEVICE,ZTMP4_DEVICE)
-!$acc kernels
- ZTMP2_DEVICE(:,:,:) = PDZX(:,:,:)*ZTMP4_DEVICE(:,:,:)
+ !$acc kernels
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP2_DEVICE(JI,JJ,JK) = PDZX(JI,JJ,JK)*ZTMP4_DEVICE(JI,JJ,JK)
+ END DO
!$acc end kernels
CALL MXF_DEVICE(ZTMP2_DEVICE, ZTMP4_DEVICE)
!$acc kernels
- ZTMP2_DEVICE(:,:,:) = PMZM_PRHODJ(:,:,:) * ZTMP4_DEVICE(:,:,:) * PINV_PDZZ(:,:,:)
+!$acc loop independent collapse(3)
+DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP2_DEVICE(JI,JJ,JK) = PMZM_PRHODJ(JI,JJ,JK) * ZTMP4_DEVICE(JI,JJ,JK) * PINV_PDZZ(JI,JJ,JK)
+END DO
!$acc end kernels
CALL DZF_DEVICE(1,IKU,1,ZTMP2_DEVICE,ZTMP4_DEVICE )
!$acc kernels
@@ -602,7 +649,9 @@ IF (KSPLT==1 .AND. LLES_CALL) THEN
CALL LES_MEAN_SUBGRID( ZTMP3_DEVICE,X_LES_RES_ddxa_Rt_SBG_UaThl , .TRUE. )
END IF
!$acc end data
+
#endif
+
CALL SECOND_MNH(ZTIME2)
XTIME_LES = XTIME_LES + ZTIME2 - ZTIME1
END IF
@@ -725,7 +774,10 @@ END IF
CALL MXM_DEVICE( PK, ZTMP1_DEVICE )
CALL GX_M_U_DEVICE(1,IKU,1,PRM(:,:,:,1),PDXX,PDZZ,PDZX,ZTMP2_DEVICE)
!$acc kernels
- ZFLX(:,:,:) = -XCHF * ZTMP1_DEVICE * ZTMP2_DEVICE(:,:,:)
+!$acc loop independent collapse(3)
+DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZFLX(JI,JJ,JK) = -XCHF * ZTMP1_DEVICE(JI,JJ,JK) * ZTMP2_DEVICE(JI,JJ,JK)
+END DO
ZFLX(:,:,IKE+1) = ZFLX(:,:,IKE)
!$acc end kernels
!
@@ -761,23 +813,38 @@ END IF
IF (.NOT. LFLAT) THEN
CALL MXM_DEVICE(PRHODJ,ZTMP1_DEVICE)
!$acc kernels
- ZTMP2_DEVICE(:,:,:) = ZTMP1_DEVICE(:,:,:) * ZFLX(:,:,:) * PINV_PDXX(:,:,:)
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP2_DEVICE(JI,JJ,JK) = ZTMP1_DEVICE(JI,JJ,JK) * ZFLX(JI,JJ,JK) * PINV_PDXX(JI,JJ,JK)
+ END DO
!$acc end kernels
CALL DXF_DEVICE( ZTMP2_DEVICE, ZTMP3_DEVICE )
!$acc kernels
- ZTMP2_DEVICE(:,:,:) = ZFLX(:,:,:) * PINV_PDXX(:,:,:)
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP2_DEVICE(JI,JJ,JK) = ZFLX(JI,JJ,JK) * PINV_PDXX(JI,JJ,JK)
+ END DO
!$acc end kernels
CALL MZM_DEVICE(ZTMP2_DEVICE,ZTMP4_DEVICE)
!$acc kernels
- ZTMP2_DEVICE(:,:,:) = PDZX(:,:,:)*ZTMP4_DEVICE(:,:,:)
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP2_DEVICE(JI,JJ,JK) = PDZX(JI,JJ,JK)*ZTMP4_DEVICE(JI,JJ,JK)
+ END DO
!$acc end kernels
CALL MXF_DEVICE(ZTMP2_DEVICE,ZTMP4_DEVICE)
!$acc kernels
- ZTMP2_DEVICE(:,:,:) = PMZM_PRHODJ(:,:,:) * ZTMP4_DEVICE(:,:,:) * PINV_PDZZ(:,:,:)
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP2_DEVICE(JI,JJ,JK) = PMZM_PRHODJ(JI,JJ,JK) * ZTMP4_DEVICE(JI,JJ,JK) * PINV_PDZZ(JI,JJ,JK)
+ END DO
!$acc end kernels
CALL DZF_DEVICE(1,IKU,1, ZTMP2_DEVICE, ZTMP4_DEVICE)
!$acc kernels
- PRRS(:,:,:,1) = PRRS(:,:,:,1) - ZTMP3_DEVICE(:,:,:) + ZTMP4_DEVICE(:,:,:)
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ PRRS(JI,JJ,JK,1) = PRRS(JI,JJ,JK,1) - ZTMP3_DEVICE(JI,JJ,JK) + ZTMP4_DEVICE(JI,JJ,JK)
+ END DO
!$acc end kernels
ELSE
CALL MXM_DEVICE(PRHODJ,ZTMP1_DEVICE)
@@ -1085,7 +1152,10 @@ END IF
CALL MYM_DEVICE( PK, ZTMP1_DEVICE )
CALL GY_M_V_DEVICE(1,IKU,1,PTHLM,PDYY,PDZZ,PDZY,ZTMP2_DEVICE)
!$acc kernels
- ZFLX(:,:,:) = -XCSHF * ZTMP1_DEVICE(:,:,:) * ZTMP2_DEVICE(:,:,:)
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZFLX(JI,JJ,JK) = -XCSHF * ZTMP1_DEVICE(JI,JJ,JK) * ZTMP2_DEVICE(JI,JJ,JK)
+ END DO
ZFLX(:,:,IKE+1) = ZFLX(:,:,IKE)
!$acc end kernels
ELSE
@@ -1129,23 +1199,38 @@ IF (.NOT. L2D) THEN
IF (.NOT. LFLAT) THEN
CALL MYM_DEVICE(PRHODJ, ZTMP1_DEVICE)
!$acc kernels
- ZTMP2_DEVICE(:,:,:) = ZTMP1_DEVICE(:,:,:) * ZFLX(:,:,:) * PINV_PDYY(:,:,:)
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP2_DEVICE(JI,JJ,JK) = ZTMP1_DEVICE(JI,JJ,JK) * ZFLX(JI,JJ,JK) * PINV_PDYY(JI,JJ,JK)
+ END DO
!$acc end kernels
CALL DYF_DEVICE( ZTMP2_DEVICE, ZTMP3_DEVICE )
!$acc kernels
- ZTMP1_DEVICE(:,:,:) = ZFLX(:,:,:) * PINV_PDYY(:,:,:)
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP1_DEVICE(JI,JJ,JK) = ZFLX(JI,JJ,JK) * PINV_PDYY(JI,JJ,JK)
+ END DO
!$acc end kernels
CALL MZM_DEVICE(ZTMP1_DEVICE, ZTMP2_DEVICE)
!$acc kernels
- ZTMP1_DEVICE(:,:,:) = PDZY(:,:,:)*ZTMP2_DEVICE(:,:,:)
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP1_DEVICE(JI,JJ,JK) = PDZY(JI,JJ,JK)*ZTMP2_DEVICE(JI,JJ,JK)
+ END DO
!$acc end kernels
CALL MYF_DEVICE(ZTMP1_DEVICE, ZTMP2_DEVICE)
!$acc kernels
- ZTMP1_DEVICE(:,:,:) = PMZM_PRHODJ(:,:,:) * ZTMP2_DEVICE(:,:,:) * PINV_PDZZ(:,:,:)
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP1_DEVICE(JI,JJ,JK) = PMZM_PRHODJ(JI,JJ,JK) * ZTMP2_DEVICE(JI,JJ,JK) * PINV_PDZZ(JI,JJ,JK)
+ END DO
!$acc end kernels
CALL DZF_DEVICE(1,IKU,1, ZTMP1_DEVICE, ZTMP2_DEVICE )
!$acc kernels
- PRTHLS(:,:,:) = PRTHLS(:,:,:) - ZTMP3_DEVICE(:,:,:) + ZTMP2_DEVICE(:,:,:)
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ PRTHLS(JI,JJ,JK) = PRTHLS(JI,JJ,JK) - ZTMP3_DEVICE(JI,JJ,JK) + ZTMP2_DEVICE(JI,JJ,JK)
+ END DO
!$acc end kernels
ELSE
CALL MYM_DEVICE(PRHODJ, ZTMP1_DEVICE)
@@ -1434,7 +1519,10 @@ IF (KRR/=0) THEN
CALL MYM_DEVICE( PK, ZTMP1_DEVICE )
CALL GY_M_V_DEVICE(1,IKU,1,PRM(:,:,:,1),PDYY,PDZZ,PDZY, ZTMP2_DEVICE)
!$acc kernels
- ZFLX(:,:,:) = -XCHF * ZTMP1_DEVICE(:,:,:) * ZTMP2_DEVICE(:,:,:)
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZFLX(JI,JJ,JK) = -XCHF * ZTMP1_DEVICE(JI,JJ,JK) * ZTMP2_DEVICE(JI,JJ,JK)
+ END DO !CONCURRENT
ZFLX(:,:,IKE+1) = ZFLX(:,:,IKE)
!$acc end kernels
ELSE
@@ -1477,25 +1565,40 @@ IF (KRR/=0) THEN
IF (.NOT. LFLAT) THEN
CALL MYM_DEVICE(PRHODJ, ZTMP1_DEVICE)
!$acc kernels
- ZTMP2_DEVICE(:,:,:) = ZTMP1_DEVICE(:,:,:) * ZFLX(:,:,:) * PINV_PDYY(:,:,:)
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP2_DEVICE(JI,JJ,JK) = ZTMP1_DEVICE(JI,JJ,JK) * ZFLX(JI,JJ,JK) * PINV_PDYY(JI,JJ,JK)
+ END DO
!$acc end kernels
CALL DYF_DEVICE( ZTMP2_DEVICE, ZTMP3_DEVICE )
!
!$acc kernels
- ZTMP1_DEVICE(:,:,:) = ZFLX(:,:,:) * PINV_PDYY(:,:,:)
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP1_DEVICE(JI,JJ,JK) = ZFLX(JI,JJ,JK) * PINV_PDYY(JI,JJ,JK)
+ END DO
!$acc end kernels
CALL MZM_DEVICE(ZTMP1_DEVICE,ZTMP2_DEVICE)
!$acc kernels
- ZTMP1_DEVICE(:,:,:) = PDZY(:,:,:)*ZTMP2_DEVICE(:,:,:)
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP1_DEVICE(JI,JJ,JK) = PDZY(JI,JJ,JK)*ZTMP2_DEVICE(JI,JJ,JK)
+ END DO
!$acc end kernels
CALL MYF_DEVICE(ZTMP1_DEVICE,ZTMP2_DEVICE)
!$acc kernels
- ZTMP1_DEVICE(:,:,:) = PMZM_PRHODJ(:,:,:) * ZTMP2_DEVICE(:,:,:) * PINV_PDZZ(:,:,:)
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP1_DEVICE(JI,JJ,JK) = PMZM_PRHODJ(JI,JJ,JK) * ZTMP2_DEVICE(JI,JJ,JK) * PINV_PDZZ(JI,JJ,JK)
+ END DO
!$acc end kernels
CALL DZF_DEVICE(1,IKU,1,ZTMP1_DEVICE,ZTMP2_DEVICE )
!
!$acc kernels
- PRRS(:,:,:,1) = PRRS(:,:,:,1) - ZTMP3_DEVICE(:,:,:) + ZTMP2_DEVICE(:,:,:)
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ PRRS(JI,JJ,JK,1) = PRRS(JI,JJ,JK,1) - ZTMP3_DEVICE(JI,JJ,JK) + ZTMP2_DEVICE(JI,JJ,JK)
+ END DO
!$acc end kernels
ELSE
CALL MYM_DEVICE(PRHODJ, ZTMP1_DEVICE)
@@ -1699,6 +1802,15 @@ end if
!$acc end data
+#ifndef MNH_OPENACC
+deallocate (zflx,zflxc,zcoeff)
+#else
+CALL MNH_REL_ZT3D ( IZFLX, IZFLXC, IZCOEFF, &
+ IZTMP1_DEVICE, IZTMP2_DEVICE, IZTMP3_DEVICE, IZTMP4_DEVICE, &
+ IZTMP5_DEVICE, IZTMP6_DEVICE, IZTMP7_DEVICE, IZTMP8_DEVICE )
+CALL MNH_CHECK_OUT_ZT3D("TURB_HOR_THERMO_FLUX")
+#endif
+
!$acc end data
END SUBROUTINE TURB_HOR_THERMO_FLUX
diff --git a/src/MNH/turb_hor_tke.f90 b/src/MNH/turb_hor_tke.f90
index f98d8de25d5d3fed9a3663e56b23796428a9463f..c5db45b264f6b9f0873232ff6b2adaff8e978855 100644
--- a/src/MNH/turb_hor_tke.f90
+++ b/src/MNH/turb_hor_tke.f90
@@ -98,7 +98,11 @@ USE MODI_GRADIENT_M
USE MODI_LES_MEAN_SUBGRID
!
USE MODI_SECOND_MNH
-!
+
+#ifdef MNH_OPENACC
+USE MODE_MNH_ZWORK , ONLY : MNH_ALLOCATE_ZT3D , MNH_REL_ZT3D, MNH_ALLOCATE_ZT3DP , MNH_ALLOCATE_ZT2D
+#endif
+
IMPLICIT NONE
!
!
@@ -125,17 +129,24 @@ REAL, DIMENSION(:,:,:), INTENT(OUT) :: PTRH ! horizontal transport of T
!
INTEGER :: IKB, IKU
!
-REAL, DIMENSION(:,:,:), allocatable :: ZCOEFF
+REAL, DIMENSION(:,:,:), pointer , contiguous :: ZCOEFF
! coefficients for the uncentred gradient
! computation near the ground
!
-REAL, DIMENSION(:,:,:), allocatable :: ZFLX
+REAL, DIMENSION(:,:,:), pointer , contiguous :: ZFLX
+#ifdef MNH_OPENACC
+INTEGER :: IZCOEFF,IZFLX
+#endif
!
REAL :: ZTIME1, ZTIME2
!
#ifdef MNH_OPENACC
-REAL, DIMENSION(:,:,:), allocatable :: ZTMP1_DEVICE, ZTMP2_DEVICE, ZTMP3_DEVICE, ZTMP4_DEVICE
+REAL, DIMENSION(:,:,:), pointer , contiguous :: ZTMP1_DEVICE, ZTMP2_DEVICE, ZTMP3_DEVICE, ZTMP4_DEVICE
+INTEGER :: IZTMP1_DEVICE, IZTMP2_DEVICE, IZTMP3_DEVICE, IZTMP4_DEVICE
#endif
+!
+INTEGER :: JIU,JJU,JKU
+INTEGER :: JI,JJ,JK
! ---------------------------------------------------------------------------
!$acc data present( PDXX, PDYY, PDZZ, PDZX, PDZY, &
@@ -161,18 +172,29 @@ if ( mppdb_initialized ) then
call Mppdb_check( ptrh, "Turb_hor_tke beg:ptrh" )
end if
-allocate( zflx (size( ptkem, 1 ), size( ptkem, 2 ), size( ptkem, 3 ) ) )
+JIU = size(ptkem, 1 )
+JJU = size(ptkem, 2 )
+JKU = size(ptkem, 3 )
+
+#ifndef MNH_OPENACC
+allocate( zflx (JIU,JJU,JKU ) )
+
+allocate( zcoeff(JIU,JJU, 1 + jpvext : 3 + jpvext ) )
+#else
+izflx = MNH_ALLOCATE_ZT3D( zflx ,JIU,JJU,JKU )
+
+izcoeff = MNH_ALLOCATE_ZT3DP( zcoeff,JIU,JJU, 1 + jpvext , 3 + jpvext )
+#endif
-allocate( zcoeff(size( pdzz, 1 ), size( pdzz, 2 ), 1 + jpvext : 3 + jpvext ) )
#ifdef MNH_OPENACC
-allocate( ztmp1_device(size( ptkem, 1 ), size( ptkem, 2 ), size( ptkem, 3 ) ) )
-allocate( ztmp2_device(size( ptkem, 1 ), size( ptkem, 2 ), size( ptkem, 3 ) ) )
-allocate( ztmp3_device(size( ptkem, 1 ), size( ptkem, 2 ), size( ptkem, 3 ) ) )
-allocate( ztmp4_device(size( ptkem, 1 ), size( ptkem, 2 ), size( ptkem, 3 ) ) )
+iztmp1_device = MNH_ALLOCATE_ZT3D( ztmp1_device,JIU,JJU,JKU)
+iztmp2_device = MNH_ALLOCATE_ZT3D( ztmp2_device,JIU,JJU,JKU)
+iztmp3_device = MNH_ALLOCATE_ZT3D( ztmp3_device,JIU,JJU,JKU)
+iztmp4_device = MNH_ALLOCATE_ZT3D( ztmp4_device,JIU,JJU,JKU)
#endif
-!$acc data create( ZCOEFF, ZFLX, &
+!$acc data present( ZCOEFF, ZFLX, &
!$acc & ZTMP1_DEVICE, ZTMP2_DEVICE, ZTMP3_DEVICE, ZTMP4_DEVICE )
!
@@ -206,14 +228,20 @@ ZFLX = -XCET * MXM(PK) * GX_M_U(1,IKU,1,PTKEM,PDXX,PDZZ,PDZX) ! < u'e >
CALL MXM_DEVICE(PK,ZTMP1_DEVICE)
CALL GX_M_U_DEVICE(1,IKU,1,PTKEM,PDXX,PDZZ,PDZX,ZTMP2_DEVICE)
!$acc kernels
-ZFLX = -XCET * ZTMP1_DEVICE * ZTMP2_DEVICE ! < u'e >
+!$acc loop independent collapse(3)
+DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZFLX(JI,JJ,JK) = -XCET * ZTMP1_DEVICE(JI,JJ,JK) * ZTMP2_DEVICE(JI,JJ,JK) ! < u'e >
+END DO !CONCURRENT
#endif
!
! special case near the ground ( uncentred gradient )
!
-ZFLX(:,:,IKB) = ZCOEFF(:,:,IKB+2)*PTKEM(:,:,IKB+2) &
- + ZCOEFF(:,:,IKB+1)*PTKEM(:,:,IKB+1) &
- + ZCOEFF(:,:,IKB )*PTKEM(:,:,IKB )
+!$acc loop independent collapse(2)
+DO CONCURRENT ( JI=1:JIU,JJ=1:JJU )
+ ZFLX(JI,JJ,IKB) = ZCOEFF(JI,JJ,IKB+2)*PTKEM(JI,JJ,IKB+2) &
+ + ZCOEFF(JI,JJ,IKB+1)*PTKEM(JI,JJ,IKB+1) &
+ + ZCOEFF(JI,JJ,IKB )*PTKEM(JI,JJ,IKB )
+END DO
!$acc end kernels
!
#ifndef MNH_OPENACC
@@ -263,23 +291,38 @@ END IF
IF (.NOT. LFLAT) THEN
CALL MXM_DEVICE(PRHODJ,ZTMP1_DEVICE)
!$acc kernels
- ZTMP2_DEVICE = ZTMP1_DEVICE * ZFLX * PINV_PDXX
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP2_DEVICE(JI,JJ,JK) = ZTMP1_DEVICE(JI,JJ,JK) * ZFLX(JI,JJ,JK) * PINV_PDXX(JI,JJ,JK)
+ END DO !CONCURRENT
!$acc end kernels
CALL DXF_DEVICE(ZTMP2_DEVICE,ZTMP1_DEVICE)
!$acc kernels
- ZTMP2_DEVICE = ZFLX*PINV_PDXX
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP2_DEVICE(JI,JJ,JK) = ZFLX(JI,JJ,JK)*PINV_PDXX(JI,JJ,JK)
+ END DO !CONCURRENT
!$acc end kernels
CALL MZM_DEVICE(ZTMP2_DEVICE,ZTMP3_DEVICE)
!$acc kernels
- ZTMP2_DEVICE = PDZX * ZTMP3_DEVICE
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP2_DEVICE(JI,JJ,JK) = PDZX(JI,JJ,JK) * ZTMP3_DEVICE(JI,JJ,JK)
+ END DO !CONCURRENT
!$acc end kernels
CALL MXF_DEVICE( ZTMP2_DEVICE,ZTMP3_DEVICE)
!$acc kernels
- ZTMP2_DEVICE = PMZM_PRHODJ * ZTMP3_DEVICE * PINV_PDZZ
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP2_DEVICE(JI,JJ,JK) = PMZM_PRHODJ(JI,JJ,JK) * ZTMP3_DEVICE(JI,JJ,JK) * PINV_PDZZ(JI,JJ,JK)
+ END DO !CONCURRENT
!$acc end kernels
CALL DZF_DEVICE(1,IKU,1,ZTMP2_DEVICE,ZTMP3_DEVICE)
!$acc kernels
- PTRH =-( ZTMP1_DEVICE - ZTMP3_DEVICE ) /PRHODJ
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ PTRH(JI,JJ,JK) =-( ZTMP1_DEVICE(JI,JJ,JK) - ZTMP3_DEVICE(JI,JJ,JK) ) /PRHODJ(JI,JJ,JK)
+ END DO !CONCURRENT
!$acc end kernels
ELSE
CALL MXM_DEVICE(PRHODJ,ZTMP1_DEVICE)
@@ -319,12 +362,17 @@ IF (.NOT. L2D) THEN
#else
CALL MYM_DEVICE(PK,ZTMP1_DEVICE)
CALL GY_M_V_DEVICE(1,IKU,1,PTKEM,PDYY,PDZZ,PDZY,ZTMP2_DEVICE)
-!$acc kernels
- ZFLX =-XCET * ZTMP1_DEVICE * ZTMP2_DEVICE ! < v'e >
+ !$acc kernels
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZFLX(JI,JJ,JK) =-XCET * ZTMP1_DEVICE(JI,JJ,JK) * ZTMP2_DEVICE(JI,JJ,JK) ! < v'e >
+ END DO !CONCURRENT
+ !$acc end kernels
#endif
!
! special case near the ground ( uncentred gradient )
!
+!$acc kernels
ZFLX(:,:,IKB) = ZCOEFF(:,:,IKB+2)*PTKEM(:,:,IKB+2) &
+ ZCOEFF(:,:,IKB+1)*PTKEM(:,:,IKB+1) &
+ ZCOEFF(:,:,IKB )*PTKEM(:,:,IKB )
@@ -379,23 +427,39 @@ IF (.NOT. L2D) THEN
IF (.NOT. LFLAT) THEN
CALL MYM_DEVICE(PRHODJ,ZTMP1_DEVICE)
!$acc kernels
- ZTMP2_DEVICE = ZTMP1_DEVICE * ZFLX * PINV_PDYY
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP2_DEVICE(JI,JJ,JK) = ZTMP1_DEVICE(JI,JJ,JK) * ZFLX(JI,JJ,JK) * PINV_PDYY(JI,JJ,JK)
+ END DO !CONCURRENT
!$acc end kernels
CALL DYF_DEVICE(ZTMP2_DEVICE,ZTMP1_DEVICE)
!$acc kernels
- ZTMP2_DEVICE = ZFLX*PINV_PDYY
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP2_DEVICE(JI,JJ,JK) = ZFLX(JI,JJ,JK)*PINV_PDYY(JI,JJ,JK)
+ END DO !CONCURRENT
!$acc end kernels
CALL MZM_DEVICE(ZTMP2_DEVICE,ZTMP3_DEVICE)
!$acc kernels
- ZTMP2_DEVICE = PDZY * ZTMP3_DEVICE
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP2_DEVICE(JI,JJ,JK) = PDZY(JI,JJ,JK) * ZTMP3_DEVICE(JI,JJ,JK)
+ END DO !CONCURRENT
!$acc end kernels
CALL MYF_DEVICE(ZTMP2_DEVICE,ZTMP3_DEVICE)
!$acc kernels
- ZTMP2_DEVICE = PMZM_PRHODJ * ZTMP3_DEVICE * PINV_PDZZ
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP2_DEVICE(JI,JJ,JK) = PMZM_PRHODJ(JI,JJ,JK) * ZTMP3_DEVICE(JI,JJ,JK) * PINV_PDZZ(JI,JJ,JK)
+ END DO !CONCURRENT
!$acc end kernels
CALL DZF_DEVICE(1,IKU,1,ZTMP2_DEVICE,ZTMP3_DEVICE)
!$acc kernels
- PTRH = PTRH - ( ZTMP1_DEVICE - ZTMP3_DEVICE ) /PRHODJ
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ PTRH(JI,JJ,JK) = PTRH(JI,JJ,JK) - ( ZTMP1_DEVICE(JI,JJ,JK) - ZTMP3_DEVICE(JI,JJ,JK) ) &
+ /PRHODJ(JI,JJ,JK)
+ END DO !CONCURRENT
!$acc end kernels
ELSE
CALL MYM_DEVICE(PRHODJ,ZTMP1_DEVICE)
@@ -434,6 +498,13 @@ end if
!$acc end data
+#ifndef MNH_OPENACC
+deallocate( ZCOEFF, ZFLX )
+#else
+CALL MNH_REL_ZT3D( IZFLX, IZCOEFF, &
+ IZTMP1_DEVICE, IZTMP2_DEVICE, IZTMP3_DEVICE, IZTMP4_DEVICE )
+#endif
+
!$acc end data
!----------------------------------------------------------------------------
diff --git a/src/MNH/turb_hor_uv.f90 b/src/MNH/turb_hor_uv.f90
index 1703f6ce3d5168b9e76cf331eef5466b2facaa74..b987f77fddcf1da56a202c4de8447b7b0057a25e 100644
--- a/src/MNH/turb_hor_uv.f90
+++ b/src/MNH/turb_hor_uv.f90
@@ -154,6 +154,10 @@ USE MODI_SECOND_MNH
USE MODI_BITREP
#endif
!
+#ifdef MNH_OPENACC
+USE MODE_MNH_ZWORK , ONLY : MNH_ALLOCATE_ZT3D , MNH_REL_ZT3D, MNH_ALLOCATE_ZT3DP , MNH_ALLOCATE_ZT2D
+#endif
+!
IMPLICIT NONE
!
!
@@ -203,30 +207,38 @@ REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PDP ! TKE production terms
!
!* 0.2 declaration of local variables
!
-REAL, DIMENSION(:,:,:), allocatable :: ZFLX,ZWORK ! work arrays
+REAL, DIMENSION(:,:,:), pointer , contiguous :: ZFLX,ZWORK ! work arrays
!
-REAL, DIMENSION(:,:), allocatable :: ZDIRSINZW
+REAL, DIMENSION(:,:), pointer , contiguous :: ZDIRSINZW
! sinus of the angle between the vertical and the normal to the orography
INTEGER :: IKB,IKE
! Index values for the Beginning and End
! mass points of the domain
!
-REAL, DIMENSION(:,:,:), allocatable :: GY_U_UV_PUM
-REAL, DIMENSION(:,:,:), allocatable :: GX_V_UV_PVM
+REAL, DIMENSION(:,:,:), pointer , contiguous :: GY_U_UV_PUM
+REAL, DIMENSION(:,:,:), pointer , contiguous :: GX_V_UV_PVM
+#ifdef MNH_OPENACC
+INTEGER :: IZFLX,IZWORK,IZDIRSINZW,IGY_U_UV_PUM,IGX_V_UV_PVM
+#endif
!
REAL :: ZTIME1, ZTIME2
!
#ifdef MNH_OPENACC
INTEGER :: IKU
-REAL, DIMENSION(:,:,:), allocatable :: ZTMP1_DEVICE
-REAL, DIMENSION(:,:,:), allocatable :: ZTMP2_DEVICE
-REAL, DIMENSION(:,:,:), allocatable :: ZTMP3_DEVICE
-REAL, DIMENSION(:,:,:), allocatable :: ZTMP4_DEVICE
-REAL, DIMENSION(:,:,:), allocatable :: ZTMP5_DEVICE
-REAL, DIMENSION(:,:,:), allocatable :: ZTMP6_DEVICE
-REAL, DIMENSION(:,:,:), allocatable :: ZTMP7_DEVICE
+REAL, DIMENSION(:,:,:), pointer , contiguous :: ZTMP1_DEVICE
+REAL, DIMENSION(:,:,:), pointer , contiguous :: ZTMP2_DEVICE
+REAL, DIMENSION(:,:,:), pointer , contiguous :: ZTMP3_DEVICE
+REAL, DIMENSION(:,:,:), pointer , contiguous :: ZTMP4_DEVICE
+REAL, DIMENSION(:,:,:), pointer , contiguous :: ZTMP5_DEVICE
+REAL, DIMENSION(:,:,:), pointer , contiguous :: ZTMP6_DEVICE
+REAL, DIMENSION(:,:,:), pointer , contiguous :: ZTMP7_DEVICE
+INTEGER :: IZTMP1_DEVICE, IZTMP2_DEVICE, IZTMP3_DEVICE, IZTMP4_DEVICE,&
+ IZTMP5_DEVICE,IZTMP6_DEVICE,IZTMP7_DEVICE
#endif
TYPE(TFIELDDATA) :: TZFIELD
+!
+INTEGER :: JIU,JJU,JKU
+INTEGER :: JI,JJ,JK
! ---------------------------------------------------------------------------
!$acc data present( PK, PINV_PDXX, PINV_PDYY, PINV_PDZZ, PMZM_PRHODJ, PDXX, PDYY, PDZZ, PDZX, PDZY, &
@@ -265,25 +277,39 @@ if ( mppdb_initialized ) then
call Mppdb_check( pdp, "Turb_hor_uv beg:pdp" )
end if
-allocate( zflx (size( pum, 1 ), size( pum, 2 ), size( pum, 3 ) ) )
-allocate( zwork(size( pum, 1 ), size( pum, 2 ), size( pum, 3 ) ) )
+JIU = size(pum, 1 )
+JJU = size(pum, 2 )
+JKU = size(pum, 3 )
+
+#ifndef MNH_OPENACC
+allocate( zflx (JIU,JJU,JKU ) )
+allocate( zwork(JIU,JJU,JKU ) )
+
+allocate( zdirsinzw(JIU,JJU ) )
-allocate( zdirsinzw(size( pum, 1 ), size( pum, 2 ) ) )
+allocate( gy_u_uv_pum(JIU,JJU,JKU ) )
+allocate( gx_v_uv_pvm(JIU,JJU,JKU ) )
+#else
+izflx = MNH_ALLOCATE_ZT3D( zflx ,JIU,JJU,JKU )
+izwork = MNH_ALLOCATE_ZT3D( zwork,JIU,JJU,JKU )
+
+izdirsinzw = MNH_ALLOCATE_ZT2D( zdirsinzw,JIU,JJU )
-allocate( gy_u_uv_pum(size( pum, 1 ), size( pum, 2 ), size( pum, 3 ) ) )
-allocate( gx_v_uv_pvm(size( pvm, 1 ), size( pvm, 2 ), size( pvm, 3 ) ) )
+igy_u_uv_pum = MNH_ALLOCATE_ZT3D( gy_u_uv_pum,JIU,JJU,JKU )
+igx_v_uv_pvm = MNH_ALLOCATE_ZT3D( gx_v_uv_pvm,JIU,JJU,JKU )
+#endif
#ifdef MNH_OPENACC
-allocate( ztmp1_device(size( pum, 1 ), size( pum, 2 ), size( pum, 3 ) ) )
-allocate( ztmp2_device(size( pum, 1 ), size( pum, 2 ), size( pum, 3 ) ) )
-allocate( ztmp3_device(size( pum, 1 ), size( pum, 2 ), size( pum, 3 ) ) )
-allocate( ztmp4_device(size( pum, 1 ), size( pum, 2 ), size( pum, 3 ) ) )
-allocate( ztmp5_device(size( pum, 1 ), size( pum, 2 ), size( pum, 3 ) ) )
-allocate( ztmp6_device(size( pum, 1 ), size( pum, 2 ), size( pum, 3 ) ) )
-allocate( ztmp7_device(size( pum, 1 ), size( pum, 2 ), size( pum, 3 ) ) )
+iztmp1_device = MNH_ALLOCATE_ZT3D( ztmp1_device,JIU,JJU,JKU )
+iztmp2_device = MNH_ALLOCATE_ZT3D( ztmp2_device,JIU,JJU,JKU )
+iztmp3_device = MNH_ALLOCATE_ZT3D( ztmp3_device,JIU,JJU,JKU )
+iztmp4_device = MNH_ALLOCATE_ZT3D( ztmp4_device,JIU,JJU,JKU )
+iztmp5_device = MNH_ALLOCATE_ZT3D( ztmp5_device,JIU,JJU,JKU )
+iztmp6_device = MNH_ALLOCATE_ZT3D( ztmp6_device,JIU,JJU,JKU )
+iztmp7_device = MNH_ALLOCATE_ZT3D( ztmp7_device,JIU,JJU,JKU )
#endif
-!$acc data create( ZFLX, ZWORK, ZDIRSINZW, GY_U_UV_PUM, GX_V_UV_PVM, &
+!$acc data present( ZFLX, ZWORK, ZDIRSINZW, GY_U_UV_PUM, GX_V_UV_PVM, &
!$acc & ZTMP1_DEVICE, ZTMP2_DEVICE, ZTMP3_DEVICE, ZTMP4_DEVICE, &
!$acc & ZTMP5_DEVICE, ZTMP6_DEVICE, ZTMP7_DEVICE )
@@ -298,11 +324,14 @@ IKU = NKMAX + 2 * JPVEXT
#endif
!
!$acc kernels
+!$acc loop independent collapse(2)
+DO CONCURRENT ( JI=1:JIU,JJ=1:JJU )
#ifndef MNH_BITREP
-ZDIRSINZW(:,:) = SQRT( 1. - PDIRCOSZW(:,:)**2 )
+ ZDIRSINZW(JI,JJ) = SQRT( 1. - PDIRCOSZW(JI,JJ)**2 )
#else
-ZDIRSINZW(:,:) = SQRT( 1. - BR_P2(PDIRCOSZW(:,:)) )
+ ZDIRSINZW(JI,JJ) = SQRT( 1. - BR_P2(PDIRCOSZW(JI,JJ)) )
#endif
+END DO
!$acc end kernels
!
#ifndef MNH_OPENACC
@@ -333,7 +362,10 @@ CALL MXM_DEVICE(PK,ZTMP1_DEVICE)
CALL MYM_DEVICE(ZTMP1_DEVICE,ZTMP2_DEVICE)
IF (.NOT. L2D) THEN
!$acc kernels
- ZFLX(:,:,:)= - XCMFS * ZTMP2_DEVICE * (GY_U_UV_PUM + GX_V_UV_PVM)
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZFLX(JI,JJ,JK)= - XCMFS * ZTMP2_DEVICE(JI,JJ,JK) * (GY_U_UV_PUM(JI,JJ,JK) + GX_V_UV_PVM(JI,JJ,JK))
+ END DO !CONCURRENT
!$acc end kernels
ELSE
!$acc kernels
@@ -426,16 +458,19 @@ ZFLX(:,:,IKB-1) = &
PDIRCOSZW(:,:) * ZDIRSINZW(:,:) &
+PVSLOPEM(:,:) * (PCOSSLOPE(:,:)**2 - PSINSLOPE(:,:)**2) * ZDIRSINZW(:,:) )
#else
-ZFLX(:,:,IKB-1) = &
- PTAU11M(:,:) * PCOSSLOPE(:,:) * PSINSLOPE(:,:) * BR_P2(PDIRCOSZW(:,:)) &
- +PTAU12M(:,:) * (BR_P2(PCOSSLOPE(:,:)) - BR_P2(PSINSLOPE(:,:))) * &
- BR_P2(PDIRCOSZW(:,:)) &
- -PTAU22M(:,:) * PCOSSLOPE(:,:) * PSINSLOPE(:,:) &
- +PTAU33M(:,:) * PCOSSLOPE(:,:) * PSINSLOPE(:,:) * BR_P2(ZDIRSINZW(:,:)) &
- -PCDUEFF(:,:) * ( &
- 2. * PUSLOPEM(:,:) * PCOSSLOPE(:,:) * PSINSLOPE(:,:) * &
- PDIRCOSZW(:,:) * ZDIRSINZW(:,:) &
- +PVSLOPEM(:,:) * (BR_P2(PCOSSLOPE(:,:)) - BR_P2(PSINSLOPE(:,:))) * ZDIRSINZW(:,:) )
+!$acc loop independent collapse(2)
+DO CONCURRENT ( JI=1:JIU,JJ=1:JJU )
+ZFLX(JI,JJ,IKB-1) = &
+ PTAU11M(JI,JJ) * PCOSSLOPE(JI,JJ) * PSINSLOPE(JI,JJ) * BR_P2(PDIRCOSZW(JI,JJ)) &
+ +PTAU12M(JI,JJ) * (BR_P2(PCOSSLOPE(JI,JJ)) - BR_P2(PSINSLOPE(JI,JJ))) * &
+ BR_P2(PDIRCOSZW(JI,JJ)) &
+ -PTAU22M(JI,JJ) * PCOSSLOPE(JI,JJ) * PSINSLOPE(JI,JJ) &
+ +PTAU33M(JI,JJ) * PCOSSLOPE(JI,JJ) * PSINSLOPE(JI,JJ) * BR_P2(ZDIRSINZW(JI,JJ)) &
+ -PCDUEFF(JI,JJ) * ( &
+ 2. * PUSLOPEM(JI,JJ) * PCOSSLOPE(JI,JJ) * PSINSLOPE(JI,JJ) * &
+ PDIRCOSZW(JI,JJ) * ZDIRSINZW(JI,JJ) &
+ +PVSLOPEM(JI,JJ) * (BR_P2(PCOSSLOPE(JI,JJ)) - BR_P2(PSINSLOPE(JI,JJ))) * ZDIRSINZW(JI,JJ) )
+END DO ! CONCURRENT
#endif
!$acc end kernels
!
@@ -481,35 +516,56 @@ END IF
#else
CALL MYM_DEVICE(PRHODJ,ZTMP1_DEVICE)
!$acc kernels
-ZTMP2_DEVICE = ZTMP1_DEVICE * PINV_PDYY
+!$acc loop independent collapse(3)
+DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP2_DEVICE(JI,JJ,JK) = ZTMP1_DEVICE(JI,JJ,JK) * PINV_PDYY(JI,JJ,JK)
+END DO !CONCURRENT
!$acc end kernels
CALL MXM_DEVICE(ZTMP2_DEVICE,ZTMP1_DEVICE)
!$acc kernels
-ZTMP2_DEVICE = ZFLX * ZTMP1_DEVICE
+!$acc loop independent collapse(3)
+DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP2_DEVICE(JI,JJ,JK) = ZFLX(JI,JJ,JK) * ZTMP1_DEVICE(JI,JJ,JK)
+END DO !CONCURRENT
!$acc end kernels
CALL DYF_DEVICE(ZTMP2_DEVICE,ZTMP1_DEVICE)
IF (.NOT. LFLAT) THEN
CALL MZM_DEVICE(ZFLX,ZTMP2_DEVICE)
CALL MZM_DEVICE(PDYY,ZTMP3_DEVICE)
-!$acc kernels
- ZTMP4_DEVICE = PDZY/ZTMP3_DEVICE
-!$acc end kernels
+ !$acc kernels
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP4_DEVICE(JI,JJ,JK) = PDZY(JI,JJ,JK)/ZTMP3_DEVICE(JI,JJ,JK)
+ END DO !CONCURRENT
+ !$acc end kernels
CALL MXM_DEVICE(ZTMP4_DEVICE,ZTMP5_DEVICE)
-!$acc kernels
- ZTMP4_DEVICE = ZTMP2_DEVICE*ZTMP5_DEVICE
-!$acc end kernels
+ !$acc kernels
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP4_DEVICE(JI,JJ,JK) = ZTMP2_DEVICE(JI,JJ,JK)*ZTMP5_DEVICE(JI,JJ,JK)
+ END DO !CONCURRENT
+ !$acc end kernels
CALL MYF_DEVICE(ZTMP4_DEVICE,ZTMP2_DEVICE)
-!$acc kernels
- ZTMP3_DEVICE = PMZM_PRHODJ * PINV_PDZZ
-!$acc end kernels
+ !$acc kernels
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP3_DEVICE(JI,JJ,JK) = PMZM_PRHODJ(JI,JJ,JK) * PINV_PDZZ(JI,JJ,JK)
+ END DO !CONCURRENT
+ !$acc end kernels
CALL MXM_DEVICE(ZTMP3_DEVICE,ZTMP4_DEVICE)
-!$acc kernels
- ZTMP5_DEVICE = ZTMP2_DEVICE*ZTMP4_DEVICE
-!$acc end kernels
+ !$acc kernels
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP5_DEVICE(JI,JJ,JK) = ZTMP2_DEVICE(JI,JJ,JK)*ZTMP4_DEVICE(JI,JJ,JK)
+ END DO !CONCURRENT
+ !$acc end kernels
CALL DZF_DEVICE(1,IKU,1,ZTMP5_DEVICE,ZTMP3_DEVICE)
-!$acc kernels
- PRUS(:,:,:) = PRUS(:,:,:) - ZTMP1_DEVICE + ZTMP3_DEVICE
-!$acc end kernels
+ !$acc kernels
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ PRUS(JI,JJ,JK) = PRUS(JI,JJ,JK) - ZTMP1_DEVICE(JI,JJ,JK) + ZTMP3_DEVICE(JI,JJ,JK)
+ END DO !CONCURRENT
+ !$acc end kernels
ELSE
!$acc kernels
PRUS(:,:,:) = PRUS(:,:,:) - ZTMP1_DEVICE
@@ -530,35 +586,56 @@ END IF
#else
CALL MXM_DEVICE(PRHODJ,ZTMP1_DEVICE)
!$acc kernels
-ZTMP2_DEVICE = ZTMP1_DEVICE * PINV_PDXX
+!$acc loop independent collapse(3)
+DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP2_DEVICE(JI,JJ,JK) = ZTMP1_DEVICE(JI,JJ,JK) * PINV_PDXX(JI,JJ,JK)
+END DO !CONCURRENT
!$acc end kernels
CALL MYM_DEVICE(ZTMP2_DEVICE,ZTMP1_DEVICE)
!$acc kernels
-ZTMP2_DEVICE = ZFLX * ZTMP1_DEVICE
+!$acc loop independent collapse(3)
+DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP2_DEVICE(JI,JJ,JK) = ZFLX(JI,JJ,JK) * ZTMP1_DEVICE(JI,JJ,JK)
+END DO !CONCURRENT
!$acc end kernels
CALL DXF_DEVICE(ZTMP2_DEVICE,ZTMP1_DEVICE)
IF (.NOT. LFLAT) THEN
CALL MZM_DEVICE(ZFLX,ZTMP2_DEVICE)
CALL MZM_DEVICE(PDXX,ZTMP3_DEVICE)
-!$acc kernels
- ZTMP4_DEVICE = PDZX/ZTMP3_DEVICE
-!$acc end kernels
+ !$acc kernels
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP4_DEVICE(JI,JJ,JK) = PDZX(JI,JJ,JK)/ZTMP3_DEVICE(JI,JJ,JK)
+ END DO !CONCURRENT
+ !$acc end kernels
CALL MYM_DEVICE(ZTMP4_DEVICE,ZTMP5_DEVICE)
-!$acc kernels
- ZTMP4_DEVICE = ZTMP2_DEVICE*ZTMP5_DEVICE
-!$acc end kernels
+ !$acc kernels
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP4_DEVICE(JI,JJ,JK) = ZTMP2_DEVICE(JI,JJ,JK)*ZTMP5_DEVICE(JI,JJ,JK)
+ END DO !CONCURRENT
+ !$acc end kernels
CALL MXF_DEVICE(ZTMP4_DEVICE,ZTMP2_DEVICE)
-!$acc kernels
- ZTMP3_DEVICE = PMZM_PRHODJ * PINV_PDZZ
-!$acc end kernels
+ !$acc kernels
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP3_DEVICE(JI,JJ,JK) = PMZM_PRHODJ(JI,JJ,JK) * PINV_PDZZ(JI,JJ,JK)
+ END DO !CONCURRENT
+ !$acc end kernels
CALL MYM_DEVICE(ZTMP3_DEVICE,ZTMP4_DEVICE)
-!$acc kernels
- ZTMP5_DEVICE = ZTMP2_DEVICE*ZTMP4_DEVICE
-!$acc end kernels
+ !$acc kernels
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP5_DEVICE(JI,JJ,JK) = ZTMP2_DEVICE(JI,JJ,JK)*ZTMP4_DEVICE(JI,JJ,JK)
+ END DO !CONCURRENT
+ !$acc end kernels
CALL DZF_DEVICE(1,IKU,1,ZTMP5_DEVICE,ZTMP3_DEVICE)
-!$acc kernels
- PRVS(:,:,:) = PRVS(:,:,:) - ZTMP1_DEVICE + ZTMP3_DEVICE
-!$acc end kernels
+ !$acc kernels
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ PRVS(JI,JJ,JK) = PRVS(JI,JJ,JK) - ZTMP1_DEVICE(JI,JJ,JK) + ZTMP3_DEVICE(JI,JJ,JK)
+ END DO !CONCURRENT
+ !$acc end kernels
ELSE
!$acc kernels
PRVS(:,:,:) = PRVS(:,:,:) - ZTMP1_DEVICE
@@ -580,8 +657,11 @@ IF (KSPLT==1) THEN
ENDIF
#else
IF (.NOT. L2D) THEN
-!$acc kernels
- ZTMP1_DEVICE = ZFLX * (GY_U_UV_PUM + GX_V_UV_PVM)
+ !$acc kernels
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP1_DEVICE(JI,JJ,JK) = ZFLX(JI,JJ,JK) * (GY_U_UV_PUM(JI,JJ,JK) + GX_V_UV_PVM(JI,JJ,JK))
+ END DO !CONCURRENT
!$acc end kernels
ELSE
!$acc kernels
@@ -590,9 +670,12 @@ IF (KSPLT==1) THEN
ENDIF
CALL MYF_DEVICE(ZTMP1_DEVICE,ZTMP2_DEVICE)
CALL MXF_DEVICE(ZTMP2_DEVICE,ZTMP1_DEVICE)
-!$acc kernels
- ZWORK(:,:,:) = - ZTMP1_DEVICE
-!$acc end kernels
+ !$acc kernels
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZWORK(JI,JJ,JK) = - ZTMP1_DEVICE(JI,JJ,JK)
+ END DO !CONCURRENT
+ !$acc end kernels
#endif
!
! evaluate the dynamic production at w(IKB+1) in PDP(IKB)
@@ -614,9 +697,9 @@ IF (KSPLT==1) THEN
) / MXF(MYM( 0.5*(PDXX(:,:,IKB:IKB)+PDXX(:,:,IKB+1:IKB+1)) ) )&
)
#else
-!$acc kernels
+ !$acc kernels
ZTMP1_DEVICE(:,:,1) = 0.5 * (ZFLX(:,:,IKB+1)+ZFLX(:,:,IKB))
-!$acc end kernels
+ !$acc end kernels
CALL MYF_DEVICE(ZTMP1_DEVICE(:,:,1:1),ZTMP2_DEVICE(:,:,1:1))
CALL MXF_DEVICE(ZTMP2_DEVICE(:,:,1:1),ZTMP1_DEVICE(:,:,1:1))
!
@@ -714,6 +797,15 @@ end if
!$acc end data
+#ifndef MNH_OPENACC
+deallocate ( ZFLX, ZWORK, ZDIRSINZW, GY_U_UV_PUM, GX_V_UV_PVM )
+#else
+CALL MNH_REL_ZT3D ( IZFLX, IZWORK, IZDIRSINZW, IGY_U_UV_PUM, IGX_V_UV_PVM, &
+ IZTMP1_DEVICE, IZTMP2_DEVICE, IZTMP3_DEVICE, IZTMP4_DEVICE, &
+ IZTMP5_DEVICE, IZTMP6_DEVICE, IZTMP7_DEVICE )
+#endif
+
+
!$acc end data
END SUBROUTINE TURB_HOR_UV
diff --git a/src/MNH/turb_hor_uw.f90 b/src/MNH/turb_hor_uw.f90
index f6e5b972cc48f6448a60f8926e8b3f8ce09b2c13..eed50515aed65393f3986ab1b9faba7fca70af2d 100644
--- a/src/MNH/turb_hor_uw.f90
+++ b/src/MNH/turb_hor_uw.f90
@@ -137,7 +137,11 @@ USE MODI_COEFJ
USE MODI_LES_MEAN_SUBGRID
!
USE MODI_SECOND_MNH
-!
+
+#ifdef MNH_OPENACC
+USE MODE_MNH_ZWORK , ONLY : MNH_ALLOCATE_ZT3D , MNH_REL_ZT3D, MNH_ALLOCATE_ZT3DP , MNH_ALLOCATE_ZT2D
+#endif
+
IMPLICIT NONE
!
!
@@ -175,24 +179,31 @@ REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PDP ! TKE production terms
!
!* 0.2 declaration of local variables
!
-REAL, DIMENSION(:,:,:), allocatable :: ZFLX,ZWORK ! work arrays
+REAL, DIMENSION(:,:,:), pointer , contiguous :: ZFLX,ZWORK ! work arrays
!
INTEGER :: IKB,IKE,IKU
! Index values for the Beginning and End
! mass points of the domain
INTEGER :: JSV ! scalar loop counter
!
-REAL, DIMENSION(:,:,:), allocatable :: GX_W_UW_PWM
+REAL, DIMENSION(:,:,:), pointer , contiguous :: GX_W_UW_PWM
+#ifdef MNH_OPENACC
+INTEGER :: IZFLX,IZWORK,IGX_W_UW_PWM
+#endif
!
REAL :: ZTIME1, ZTIME2
!
#ifdef MNH_OPENACC
-REAL, DIMENSION(:,:,:), allocatable :: ZTMP1_DEVICE
-REAL, DIMENSION(:,:,:), allocatable :: ZTMP2_DEVICE
-REAL, DIMENSION(:,:,:), allocatable :: ZTMP3_DEVICE
-REAL, DIMENSION(:,:,:), allocatable :: ZTMP4_DEVICE
+REAL, DIMENSION(:,:,:), pointer , contiguous :: ZTMP1_DEVICE
+REAL, DIMENSION(:,:,:), pointer , contiguous :: ZTMP2_DEVICE
+REAL, DIMENSION(:,:,:), pointer , contiguous :: ZTMP3_DEVICE
+REAL, DIMENSION(:,:,:), pointer , contiguous :: ZTMP4_DEVICE
+INTEGER :: IZTMP1_DEVICE, IZTMP2_DEVICE, IZTMP3_DEVICE, IZTMP4_DEVICE
#endif
TYPE(TFIELDDATA) :: TZFIELD
+!
+INTEGER :: JIU,JJU,JKU
+INTEGER :: JI,JJ,JK
! ---------------------------------------------------------------------------
!$acc data present( PK, PINV_PDXX, PINV_PDZZ, PMZM_PRHODJ, PDXX, PDZZ, PDZX, &
@@ -224,19 +235,30 @@ if ( mppdb_initialized ) then
call Mppdb_check( pdp, "Turb_hor_uw beg:pdp" )
end if
-allocate( zflx (size( pwm, 1 ), size( pwm, 2 ), size( pwm, 3 ) ) )
-allocate( zwork(size( pwm, 1 ), size( pwm, 2 ), size( pwm, 3 ) ) )
+JIU = size(pwm, 1 )
+JJU = size(pwm, 2 )
+JKU = size(pwm, 3 )
+
+#ifndef MNH_OPENACC
+allocate( zflx (JIU,JJU,JKU ) )
+allocate( zwork(JIU,JJU,JKU ) )
+
+allocate( gx_w_uw_pwm(JIU,JJU,JKU ) )
+#else
+izflx = MNH_ALLOCATE_ZT3D( zflx ,JIU,JJU,JKU)
+izwork = MNH_ALLOCATE_ZT3D( zwork,JIU,JJU,JKU)
-allocate( gx_w_uw_pwm(size( pwm, 1 ), size( pwm, 2 ), size( pwm, 3 ) ) )
+igx_w_uw_pwm = MNH_ALLOCATE_ZT3D( gx_w_uw_pwm,JIU,JJU,JKU)
+#endif
#ifdef MNH_OPENACC
-allocate( ztmp1_device(size( pwm, 1 ), size( pwm, 2 ), size( pwm, 3 ) ) )
-allocate( ztmp2_device(size( pwm, 1 ), size( pwm, 2 ), size( pwm, 3 ) ) )
-allocate( ztmp3_device(size( pwm, 1 ), size( pwm, 2 ), size( pwm, 3 ) ) )
-allocate( ztmp4_device(size( pwm, 1 ), size( pwm, 2 ), size( pwm, 3 ) ) )
+iztmp1_device = MNH_ALLOCATE_ZT3D( ztmp1_device,JIU,JJU,JKU)
+iztmp2_device = MNH_ALLOCATE_ZT3D( ztmp2_device,JIU,JJU,JKU)
+iztmp3_device = MNH_ALLOCATE_ZT3D( ztmp3_device,JIU,JJU,JKU)
+iztmp4_device = MNH_ALLOCATE_ZT3D( ztmp4_device,JIU,JJU,JKU)
#endif
-!$acc data create( ZFLX, ZWORK, GX_W_UW_PWM, &
+!$acc data present( ZFLX, ZWORK, GX_W_UW_PWM, &
!$acc & ZTMP1_DEVICE, ZTMP2_DEVICE, ZTMP3_DEVICE, ZTMP4_DEVICE )
!
@@ -267,7 +289,10 @@ ZFLX(:,:,:) = &
CALL MZM_DEVICE(PK,ZTMP1_DEVICE)
CALL MXM_DEVICE(ZTMP1_DEVICE,ZTMP2_DEVICE)
!$acc kernels
-ZFLX(:,:,:) = - XCMFS * ZTMP2_DEVICE * GX_W_UW_PWM
+!$acc loop independent collapse(3)
+DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZFLX(JI,JJ,JK) = - XCMFS * ZTMP2_DEVICE(JI,JJ,JK) * GX_W_UW_PWM(JI,JJ,JK)
+END DO !CONCURRENT
#endif
!! & to be tested
!! - (2./3.) * XCMFB * MZM( ZVPTU * MXM( PLM / SQRT(PTKEM) * XG / PTHVREF ) )
@@ -305,11 +330,17 @@ PRUS(:,:,:) = PRUS(:,:,:) - DZF( ZFLX* MXM( PMZM_PRHODJ ) / MXM( PDZZ ) )
CALL MXM_DEVICE( PMZM_PRHODJ, ZTMP1_DEVICE )
CALL MXM_DEVICE( PDZZ, ZTMP2_DEVICE )
!$acc kernels
-ZTMP3_DEVICE = ZFLX* ZTMP1_DEVICE / ZTMP2_DEVICE
+!$acc loop independent collapse(3)
+DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP3_DEVICE(JI,JJ,JK) = ZFLX(JI,JJ,JK)* ZTMP1_DEVICE(JI,JJ,JK) / ZTMP2_DEVICE(JI,JJ,JK)
+END DO !CONCURRENT
!$acc end kernels
CALL DZF_DEVICE(1,IKU,1, ZTMP3_DEVICE, ZTMP1_DEVICE )
!$acc kernels
-PRUS(:,:,:) = PRUS(:,:,:) - ZTMP1_DEVICE(:,:,:)
+!$acc loop independent collapse(3)
+DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ PRUS(JI,JJ,JK) = PRUS(JI,JJ,JK) - ZTMP1_DEVICE(JI,JJ,JK)
+END DO !CONCURRENT
!$acc end kernels
#endif
!
@@ -325,32 +356,50 @@ END IF
#else
CALL MXM_DEVICE(PRHODJ,ZTMP1_DEVICE)
!$acc kernels
- ZTMP2_DEVICE = ZTMP1_DEVICE * PINV_PDXX
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP2_DEVICE(JI,JJ,JK) = ZTMP1_DEVICE(JI,JJ,JK) * PINV_PDXX(JI,JJ,JK)
+ END DO !CONCURRENT
!$acc end kernels
CALL MZM_DEVICE(ZTMP2_DEVICE, ZTMP1_DEVICE)
!$acc kernels
- ZTMP2_DEVICE = ZTMP1_DEVICE * ZFLX
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP2_DEVICE(JI,JJ,JK) = ZTMP1_DEVICE(JI,JJ,JK) * ZFLX(JI,JJ,JK)
+ END DO !CONCURRENT
!$acc end kernels
CALL DXF_DEVICE( ZTMP2_DEVICE,ZTMP1_DEVICE)
IF (.NOT. LFLAT) THEN
- !$acc kernels
- ZTMP2_DEVICE = ZFLX*PDZX
- !$acc end kernels
- CALL MZF_DEVICE(1,IKU,1, ZTMP2_DEVICE, ZTMP3_DEVICE )
- !$acc kernels
- ZTMP2_DEVICE = ZTMP3_DEVICE*PINV_PDXX
- !$acc end kernels
- CALL MXF_DEVICE( ZTMP2_DEVICE, ZTMP3_DEVICE )
- CALL MZF_DEVICE(1,IKU,1,PDZZ, ZTMP2_DEVICE)
- !$acc kernels
- ZTMP4_DEVICE = PRHODJ * ZTMP3_DEVICE / ZTMP2_DEVICE
- !$acc end kernels
- CALL DZM_DEVICE(1,IKU,1, ZTMP4_DEVICE, ZTMP2_DEVICE )
- !$acc kernels
- PRWS(:,:,:) = PRWS(:,:,:) &
- - ZTMP1_DEVICE &
- + ZTMP2_DEVICE
- !$acc end kernels
+ !$acc kernels
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP2_DEVICE(JI,JJ,JK) = ZFLX(JI,JJ,JK)*PDZX(JI,JJ,JK)
+ END DO !CONCURRENT
+ !$acc end kernels
+ CALL MZF_DEVICE(1,IKU,1, ZTMP2_DEVICE, ZTMP3_DEVICE )
+ !$acc kernels
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP2_DEVICE(JI,JJ,JK) = ZTMP3_DEVICE(JI,JJ,JK)*PINV_PDXX(JI,JJ,JK)
+ END DO !CONCURRENT
+ !$acc end kernels
+ CALL MXF_DEVICE( ZTMP2_DEVICE, ZTMP3_DEVICE )
+ CALL MZF_DEVICE(1,IKU,1,PDZZ, ZTMP2_DEVICE)
+ !$acc kernels
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP4_DEVICE(JI,JJ,JK) = PRHODJ(JI,JJ,JK) * ZTMP3_DEVICE(JI,JJ,JK) / ZTMP2_DEVICE(JI,JJ,JK)
+ END DO !CONCURRENT
+ !$acc end kernels
+ CALL DZM_DEVICE(1,IKU,1, ZTMP4_DEVICE, ZTMP2_DEVICE )
+ !$acc kernels
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ PRWS(JI,JJ,JK) = PRWS(JI,JJ,JK) &
+ - ZTMP1_DEVICE(JI,JJ,JK) &
+ + ZTMP2_DEVICE(JI,JJ,JK)
+ END DO !CONCURRENT
+ !$acc end kernels
ELSE
!$acc kernels
PRWS(:,:,:) = PRWS(:,:,:) - ZTMP1_DEVICE
@@ -368,12 +417,18 @@ IF (KSPLT==1) THEN
#else
CALL GZ_U_UW_DEVICE(1,IKU,1,PUM,PDZZ,ZTMP1_DEVICE)
!$acc kernels
- ZTMP2_DEVICE = ZFLX *( ZTMP1_DEVICE + GX_W_UW_PWM )
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP2_DEVICE(JI,JJ,JK) = ZFLX(JI,JJ,JK) *( ZTMP1_DEVICE(JI,JJ,JK) + GX_W_UW_PWM(JI,JJ,JK) )
+ END DO !CONCURRENT
!$acc end kernels
CALL MXF_DEVICE( ZTMP2_DEVICE,ZTMP1_DEVICE )
CALL MZF_DEVICE(1,IKU,1, ZTMP1_DEVICE, ZTMP2_DEVICE )
!$acc kernels
- ZWORK(:,:,:) = -ZTMP2_DEVICE(:,:,:)
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZWORK(JI,JJ,JK) = -ZTMP2_DEVICE(JI,JJ,JK)
+ END DO !CONCURRENT
!$acc end kernels
#endif
!
@@ -514,6 +569,13 @@ end if
!$acc end data
+#ifndef MNH_OPENACC
+deallocate( ZFLX, ZWORK, GX_W_UW_PWM )
+#else
+CALL MNH_REL_ZT3D ( IZFLX, IZWORK, IGX_W_UW_PWM, &
+ IZTMP1_DEVICE, IZTMP2_DEVICE, IZTMP3_DEVICE, IZTMP4_DEVICE )
+#endif
+
!$acc end data
END SUBROUTINE TURB_HOR_UW
diff --git a/src/MNH/turb_hor_vw.f90 b/src/MNH/turb_hor_vw.f90
index 0bc690ba35dbafc05a8bbeaae49e2797ceff88b3..98342494cc0485c71bab8a1a64618f65c8615b94 100644
--- a/src/MNH/turb_hor_vw.f90
+++ b/src/MNH/turb_hor_vw.f90
@@ -136,7 +136,11 @@ USE MODI_COEFJ
USE MODI_LES_MEAN_SUBGRID
!
USE MODI_SECOND_MNH
-!
+
+#ifdef MNH_OPENACC
+USE MODE_MNH_ZWORK , ONLY : MNH_ALLOCATE_ZT3D , MNH_REL_ZT3D, MNH_ALLOCATE_ZT3DP , MNH_ALLOCATE_ZT2D
+#endif
+
IMPLICIT NONE
!
!
@@ -173,24 +177,31 @@ REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PDP ! TKE production terms
!
!* 0.2 declaration of local variables
!
-REAL, DIMENSION(:,:,:), allocatable :: ZFLX,ZWORK ! work arrays
-!! REAL, DIMENSION(:,:,:), allocatable :: ZVPTV
+REAL, DIMENSION(:,:,:), pointer , contiguous :: ZFLX,ZWORK ! work arrays
+!! REAL, DIMENSION(:,:,:), pointer , contiguous :: ZVPTV
INTEGER :: IKB,IKE,IKU
! Index values for the Beginning and End
! mass points of the domain
INTEGER :: JSV ! scalar loop counter
!
-REAL, DIMENSION(:,:,:), allocatable :: GY_W_VW_PWM
+REAL, DIMENSION(:,:,:), pointer , contiguous :: GY_W_VW_PWM
+#ifdef MNH_OPENACC
+INTEGER :: IZFLX,IZWORK,IGY_W_VW_PWM
+#endif
!
REAL :: ZTIME1, ZTIME2
!
#ifdef MNH_OPENACC
-REAL, DIMENSION(:,:,:), allocatable :: ZTMP1_DEVICE
-REAL, DIMENSION(:,:,:), allocatable :: ZTMP2_DEVICE
-REAL, DIMENSION(:,:,:), allocatable :: ZTMP3_DEVICE
-REAL, DIMENSION(:,:,:), allocatable :: ZTMP4_DEVICE
+REAL, DIMENSION(:,:,:), pointer , contiguous :: ZTMP1_DEVICE
+REAL, DIMENSION(:,:,:), pointer , contiguous :: ZTMP2_DEVICE
+REAL, DIMENSION(:,:,:), pointer , contiguous :: ZTMP3_DEVICE
+REAL, DIMENSION(:,:,:), pointer , contiguous :: ZTMP4_DEVICE
+INTEGER :: IZTMP1_DEVICE, IZTMP2_DEVICE, IZTMP3_DEVICE, IZTMP4_DEVICE
#endif
TYPE(TFIELDDATA) :: TZFIELD
+!
+INTEGER :: JIU,JJU,JKU
+INTEGER :: JI,JJ,JK
! ---------------------------------------------------------------------------
!$acc data present( PK, PINV_PDYY, PINV_PDZZ, PMZM_PRHODJ, PDYY, PDZZ, PDZY, &
@@ -221,19 +232,30 @@ if ( mppdb_initialized ) then
call Mppdb_check( pdp, "Turb_hor_vw beg:pdp" )
end if
-allocate( zflx (size( pwm, 1 ), size( pwm, 2 ), size( pwm, 3 ) ) )
-allocate( zwork(size( pwm, 1 ), size( pwm, 2 ), size( pwm, 3 ) ) )
+JIU = size(pwm, 1 )
+JJU = size(pwm, 2 )
+JKU = size(pwm, 3 )
+
+#ifndef MNH_OPENACC
+allocate( zflx (JIU,JJU,JKU ) )
+allocate( zwork(JIU,JJU,JKU ) )
-allocate( gy_w_vw_pwm(size( pwm, 1 ), size( pwm, 2 ), size( pwm, 3 ) ) )
+allocate( gy_w_vw_pwm(JIU,JJU,JKU ) )
+#else
+izflx = MNH_ALLOCATE_ZT3D( zflx ,JIU,JJU,JKU)
+izwork = MNH_ALLOCATE_ZT3D( zwork,JIU,JJU,JKU)
+
+igy_w_vw_pwm = MNH_ALLOCATE_ZT3D( gy_w_vw_pwm,JIU,JJU,JKU)
+#endif
#ifdef MNH_OPENACC
-allocate( ztmp1_device(size( pwm, 1 ), size( pwm, 2 ), size( pwm, 3 ) ) )
-allocate( ztmp2_device(size( pwm, 1 ), size( pwm, 2 ), size( pwm, 3 ) ) )
-allocate( ztmp3_device(size( pwm, 1 ), size( pwm, 2 ), size( pwm, 3 ) ) )
-allocate( ztmp4_device(size( pwm, 1 ), size( pwm, 2 ), size( pwm, 3 ) ) )
+iztmp1_device = MNH_ALLOCATE_ZT3D( ztmp1_device,JIU,JJU,JKU)
+iztmp2_device = MNH_ALLOCATE_ZT3D( ztmp2_device,JIU,JJU,JKU)
+iztmp3_device = MNH_ALLOCATE_ZT3D( ztmp3_device,JIU,JJU,JKU)
+iztmp4_device = MNH_ALLOCATE_ZT3D( ztmp4_device,JIU,JJU,JKU)
#endif
-!$acc data create( ZFLX, ZWORK, GY_W_VW_PWM, &
+!$acc data present( ZFLX, ZWORK, GY_W_VW_PWM, &
!$acc & ZTMP1_DEVICE, ZTMP2_DEVICE, ZTMP3_DEVICE, ZTMP4_DEVICE )
!
@@ -266,9 +288,12 @@ IF (.NOT. L2D) THEN
#else
CALL MZM_DEVICE(PK,ZTMP1_DEVICE)
CALL MYM_DEVICE(ZTMP1_DEVICE,ZTMP2_DEVICE)
-!$acc kernels
- ZFLX(:,:,:) = - XCMFS * ZTMP2_DEVICE * GY_W_VW_PWM
-!$acc end kernels
+ !$acc kernels
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZFLX(JI,JJ,JK) = - XCMFS * ZTMP2_DEVICE(JI,JJ,JK) * GY_W_VW_PWM(JI,JJ,JK)
+ END DO !CONCURRENT
+ !$acc end kernels
#endif
ELSE
!$acc kernels
@@ -312,11 +337,17 @@ IF (.NOT. L2D) THEN
CALL MYM_DEVICE( PMZM_PRHODJ, ZTMP1_DEVICE )
CALL MYM_DEVICE( PDZZ, ZTMP2_DEVICE )
!$acc kernels
- ZTMP3_DEVICE = ZFLX* ZTMP1_DEVICE / ZTMP2_DEVICE
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP3_DEVICE(JI,JJ,JK) = ZFLX(JI,JJ,JK)* ZTMP1_DEVICE(JI,JJ,JK) / ZTMP2_DEVICE(JI,JJ,JK)
+ END DO !CONCURRENT
!$acc end kernels
CALL DZF_DEVICE(1,IKU,1, ZTMP3_DEVICE, ZTMP1_DEVICE )
!$acc kernels
- PRVS(:,:,:) = PRVS(:,:,:) - ZTMP1_DEVICE
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ PRVS(JI,JJ,JK) = PRVS(JI,JJ,JK) - ZTMP1_DEVICE(JI,JJ,JK)
+ END DO !CONCURRENT
!$acc end kernels
ENDIF
#endif
@@ -337,30 +368,48 @@ IF (.NOT. L2D) THEN
IF (.NOT. LFLAT) THEN
CALL MYM_DEVICE(PRHODJ, ZTMP1_DEVICE)
!$acc kernels
- ZTMP2_DEVICE = ZTMP1_DEVICE * PINV_PDYY
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP2_DEVICE(JI,JJ,JK) = ZTMP1_DEVICE(JI,JJ,JK) * PINV_PDYY(JI,JJ,JK)
+ END DO !CONCURRENT
!$acc end kernels
CALL MZM_DEVICE(ZTMP2_DEVICE, ZTMP1_DEVICE)
!$acc kernels
- ZTMP2_DEVICE = ZTMP1_DEVICE * ZFLX
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP2_DEVICE(JI,JJ,JK) = ZTMP1_DEVICE(JI,JJ,JK) * ZFLX(JI,JJ,JK)
+ END DO !CONCURRENT
!$acc end kernels
CALL DYF_DEVICE( ZTMP2_DEVICE, ZTMP1_DEVICE )
!$acc kernels
- ZTMP2_DEVICE = ZFLX*PDZY
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP2_DEVICE(JI,JJ,JK) = ZFLX(JI,JJ,JK) *PDZY(JI,JJ,JK)
+ END DO !CONCURRENT
!$acc end kernels
CALL MZF_DEVICE(1,IKU,1,ZTMP2_DEVICE,ZTMP3_DEVICE )
!$acc kernels
- ZTMP2_DEVICE = ZTMP3_DEVICE * PINV_PDYY
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP2_DEVICE(JI,JJ,JK) = ZTMP3_DEVICE(JI,JJ,JK) * PINV_PDYY(JI,JJ,JK)
+ END DO !CONCURRENT
!$acc end kernels
CALL MYF_DEVICE(ZTMP2_DEVICE,ZTMP3_DEVICE)
CALL MZF_DEVICE(1,IKU,1,PDZZ,ZTMP2_DEVICE)
!$acc kernels
- ZTMP4_DEVICE = PRHODJ * ZTMP3_DEVICE / ZTMP2_DEVICE
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP4_DEVICE(JI,JJ,JK) = PRHODJ(JI,JJ,JK) * ZTMP3_DEVICE(JI,JJ,JK) / ZTMP2_DEVICE(JI,JJ,JK)
+ END DO !CONCURRENT
!$acc end kernels
CALL DZM_DEVICE(1,IKU,1,ZTMP4_DEVICE,ZTMP2_DEVICE)
!$acc kernels
- PRWS(:,:,:) = PRWS(:,:,:) &
- - ZTMP1_DEVICE &
- + ZTMP2_DEVICE
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ PRWS(JI,JJ,JK) = PRWS(JI,JJ,JK) &
+ - ZTMP1_DEVICE(JI,JJ,JK) &
+ + ZTMP2_DEVICE(JI,JJ,JK)
+ END DO !CONCURRENT
!$acc end kernels
ELSE
CALL MYM_DEVICE(PRHODJ, ZTMP1_DEVICE)
@@ -389,12 +438,18 @@ IF (KSPLT==1) THEN
#else
CALL GZ_V_VW_DEVICE(1,IKU,1,PVM,PDZZ,ZTMP1_DEVICE)
!$acc kernels
- ZTMP2_DEVICE = ZFLX *( ZTMP1_DEVICE + GY_W_VW_PWM )
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP2_DEVICE(JI,JJ,JK) = ZFLX(JI,JJ,JK) *( ZTMP1_DEVICE(JI,JJ,JK) + GY_W_VW_PWM(JI,JJ,JK) )
+ END DO !CONCURRENT
!$acc end kernels
CALL MYF_DEVICE(ZTMP2_DEVICE,ZTMP1_DEVICE)
CALL MZF_DEVICE(1,IKU,1,ZTMP1_DEVICE,ZTMP2_DEVICE)
!$acc kernels
- ZWORK(:,:,:) = -ZTMP2_DEVICE
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZWORK(JI,JJ,JK) = -ZTMP2_DEVICE(JI,JJ,JK)
+ END DO !CONCURRENT
!$acc end kernels
#endif
!
@@ -543,6 +598,13 @@ end if
!$acc end data
+#ifndef MNH_OPENACC
+deallocate( ZFLX, ZWORK, GY_W_VW_PWM )
+#else
+CALL MNH_REL_ZT3D ( IZFLX, IZWORK, IGY_W_VW_PWM, &
+ IZTMP1_DEVICE, IZTMP2_DEVICE, IZTMP3_DEVICE, IZTMP4_DEVICE )
+#endif
+
!$acc end data
END SUBROUTINE TURB_HOR_VW
diff --git a/src/MNH/turb_ver.f90 b/src/MNH/turb_ver.f90
index 0f4e3e0b2d9894f0e21f7a7d8a40c081d1ad49be..904059b7c4648f7a679aac2f293083122de1d9e3 100644
--- a/src/MNH/turb_ver.f90
+++ b/src/MNH/turb_ver.f90
@@ -342,6 +342,10 @@ USE MODE_PRANDTL
!
USE MODI_SECOND_MNH
!
+#ifdef MNH_OPENACC
+USE MODE_MNH_ZWORK, ONLY : MNH_ALLOCATE_ZT3D , MNH_REL_ZT3D, MNH_ALLOCATE_ZT4D , MNH_REL_ZT4D
+#endif
+!
IMPLICIT NONE
!
!* 0.1 declarations of arguments
@@ -431,7 +435,7 @@ REAL, DIMENSION(:,:,:,:),INTENT(OUT) :: PWSV ! scalar flux
!
!* 0.2 declaration of local variables
!
-REAL, DIMENSION(:,:,:), allocatable :: &
+REAL, DIMENSION(:,:,:), pointer,contiguous :: &
ZBETA, & ! buoyancy coefficient
ZSQRT_TKE,& ! sqrt(e)
ZDTH_DZ, & ! d(th)/dz
@@ -453,11 +457,20 @@ REAL, DIMENSION(:,:,:), allocatable :: &
ZTHLP, & ! guess of potential temperature due to vert. turbulent flux
ZRP ! guess of total water due to vert. turbulent flux
-REAL, DIMENSION(:,:,:,:), allocatable :: &
+#ifdef MNH_OPENACC
+INTEGER :: izbeta,izsqrt_tke,izdth_dz,izdr_dz,izred2th3,izred2r3,izred2thr3, &
+ izbll_o_e,izetheta,izemoist,izredth1,izredr1,izphi3,izpsi3, &
+ izd,izwthv,izwu,izwv,izthlp,izrp
+#endif
+
+REAL, DIMENSION(:,:,:,:), pointer , contiguous :: &
ZPSI_SV, & ! Prandtl number for scalars
ZREDS1, & ! 1D Redelsperger number R_sv
ZRED2THS, & ! 3D Redelsperger number R*2_thsv
ZRED2RS ! 3D Redelsperger number R*2_rsv
+#ifdef MNH_OPENACC
+INTEGER :: IZPSI_SV,IZREDS1,IZRED2THS,IZRED2RS
+#endif
!
LOGICAL :: GUSERV ! flag to use water vapor
INTEGER :: IKB,IKE ! index value for the Beginning
@@ -468,6 +481,9 @@ REAL :: ZTIME2
!
TYPE(TFIELDDATA) :: TZFIELD
!
+INTEGER :: JIU,JJU,JKU
+INTEGER :: JI,JJ,JK
+!
!----------------------------------------------------------------------------
!$acc data present( PDXX, PDYY, PDZZ, PDZX, PDZY, PDIRCOSZW, PZZ, &
@@ -539,33 +555,67 @@ if ( mppdb_initialized ) then
call Mppdb_check( prrs, "Turb_ver beg:prrs" )
end if
-allocate( zbeta (size( pthlm, 1 ), size( pthlm, 2 ), size( pthlm, 3 ) ) )
-allocate( zsqrt_tke(size( pthlm, 1 ), size( pthlm, 2 ), size( pthlm, 3 ) ) )
-allocate( zdth_dz (size( pthlm, 1 ), size( pthlm, 2 ), size( pthlm, 3 ) ) )
-allocate( zdr_dz (size( pthlm, 1 ), size( pthlm, 2 ), size( pthlm, 3 ) ) )
-allocate( zred2th3 (size( pthlm, 1 ), size( pthlm, 2 ), size( pthlm, 3 ) ) )
-allocate( zred2r3 (size( pthlm, 1 ), size( pthlm, 2 ), size( pthlm, 3 ) ) )
-allocate( zred2thr3(size( pthlm, 1 ), size( pthlm, 2 ), size( pthlm, 3 ) ) )
-allocate( zbll_o_e (size( pthlm, 1 ), size( pthlm, 2 ), size( pthlm, 3 ) ) )
-allocate( zetheta (size( pthlm, 1 ), size( pthlm, 2 ), size( pthlm, 3 ) ) )
-allocate( zemoist (size( pthlm, 1 ), size( pthlm, 2 ), size( pthlm, 3 ) ) )
-allocate( zredth1 (size( pthlm, 1 ), size( pthlm, 2 ), size( pthlm, 3 ) ) )
-allocate( zredr1 (size( pthlm, 1 ), size( pthlm, 2 ), size( pthlm, 3 ) ) )
-allocate( zphi3 (size( pthlm, 1 ), size( pthlm, 2 ), size( pthlm, 3 ) ) )
-allocate( zpsi3 (size( pthlm, 1 ), size( pthlm, 2 ), size( pthlm, 3 ) ) )
-allocate( zd (size( pthlm, 1 ), size( pthlm, 2 ), size( pthlm, 3 ) ) )
-allocate( zwthv (size( pthlm, 1 ), size( pthlm, 2 ), size( pthlm, 3 ) ) )
-allocate( zwu (size( pthlm, 1 ), size( pthlm, 2 ), size( pthlm, 3 ) ) )
-allocate( zwv (size( pthlm, 1 ), size( pthlm, 2 ), size( pthlm, 3 ) ) )
-allocate( zthlp (size( pthlm, 1 ), size( pthlm, 2 ), size( pthlm, 3 ) ) )
-allocate( zrp (size( pthlm, 1 ), size( pthlm, 2 ), size( pthlm, 3 ) ) )
+JIU = size( pthlm, 1 )
+JJU = size( pthlm, 2 )
+JKU = size( pthlm, 3 )
+
+#ifndef MNH_OPENACC
+allocate( zbeta (JIU,JJU,JKU) )
+allocate( zsqrt_tke(JIU,JJU,JKU) )
+allocate( zdth_dz (JIU,JJU,JKU) )
+allocate( zdr_dz (JIU,JJU,JKU) )
+allocate( zred2th3 (JIU,JJU,JKU) )
+allocate( zred2r3 (JIU,JJU,JKU) )
+allocate( zred2thr3(JIU,JJU,JKU) )
+allocate( zbll_o_e (JIU,JJU,JKU) )
+allocate( zetheta (JIU,JJU,JKU) )
+allocate( zemoist (JIU,JJU,JKU) )
+allocate( zredth1 (JIU,JJU,JKU) )
+allocate( zredr1 (JIU,JJU,JKU) )
+allocate( zphi3 (JIU,JJU,JKU) )
+allocate( zpsi3 (JIU,JJU,JKU) )
+allocate( zd (JIU,JJU,JKU) )
+allocate( zwthv (JIU,JJU,JKU) )
+allocate( zwu (JIU,JJU,JKU) )
+allocate( zwv (JIU,JJU,JKU) )
+allocate( zthlp (JIU,JJU,JKU) )
+allocate( zrp (JIU,JJU,JKU) )
+#else
+izbeta = MNH_ALLOCATE_ZT3D( zbeta ,JIU,JJU,JKU )
+izsqrt_tke = MNH_ALLOCATE_ZT3D( zsqrt_tke,JIU,JJU,JKU )
+izdth_dz = MNH_ALLOCATE_ZT3D( zdth_dz ,JIU,JJU,JKU )
+izdr_dz = MNH_ALLOCATE_ZT3D( zdr_dz ,JIU,JJU,JKU )
+izred2th3 = MNH_ALLOCATE_ZT3D( zred2th3 ,JIU,JJU,JKU )
+izred2r3 = MNH_ALLOCATE_ZT3D( zred2r3 ,JIU,JJU,JKU )
+izred2thr3 = MNH_ALLOCATE_ZT3D( zred2thr3,JIU,JJU,JKU )
+izbll_o_e = MNH_ALLOCATE_ZT3D( zbll_o_e ,JIU,JJU,JKU )
+izetheta = MNH_ALLOCATE_ZT3D( zetheta ,JIU,JJU,JKU )
+izemoist = MNH_ALLOCATE_ZT3D( zemoist ,JIU,JJU,JKU )
+izredth1 = MNH_ALLOCATE_ZT3D( zredth1 ,JIU,JJU,JKU )
+izredr1 = MNH_ALLOCATE_ZT3D( zredr1 ,JIU,JJU,JKU )
+izphi3 = MNH_ALLOCATE_ZT3D( zphi3 ,JIU,JJU,JKU )
+izpsi3 = MNH_ALLOCATE_ZT3D( zpsi3 ,JIU,JJU,JKU )
+izd = MNH_ALLOCATE_ZT3D( zd ,JIU,JJU,JKU )
+izwthv = MNH_ALLOCATE_ZT3D( zwthv ,JIU,JJU,JKU )
+izwu = MNH_ALLOCATE_ZT3D( zwu ,JIU,JJU,JKU )
+izwv = MNH_ALLOCATE_ZT3D( zwv ,JIU,JJU,JKU )
+izthlp = MNH_ALLOCATE_ZT3D( zthlp ,JIU,JJU,JKU )
+izrp = MNH_ALLOCATE_ZT3D( zrp ,JIU,JJU,JKU )
+#endif
-allocate( zpsi_sv (size( pthlm, 1 ), size( pthlm, 2 ), size( pthlm, 3 ), nsv ) )
-allocate( zreds1 (size( pthlm, 1 ), size( pthlm, 2 ), size( pthlm, 3 ), nsv ) )
-allocate( zred2ths(size( pthlm, 1 ), size( pthlm, 2 ), size( pthlm, 3 ), nsv ) )
-allocate( zred2rs (size( pthlm, 1 ), size( pthlm, 2 ), size( pthlm, 3 ), nsv ) )
+#ifndef MNH_OPENACC
+allocate( zpsi_sv (JIU,JJU,JKU, nsv ) )
+allocate( zreds1 (JIU,JJU,JKU, nsv ) )
+allocate( zred2ths(JIU,JJU,JKU, nsv ) )
+allocate( zred2rs (JIU,JJU,JKU, nsv ) )
+#else
+izpsi_sv = MNH_ALLOCATE_ZT4D( zpsi_sv ,JIU,JJU,JKU, nsv )
+izreds1 = MNH_ALLOCATE_ZT4D( zreds1 ,JIU,JJU,JKU, nsv )
+izred2ths = MNH_ALLOCATE_ZT4D( zred2ths,JIU,JJU,JKU, nsv )
+izred2rs = MNH_ALLOCATE_ZT4D( zred2rs ,JIU,JJU,JKU, nsv )
+#endif
-!$acc data create( ZBETA, ZSQRT_TKE, ZDTH_DZ, ZDR_DZ, ZRED2TH3, ZRED2R3, ZRED2THR3,&
+!$acc data present (ZBETA, ZSQRT_TKE, ZDTH_DZ, ZDR_DZ, ZRED2TH3, ZRED2R3, ZRED2THR3,&
!$acc & ZBLL_O_E, ZETHETA, ZEMOIST, ZREDTH1, ZREDR1, &
!$acc & ZPHI3, ZPSI3, ZD, ZWTHV, ZWU, ZWV, ZTHLP, ZRP, &
!$acc & ZPSI_SV, ZREDS1, ZRED2THS, ZRED2RS )
@@ -629,7 +679,10 @@ ENDIF
! Denominator factor in 3rd order terms
!
!$acc kernels
-ZD(:,:,:) = (1.+ZREDTH1(:,:,:)+ZREDR1(:,:,:)) * (1.+0.5*(ZREDTH1(:,:,:)+ZREDR1(:,:,:)))
+!$acc loop independent collapse(3)
+DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZD(JI,JJ,JK) = (1.+ZREDTH1(JI,JJ,JK)+ZREDR1(JI,JJ,JK)) * (1.+0.5*(ZREDTH1(JI,JJ,JK)+ZREDR1(JI,JJ,JK)))
+END DO
!$acc end kernels
!
! Phi3 and Psi3 Prandtl numbers
@@ -858,6 +911,24 @@ end if
!$acc end data
+#ifndef MNH_OPENACC
+DEALLOCATE(zbeta,zsqrt_tke,zdth_dz,zdr_dz,zred2th3,zred2r3,zred2thr3, &
+ zbll_o_e,zetheta,zemoist,zredth1,zredr1,zphi3,zpsi3, &
+ zd,zwthv,zwu,zwv,zthlp,zrp)
+#else
+CALL MNH_REL_ZT3D(izbeta,izsqrt_tke,izdth_dz,izdr_dz,izred2th3,izred2r3,izred2thr3, &
+ izbll_o_e,izetheta,izemoist,izredth1,izredr1,izphi3,izpsi3, &
+ izd,izwthv,izwu,izwv,izthlp,izrp)
+#endif
+
+#ifndef MNH_OPENACC
+DEALLOCATE(zpsi_sv,zreds1,zred2ths,zred2rs)
+#else
+CALL MNH_REL_ZT4D (nsv , izred2rs )
+CALL MNH_REL_ZT4D (nsv , izred2ths )
+CALL MNH_REL_ZT4D (nsv , izreds1 )
+CALL MNH_REL_ZT4D (nsv , izpsi_sv )
+#endif
!$acc end data
!----------------------------------------------------------------------------
diff --git a/src/MNH/turb_ver_dyn_flux.f90 b/src/MNH/turb_ver_dyn_flux.f90
index 27e9cb248ffb494df16215b8e57b441b2b916f71..e7c6ae4ae4b0cd222b7d873a9036e670890d5d92 100644
--- a/src/MNH/turb_ver_dyn_flux.f90
+++ b/src/MNH/turb_ver_dyn_flux.f90
@@ -80,7 +80,6 @@ END INTERFACE
!
END MODULE MODI_TURB_VER_DYN_FLUX
!
-!
! ###############################################################
SUBROUTINE TURB_VER_DYN_FLUX(KKA,KKU,KKL, &
OTURB_FLX,KRR, &
@@ -321,6 +320,10 @@ use mode_mppdb
USE MODE_MSG
#endif
!
+#ifdef MNH_OPENACC
+USE MODE_MNH_ZWORK , ONLY : MNH_ALLOCATE_ZT3D , MNH_REL_ZT3D, MNH_ALLOCATE_ZT3DP , MNH_ALLOCATE_ZT2D
+#endif
+
IMPLICIT NONE
!
!* 0.1 declarations of arguments
@@ -379,11 +382,11 @@ REAL, DIMENSION(:,:,:), INTENT(OUT) :: PDP ! Dynamic TKE production t
!* 0.2 declaration of local variables
!
!
-REAL, DIMENSION(:,:), allocatable :: ZDIRSINZW ! sinus of the angle
+REAL, DIMENSION(:,:), pointer , contiguous :: ZDIRSINZW ! sinus of the angle
! between the normal and the vertical at the surface
-REAL, DIMENSION(:,:,:), allocatable :: ZCOEFS ! coeff. for the
+REAL, DIMENSION(:,:,:), pointer , contiguous :: ZCOEFS ! coeff. for the
! implicit scheme for the wind at the surface
-REAL, DIMENSION(:,:,:), allocatable :: &
+REAL, DIMENSION(:,:,:), pointer , contiguous :: &
ZA, & ! under diagonal elements of the tri-diagonal matrix involved
! in the temporal implicit scheme (also used to store coefficient
! J in Section 5)
@@ -393,25 +396,35 @@ REAL, DIMENSION(:,:,:), allocatable :: &
ZFLXZ, & ! vertical flux of the treated variable
ZSOURCE, & ! source of evolution for the treated variable
ZKEFF ! effectif diffusion coeff = LT * SQRT( TKE )
+#ifdef MNH_OPENACC
+INTEGER :: IZDIRSINZW,IZCOEFS,IZA,IZRES,IZFLXZ,IZSOURCE,IZKEFF
+#endif
INTEGER :: IIB,IIE, & ! I index values for the Beginning and End
IJB,IJE, & ! mass points of the domain in the 3 direct.
IKB,IKE !
INTEGER :: IKT ! array size in k direction
INTEGER :: IKTB,IKTE ! start, end of k loops in physical domain
INTEGER :: JSV ! scalar loop counter
-REAL, DIMENSION(:,:,:), allocatable :: ZCOEFFLXU, &
+REAL, DIMENSION(:,:,:), pointer , contiguous :: ZCOEFFLXU, &
ZCOEFFLXV, ZUSLOPEM, ZVSLOPEM
! coefficients for the surface flux
! evaluation and copy of PUSLOPEM and
- ! PVSLOPEM in local 3D arrays
+ ! PVSLOPEM in local 3D arrays
+#ifdef MNH_OPENACC
+INTEGER :: IZCOEFFLXU,IZCOEFFLXV,IZUSLOPEM,IZVSLOPEM
+#endif
INTEGER :: IIU,IJU ! size of array in x,y,z directions
!
REAL :: ZTIME1, ZTIME2
!
#ifdef MNH_OPENACC
-REAL, DIMENSION(:,:,:), allocatable :: ZTMP1_DEVICE,ZTMP2_DEVICE,ZTMP3_DEVICE,ZTMP4_DEVICE
+REAL, DIMENSION(:,:,:), pointer , contiguous :: ZTMP1_DEVICE,ZTMP2_DEVICE,ZTMP3_DEVICE,ZTMP4_DEVICE
+INTEGER :: IZTMP1_DEVICE,IZTMP2_DEVICE,IZTMP3_DEVICE,IZTMP4_DEVICE
#endif
TYPE(TFIELDDATA) :: TZFIELD
+!
+INTEGER :: JIU,JJU,JKU
+INTEGER :: JI,JJ,JK
!----------------------------------------------------------------------------
!$acc data present( PDXX, PDYY, PDZZ, PDZX, PDZY, PDIRCOSZW, &
@@ -454,29 +467,50 @@ if ( mppdb_initialized ) then
call Mppdb_check( prws, "Turb_ver_dyn_flux beg:prws" )
end if
-allocate( zdirsinzw(size( pum, 1 ), size( pum, 2 ) ) )
+JIU = size(pum, 1 )
+JJU = size(pum, 2 )
+JKU = size(pum, 3 )
+
+#ifndef MNH_OPENACC
+allocate( zdirsinzw(JIU,JJU ) )
+
+allocate( zcoefs (JIU,JJU, 1 ) )
+
+allocate( za (JIU,JJU,JKU ) )
+allocate( zres (JIU,JJU,JKU ) )
+allocate( zflxz (JIU,JJU,JKU ) )
+allocate( zsource (JIU,JJU,JKU ) )
+allocate( zkeff (JIU,JJU,JKU ) )
+
+allocate( zcoefflxu(JIU,JJU, 1 ) )
+allocate( zcoefflxv(JIU,JJU, 1 ) )
+allocate( zuslopem (JIU,JJU, 1 ) )
+allocate( zvslopem (JIU,JJU, 1 ) )
+#else
+izdirsinzw = MNH_ALLOCATE_ZT2D( zdirsinzw,JIU,JJU )
-allocate( zcoefs (size( pum, 1 ), size( pum, 2 ), 1 ) )
+izcoefs = MNH_ALLOCATE_ZT3DP( zcoefs ,JIU,JJU, 1 , 1 )
-allocate( za (size( pum, 1 ), size( pum, 2 ), size( pum, 3 ) ) )
-allocate( zres (size( pum, 1 ), size( pum, 2 ), size( pum, 3 ) ) )
-allocate( zflxz (size( pum, 1 ), size( pum, 2 ), size( pum, 3 ) ) )
-allocate( zsource (size( pum, 1 ), size( pum, 2 ), size( pum, 3 ) ) )
-allocate( zkeff (size( pum, 1 ), size( pum, 2 ), size( pum, 3 ) ) )
+iza = MNH_ALLOCATE_ZT3D( za ,JIU,JJU,JKU )
+izres = MNH_ALLOCATE_ZT3D( zres ,JIU,JJU,JKU )
+izflxz = MNH_ALLOCATE_ZT3D( zflxz ,JIU,JJU,JKU )
+izsource = MNH_ALLOCATE_ZT3D( zsource ,JIU,JJU,JKU )
+izkeff = MNH_ALLOCATE_ZT3D( zkeff ,JIU,JJU,JKU )
-allocate( zcoefflxu(size( pdzz, 1 ), size( pdzz, 2 ), 1 ) )
-allocate( zcoefflxv(size( pdzz, 1 ), size( pdzz, 2 ), 1 ) )
-allocate( zuslopem (size( pdzz, 1 ), size( pdzz, 2 ), 1 ) )
-allocate( zvslopem (size( pdzz, 1 ), size( pdzz, 2 ), 1 ) )
+izcoefflxu = MNH_ALLOCATE_ZT3DP( zcoefflxu,JIU,JJU, 1 , 1 )
+izcoefflxv = MNH_ALLOCATE_ZT3DP( zcoefflxv,JIU,JJU, 1 , 1 )
+izuslopem = MNH_ALLOCATE_ZT3DP( zuslopem ,JIU,JJU, 1 , 1 )
+izvslopem = MNH_ALLOCATE_ZT3DP( zvslopem ,JIU,JJU, 1 , 1 )
+#endif
#ifdef MNH_OPENACC
-allocate( ztmp1_device(size( pthlm, 1 ), size( pthlm, 2 ), size( pthlm, 3 ) ) )
-allocate( ztmp2_device(size( pthlm, 1 ), size( pthlm, 2 ), size( pthlm, 3 ) ) )
-allocate( ztmp3_device(size( pthlm, 1 ), size( pthlm, 2 ), size( pthlm, 3 ) ) )
-allocate( ztmp4_device(size( pthlm, 1 ), size( pthlm, 2 ), size( pthlm, 3 ) ) )
+iztmp1_device = MNH_ALLOCATE_ZT3D( ztmp1_device,JIU,JJU,JKU )
+iztmp2_device = MNH_ALLOCATE_ZT3D( ztmp2_device,JIU,JJU,JKU )
+iztmp3_device = MNH_ALLOCATE_ZT3D( ztmp3_device,JIU,JJU,JKU )
+iztmp4_device = MNH_ALLOCATE_ZT3D( ztmp4_device,JIU,JJU,JKU )
#endif
-!$acc data create( zdirsinzw, zcoefs, za, zres, zflxz, zsource, zkeff, zcoefflxu, zcoefflxv, zuslopem, zvslopem, &
+!$acc data present( zdirsinzw, zcoefs, za, zres, zflxz, zsource, zkeff, zcoefflxu, zcoefflxv, zuslopem, zvslopem, &
!$acc & ztmp1_device, ztmp2_device, ztmp3_device, ztmp4_device )
!
@@ -500,7 +534,10 @@ ZSOURCE(:,:,:) = 0.
#ifndef MNH_BITREP
ZDIRSINZW(:,:) = SQRT(1.-PDIRCOSZW(:,:)**2)
#else
-ZDIRSINZW(:,:) = SQRT(1.-BR_P2(PDIRCOSZW(:,:)))
+!$acc loop independent collapse(2)
+DO CONCURRENT ( JI=1:JIU,JJ=1:JJU )
+ ZDIRSINZW(JI,JJ) = SQRT(1.-BR_P2(PDIRCOSZW(JI,JJ)))
+END DO
#endif
! compute the coefficients for the uncentred gradient computation near the
! ground
@@ -545,7 +582,10 @@ CALL MXM_DEVICE( PDZZ, ZTMP4_DEVICE )
#ifndef MNH_BITREP
ZA(:,:,:) = -PTSTEP * XCMFS * ZTMP1_DEVICE(:,:,:) * ZTMP3_DEVICE(:,:,:) / ZTMP4_DEVICE(:,:,:)**2
#else
-ZA(:,:,:) = -PTSTEP * XCMFS * ZTMP1_DEVICE(:,:,:) * ZTMP3_DEVICE(:,:,:) / BR_P2(ZTMP4_DEVICE(:,:,:))
+!$acc loop independent collapse(3)
+DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZA(JI,JJ,JK) = -PTSTEP * XCMFS * ZTMP1_DEVICE(JI,JJ,JK) * ZTMP3_DEVICE(JI,JJ,JK) / BR_P2(ZTMP4_DEVICE(JI,JJ,JK))
+END DO
#endif
!$acc end kernels
#endif
@@ -558,21 +598,31 @@ ZA(:,:,:) = -PTSTEP * XCMFS * ZTMP1_DEVICE(:,:,:) * ZTMP3_DEVICE(:,:,:) / BR_P2(
!$acc kernels
#ifndef MNH_BITREP
ZCOEFFLXU(:,:,1) = PCDUEFF(:,:) * (PDIRCOSZW(:,:)**2 - ZDIRSINZW(:,:)**2) &
+ * PCOSSLOPE(:,:)
#else
-ZCOEFFLXU(:,:,1) = PCDUEFF(:,:) * (BR_P2(PDIRCOSZW(:,:)) - BR_P2(ZDIRSINZW(:,:))) &
+!$acc loop independent collapse(2)
+DO CONCURRENT ( JI=1:JIU,JJ=1:JJU )
+ ZCOEFFLXU(JI,JJ,1) = PCDUEFF(JI,JJ) * (BR_P2(PDIRCOSZW(JI,JJ)) - BR_P2(ZDIRSINZW(JI,JJ))) &
+ * PCOSSLOPE(JI,JJ)
+END DO
#endif
- * PCOSSLOPE(:,:)
-ZCOEFFLXV(:,:,1) = PCDUEFF(:,:) * PDIRCOSZW(:,:) * PSINSLOPE(:,:)
-
-! prepare the implicit scheme coefficients for the surface flux
-ZCOEFS(:,:,1)= ZCOEFFLXU(:,:,1) * PCOSSLOPE(:,:) * PDIRCOSZW(:,:) &
- +ZCOEFFLXV(:,:,1) * PSINSLOPE(:,:)
+!$acc loop independent collapse(2)
+DO CONCURRENT ( JI=1:JIU,JJ=1:JJU )
+ ZCOEFFLXV(JI,JJ,1) = PCDUEFF(JI,JJ) * PDIRCOSZW(JI,JJ) * PSINSLOPE(JI,JJ)
+
+ ! prepare the implicit scheme coefficients for the surface flux
+ ZCOEFS(JI,JJ,1)= ZCOEFFLXU(JI,JJ,1) * PCOSSLOPE(JI,JJ) * PDIRCOSZW(JI,JJ) &
+ +ZCOEFFLXV(JI,JJ,1) * PSINSLOPE(JI,JJ)
+END DO
!
! average this flux to be located at the U,W vorticity point
#ifndef MNH_OPENACC
ZCOEFS(:,:,1:1)=MXM(ZCOEFS(:,:,1:1) / PDZZ(:,:,IKB:IKB) )
#else
-ZTMP1_DEVICE(:,:,1) = ZCOEFS(:,:,1) / PDZZ(:,:,IKB)
+!$acc loop independent collapse(2)
+DO CONCURRENT ( JI=1:JIU,JJ=1:JJU )
+ ZTMP1_DEVICE(JI,JJ,1) = ZCOEFS(JI,JJ,1) / PDZZ(JI,JJ,IKB)
+END DO
!$acc end kernels
CALL MXM_DEVICE(ZTMP1_DEVICE(:,:,1:1),ZCOEFS(:,:,1:1))
#endif
@@ -664,6 +714,7 @@ PRUS(:,:,:)=PRUS(:,:,:)+MXM(PRHODJ(:,:,:))*(ZRES(:,:,:)-PUM(:,:,:))/PTSTEP
#else
!$acc kernels
PRUS(:,:,:)=PRUS(:,:,:)+ZTMP1_DEVICE(:,:,:)*(ZRES(:,:,:)-PUM(:,:,:))/PTSTEP
+!$acc end kernels
#endif
!
!
@@ -675,13 +726,20 @@ PRUS(:,:,:)=PRUS(:,:,:)+ZTMP1_DEVICE(:,:,:)*(ZRES(:,:,:)-PUM(:,:,:))/PTSTEP
ZFLXZ(:,:,:) = -XCMFS * MXM(ZKEFF) * &
DZM (PIMPL*ZRES + PEXPL*PUM) / MXM(PDZZ)
#else
-ZTMP2_DEVICE(:,:,:) = PIMPL*ZRES(:,:,:) + PEXPL*PUM(:,:,:)
+!$acc kernels
+!$acc loop independent collapse(3)
+DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP2_DEVICE(JI,JJ,JK) = PIMPL*ZRES(JI,JJ,JK) + PEXPL*PUM(JI,JJ,JK)
+END DO
!$acc end kernels
CALL MXM_DEVICE(ZKEFF,ZTMP1_DEVICE)
CALL DZM_DEVICE(KKA,KKU,KKL,ZTMP2_DEVICE,ZTMP3_DEVICE)
CALL MXM_DEVICE(PDZZ,ZTMP4_DEVICE)
!$acc kernels
-ZFLXZ(:,:,:) = -XCMFS * ZTMP1_DEVICE(:,:,:) * ZTMP3_DEVICE(:,:,:) / ZTMP4_DEVICE(:,:,:)
+!$acc loop independent collapse(3)
+DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZFLXZ(JI,JJ,JK) = -XCMFS * ZTMP1_DEVICE(JI,JJ,JK) * ZTMP3_DEVICE(JI,JJ,JK) / ZTMP4_DEVICE(JI,JJ,JK)
+END DO
!$acc end kernels
#endif
!
@@ -742,7 +800,10 @@ PDP(:,:,:) = - MZF( MXF ( ZFLXZ * GZ_U_UW(PUM,PDZZ) ) )
#else
CALL GZ_U_UW_DEVICE(KKA,KKU,KKL,PUM,PDZZ,ZTMP1_DEVICE)
!$acc kernels
-ZTMP2_DEVICE(:,:,:) = ZFLXZ(:,:,:) * ZTMP1_DEVICE(:,:,:)
+!$acc loop independent collapse(3)
+DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU )
+ ZTMP2_DEVICE(JI,JJ,JK) = ZFLXZ(JI,JJ,JK) * ZTMP1_DEVICE(JI,JJ,JK)
+END DO
!$acc end kernels
CALL MXF_DEVICE( ZTMP2_DEVICE,ZTMP3_DEVICE )
CALL MZF_DEVICE(KKA,KKU,KKL, ZTMP3_DEVICE, ZTMP4_DEVICE )
@@ -837,26 +898,41 @@ IF(HTURBDIM=='3DIM') THEN
END IF
#else
CALL MXM_DEVICE(PRHODJ,ZTMP1_DEVICE)
-!$acc kernels
- ZTMP2_DEVICE(:,:,:) = ZTMP1_DEVICE(:,:,:) /PDXX(:,:,:)
+ !$acc kernels
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP2_DEVICE(JI,JJ,JK) = ZTMP1_DEVICE(JI,JJ,JK) /PDXX(JI,JJ,JK)
+ END DO
!$acc end kernels
CALL MZM_DEVICE(ZTMP2_DEVICE,ZTMP3_DEVICE )
-!$acc kernels
- ZTMP2_DEVICE(:,:,:) = ZTMP3_DEVICE(:,:,:) * ZFLXZ(:,:,:)
+ !$acc kernels
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP2_DEVICE(JI,JJ,JK) = ZTMP3_DEVICE(JI,JJ,JK) * ZFLXZ(JI,JJ,JK)
+ END DO
!$acc end kernels
CALL DXF_DEVICE( ZTMP2_DEVICE,ZTMP1_DEVICE )
IF (.NOT. LFLAT) THEN
CALL MZF_DEVICE(KKA,KKU,KKL,PDZZ,ZTMP2_DEVICE )
!$acc kernels
- ZTMP3_DEVICE(:,:,:) = ZFLXZ(:,:,:)*PDZX(:,:,:)
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP3_DEVICE(JI,JJ,JK) = ZFLXZ(JI,JJ,JK)*PDZX(JI,JJ,JK)
+ END DO
!$acc end kernels
CALL MZF_DEVICE(KKA,KKU,KKL, ZTMP3_DEVICE,ZTMP4_DEVICE )
!$acc kernels
- ZTMP3_DEVICE(:,:,:) = ZTMP4_DEVICE(:,:,:) / PDXX(:,:,:)
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP3_DEVICE(JI,JJ,JK) = ZTMP4_DEVICE(JI,JJ,JK) / PDXX(JI,JJ,JK)
+ END DO
!$acc end kernels
CALL MXF_DEVICE( ZTMP3_DEVICE,ZTMP4_DEVICE )
!$acc kernels
- ZTMP3_DEVICE(:,:,:) = PRHODJ(:,:,:) / ZTMP2_DEVICE(:,:,:) * ZTMP4_DEVICE(:,:,:)
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP3_DEVICE(JI,JJ,JK) = PRHODJ(JI,JJ,JK) / ZTMP2_DEVICE(JI,JJ,JK) * ZTMP4_DEVICE(JI,JJ,JK)
+ END DO
!$acc end kernels
CALL DZM_DEVICE(KKA,KKU,KKL, ZTMP3_DEVICE,ZTMP2_DEVICE)
!$acc kernels
@@ -875,13 +951,19 @@ IF(HTURBDIM=='3DIM') THEN
ZA(:,:,:)=-MZF( MXF ( ZFLXZ * GX_W_UW( PWM,PDXX,PDZZ,PDZX) ) )
#else
CALL GX_W_UW_DEVICE(KKA,KKU,KKL, PWM,PDXX,PDZZ,PDZX,ZTMP1_DEVICE)
-!$acc kernels
- ZTMP2_DEVICE(:,:,:) = ZFLXZ(:,:,:) * ZTMP1_DEVICE(:,:,:)
+ !$acc kernels
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP2_DEVICE(JI,JJ,JK) = ZFLXZ(JI,JJ,JK) * ZTMP1_DEVICE(JI,JJ,JK)
+ END DO
!$acc end kernels
CALL MXF_DEVICE(ZTMP2_DEVICE,ZTMP1_DEVICE)
CALL MZF_DEVICE(KKA,KKU,KKL, ZTMP1_DEVICE,ZTMP2_DEVICE )
-!$acc kernels
- ZA(:,:,:)=-ZTMP2_DEVICE(:,:,:)
+ !$acc kernels
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZA(JI,JJ,JK)=-ZTMP2_DEVICE(JI,JJ,JK)
+ END DO
!$acc end kernels
#endif
!
@@ -1029,7 +1111,10 @@ CALL MYM_DEVICE(ZTMP3_DEVICE,ZTMP4_DEVICE)
#ifndef MNH_BITREP
ZA(:,:,:) = - PTSTEP * XCMFS * ZTMP1_DEVICE(:,:,:) * ZTMP4_DEVICE(:,:,:) / ZTMP2_DEVICE(:,:,:)**2
#else
-ZA(:,:,:) = - PTSTEP * XCMFS * ZTMP1_DEVICE(:,:,:) * ZTMP4_DEVICE(:,:,:) / BR_P2(ZTMP2_DEVICE(:,:,:))
+!$acc loop independent collapse(3)
+DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZA(JI,JJ,JK) = - PTSTEP * XCMFS * ZTMP1_DEVICE(JI,JJ,JK) * ZTMP4_DEVICE(JI,JJ,JK) / BR_P2(ZTMP2_DEVICE(JI,JJ,JK))
+END DO
#endif
#endif
!
@@ -1040,21 +1125,31 @@ ZA(:,:,:) = - PTSTEP * XCMFS * ZTMP1_DEVICE(:,:,:) * ZTMP4_DEVICE(:,:,:) / BR
! wind following the slope
#ifndef MNH_BITREP
ZCOEFFLXU(:,:,1) = PCDUEFF(:,:) * (PDIRCOSZW(:,:)**2 - ZDIRSINZW(:,:)**2) &
+ * PSINSLOPE(:,:)
#else
-ZCOEFFLXU(:,:,1) = PCDUEFF(:,:) * (BR_P2(PDIRCOSZW(:,:)) - BR_P2(ZDIRSINZW(:,:))) &
+!$acc loop independent collapse(2)
+DO CONCURRENT ( JI=1:JIU,JJ=1:JJU )
+ZCOEFFLXU(JI,JJ,1) = PCDUEFF(JI,JJ) * (BR_P2(PDIRCOSZW(JI,JJ)) - BR_P2(ZDIRSINZW(JI,JJ))) &
+ * PSINSLOPE(JI,JJ)
+END DO
#endif
- * PSINSLOPE(:,:)
ZCOEFFLXV(:,:,1) = PCDUEFF(:,:) * PDIRCOSZW(:,:) * PCOSSLOPE(:,:)
! prepare the implicit scheme coefficients for the surface flux
-ZCOEFS(:,:,1)= ZCOEFFLXU(:,:,1) * PSINSLOPE(:,:) * PDIRCOSZW(:,:) &
- +ZCOEFFLXV(:,:,1) * PCOSSLOPE(:,:)
+!$acc loop independent collapse(2)
+DO CONCURRENT ( JI=1:JIU,JJ=1:JJU )
+ZCOEFS(JI,JJ,1)= ZCOEFFLXU(JI,JJ,1) * PSINSLOPE(JI,JJ) * PDIRCOSZW(JI,JJ) &
+ +ZCOEFFLXV(JI,JJ,1) * PCOSSLOPE(JI,JJ)
+END DO
!
! average this flux to be located at the V,W vorticity point
#ifndef MNH_OPENACC
ZCOEFS(:,:,1:1)=MYM(ZCOEFS(:,:,1:1) / PDZZ(:,:,IKB:IKB) )
#else
-ZTMP1_DEVICE(:,:,1:1) = ZCOEFS(:,:,1:1) / PDZZ(:,:,IKB:IKB)
+!$acc loop independent collapse(2)
+DO CONCURRENT ( JI=1:JIU,JJ=1:JJU )
+ ZTMP1_DEVICE(JI,JJ,1) = ZCOEFS(JI,JJ,1) / PDZZ(JI,JJ,IKB)
+END DO
!$acc end kernels
CALL MYM_DEVICE(ZTMP1_DEVICE(:,:,1:1),ZCOEFS(:,:,1:1) )
#endif
@@ -1157,13 +1252,19 @@ ZFLXZ(:,:,IKB:IKB) = MYM(PDZZ(:,:,IKB:IKB)) * &
) / 0.5 / ( 1. + MYM(PRHODJ(:,:,KKA:KKA)) / MYM(PRHODJ(:,:,IKB:IKB)) )
#else
!$acc kernels
-ZTMP1_DEVICE(:,:,:) = PIMPL*ZRES(:,:,:) + PEXPL*PVM(:,:,:)
+!$acc loop independent collapse(3)
+DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP1_DEVICE(JI,JJ,JK) = PIMPL*ZRES(JI,JJ,JK) + PEXPL*PVM(JI,JJ,JK)
+END DO
!$acc end kernels
CALL DZM_DEVICE(KKA,KKU,KKL,ZTMP1_DEVICE,ZTMP2_DEVICE)
CALL MYM_DEVICE(PDZZ,ZTMP3_DEVICE)
CALL MYM_DEVICE(ZKEFF,ZTMP1_DEVICE)
!$acc kernels
-ZFLXZ(:,:,:) = -XCMFS * ZTMP1_DEVICE(:,:,:) * ZTMP2_DEVICE(:,:,:) / ZTMP3_DEVICE(:,:,:)
+!$acc loop independent collapse(3)
+DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZFLXZ(JI,JJ,JK) = -XCMFS * ZTMP1_DEVICE(JI,JJ,JK) * ZTMP2_DEVICE(JI,JJ,JK) / ZTMP3_DEVICE(JI,JJ,JK)
+END DO
!$acc end kernels
!
CALL MYM_DEVICE(PDZZ(:,:,IKB:IKB),ZTMP1_DEVICE(:,:,1:1))
@@ -1216,12 +1317,18 @@ ZA(:,:,:) = - MZF( MYF ( ZFLXZ * GZ_V_VW(PVM,PDZZ) ) )
#else
CALL GZ_V_VW_DEVICE(KKA,KKU,KKL,PVM,PDZZ,ZTMP1_DEVICE)
!$acc kernels
-ZTMP2_DEVICE(:,:,:) = ZFLXZ(:,:,:) * ZTMP1_DEVICE(:,:,:)
+!$acc loop independent collapse(3)
+DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP2_DEVICE(JI,JJ,JK) = ZFLXZ(JI,JJ,JK) * ZTMP1_DEVICE(JI,JJ,JK)
+END DO
!$acc end kernels
CALL MYF_DEVICE( ZTMP2_DEVICE, ZTMP3_DEVICE )
CALL MZF_DEVICE(KKA,KKU,KKL, ZTMP3_DEVICE, ZTMP1_DEVICE )
!$acc kernels
-ZA(:,:,:) = - ZTMP1_DEVICE(:,:,:)
+!$acc loop independent collapse(3)
+DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZA(JI,JJ,JK) = - ZTMP1_DEVICE(JI,JJ,JK)
+END DO
!$acc end kernels
#endif
!
@@ -1311,26 +1418,41 @@ IF(HTURBDIM=='3DIM') THEN
#else
IF (.NOT. L2D) THEN
CALL MYM_DEVICE(PRHODJ,ZTMP1_DEVICE)
-!$acc kernels
- ZTMP2_DEVICE(:,:,:) = ZTMP1_DEVICE(:,:,:) /PDYY(:,:,:)
-!$acc end kernels
+ !$acc kernels
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP2_DEVICE(JI,JJ,JK) = ZTMP1_DEVICE(JI,JJ,JK) /PDYY(JI,JJ,JK)
+ END DO
+ !$acc end kernels
CALL MZM_DEVICE(ZTMP2_DEVICE,ZTMP1_DEVICE)
-!$acc kernels
- ZTMP2_DEVICE(:,:,:) = ZTMP1_DEVICE(:,:,:) * ZFLXZ(:,:,:)
-!$acc end kernels
+ !$acc kernels
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP2_DEVICE(JI,JJ,JK) = ZTMP1_DEVICE(JI,JJ,JK) * ZFLXZ(JI,JJ,JK)
+ END DO
+ !$acc end kernels
CALL DYF_DEVICE( ZTMP2_DEVICE,ZTMP1_DEVICE )
IF (.NOT. LFLAT) THEN
CALL MZF_DEVICE(KKA,KKU,KKL,PDZZ,ZTMP2_DEVICE )
!$acc kernels
- ZTMP3_DEVICE(:,:,:) = ZFLXZ(:,:,:)*PDZY(:,:,:)
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP3_DEVICE(JI,JJ,JK) = ZFLXZ(JI,JJ,JK)*PDZY(JI,JJ,JK)
+ END DO
!$acc end kernels
CALL MZF_DEVICE(KKA,KKU,KKL,ZTMP3_DEVICE,ZTMP4_DEVICE)
!$acc kernels
- ZTMP3_DEVICE(:,:,:) = ZTMP4_DEVICE(:,:,:) / PDYY(:,:,:)
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP3_DEVICE(JI,JJ,JK) = ZTMP4_DEVICE(JI,JJ,JK) / PDYY(JI,JJ,JK)
+ END DO
!$acc end kernels
CALL MYF_DEVICE(ZTMP3_DEVICE,ZTMP4_DEVICE)
!$acc kernels
- ZTMP3_DEVICE(:,:,:) = PRHODJ(:,:,:) / ZTMP2_DEVICE(:,:,:) * ZTMP4_DEVICE(:,:,:)
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP3_DEVICE(JI,JJ,JK) = PRHODJ(JI,JJ,JK) / ZTMP2_DEVICE(JI,JJ,JK) * ZTMP4_DEVICE(JI,JJ,JK)
+ END DO
!$acc end kernels
CALL DZM_DEVICE(KKA,KKU,KKL,ZTMP3_DEVICE, ZTMP4_DEVICE)
!$acc kernels
@@ -1350,14 +1472,20 @@ IF(HTURBDIM=='3DIM') THEN
ZA(:,:,:) = - MZF( MYF ( ZFLXZ(:,:,:) * GY_W_VW( PWM,PDYY,PDZZ,PDZY) ) )
#else
CALL GY_W_VW_DEVICE(KKA,KKU,KKL, PWM,PDYY,PDZZ,PDZY,ZTMP1_DEVICE)
-!$acc kernels
- ZTMP2_DEVICE(:,:,:) = ZFLXZ(:,:,:) * ZTMP1_DEVICE(:,:,:)
-!$acc end kernels
+ !$acc kernels
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP2_DEVICE(JI,JJ,JK) = ZFLXZ(JI,JJ,JK) * ZTMP1_DEVICE(JI,JJ,JK)
+ END DO
+ !$acc end kernels
CALL MYF_DEVICE(ZTMP2_DEVICE,ZTMP1_DEVICE)
CALL MZF_DEVICE(KKA,KKU,KKL,ZTMP1_DEVICE,ZTMP2_DEVICE )
-!$acc kernels
- ZA(:,:,:) = - ZTMP2_DEVICE(:,:,:)
-!$acc end kernels
+ !$acc kernels
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZA(JI,JJ,JK) = - ZTMP2_DEVICE(JI,JJ,JK)
+ END DO
+ !$acc end kernels
#endif
!
! evaluate the dynamic production at w(IKB+KKL) in PDP(IKB)
@@ -1508,6 +1636,12 @@ end if
!$acc end data
+#ifndef MNH_OPENACC
+deallocate (zdirsinzw,zcoefs,za,zres,zflxz,zsource,zkeff,zcoefflxu,zcoefflxv,zuslopem,zvslopem)
+#else
+CALL MNH_REL_ZT3D(izdirsinzw,izcoefs,iza,izres,izflxz,izsource,izkeff,izcoefflxu,izcoefflxv,izuslopem,izvslopem,&
+ iztmp1_device,iztmp2_device,iztmp3_device,iztmp4_device)
+#endif
!$acc end data
!----------------------------------------------------------------------------
diff --git a/src/MNH/turb_ver_thermo_corr.f90 b/src/MNH/turb_ver_thermo_corr.f90
index 0bbbd7f376613bd879e944eb7b711635984260e9..4b7898b182b55adf67b9bd362f63d30c1f609354 100644
--- a/src/MNH/turb_ver_thermo_corr.f90
+++ b/src/MNH/turb_ver_thermo_corr.f90
@@ -317,6 +317,10 @@ USE MODI_SECOND_MNH
USE MODI_BITREP
#endif
!
+#ifdef MNH_OPENACC
+USE MODE_MNH_ZWORK , ONLY : MNH_ALLOCATE_ZT3D , MNH_REL_ZT3D, MNH_ALLOCATE_GT3D , MNH_REL_GT3D , MNH_ALLOCATE_ZT3DP
+#endif
+
IMPLICIT NONE
!
!* 0.1 declarations of arguments
@@ -380,18 +384,24 @@ REAL, DIMENSION(:,:,:), INTENT(OUT) :: PSIGS ! Vert. part of Sigma_s at
!* 0.2 declaration of local variables
!
!
-REAL, DIMENSION(:,:,:), allocatable :: &
+REAL, DIMENSION(:,:,:), pointer , contiguous :: &
ZFLXZ, & ! vertical flux of the treated variable
ZKEFF, & ! effectif diffusion coeff = LT * SQRT( TKE )
ZF, & ! Flux in dTh/dt =-dF/dz (evaluated at t-1)(or rt instead of Th)
ZDFDDTDZ, & ! dF/d(dTh/dz)
ZDFDDRDZ ! dF/d(dr/dz)
+#ifdef MNH_OPENACC
+INTEGER :: IZFLXZ,IZKEFF,IZF,IZDFDDTDZ,IZDFDDRDZ
+#endif
INTEGER :: IKB,IKE ! I index values for the Beginning and End
! mass points of the domain in the 3 direct.
INTEGER :: I1,I2 ! For ZCOEFF allocation
-REAL, DIMENSION(:,:,:),ALLOCATABLE :: ZCOEFF
+REAL, DIMENSION(:,:,:),POINTER , CONTIGUOUS :: ZCOEFF
! coefficients for the uncentred gradient
! computation near the ground
+#ifdef MNH_OPENACC
+INTEGER :: IZCOEFF
+#endif
!
REAL :: ZTIME1, ZTIME2
!
@@ -403,10 +413,15 @@ LOGICAL :: GFWR ! flag to use w'2r'
LOGICAL :: GFTHR ! flag to use w'th'r'
!
#ifdef MNH_OPENACC
-REAL, DIMENSION(:,:,:), allocatable :: ZTMP1_DEVICE,ZTMP2_DEVICE,ZTMP3_DEVICE,ZTMP4_DEVICE
-REAL, DIMENSION(:,:,:), allocatable :: ZTMP5_DEVICE,ZTMP6_DEVICE,ZTMP7_DEVICE,ZTMP8_DEVICE
+REAL, DIMENSION(:,:,:), pointer , contiguous :: ZTMP1_DEVICE,ZTMP2_DEVICE,ZTMP3_DEVICE,ZTMP4_DEVICE
+REAL, DIMENSION(:,:,:), pointer , contiguous :: ZTMP5_DEVICE,ZTMP6_DEVICE,ZTMP7_DEVICE,ZTMP8_DEVICE
+INTEGER :: IZTMP1_DEVICE,IZTMP2_DEVICE,IZTMP3_DEVICE,IZTMP4_DEVICE
+INTEGER :: IZTMP5_DEVICE,IZTMP6_DEVICE,IZTMP7_DEVICE,IZTMP8_DEVICE
#endif
TYPE(TFIELDDATA) :: TZFIELD
+!
+INTEGER :: JIU,JJU,JKU
+INTEGER :: JI,JJ,JK
!----------------------------------------------------------------------------
!$acc data present( PDZZ, &
@@ -462,26 +477,41 @@ IKE=KKU-JPVEXT_TURB*KKL
I1=MIN(KKA+JPVEXT_TURB*KKL,KKA+JPVEXT_TURB*KKL+2*KKL)
I2=MAX(KKA+JPVEXT_TURB*KKL,KKA+JPVEXT_TURB*KKL+2*KKL)
-allocate( zflxz (size( pthlm, 1 ), size( pthlm, 2 ), size( pthlm, 3 ) ) )
-allocate( zkeff (size( pthlm, 1 ), size( pthlm, 2 ), size( pthlm, 3 ) ) )
-allocate( zf (size( pthlm, 1 ), size( pthlm, 2 ), size( pthlm, 3 ) ) )
-allocate( zdfddtdz (size( pthlm, 1 ), size( pthlm, 2 ), size( pthlm, 3 ) ) )
-allocate( zdfddrdz (size( pthlm, 1 ), size( pthlm, 2 ), size( pthlm, 3 ) ) )
+JIU = size( pthlm, 1 )
+JJU = size( pthlm, 2 )
+JKU = size( pthlm, 3 )
+
+#ifndef MNH_OPENACC
+allocate( zflxz (JIU,JJU,JKU) )
+allocate( zkeff (JIU,JJU,JKU) )
+allocate( zf (JIU,JJU,JKU) )
+allocate( zdfddtdz (JIU,JJU,JKU) )
+allocate( zdfddrdz (JIU,JJU,JKU) )
+
+allocate( zcoeff(JIU,JJU, i1 : i2 ) )
+#else
+izflxz = MNH_ALLOCATE_ZT3D( zflxz ,JIU,JJU,JKU )
+izkeff = MNH_ALLOCATE_ZT3D( zkeff ,JIU,JJU,JKU )
+izf = MNH_ALLOCATE_ZT3D( zf ,JIU,JJU,JKU )
+izdfddtdz = MNH_ALLOCATE_ZT3D( zdfddtdz ,JIU,JJU,JKU )
+izdfddrdz = MNH_ALLOCATE_ZT3D( zdfddrdz ,JIU,JJU,JKU )
-allocate( zcoeff(size( pdzz, 1 ), size( pdzz, 2 ), i1 : i2 ) )
+izcoeff = MNH_ALLOCATE_ZT3DP( zcoeff,JIU,JJU, i1 , i2 )
+
+#endif
#ifdef MNH_OPENACC
-allocate( ztmp1_device(size( pthlm, 1 ), size( pthlm, 2 ), size( pthlm, 3 ) ) )
-allocate( ztmp2_device(size( pthlm, 1 ), size( pthlm, 2 ), size( pthlm, 3 ) ) )
-allocate( ztmp3_device(size( pthlm, 1 ), size( pthlm, 2 ), size( pthlm, 3 ) ) )
-allocate( ztmp4_device(size( pthlm, 1 ), size( pthlm, 2 ), size( pthlm, 3 ) ) )
-allocate( ztmp5_device(size( pthlm, 1 ), size( pthlm, 2 ), size( pthlm, 3 ) ) )
-allocate( ztmp6_device(size( pthlm, 1 ), size( pthlm, 2 ), size( pthlm, 3 ) ) )
-allocate( ztmp7_device(size( pthlm, 1 ), size( pthlm, 2 ), size( pthlm, 3 ) ) )
-allocate( ztmp8_device(size( pthlm, 1 ), size( pthlm, 2 ), size( pthlm, 3 ) ) )
+iztmp1_device = MNH_ALLOCATE_ZT3D( ztmp1_device,JIU,JJU,JKU )
+iztmp2_device = MNH_ALLOCATE_ZT3D( ztmp2_device,JIU,JJU,JKU )
+iztmp3_device = MNH_ALLOCATE_ZT3D( ztmp3_device,JIU,JJU,JKU )
+iztmp4_device = MNH_ALLOCATE_ZT3D( ztmp4_device,JIU,JJU,JKU )
+iztmp5_device = MNH_ALLOCATE_ZT3D( ztmp5_device,JIU,JJU,JKU )
+iztmp6_device = MNH_ALLOCATE_ZT3D( ztmp6_device,JIU,JJU,JKU )
+iztmp7_device = MNH_ALLOCATE_ZT3D( ztmp7_device,JIU,JJU,JKU )
+iztmp8_device = MNH_ALLOCATE_ZT3D( ztmp8_device,JIU,JJU,JKU )
#endif
-!$acc data create( zflxz, zkeff, zf, zdfddtdz, zdfddrdz, zcoeff, &
+!$acc data present( zflxz, zkeff, zf, zdfddtdz, zdfddrdz, zcoeff, &
!$acc & ztmp1_device, ztmp2_device, ztmp3_device, ztmp4_device, &
!$acc & ztmp5_device, ztmp6_device, ztmp7_device, ztmp8_device )
@@ -542,13 +572,19 @@ END IF
#ifndef MNH_BITREP
ZTMP1_DEVICE(:,:,:) = PPHI3(:,:,:)*PDTH_DZ(:,:,:)**2
#else
- ZTMP1_DEVICE(:,:,:) = PPHI3(:,:,:)*BR_P2(PDTH_DZ(:,:,:))
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP1_DEVICE(JI,JJ,JK) = PPHI3(JI,JJ,JK)*BR_P2(PDTH_DZ(JI,JJ,JK))
+ END DO
#endif
!$acc end kernels
CALL MZF_DEVICE(KKA,KKU,KKL,ZTMP1_DEVICE(:,:,:),ZTMP2_DEVICE(:,:,:))
!$acc kernels
- ZF (:,:,:) = XCTV*PLM(:,:,:)*PLEPS(:,:,:)*ZTMP2_DEVICE(:,:,:)
- ZDFDDTDZ(:,:,:) = 0. ! this term, because of discretization, is treated separately
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZF (JI,JJ,JK) = XCTV*PLM(JI,JJ,JK)*PLEPS(JI,JJ,JK)*ZTMP2_DEVICE(JI,JJ,JK)
+ END DO
+ ZDFDDTDZ(:,:,:) = 0. ! this term, because of discretization, is treated separately
!$acc end kernels
#endif
!
@@ -681,14 +717,23 @@ END IF
! *DZM(PTHLP(:,:,:) - PTHLM(:,:,:)) / PDZZ(:,:,:) ) &
+ PIMPL * ZDFDDTDZ(:,:,:) * MZF(DZM(PTHLP(:,:,:) - PTHLM(:,:,:)) / PDZZ(:,:,:) )
#else
+ !$acc kernels
ZTMP1_DEVICE(:,:,:) = PTHLP(:,:,:) - PTHLM(:,:,:)
+ !$acc end kernels
CALL DZM_DEVICE(KKA,KKU,KKL,ZTMP1_DEVICE(:,:,:),ZTMP2_DEVICE(:,:,:))
- ZTMP3_DEVICE(:,:,:) = ZTMP2_DEVICE(:,:,:) / PDZZ(:,:,:)
+ !$acc kernels
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP3_DEVICE(JI,JJ,JK) = ZTMP2_DEVICE(JI,JJ,JK) / PDZZ(JI,JJ,JK)
+ END DO
+ !$acc end kernels
CALL MZF_DEVICE(KKA,KKU,KKL,ZTMP3_DEVICE(:,:,:),ZTMP4_DEVICE(:,:,:) )
-
-!$acc kernels
- ZFLXZ(:,:,:) = ZF(:,:,:) &
- + PIMPL * ZDFDDTDZ(:,:,:) * ZTMP4_DEVICE(:,:,:)
+ !$acc kernels
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZFLXZ(JI,JJ,JK) = ZF(JI,JJ,JK) &
+ + PIMPL * ZDFDDTDZ(JI,JJ,JK) * ZTMP4_DEVICE(JI,JJ,JK)
+ END DO
#endif
!
! special case near the ground ( uncentred gradient )
@@ -705,17 +750,20 @@ END IF
+ZCOEFF(:,:,IKB )*PTHLP(:,:,IKB ) )**2 &
)
#else
- ZFLXZ(:,:,IKB) = XCTV * PPHI3(:,:,IKB+KKL) * PLM(:,:,IKB) &
- * PLEPS(:,:,IKB) &
+ !$acc loop independent collapse(2)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU )
+ ZFLXZ(JI,JJ,IKB) = XCTV * PPHI3(JI,JJ,IKB+KKL) * PLM(JI,JJ,IKB) &
+ * PLEPS(JI,JJ,IKB) &
*( PEXPL * &
- BR_P2( ZCOEFF(:,:,IKB+2*KKL)*PTHLM(:,:,IKB+2*KKL) &
- +ZCOEFF(:,:,IKB+KKL )*PTHLM(:,:,IKB+KKL ) &
- +ZCOEFF(:,:,IKB )*PTHLM(:,:,IKB ) ) &
+ BR_P2( ZCOEFF(JI,JJ,IKB+2*KKL)*PTHLM(JI,JJ,IKB+2*KKL) &
+ +ZCOEFF(JI,JJ,IKB+KKL )*PTHLM(JI,JJ,IKB+KKL ) &
+ +ZCOEFF(JI,JJ,IKB )*PTHLM(JI,JJ,IKB ) ) &
+PIMPL * &
- BR_P2( ZCOEFF(:,:,IKB+2*KKL)*PTHLP(:,:,IKB+2*KKL) &
- +ZCOEFF(:,:,IKB+KKL )*PTHLP(:,:,IKB+KKL ) &
- +ZCOEFF(:,:,IKB )*PTHLP(:,:,IKB ) ) &
- )
+ BR_P2( ZCOEFF(JI,JJ,IKB+2*KKL)*PTHLP(JI,JJ,IKB+2*KKL) &
+ +ZCOEFF(JI,JJ,IKB+KKL )*PTHLP(JI,JJ,IKB+KKL ) &
+ +ZCOEFF(JI,JJ,IKB )*PTHLP(JI,JJ,IKB ) ) &
+ )
+ END DO
#endif
!
ZFLXZ(:,:,KKA) = ZFLXZ(:,:,IKB)
@@ -804,8 +852,13 @@ END IF
!$acc end kernels
CALL MZF_DEVICE(KKA,KKU,KKL,ZTMP1_DEVICE(:,:,:),ZTMP2_DEVICE(:,:,:))
!$acc kernels
- ZF (:,:,:) = XCTV*PLM(:,:,:)*PLEPS(:,:,:)*ZTMP2_DEVICE(:,:,:)
+!$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZF (JI,JJ,JK) = XCTV*PLM(JI,JJ,JK)*PLEPS(JI,JJ,JK)*ZTMP2_DEVICE(JI,JJ,JK)
+ END DO
+!$acc end kernels
#endif
+!$acc kernels
ZDFDDTDZ(:,:,:) = 0. ! this term, because of discretization, is treated separately
ZDFDDRDZ(:,:,:) = 0. ! this term, because of discretization, is treated separately
!$acc end kernels
@@ -988,8 +1041,12 @@ END IF
CALL DZM_DEVICE(KKA,KKU,KKL,ZTMP1_DEVICE(:,:,:),ZTMP3_DEVICE(:,:,:))
CALL DZM_DEVICE(KKA,KKU,KKL,ZTMP2_DEVICE(:,:,:),ZTMP4_DEVICE(:,:,:))
!$acc kernels
- ZTMP1_DEVICE(:,:,:) = ZTMP3_DEVICE(:,:,:) / PDZZ(:,:,:)
- ZTMP2_DEVICE(:,:,:) = ZTMP4_DEVICE(:,:,:) / PDZZ(:,:,:)
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP1_DEVICE(JI,JJ,JK) = ZTMP3_DEVICE(JI,JJ,JK) / PDZZ(JI,JJ,JK)
+ ZTMP2_DEVICE(JI,JJ,JK) = ZTMP4_DEVICE(JI,JJ,JK) / PDZZ(JI,JJ,JK)
+ END DO
+
!$acc end kernels
CALL D_PHI3DTDZ_O_DDTDZ(PPHI3(:,:,:),PREDTH1(:,:,:),PREDR1(:,:,:),PRED2TH3(:,:,:),PRED2THR3(:,:,:), &
HTURBDIM,GUSERV,ZTMP3_DEVICE(:,:,:)) ! d(phi3*dthdz)/ddthdz term
@@ -1007,8 +1064,13 @@ END IF
CALL DZM_DEVICE(KKA,KKU,KKL,ZTMP8_DEVICE(:,:,:),ZTMP1_DEVICE(:,:,:))
!!!
!$acc kernels
- ZTMP7_DEVICE(:,:,:) = ( ZTMP3_DEVICE(:,:,:) + ZTMP4_DEVICE(:,:,:)) * PDR_DZ(:,:,:) * ZTMP2_DEVICE(:,:,:) / PDZZ(:,:,:) &
- + ( ZTMP5_DEVICE(:,:,:) + ZTMP6_DEVICE(:,:,:)) * PDTH_DZ(:,:,:) * ZTMP1_DEVICE(:,:,:) / PDZZ(:,:,:)
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP7_DEVICE(JI,JJ,JK) = ( ZTMP3_DEVICE(JI,JJ,JK) + ZTMP4_DEVICE(JI,JJ,JK)) * PDR_DZ(JI,JJ,JK) &
+ * ZTMP2_DEVICE(JI,JJ,JK) / PDZZ(JI,JJ,JK) &
+ + ( ZTMP5_DEVICE(JI,JJ,JK) + ZTMP6_DEVICE(JI,JJ,JK)) * PDTH_DZ(JI,JJ,JK) &
+ * ZTMP1_DEVICE(JI,JJ,JK) / PDZZ(JI,JJ,JK)
+ END DO
!$acc end kernels
!!!
!$acc kernels
@@ -1018,38 +1080,47 @@ END IF
CALL DZM_DEVICE(KKA,KKU,KKL,ZTMP1_DEVICE(:,:,:),ZTMP3_DEVICE(:,:,:))
CALL DZM_DEVICE(KKA,KKU,KKL,ZTMP2_DEVICE(:,:,:),ZTMP4_DEVICE(:,:,:))
!$acc kernels
- ZTMP1_DEVICE(:,:,:) = ZTMP3_DEVICE(:,:,:) / PDZZ(:,:,:)
- ZTMP2_DEVICE(:,:,:) = ZTMP4_DEVICE(:,:,:) /PDZZ(:,:,:)
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP1_DEVICE(JI,JJ,JK) = ZTMP3_DEVICE(JI,JJ,JK) / PDZZ(JI,JJ,JK)
+ ZTMP2_DEVICE(JI,JJ,JK) = ZTMP4_DEVICE(JI,JJ,JK) /PDZZ(JI,JJ,JK)
+ END DO
!$acc end kernels
!!!
CALL MZF_DEVICE(KKA,KKU,KKL,ZTMP7_DEVICE(:,:,:),ZTMP3_DEVICE(:,:,:))
CALL MZF_DEVICE(KKA,KKU,KKL,ZTMP1_DEVICE(:,:,:), ZTMP4_DEVICE(:,:,:) )
CALL MZF_DEVICE(KKA,KKU,KKL,ZTMP2_DEVICE(:,:,:), ZTMP5_DEVICE(:,:,:) )
!$acc kernels
- ZFLXZ(:,:,:) = ZF(:,:,:) &
- + PIMPL * XCTV*PLM(:,:,:)*PLEPS(:,:,:)*0.5 * ZTMP3_DEVICE(:,:,:) &
- + PIMPL * ZDFDDTDZ(:,:,:) * ZTMP4_DEVICE(:,:,:) &
- + PIMPL * ZDFDDRDZ(:,:,:) * ZTMP5_DEVICE(:,:,:)
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZFLXZ(JI,JJ,JK) = ZF(JI,JJ,JK) &
+ + PIMPL * XCTV*PLM(JI,JJ,JK)*PLEPS(JI,JJ,JK)*0.5 * ZTMP3_DEVICE(JI,JJ,JK) &
+ + PIMPL * ZDFDDTDZ(JI,JJ,JK) * ZTMP4_DEVICE(JI,JJ,JK) &
+ + PIMPL * ZDFDDRDZ(JI,JJ,JK) * ZTMP5_DEVICE(JI,JJ,JK)
+ END DO
#endif
!
! special case near the ground ( uncentred gradient )
- ZFLXZ(:,:,IKB) = &
- (XCHT1 * PPHI3(:,:,IKB+KKL) + XCHT2 * PPSI3(:,:,IKB+KKL)) &
+ !$acc loop independent collapse(2)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU )
+ ZFLXZ(JI,JJ,IKB) = &
+ (XCHT1 * PPHI3(JI,JJ,IKB+KKL) + XCHT2 * PPSI3(JI,JJ,IKB+KKL)) &
*( PEXPL * &
- ( ZCOEFF(:,:,IKB+2*KKL)*PTHLM(:,:,IKB+2*KKL) &
- +ZCOEFF(:,:,IKB+KKL )*PTHLM(:,:,IKB+KKL ) &
- +ZCOEFF(:,:,IKB )*PTHLM(:,:,IKB )) &
- *( ZCOEFF(:,:,IKB+2*KKL)*PRM(:,:,IKB+2*KKL,1) &
- +ZCOEFF(:,:,IKB+KKL )*PRM(:,:,IKB+KKL,1 ) &
- +ZCOEFF(:,:,IKB )*PRM(:,:,IKB ,1 )) &
+ ( ZCOEFF(JI,JJ,IKB+2*KKL)*PTHLM(JI,JJ,IKB+2*KKL) &
+ +ZCOEFF(JI,JJ,IKB+KKL )*PTHLM(JI,JJ,IKB+KKL ) &
+ +ZCOEFF(JI,JJ,IKB )*PTHLM(JI,JJ,IKB )) &
+ *( ZCOEFF(JI,JJ,IKB+2*KKL)*PRM(JI,JJ,IKB+2*KKL,1) &
+ +ZCOEFF(JI,JJ,IKB+KKL )*PRM(JI,JJ,IKB+KKL,1 ) &
+ +ZCOEFF(JI,JJ,IKB )*PRM(JI,JJ,IKB ,1 )) &
+PIMPL * &
- ( ZCOEFF(:,:,IKB+2*KKL)*PTHLP(:,:,IKB+2*KKL) &
- +ZCOEFF(:,:,IKB+KKL )*PTHLP(:,:,IKB+KKL ) &
- +ZCOEFF(:,:,IKB )*PTHLP(:,:,IKB )) &
- *( ZCOEFF(:,:,IKB+2*KKL)*PRP(:,:,IKB+2*KKL ) &
- +ZCOEFF(:,:,IKB+KKL )*PRP(:,:,IKB+KKL ) &
- +ZCOEFF(:,:,IKB )*PRP(:,:,IKB )) &
- )
+ ( ZCOEFF(JI,JJ,IKB+2*KKL)*PTHLP(JI,JJ,IKB+2*KKL) &
+ +ZCOEFF(JI,JJ,IKB+KKL )*PTHLP(JI,JJ,IKB+KKL ) &
+ +ZCOEFF(JI,JJ,IKB )*PTHLP(JI,JJ,IKB )) &
+ *( ZCOEFF(JI,JJ,IKB+2*KKL)*PRP(JI,JJ,IKB+2*KKL ) &
+ +ZCOEFF(JI,JJ,IKB+KKL )*PRP(JI,JJ,IKB+KKL ) &
+ +ZCOEFF(JI,JJ,IKB )*PRP(JI,JJ,IKB )) &
+ )
+ END DO
!
ZFLXZ(:,:,KKA) = ZFLXZ(:,:,IKB)
!
@@ -1145,12 +1216,18 @@ END IF
#ifndef MNH_BITREP
ZTMP1_DEVICE(:,:,:) = PPSI3(:,:,:)*PDR_DZ(:,:,:)**2
#else
- ZTMP1_DEVICE(:,:,:) = PPSI3(:,:,:)*BR_P2(PDR_DZ(:,:,:))
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP1_DEVICE(JI,JJ,JK) = PPSI3(JI,JJ,JK)*BR_P2(PDR_DZ(JI,JJ,JK))
+ END DO
#endif
!$acc end kernels
CALL MZF_DEVICE(KKA,KKU,KKL,ZTMP1_DEVICE(:,:,:),ZTMP2_DEVICE(:,:,:))
!$acc kernels
- ZF (:,:,:) = XCTV*PLM(:,:,:)*PLEPS(:,:,:)*ZTMP2_DEVICE(:,:,:)
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZF (JI,JJ,JK) = XCTV*PLM(JI,JJ,JK)*PLEPS(JI,JJ,JK)*ZTMP2_DEVICE(JI,JJ,JK)
+ END DO
#endif
ZDFDDRDZ(:,:,:) = 0. ! this term, because of discretization, is treated separately
!$acc end kernels
@@ -1293,17 +1370,26 @@ END IF
!$acc end kernels
CALL DZM_DEVICE(KKA,KKU,KKL,ZTMP2_DEVICE(:,:,:),ZTMP3_DEVICE(:,:,:))
!$acc kernels
- ZTMP2_DEVICE(:,:,:) = ZTMP1_DEVICE(:,:,:) * ZTMP3_DEVICE(:,:,:) / PDZZ(:,:,:)
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP2_DEVICE(JI,JJ,JK) = ZTMP1_DEVICE(JI,JJ,JK) * ZTMP3_DEVICE(JI,JJ,JK) / PDZZ(JI,JJ,JK)
+ END DO
!$acc end kernels
CALL MZF_DEVICE(KKA,KKU,KKL,ZTMP2_DEVICE(:,:,:),ZTMP1_DEVICE(:,:,:))
!$acc kernels
- ZTMP2_DEVICE(:,:,:) = ZTMP3_DEVICE(:,:,:) / PDZZ(:,:,:)
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP2_DEVICE(JI,JJ,JK) = ZTMP3_DEVICE(JI,JJ,JK) / PDZZ(JI,JJ,JK)
+ END DO
!$acc end kernels
CALL MZF_DEVICE(KKA,KKU,KKL,ZTMP2_DEVICE(:,:,:),ZTMP3_DEVICE(:,:,:))
!$acc kernels
- ZFLXZ(:,:,:) = ZF(:,:,:) &
- + PIMPL * XCTV*PLM(:,:,:)*PLEPS(:,:,:) * ZTMP1_DEVICE(:,:,:) &
- + PIMPL * ZDFDDRDZ(:,:,:) * ZTMP3_DEVICE(:,:,:)
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZFLXZ(JI,JJ,JK) = ZF(JI,JJ,JK) &
+ + PIMPL * XCTV*PLM(JI,JJ,JK)*PLEPS(JI,JJ,JK) * ZTMP1_DEVICE(JI,JJ,JK) &
+ + PIMPL * ZDFDDRDZ(JI,JJ,JK) * ZTMP3_DEVICE(JI,JJ,JK)
+ END DO
#endif
!
! special case near the ground ( uncentred gradient )
@@ -1320,17 +1406,20 @@ END IF
+ZCOEFF(:,:,IKB )*PRP(:,:,IKB ))**2 &
)
#else
- ZFLXZ(:,:,IKB) = XCHV * PPSI3(:,:,IKB+KKL) * PLM(:,:,IKB) &
- * PLEPS(:,:,IKB) &
+ !$acc loop independent collapse(2)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU )
+ ZFLXZ(JI,JJ,IKB) = XCHV * PPSI3(JI,JJ,IKB+KKL) * PLM(JI,JJ,IKB) &
+ * PLEPS(JI,JJ,IKB) &
*( PEXPL * &
- BR_P2( ZCOEFF(:,:,IKB+2*KKL)*PRM(:,:,IKB+2*KKL,1) &
- +ZCOEFF(:,:,IKB+KKL )*PRM(:,:,IKB+KKL,1 ) &
- +ZCOEFF(:,:,IKB )*PRM(:,:,IKB ,1 )) &
+ BR_P2( ZCOEFF(JI,JJ,IKB+2*KKL)*PRM(JI,JJ,IKB+2*KKL,1) &
+ +ZCOEFF(JI,JJ,IKB+KKL )*PRM(JI,JJ,IKB+KKL,1 ) &
+ +ZCOEFF(JI,JJ,IKB )*PRM(JI,JJ,IKB ,1 )) &
+PIMPL * &
- BR_P2( ZCOEFF(:,:,IKB+2*KKL)*PRP(:,:,IKB+2*KKL) &
- +ZCOEFF(:,:,IKB+KKL )*PRP(:,:,IKB+KKL ) &
- +ZCOEFF(:,:,IKB )*PRP(:,:,IKB )) &
- )
+ BR_P2( ZCOEFF(JI,JJ,IKB+2*KKL)*PRP(JI,JJ,IKB+2*KKL) &
+ +ZCOEFF(JI,JJ,IKB+KKL )*PRP(JI,JJ,IKB+KKL ) &
+ +ZCOEFF(JI,JJ,IKB )*PRP(JI,JJ,IKB )) &
+ )
+ END DO
#endif
!
ZFLXZ(:,:,KKA) = ZFLXZ(:,:,IKB)
@@ -1415,6 +1504,14 @@ end if
!$acc end data
+#ifndef MNH_OPENACC
+deallocate( zflxz, zkeff, zf , zdfddtdz , zdfddrdz , zcoeff )
+#else
+CALL MNH_REL_ZT3D(IZFLXZ,IZKEFF,IZF,IZDFDDTDZ,IZDFDDRDZ,IZCOEFF,&
+ IZTMP1_DEVICE,IZTMP2_DEVICE,IZTMP3_DEVICE,IZTMP4_DEVICE,&
+ IZTMP5_DEVICE,IZTMP6_DEVICE,IZTMP7_DEVICE,IZTMP8_DEVICE )
+#endif
+
!$acc end data
!----------------------------------------------------------------------------
diff --git a/src/MNH/turb_ver_thermo_flux.f90 b/src/MNH/turb_ver_thermo_flux.f90
index b67905978d035d03cdaedef696926cb914efd9cf..e79a2a5d6b840d76c29be310e9311af453d98de0 100644
--- a/src/MNH/turb_ver_thermo_flux.f90
+++ b/src/MNH/turb_ver_thermo_flux.f90
@@ -375,6 +375,10 @@ USE MODE_PRANDTL
!
USE MODI_SECOND_MNH
!
+#ifdef MNH_OPENACC
+USE MODE_MNH_ZWORK , ONLY : MNH_ALLOCATE_ZT3D , MNH_REL_ZT3D, MNH_ALLOCATE_GT3D , MNH_REL_GT3D
+#endif
+
IMPLICIT NONE
!
!* 0.1 declarations of arguments
@@ -502,7 +506,7 @@ LOGICAL :: GFR2 ! flag to use w'r'2
LOGICAL :: GFWR ! flag to use w'2r'
LOGICAL :: GFTHR ! flag to use w'th'r'
!
-REAL, DIMENSION(:,:,:), allocatable :: &
+REAL, DIMENSION(:,:,:), pointer , contiguous :: &
ZA, & ! work variable for wrc or LES computation
ZFLXZ, & ! vertical flux of the treated variable
ZSOURCE, & ! source of evolution for the treated variable
@@ -510,16 +514,23 @@ REAL, DIMENSION(:,:,:), allocatable :: &
ZF, & ! Flux in dTh/dt =-dF/dz (evaluated at t-1)(or rt instead of Th)
ZDFDDTDZ, & ! dF/d(dTh/dz)
ZDFDDRDZ, & ! dF/d(dr/dz)
- Z3RDMOMENT, & ! 3 order term in flux or variance equation
+ Z3RDMOMENT, & ! 3 order term in flux or variance equation
ZF_NEW, &
ZRWTHL, &
ZRWRNP, &
ZCLD_THOLD
-REAL, DIMENSION(:,:,:), allocatable :: ZALT
+REAL, DIMENSION(:,:,:), pointer , contiguous :: ZALT
+#ifdef MNH_OPENACC
+INTEGER :: IZA, IZFLXZ, IZSOURCE, IZKEFF, IZF, IZDFDDTDZ, IZDFDDRDZ, IZ3RDMOMENT, IZF_NEW, IZRWTHL, IZRWRNP, IZCLD_THOLD, IZALT
+#endif
#ifdef MNH_OPENACC
-REAL, DIMENSION(:,:,:), allocatable :: ZTMP1_DEVICE,ZTMP2_DEVICE,ZTMP3_DEVICE,ZTMP4_DEVICE
+REAL, DIMENSION(:,:,:), pointer , contiguous :: ZTMP1_DEVICE,ZTMP2_DEVICE,ZTMP3_DEVICE,ZTMP4_DEVICE
+INTEGER :: IZTMP1_DEVICE,IZTMP2_DEVICE,IZTMP3_DEVICE,IZTMP4_DEVICE
#endif
TYPE(TFIELDDATA) :: TZFIELD
+
+INTEGER :: JIU,JJU,JKU
+
!----------------------------------------------------------------------------
!$acc data present( PDZZ, PDIRCOSZW, PZZ, &
@@ -581,31 +592,50 @@ if ( mppdb_initialized ) then
call Mppdb_check( prrs, "Turb_ver_thermo_flux beg:prrs" )
end if
-allocate( za (size( pthlm, 1 ), size( pthlm, 2 ), size( pthlm, 3 ) ) )
-allocate( zflxz (size( pthlm, 1 ), size( pthlm, 2 ), size( pthlm, 3 ) ) )
-allocate( zsource (size( pthlm, 1 ), size( pthlm, 2 ), size( pthlm, 3 ) ) )
-allocate( zkeff (size( pthlm, 1 ), size( pthlm, 2 ), size( pthlm, 3 ) ) )
-allocate( zf (size( pthlm, 1 ), size( pthlm, 2 ), size( pthlm, 3 ) ) )
-allocate( zdfddtdz (size( pthlm, 1 ), size( pthlm, 2 ), size( pthlm, 3 ) ) )
-allocate( zdfddrdz (size( pthlm, 1 ), size( pthlm, 2 ), size( pthlm, 3 ) ) )
-allocate( z3rdmoment(size( pthlm, 1 ), size( pthlm, 2 ), size( pthlm, 3 ) ) )
-allocate( ZF_NEW (size( pthlm, 1 ), size( pthlm, 2 ), size( pthlm, 3 ) ) )
-allocate( ZRWTHL (size( pthlm, 1 ), size( pthlm, 2 ), size( pthlm, 3 ) ) )
-allocate( ZRWRNP (size( pthlm, 1 ), size( pthlm, 2 ), size( pthlm, 3 ) ) )
-allocate( ZCLD_THOLD(size( pthlm, 1 ), size( pthlm, 2 ), size( pthlm, 3 ) ) )
+JIU = size( pthlm, 1 )
+JJU = size( pthlm, 2 )
+JKU = size( pthlm, 3 )
-Allocate( ZALT(Size( XZS, 1 ), Size( XZS, 2 ), KKU ) )
+#ifndef MNH_OPENACC
+allocate( za (JIU,JJU,JKU ) )
+allocate( zflxz (JIU,JJU,JKU ) )
+allocate( zsource (JIU,JJU,JKU ) )
+allocate( zkeff (JIU,JJU,JKU ) )
+allocate( zf (JIU,JJU,JKU ) )
+allocate( zdfddtdz (JIU,JJU,JKU ) )
+allocate( zdfddrdz (JIU,JJU,JKU ) )
+allocate( z3rdmoment(JIU,JJU,JKU ) )
+allocate( zf_new (JIU,JJU,JKU ) )
+allocate( zrwthl (JIU,JJU,JKU ) )
+allocate( zrwrnp (JIU,JJU,JKU ) )
+allocate( zcld_thold(JIU,JJU,JKU ) )
+allocate( zalt (JIU,JJU,JKU ) )
+#else
+iza = MNH_ALLOCATE_ZT3D( za ,JIU,JJU,JKU )
+izflxz = MNH_ALLOCATE_ZT3D( zflxz ,JIU,JJU,JKU )
+izsource = MNH_ALLOCATE_ZT3D( zsource ,JIU,JJU,JKU )
+izkeff = MNH_ALLOCATE_ZT3D( zkeff ,JIU,JJU,JKU )
+izf = MNH_ALLOCATE_ZT3D( zf ,JIU,JJU,JKU )
+izdfddtdz = MNH_ALLOCATE_ZT3D( zdfddtdz ,JIU,JJU,JKU )
+izdfddrdz = MNH_ALLOCATE_ZT3D( zdfddrdz ,JIU,JJU,JKU )
+iz3rdmoment = MNH_ALLOCATE_ZT3D( z3rdmoment,JIU,JJU,JKU )
+izf_new = MNH_ALLOCATE_ZT3D( zf_new ,JIU,JJU,JKU )
+izrwthl = MNH_ALLOCATE_ZT3D( zrwthl ,JIU,JJU,JKU )
+izrwrnp = MNH_ALLOCATE_ZT3D( zrwrnp ,JIU,JJU,JKU )
+izcld_thold = MNH_ALLOCATE_ZT3D( zcld_thold,JIU,JJU,JKU )
+izalt = MNH_ALLOCATE_ZT3D( zalt ,JIU,JJU,JKU )
+#endif
#ifdef MNH_OPENACC
-allocate( ztmp1_device(size( pthlm, 1 ), size( pthlm, 2 ), size( pthlm, 3 ) ) )
-allocate( ztmp2_device(size( pthlm, 1 ), size( pthlm, 2 ), size( pthlm, 3 ) ) )
-allocate( ztmp3_device(size( pthlm, 1 ), size( pthlm, 2 ), size( pthlm, 3 ) ) )
-allocate( ztmp4_device(size( pthlm, 1 ), size( pthlm, 2 ), size( pthlm, 3 ) ) )
+iztmp1_device = MNH_ALLOCATE_ZT3D( ztmp1_device,JIU,JJU,JKU )
+iztmp2_device = MNH_ALLOCATE_ZT3D( ztmp2_device,JIU,JJU,JKU )
+iztmp3_device = MNH_ALLOCATE_ZT3D( ztmp3_device,JIU,JJU,JKU )
+iztmp4_device = MNH_ALLOCATE_ZT3D( ztmp4_device,JIU,JJU,JKU )
#endif
-!$acc data create( ZA, ZFLXZ, ZSOURCE, ZKEFF, ZF, ZDFDDTDZ, ZDFDDRDZ, Z3RDMOMENT, &
-!$acc & ZF_NEW, ZRWTHL, ZRWRNP, ZCLD_THOLD, ZALT, &
-!$acc & ZTMP1_DEVICE, ZTMP2_DEVICE, ZTMP3_DEVICE, ZTMP4_DEVICE )
+!$acc data present( ZA, ZFLXZ, ZSOURCE, ZKEFF, ZF, ZDFDDTDZ, ZDFDDRDZ, Z3RDMOMENT, &
+!$acc & ZF_NEW, ZRWTHL, ZRWRNP, ZCLD_THOLD, ZALT, &
+!$acc & ZTMP1_DEVICE, ZTMP2_DEVICE, ZTMP3_DEVICE, ZTMP4_DEVICE )
!
!* 1. PRELIMINARIES
@@ -712,12 +742,18 @@ ZDFDDTDZ(:,:,:) = -XCSHF*ZKEFF(:,:,:)*D_PHI3DTDZ_O_DDTDZ(PPHI3,PREDTH1,PREDR1,PR
#else
CALL DZM_DEVICE(KKA,KKU,KKL,PTHLM,ZTMP1_DEVICE)
!$acc kernels
-ZF (:,:,:) = -XCSHF*PPHI3(:,:,:)*ZKEFF(:,:,:)*ZTMP1_DEVICE(:,:,:)/PDZZ(:,:,:)
+!$acc loop independent collapse(3)
+DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZF (JI,JJ,JK) = -XCSHF*PPHI3(JI,JJ,JK)*ZKEFF(JI,JJ,JK)*ZTMP1_DEVICE(JI,JJ,JK)/PDZZ(JI,JJ,JK)
+END DO
!$acc end kernels
!
CALL D_PHI3DTDZ_O_DDTDZ(PPHI3,PREDTH1,PREDR1,PRED2TH3,PRED2THR3,HTURBDIM,GUSERV,ZTMP2_DEVICE)
!$acc kernels
-ZDFDDTDZ(:,:,:) = -XCSHF*ZKEFF(:,:,:)*ZTMP2_DEVICE(:,:,:)
+!$acc loop independent collapse(3)
+DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZDFDDTDZ(JI,JJ,JK) = -XCSHF*ZKEFF(JI,JJ,JK)*ZTMP2_DEVICE(JI,JJ,JK)
+END DO
!$acc end kernels
#endif
!
@@ -937,7 +973,10 @@ ZTMP1_DEVICE(:,:,:) = PTHLP(:,:,:) - PTHLM(:,:,:)
!$acc end kernels
CALL DZM_DEVICE(KKA,KKU,KKL,ZTMP1_DEVICE,ZTMP2_DEVICE)
!$acc kernels
-ZFLXZ(:,:,:) = ZF(:,:,:) + PIMPL * ZDFDDTDZ(:,:,:) * ZTMP2_DEVICE(:,:,:) / PDZZ(:,:,:)
+!$acc loop independent collapse(3)
+DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZFLXZ(JI,JJ,JK) = ZF(JI,JJ,JK) + PIMPL * ZDFDDTDZ(JI,JJ,JK) * ZTMP2_DEVICE(JI,JJ,JK) / PDZZ(JI,JJ,JK)
+END DO
!$acc end kernels
#endif
! replace the flux by the Leonard terms
@@ -1006,7 +1045,10 @@ ELSE
IF (KRR /= 0) THEN
CALL MZM_DEVICE(PETHETA,ZTMP1_DEVICE)
!$acc kernels
- ZTMP2_DEVICE(:,:,:) = ZTMP1_DEVICE(:,:,:) * ZFLXZ(:,:,:)
+!$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP2_DEVICE(JI,JJ,JK) = ZTMP1_DEVICE(JI,JJ,JK) * ZFLXZ(JI,JJ,JK)
+ END DO
!$acc end kernels
CALL MZF_DEVICE(KKA,KKU,KKL, ZTMP2_DEVICE,ZTMP3_DEVICE)
!$acc kernels
@@ -1146,8 +1188,12 @@ IF (LLES_CALL) THEN
END IF
!* diagnostic of mixing coefficient for heat
CALL DZM_DEVICE(KKA,KKU,KKL,PTHLP,ZA)
-!$acc kernels
- WHERE (ZA(:,:,:)==0.) ZA(:,:,:)=1.E-6
+ !$acc kernels
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ IF (ZA(JI,JJ,JK)==0.) THEN
+ ZA(JI,JJ,JK)=1.E-6
+ END IF
+ END DO
ZA(:,:,:) = - ZFLXZ(:,:,:) / ZA(:,:,:) * PDZZ(:,:,:)
ZA(:,:,IKB) = XCSHF*PPHI3(:,:,IKB)*ZKEFF(:,:,IKB)
!Copy ZA into ZTMP1_DEVICE to prevent aliasing in the following call to MZF_DEVICE
@@ -1188,12 +1234,18 @@ IF (KRR /= 0) THEN
#else
CALL DZM_DEVICE(KKA,KKU,KKL,PRM(:,:,:,1),ZTMP1_DEVICE)
!$acc kernels
- ZF (:,:,:) = -XCSHF*PPSI3(:,:,:)*ZKEFF(:,:,:)*ZTMP1_DEVICE(:,:,:)/PDZZ(:,:,:)
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZF (JI,JJ,JK) = -XCSHF*PPSI3(JI,JJ,JK)*ZKEFF(JI,JJ,JK)*ZTMP1_DEVICE(JI,JJ,JK)/PDZZ(JI,JJ,JK)
+ END DO
!$acc end kernels
CALL D_PSI3DRDZ_O_DDRDZ(PPSI3,PREDR1,PREDTH1,PRED2R3,PRED2THR3,HTURBDIM,GUSERV,ZTMP1_DEVICE)
!CALL D_PHI3DRDZ_O_DDRDZ_DEVICE(PPSI3,PREDR1,PREDTH1,PRED2R3,PRED2THR3,HTURBDIM,GUSERV,ZTMP1_DEVICE)
!$acc kernels
- ZDFDDRDZ(:,:,:) = -XCSHF*ZKEFF(:,:,:)*ZTMP1_DEVICE(:,:,:)
+ !$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZDFDDRDZ(JI,JJ,JK) = -XCSHF*ZKEFF(JI,JJ,JK)*ZTMP1_DEVICE(JI,JJ,JK)
+ END DO
!$acc end kernels
#endif
!
@@ -1417,7 +1469,10 @@ IF (KRR /= 0) THEN
!$acc end kernels
CALL DZM_DEVICE(KKA,KKU,KKL,ZTMP1_DEVICE,ZTMP2_DEVICE)
!$acc kernels
- ZFLXZ(:,:,:) = ZF(:,:,:) + PIMPL * ZDFDDRDZ(:,:,:) *ZTMP2_DEVICE(:,:,:) / PDZZ(:,:,:)
+!$acc loop independent collapse(3)
+DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZFLXZ(JI,JJ,JK) = ZF(JI,JJ,JK) + PIMPL * ZDFDDRDZ(JI,JJ,JK) *ZTMP2_DEVICE(JI,JJ,JK) / PDZZ(JI,JJ,JK)
+END DO
!$acc end kernels
#endif
!
@@ -1475,11 +1530,17 @@ IF (KRR /= 0) THEN
#else
CALL MZM_DEVICE(PEMOIST,ZTMP1_DEVICE)
!$acc kernels
- ZTMP2_DEVICE(:,:,:) = ZTMP1_DEVICE(:,:,:) * ZFLXZ(:,:,:)
+!$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZTMP2_DEVICE(JI,JJ,JK) = ZTMP1_DEVICE(JI,JJ,JK) * ZFLXZ(JI,JJ,JK)
+ END DO
!$acc end kernels
CALL MZF_DEVICE(KKA,KKU,KKL, ZTMP2_DEVICE, ZTMP3_DEVICE )
!$acc kernels
- ZA(:,:,:) = PBETA(:,:,:) * ZTMP3_DEVICE(:,:,:)
+!$acc loop independent collapse(3)
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ ZA(JI,JJ,JK) = PBETA(JI,JJ,JK) * ZTMP3_DEVICE(JI,JJ,JK)
+ END DO
#endif
ZA(:,:,IKB) = PBETA(:,:,IKB) * PEMOIST(:,:,IKB) * &
0.5 * ( ZFLXZ (:,:,IKB) + ZFLXZ (:,:,IKB+KKL) )
@@ -1493,9 +1554,13 @@ IF (KRR /= 0) THEN
PWTHV = PWTHV + MZM(PEMOIST) * ZFLXZ
#else
CALL MZM_DEVICE(PEMOIST,ZTMP1_DEVICE)
-!$acc kernels
- PWTHV(:,:,:) = PWTHV(:,:,:) + ZTMP1_DEVICE * ZFLXZ
+ !$acc kernels
+ DO CONCURRENT ( JI=1:JIU,JJ=1:JJU,JK=1:JKU)
+ PWTHV(JI,JJ,JK) = PWTHV(JI,JJ,JK) + ZTMP1_DEVICE(JI,JJ,JK) * ZFLXZ(JI,JJ,JK)
+ END DO
+ !$acc end kernels
#endif
+ !$acc kernels
PWTHV(:,:,IKB) = PWTHV(:,:,IKB) + PEMOIST(:,:,IKB) * ZFLXZ(:,:,IKB)
!$acc end kernels
IF (LOCEAN) THEN
@@ -1714,6 +1779,14 @@ end if
!$acc end data
+#ifndef MNH_OPENACC
+Deallocate( za, zflxz, zsource, zkeff, zf, zdfddtdz, zdfddrdz, z3rdmoment, zf_new, zrwthl, zrwrnp, zcld_thold, zalt )
+#else
+CALL MNH_REL_ZT3D( IZA, IZFLXZ, IZSOURCE, IZKEFF, IZF, IZDFDDTDZ, IZDFDDRDZ, IZ3RDMOMENT, &
+ IZF_NEW, IZRWTHL, IZRWRNP, IZCLD_THOLD, IZALT, &
+ IZTMP1_DEVICE, IZTMP2_DEVICE, IZTMP3_DEVICE, IZTMP4_DEVICE )
+#endif
+
!$acc end data
!----------------------------------------------------------------------------
diff --git a/src/MNH/unpack_1d_2d.f90 b/src/MNH/unpack_1d_2d.f90
index ebfd7e2137bb83464cda4275e71a872d4ba7dfda..aa5f8d9a426c674d7eea29ec2800acbd017eef19 100644
--- a/src/MNH/unpack_1d_2d.f90
+++ b/src/MNH/unpack_1d_2d.f90
@@ -228,6 +228,7 @@ END SUBROUTINE UNPACK_1D_2D_FROML2D
!! MODIFICATIONS
!! -------------
!! Original 21/01/03
+!! J.Escobar 24/07/2020 : nvhpc20.5 BUG , reshape wrong without (:,:) in O2 ?!
!-------------------------------------------------------------------------------
!
!* 0. DECLARATIONS
@@ -261,7 +262,7 @@ DO JI=1,SIZE(P1D)
Z1D(KM(JI)) = P1D(JI)
ENDDO
!
-P2D=RESHAPE(Z1D, (/ SIZE(P2D,1), SIZE(P2D,2) /) )
+P2D(:,:)=RESHAPE(Z1D, (/ SIZE(P2D,1), SIZE(P2D,2) /) )
DEALLOCATE(Z1D)
!-------------------------------------------------------------------------------
!
diff --git a/src/MNH_OPENACC_SHUMAN_MACRO.CPP b/src/MNH_OPENACC_SHUMAN_MACRO.CPP
new file mode 100644
index 0000000000000000000000000000000000000000..bd89169588dc601d7e553790e384c7116cbbc9e6
--- /dev/null
+++ b/src/MNH_OPENACC_SHUMAN_MACRO.CPP
@@ -0,0 +1,12 @@
+#define MxF(PA) (0.5*(PA+EOSHIFT(PA,+1,DIM=1)))
+#define MxM(PA) (0.5*(PA+EOSHIFT(PA,-1,DIM=1)))
+#define MyF(PA) (0.5*(PA+EOSHIFT(PA,+1,DIM=2)))
+#define MyM(PA) (0.5*(PA+EOSHIFT(PA,-1,DIM=2)))
+#define MzF(PA) (0.5*(PA+EOSHIFT(PA,+1,DIM=3)))
+#define MzM(PA) (0.5*(PA+EOSHIFT(PA,-1,DIM=3)))
+#define DxF(PA) (EOSHIFT(PA,+1,DIM=1)-PA)
+#define DxM(PA) (PA-EOSHIFT(PA,-1,DIM=1))
+#define DyF(PA) (EOSHIFT(PA,+1,DIM=2)-PA)
+#define DyM(PA) (PA-EOSHIFT(PA,-1,DIM=2))
+#define DzF(PA) (EOSHIFT(PA,+1,DIM=3)-PA)
+#define DzM(PA) (PA-EOSHIFT(PA,-1,DIM=3))
diff --git a/src/Makefile b/src/Makefile
index 03c5d4492c4f7bc0cba2db78ed82a3ad46a152ae..796bcc55f18303c2f29b006dafd4cb06d182ea34 100644
--- a/src/Makefile
+++ b/src/Makefile
@@ -342,7 +342,7 @@ NETCDF_OPT ?= ${OPT_BASE_I4:-$OPT_BASE}
#
cdf : $(CDF_MOD)
$(CDF_MOD) :
- cd ${DIR_LIBAEC} && ./configure --disable-shared --prefix=${CDF_PATH} --libdir=${CDF_PATH}/lib64 CC="$(CC)" CFLAGS="$(HDF_OPT)" && \
+ cd ${DIR_LIBAEC} && ./configure --disable-shared --prefix=${CDF_PATH} --libdir=${CDF_PATH}/lib64 CC="$(CC)" CFLAGS="$(HDF_OPT)" ${CDF_CONF} && \
$(MAKE) && $(MAKE) install && $(MAKE) clean
cd ${DIR_HDF} && ./configure --enable-fortran --disable-shared --prefix=${CDF_PATH} --libdir=${CDF_PATH}/lib64 --with-szlib=${CDF_PATH}/include,${CDF_PATH}/lib64 \
CC="$(CC)" CFLAGS="$(HDF_OPT)" FC="$(FC)" FCFLAGS="$(NETCDF_OPT)" LDFLAGS="-L${CDF_PATH}/lib64" LIBS="-lsz -laec -lz" && \
diff --git a/src/Rules.LXgfortran.mk b/src/Rules.LXgfortran.mk
index f9ba987e6c59b96ec7070d54fe7c9a56683f7501..871219c5445bdc2760f5916f2276babd9964f488 100644
--- a/src/Rules.LXgfortran.mk
+++ b/src/Rules.LXgfortran.mk
@@ -22,6 +22,11 @@ OPT_I8 = -fdefault-integer-8
OPT_R8 = -fdefault-real-8 -fdefault-double-8
OPT_OPENACC = -fopenacc
#
+ifeq "$(VER_USER)" "ZSOLVER"
+CPPFLAGS += -DCARTESIANGEOMETRY -DPIECEWISELINEAR
+# -DOVERLAPCOMMS
+PROG_LIST += MG_MAIN MG_MAIN_MNH_ALL
+endif
#
# Real/Integer 4/8 option
#
@@ -52,6 +57,13 @@ OPT0 = $(OPT_BASE) $(OPT_PERF0) $(OPT_CHECK)
OPT_NOCB = $(OPT_BASE) $(OPT_PERF0)
CFLAGS += -g -O0
endif
+ifeq "$(OPTLEVEL)" "OPENACCDEFONLY"
+CPPFLAGS += -DMNH_OPENACC -D_FAKEOPENACC
+OPT = $(OPT_BASE) $(OPT_PERF0) $(OPT_CHECK)
+OPT0 = $(OPT_BASE) $(OPT_PERF0) $(OPT_CHECK)
+OPT_NOCB = $(OPT_BASE) $(OPT_PERF0)
+CFLAGS += -g -O0
+endif
#
ifeq "$(OPTLEVEL)" "OPENACC"
CPPFLAGS += -DMNH_OPENACC -fopenacc
@@ -103,6 +115,11 @@ endif
HDF_CONF= CFLAGS=-std=c99
HDF_OPT ?= -fPIC
NETCDF_OPT ?= -fPIC
+#if MNH_BITREP exists => compile with the BITREP library
+ifeq "$(MNH_BITREP)" "YES"
+CPPFLAGS_MNH += -DMNH_BITREP
+endif
+
#
## LIBTOOLS flags
#
diff --git a/src/Rules.LXifort.mk b/src/Rules.LXifort.mk
index b7f8e24bdb1236b64d9c9ed0346b2a463f8066b9..b667f42703360d2ee7e0d9ae062470c379bb9e05 100644
--- a/src/Rules.LXifort.mk
+++ b/src/Rules.LXifort.mk
@@ -9,7 +9,8 @@
##########################################################
#OBJDIR_PATH=/home/escj/azertyuiopqsdfghjklm/wxcvbn/azertyuiopqsdfghjklmwxcvbn
#
-OPT_BASE = -g -w -assume nosource_include -assume byterecl -fpe0 -ftz -fpic -traceback -fp-model precise -switch fe_inline_all_arg_copy_inout -fno-common
+OPT_BASE = -g -w -assume nosource_include -assume byterecl -fpe0 -ftz -fpic -traceback -fp-model consistent -switch fe_inline_all_arg_copy_inout -fno-common
+# -fimf-arch-consistency
OPT_PERF0 = -O0
OPT_PERF2 = -O2
OPT_PERF3 = -O3 -xHost
@@ -44,6 +45,12 @@ OPT0 = $(OPT_BASE) $(OPT_PERF0) $(OPT_CHECK)
OPT_NOCB = $(OPT_BASE) $(OPT_PERF0)
CFLAGS += -g
endif
+ifeq "$(OPTLEVEL)" "OPENACCDEFONLY"
+CPPFLAGS += -DMNH_OPENACC -D_FAKEOPENACC
+OPT = $(OPT_BASE) $(OPT_PERF2)
+OPT0 = $(OPT_BASE) $(OPT_PERF0)
+OPT_NOCB = $(OPT_BASE) $(OPT_PERF2)
+endif
ifeq "$(OPTLEVEL)" "O2"
OPT = $(OPT_BASE) $(OPT_PERF2)
OPT0 = $(OPT_BASE) $(OPT_PERF0)
@@ -189,6 +196,11 @@ HDF_CONF= CFLAGS=-std=c99
HDF_OPT ?= -fPIC
NETCDF_OPT ?= -fPIC
#
+#if MNH_BITREP exists => compile with the BITREP library
+ifeq "$(MNH_BITREP)" "YES"
+CPPFLAGS_MNH += -DMNH_BITREP
+endif
+#
# LIBTOOLS flags
#
#if MNH_TOOLS exists => compile the tools
diff --git a/src/Rules.LXnvhpc2005.mk b/src/Rules.LXnvhpc2005.mk
new file mode 100644
index 0000000000000000000000000000000000000000..c362e60e94f8b3b4a6275e5d1bfc275b68ea11ff
--- /dev/null
+++ b/src/Rules.LXnvhpc2005.mk
@@ -0,0 +1,282 @@
+#MNH_LIC Copyright 1994-2019 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.
+##########################################################
+# #
+# Compiler Options #
+# #
+##########################################################
+#OBJDIR_PATH=${WORKDIR}
+#
+# Processor type
+#TP= -tp=sandybridge
+#TP= -tp=px
+TP= -tp=p7-64
+#
+#Version of CUDA
+#(8.0 at least if compute capability >= 6.0)
+CUDALEVEL=cuda10.1
+#
+#Compute capability of GPU
+#
+#OPT_CPTCAP=cc35,cc50,cc70
+OPT_CPTCAP=cc35,cc50,cc60,cc70
+#Aeropc45: cc50
+#Nuwa: cc35
+#Ouessant Firestone K80: cc35
+#Ouessant Minsky P100: cc60
+#
+#Compiler info level
+#OPT_INFO = -Minfo=ftn,accel,inline,ipa,loop,lre,mp,opt,par,unified,vect,ccff
+OPT_INFO = -Minfo=accel
+#
+#Compiler profiling options
+#OPT_PROF = -Mprof=ccff
+#
+#PW: if -Ktrap=fp: nvprof/pgprof do not work OPT_BASE = -Ktrap=fp ...
+#PW: -g: big impact on performance
+OPT_BASE = $(TP) -Mbackslash -Mextend -Kieee -nofma -Mallocatable=95
+#
+OPT_PERF0 = -O0
+OPT_PERF1 = -O1
+OPT_PERF2 = -O2
+#
+OPT_MANAGED = -Mframe -Mnostack_arrays -Mallocatable=95 -acc=host,gpu -gpu=nofma,$(OPT_CPTCAP),$(CUDALEVEL),managed $(OPT_INFO) $(OPT_PROF)
+OPT_MULTICORE = -acc=multicore $(OPT_INFO) $(OPT_PROF)
+OPT_NOOPENACC = -acc=host $(OPT_INFO) $(OPT_PROF)
+OPT_OPENACC = -Mframe -Mnostack_arrays -Mallocatable=95 -acc=host,gpu -gpu=nofma,$(OPT_CPTCAP),$(CUDALEVEL) $(OPT_INFO) $(OPT_PROF)
+#
+OPT_CHECK = -C #-Mchkfpstk -Mchkptr
+OPT_I8 = -i8
+OPT_R8 = -r8
+#
+ifeq "$(VER_USER)" "ZSOLVER"
+CPPFLAGS += -DCARTESIANGEOMETRY -DOVERLAPCOMMS -DPIECEWISELINEAR
+PROG_LIST += MG_MAIN MG_MAIN_MNH_ALL
+endif
+#
+IGNORE_OBJS += pgprof.o
+#
+# Real/integer 4/8 option
+#
+MNH_REAL ?=8
+MNH_INT ?=4
+#
+ifneq "$(MNH_REAL)" "4"
+OPT_BASE += $(OPT_R8)
+endif
+#
+OPT_BASE_I4 := $(OPT_BASE)
+ifeq "$(MNH_INT)" "8"
+OPT_BASE += $(OPT_I8)
+LFI_INT ?=8
+else
+LFI_INT ?=4
+endif
+#
+#
+OPT = $(OPT_BASE) $(OPT_PERF2)
+OPT0 = $(OPT_BASE) $(OPT_PERF0)
+OPT_NOCB = $(OPT_BASE) $(OPT_PERF2)
+#
+ifeq "$(OPTLEVEL)" "DEBUG"
+OPT = -g $(OPT_BASE) $(OPT_PERF0) $(OPT_CHECK)
+OPT0 = -g $(OPT_BASE) $(OPT_PERF0) $(OPT_CHECK)
+OPT_NOCB = -g $(OPT_BASE) $(OPT_PERF0)
+endif
+#
+ifeq "$(OPTLEVEL)" "MANAGED"
+CPPFLAGS += -DMNH_OPENACC
+OPT = -g $(OPT_BASE) $(OPT_MANAGED) $(OPT_PERF2)
+OPT0 = -g $(OPT_BASE) $(OPT_MANAGED) $(OPT_PERF0)
+OPT_NOCB = -g $(OPT_BASE) $(OPT_MANAGED) $(OPT_PERF2)
+CXXFLAGS = -g -acc -Kieee -Mnofma $(OPT_MANAGED)
+OBJS_REPROD= spll_mode_sum_ll.o
+$(OBJS_REPROD) : OPT = $(OPT_BASE) $(OPT_MANAGED) $(OPT_PERF2) -Mvect=nosimd -Minfo=all -g
+endif
+#
+ifeq "$(OPTLEVEL)" "MANAGEDO2"
+CPPFLAGS += -DMNH_OPENACC
+OPT = $(OPT_BASE) $(OPT_MANAGED) $(OPT_PERF2)
+OPT0 = $(OPT_BASE) $(OPT_MANAGED) $(OPT_PERF0)
+OPT_NOCB = $(OPT_BASE) $(OPT_MANAGED) $(OPT_PERF2)
+CXXFLAGS = -acc -Kieee -Mnofma $(OPT_MANAGED) -gpu=nofma
+OBJS_REPROD= spll_mode_sum_ll.o
+$(OBJS_REPROD) : OPT = $(OPT_BASE) $(OPT_MANAGED) $(OPT_PERF2) -Mvect=nosimd -Minfo=all
+OBJS_OPENACC = spll_modd_halo_d.o
+$(OBJS_OPENACC) : OPT = $(OPT_BASE) $(OPT_OPENACC) $(OPT_PERF2)
+endif
+#
+ifeq "$(OPTLEVEL)" "MULTICORE"
+CPPFLAGS += -DMNH_OPENACC
+OPT = $(OPT_BASE) $(OPT_MULTICORE)
+OPT0 = $(OPT_BASE) $(OPT_MULTICORE) $(OPT_PERF0)
+OPT_NOCB = $(OPT_BASE) $(OPT_MULTICORE)
+CXXFLAGS = -acc -Kieee -Mnofma $(OPT_MULTICORE)
+endif
+#
+ifeq "$(OPTLEVEL)" "OPENACC"
+CPPFLAGS += -DMNH_OPENACC
+# -imacros MNH_OPENACC_SHUMAN_MACRO.CPP
+OPT = -g $(OPT_BASE) $(OPT_OPENACC) $(OPT_PERF0)
+OPT0 = -g $(OPT_BASE) $(OPT_OPENACC) $(OPT_PERF0)
+OPT_NOCB = -g $(OPT_BASE) $(OPT_OPENACC) $(OPT_PERF0)
+CXXFLAGS = -g -acc -Kieee -Mnofma $(OPT_OPENACC)
+OBJS_REPROD= spll_mode_sum_ll.o
+$(OBJS_REPROD) : OPT = $(OPT_BASE) $(OPT_OPENACC) $(OPT_PERF2) -Mvect=nosimd -Minfo=all -g
+endif
+ifeq "$(OPTLEVEL)" "OPENACCO2"
+CPPFLAGS += -DMNH_OPENACC
+OPT = $(OPT_BASE) $(OPT_OPENACC) $(OPT_PERF2)
+OPT0 = $(OPT_BASE) $(OPT_OPENACC) $(OPT_PERF0)
+OPT_NOCB = $(OPT_BASE) $(OPT_OPENACC) $(OPT_PERF2)
+CXXFLAGS = -acc -Kieee -Mnofma $(OPT_OPENACC)
+OBJS_REPROD= spll_mode_sum_ll.o
+$(OBJS_REPROD) : OPT = $(OPT_BASE) $(OPT_OPENACC) $(OPT_PERF2) -Mvect=nosimd -Minfo=all
+endif
+#
+ifeq "$(OPTLEVEL)" "OPENACCDEFONLY"
+CPPFLAGS += -DMNH_OPENACC -D_FAKEOPENACC
+OPT = $(OPT_BASE) $(OPT_NOOPENACC) $(OPT_PERF2)
+OPT0 = $(OPT_BASE) $(OPT_NOOPENACC) $(OPT_PERF0)
+OPT_NOCB = $(OPT_BASE) $(OPT_NOOPENACC) $(OPT_PERF2)
+CXXFLAGS = -Kieee -Mnofma $(OPT_NOOPENACC)
+OBJS_REPROD= spll_mode_sum_ll.o
+$(OBJS_REPROD) : OPT = $(OPT_BASE) $(OPT_NOOPENACC) $(OPT_PERF2) -Mvect=nosimd -Minfo=all
+endif
+#
+ifeq "$(OPTLEVEL)" "NOOPENACC"
+#CPPFLAGS += -D_OPT_LINEARIZED_LOOPS
+OPT = $(OPT_BASE) $(OPT_NOOPENACC) $(OPT_PERF2)
+OPT0 = $(OPT_BASE) $(OPT_NOOPENACC) $(OPT_PERF0)
+OPT_NOCB = $(OPT_BASE) $(OPT_NOOPENACC) $(OPT_PERF2)
+CXXFLAGS = -Kieee -Mnofma $(OPT_NOOPENACC)
+OBJS_REPROD= spll_mode_sum_ll.o
+$(OBJS_REPROD) : OPT = $(OPT_BASE) $(OPT_NOOPENACC) $(OPT_PERF2) -Mvect=nosimd -Minfo=all -g
+endif
+#
+CC = pgcc
+CXXFLAGS += $(TP)
+CFLAGS += $(TP)
+FC = pgf90
+ifeq "$(VER_MPI)" "MPIAUTO"
+F90 = mpif90
+CC = mpicc
+CXX = mpicxx
+else
+F90 = pgf90
+CC = pgcc
+CXX = pgcxx
+endif
+#
+F77FLAGS = $(OPT)
+F77 = $(F90)
+F90FLAGS = $(OPT)
+FX90 = $(F90)
+FX90FLAGS = $(OPT)
+#
+LDFLAGS = -Wl,-warn-once $(OPT)
+#
+# preprocessing flags
+#
+CPP = cpp -P -traditional -Wcomment -D_OPENACC=201711
+#
+CPPFLAGS_SURFEX =
+CPPFLAGS_SURCOUCHE +=
+CPPFLAGS_RAD =
+CPPFLAGS_NEWLFI = -DSWAPIO -DLINUX -DLFI_INT=${LFI_INT}
+CPPFLAGS_MNH = -DMNH -DMNH_PGI -DSFX_MNH
+CPPFLAGS_MNH += -Uvector -Upixel
+#
+# Gribex flags
+#
+TARGET_GRIBEX=linux
+CNAME_GRIBEX=_pgf77
+GRIBAPI_CONF="CPP=cpp"
+#
+# Netcdf/HDF5 flags
+#
+#HDF_CONF= CXXFLAGS=$(TP)
+HDF_OPT ?= $(TP)
+NETCDF_OPT ?= $(TP)
+CDF_CONF="CPP=cpp"
+HDF_CONF="CPP=cpp"
+#
+# BITREP flags
+#
+#if MNH_BITREP exists => compile with the BITREP library
+MNH_BITREP = YES
+ifeq "$(MNH_BITREP)" "YES"
+CPPFLAGS_MNH += -DMNH_BITREP
+endif
+#
+# LIBTOOLS flags
+#
+#if MNH_TOOLS exists => compile the tools
+MNH_TOOLS = yes
+#
+## COMPRESS flag
+#
+#if MNH_COMPRESS exists => compile the COMPRESS library (for LFI files)
+MNH_COMPRESS=yes
+#
+## S4PY flag
+#
+#if MNH_S4PY exists => compile the libs4py library (for epygram)
+#MNH_S4PY=no
+#
+##########################################################
+# #
+# Source of MESONH PACKAGE Distribution #
+# #
+##########################################################
+#DIR_SURFEX += ARCH_SRC/surfex.MNH-462
+
+OBJS_NOCB += spll_isba.o
+#
+include Makefile.MESONH.mk
+#
+##########################################################
+# #
+# extra VPATH, Compilation flag modification #
+# systeme module , etc ... #
+# external precompiled module librairie #
+# etc ... #
+# #
+##########################################################
+OBJS_O1 += spll_modd_isba_n.o spll_mode_construct_ll.o \
+ spll_init_surf_atm_n.o spll_mode_scatter_ll.o spll_convert_patch_teb.o \
+ spll_define_mask_n.o spll_del1dfield_ll.o spll_mode_fm.o spll_mode_gather_ll.o \
+ spll_convect_updraft.o spll_convect_updraft_shal.o \
+ spll_mode_dustopt.o spll_mode_saltopt.o \
+ spll_aeroopt_get.o spll_write_lfifm1_for_diag_supp.o spll_write_lfifm1_for_diag.o spll_write_lfifm_n.o \
+
+#spll_unpack_1d_2d_from2d.o
+#spll_pack_isba_patch_n.o
+#spll_phys_param_n.o
+$(OBJS_O1) : OPT = $(OPT_BASE) $(OPT_PERF1)
+
+OBJS_O0= spll_mode_mppdb.o \
+ spll_fft55.o spll_fft.o spll_flat_invz.o \
+ spll_mode_repro_sum.o \
+ spll_modd_les_n.o
+
+# spll_fast_terms.o
+# spll_modd_ch_solver_n.o \
+# spll_modd_dummy_gr_field_n.o spll_modd_dyn_n.o
+# spll_mode_sum_ll.o
+$(OBJS_O0) : OPT = -g $(OPT_BASE) $(OPT_PERF0)
+
+OBJS_O2= spll_mode_device.o
+$(OBJS_O2) : OPT = $(OPT_BASE) $(OPT_OPENACC) $(OPT_PERF2)
+
+ifneq "$(findstring 8,$(LFI_INT))" ""
+OBJS_I8=spll_NEWLFI_ALL.o
+$(OBJS_I8) : OPT = $(OPT_BASE) $(OPT_PERF2) $(OPT_I8)
+endif
+
+ifeq "$(MNH_INT)" "8"
+OBJS_I4=spll_modd_netcdf.o
+$(OBJS_I4) : OPT = $(OPT_BASE_I4)
+endif
diff --git a/src/Rules.LXpgi2004.mk b/src/Rules.LXpgi2004.mk
new file mode 100644
index 0000000000000000000000000000000000000000..d3c5f1039a3b326e369807bf0a590ce2adddb7b5
--- /dev/null
+++ b/src/Rules.LXpgi2004.mk
@@ -0,0 +1,279 @@
+#MNH_LIC Copyright 1994-2019 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.
+##########################################################
+# #
+# Compiler Options #
+# #
+##########################################################
+#OBJDIR_PATH=${WORKDIR}
+#
+# Processor type
+#TP= -tp=sandybridge
+#TP= -tp=px
+TP= -tp=p7-64
+#
+#Version of CUDA
+#(8.0 at least if compute capability >= 6.0)
+CUDALEVEL=cuda10.1
+#
+#Compute capability of GPU
+#
+OPT_CPTCAP=cc35,cc50,cc60,cc70
+#Aeropc45: cc50
+#Nuwa: cc35
+#Ouessant Firestone K80: cc35
+#Ouessant Minsky P100: cc60
+#
+#Compiler info level
+#OPT_INFO = -Minfo=ftn,accel,inline,ipa,loop,lre,mp,opt,par,unified,vect,ccff
+OPT_INFO = -Minfo=accel
+#
+#Compiler profiling options
+#OPT_PROF = -Mprof=ccff
+#
+#PW: if -Ktrap=fp: nvprof/pgprof do not work OPT_BASE = -Ktrap=fp ...
+#PW: -g: big impact on performance
+OPT_BASE = $(TP) -Mbackslash -Mextend -Kieee -nofma -Mallocatable=95
+#
+OPT_PERF0 = -O0
+OPT_PERF1 = -O1
+OPT_PERF2 = -O2
+#
+OPT_MANAGED = -Mframe -Mnostack_arrays -Mallocatable=95 -ta=host,tesla:nofma,$(OPT_CPTCAP),$(CUDALEVEL),managed $(OPT_INFO) $(OPT_PROF)
+OPT_MULTICORE = -ta=multicore $(OPT_INFO) $(OPT_PROF)
+OPT_NOOPENACC = -ta=host $(OPT_INFO) $(OPT_PROF)
+OPT_OPENACC = -Mframe -Mnostack_arrays -Mallocatable=95 -ta=host,tesla:nofma,$(OPT_CPTCAP),$(CUDALEVEL) $(OPT_INFO) $(OPT_PROF)
+#
+OPT_CHECK = -C #-Mchkfpstk -Mchkptr
+OPT_I8 = -i8
+OPT_R8 = -r8
+#
+ifeq "$(VER_USER)" "ZSOLVER"
+CPPFLAGS += -DCARTESIANGEOMETRY -DOVERLAPCOMMS -DPIECEWISELINEAR
+PROG_LIST += MG_MAIN MG_MAIN_MNH_ALL
+endif
+#
+IGNORE_OBJS += pgprof.o
+#
+# Real/integer 4/8 option
+#
+MNH_REAL ?=8
+MNH_INT ?=4
+#
+ifneq "$(MNH_REAL)" "4"
+OPT_BASE += $(OPT_R8)
+endif
+#
+OPT_BASE_I4 := $(OPT_BASE)
+ifeq "$(MNH_INT)" "8"
+OPT_BASE += $(OPT_I8)
+LFI_INT ?=8
+else
+LFI_INT ?=4
+endif
+#
+#
+OPT = $(OPT_BASE) $(OPT_PERF2)
+OPT0 = $(OPT_BASE) $(OPT_PERF0)
+OPT_NOCB = $(OPT_BASE) $(OPT_PERF2)
+#
+ifeq "$(OPTLEVEL)" "DEBUG"
+OPT = -g $(OPT_BASE) $(OPT_PERF0) $(OPT_CHECK)
+OPT0 = -g $(OPT_BASE) $(OPT_PERF0) $(OPT_CHECK)
+OPT_NOCB = -g $(OPT_BASE) $(OPT_PERF0)
+endif
+#
+ifeq "$(OPTLEVEL)" "MANAGED"
+CPPFLAGS += -DMNH_OPENACC
+OPT = -g $(OPT_BASE) $(OPT_MANAGED) $(OPT_PERF2)
+OPT0 = -g $(OPT_BASE) $(OPT_MANAGED) $(OPT_PERF0)
+OPT_NOCB = -g $(OPT_BASE) $(OPT_MANAGED) $(OPT_PERF2)
+CXXFLAGS = -g -acc -Kieee -Mnofma $(OPT_MANAGED)
+OBJS_REPROD= spll_mode_sum_ll.o
+$(OBJS_REPROD) : OPT = $(OPT_BASE) $(OPT_MANAGED) $(OPT_PERF2) -Mvect=nosimd -Minfo=all -g
+endif
+#
+ifeq "$(OPTLEVEL)" "MANAGEDO2"
+CPPFLAGS += -DMNH_OPENACC
+OPT = $(OPT_BASE) $(OPT_MANAGED) $(OPT_PERF2)
+OPT0 = $(OPT_BASE) $(OPT_MANAGED) $(OPT_PERF0)
+OPT_NOCB = $(OPT_BASE) $(OPT_MANAGED) $(OPT_PERF2)
+CXXFLAGS = -acc -Kieee -Mnofma $(OPT_MANAGED)
+OBJS_REPROD= spll_mode_sum_ll.o
+$(OBJS_REPROD) : OPT = $(OPT_BASE) $(OPT_MANAGED) $(OPT_PERF2) -Mvect=nosimd -Minfo=all
+OBJS_OPENACC = spll_modd_halo_d.o
+$(OBJS_OPENACC) : OPT = $(OPT_BASE) $(OPT_OPENACC) $(OPT_PERF2)
+endif
+#
+ifeq "$(OPTLEVEL)" "MULTICORE"
+CPPFLAGS += -DMNH_OPENACC
+OPT = $(OPT_BASE) $(OPT_MULTICORE)
+OPT0 = $(OPT_BASE) $(OPT_MULTICORE) $(OPT_PERF0)
+OPT_NOCB = $(OPT_BASE) $(OPT_MULTICORE)
+CXXFLAGS = -acc -Kieee -Mnofma $(OPT_MULTICORE)
+endif
+#
+ifeq "$(OPTLEVEL)" "OPENACC"
+CPPFLAGS += -DMNH_OPENACC
+# -imacros MNH_OPENACC_SHUMAN_MACRO.CPP
+OPT = -g $(OPT_BASE) $(OPT_OPENACC) $(OPT_PERF0)
+OPT0 = -g $(OPT_BASE) $(OPT_OPENACC) $(OPT_PERF0)
+OPT_NOCB = -g $(OPT_BASE) $(OPT_OPENACC) $(OPT_PERF0)
+CXXFLAGS = -g -acc -Kieee -Mnofma $(OPT_OPENACC)
+OBJS_REPROD= spll_mode_sum_ll.o
+$(OBJS_REPROD) : OPT = $(OPT_BASE) $(OPT_OPENACC) $(OPT_PERF2) -Mvect=nosimd -Minfo=all -g
+endif
+ifeq "$(OPTLEVEL)" "OPENACCO2"
+CPPFLAGS += -DMNH_OPENACC
+OPT = $(OPT_BASE) $(OPT_OPENACC) $(OPT_PERF2)
+OPT0 = $(OPT_BASE) $(OPT_OPENACC) $(OPT_PERF0)
+OPT_NOCB = $(OPT_BASE) $(OPT_OPENACC) $(OPT_PERF2)
+CXXFLAGS = -acc -Kieee -Mnofma $(OPT_OPENACC)
+OBJS_REPROD= spll_mode_sum_ll.o
+$(OBJS_REPROD) : OPT = $(OPT_BASE) $(OPT_OPENACC) $(OPT_PERF2) -Mvect=nosimd -Minfo=all
+endif
+#
+ifeq "$(OPTLEVEL)" "OPENACCDEFONLY"
+CPPFLAGS += -DMNH_OPENACC -D_FAKEOPENACC
+OPT = $(OPT_BASE) $(OPT_NOOPENACC) $(OPT_PERF2)
+OPT0 = $(OPT_BASE) $(OPT_NOOPENACC) $(OPT_PERF0)
+OPT_NOCB = $(OPT_BASE) $(OPT_NOOPENACC) $(OPT_PERF2)
+CXXFLAGS = -Kieee -Mnofma $(OPT_NOOPENACC)
+OBJS_REPROD= spll_mode_sum_ll.o
+$(OBJS_REPROD) : OPT = $(OPT_BASE) $(OPT_NOOPENACC) $(OPT_PERF2) -Mvect=nosimd -Minfo=all
+endif
+#
+ifeq "$(OPTLEVEL)" "NOOPENACC"
+#CPPFLAGS += -D_OPT_LINEARIZED_LOOPS
+OPT = $(OPT_BASE) $(OPT_NOOPENACC) $(OPT_PERF2)
+OPT0 = $(OPT_BASE) $(OPT_NOOPENACC) $(OPT_PERF0)
+OPT_NOCB = $(OPT_BASE) $(OPT_NOOPENACC) $(OPT_PERF2)
+CXXFLAGS = -Kieee -Mnofma $(OPT_NOOPENACC)
+OBJS_REPROD= spll_mode_sum_ll.o
+$(OBJS_REPROD) : OPT = $(OPT_BASE) $(OPT_NOOPENACC) $(OPT_PERF2) -Mvect=nosimd -Minfo=all -g
+endif
+#
+CC = pgcc
+CXXFLAGS += $(TP)
+CFLAGS += $(TP)
+FC = pgf90
+ifeq "$(VER_MPI)" "MPIAUTO"
+F90 = mpif90
+CC = mpicc
+CXX = mpicxx
+else
+F90 = pgf90
+CC = pgcc
+CXX = pgcxx
+endif
+#
+F77FLAGS = $(OPT)
+F77 = $(F90)
+F90FLAGS = $(OPT)
+FX90 = $(F90)
+FX90FLAGS = $(OPT)
+#
+LDFLAGS = -Wl,-warn-once $(OPT)
+#
+# preprocessing flags
+#
+CPP = cpp -P -traditional -Wcomment -D_OPENACC=201711
+#
+CPPFLAGS_SURFEX =
+CPPFLAGS_SURCOUCHE +=
+CPPFLAGS_RAD =
+CPPFLAGS_NEWLFI = -DSWAPIO -DLINUX -DLFI_INT=${LFI_INT}
+CPPFLAGS_MNH = -DMNH -DMNH_PGI -DSFX_MNH
+CPPFLAGS_MNH += -Uvector -Upixel
+#
+# Gribex flags
+#
+TARGET_GRIBEX=linux
+CNAME_GRIBEX=_pgf77
+GRIBAPI_CONF="CPP=cpp"
+CDF_CONF="CPP=cpp"
+#
+# Netcdf/HDF5 flags
+#
+HDF_OPT ?= $(TP)
+NETCDF_OPT ?= $(TP)
+#
+# BITREP flags
+#
+#if MNH_BITREP exists => compile with the BITREP library
+MNH_BITREP = YES
+ifeq "$(MNH_BITREP)" "YES"
+CPPFLAGS_MNH += -DMNH_BITREP
+endif
+#
+# LIBTOOLS flags
+#
+#if MNH_TOOLS exists => compile the tools
+MNH_TOOLS = yes
+#
+## COMPRESS flag
+#
+#if MNH_COMPRESS exists => compile the COMPRESS library (for LFI files)
+MNH_COMPRESS=yes
+#
+## S4PY flag
+#
+#if MNH_S4PY exists => compile the libs4py library (for epygram)
+#MNH_S4PY=no
+#
+##########################################################
+# #
+# Source of MESONH PACKAGE Distribution #
+# #
+##########################################################
+#DIR_SURFEX += ARCH_SRC/surfex.MNH-462
+
+OBJS_NOCB += spll_isba.o
+#
+include Makefile.MESONH.mk
+#
+##########################################################
+# #
+# extra VPATH, Compilation flag modification #
+# systeme module , etc ... #
+# external precompiled module librairie #
+# etc ... #
+# #
+##########################################################
+OBJS_O1 += spll_modd_isba_n.o spll_mode_construct_ll.o \
+ spll_init_surf_atm_n.o spll_mode_scatter_ll.o spll_convert_patch_teb.o \
+ spll_define_mask_n.o spll_del1dfield_ll.o spll_mode_fm.o spll_mode_gather_ll.o \
+ spll_convect_updraft.o spll_convect_updraft_shal.o \
+ spll_mode_dustopt.o spll_mode_saltopt.o \
+ spll_aeroopt_get.o spll_write_lfifm1_for_diag_supp.o spll_write_lfifm1_for_diag.o spll_write_lfifm_n.o \
+
+#spll_unpack_1d_2d_from2d.o
+#spll_pack_isba_patch_n.o
+#spll_phys_param_n.o
+$(OBJS_O1) : OPT = $(OPT_BASE) $(OPT_PERF1)
+
+OBJS_O0= spll_mode_mppdb.o \
+ spll_fft55.o spll_fft.o spll_flat_invz.o \
+ spll_mode_repro_sum.o \
+ spll_modd_les_n.o
+
+# spll_fast_terms.o
+# spll_modd_ch_solver_n.o \
+# spll_modd_dummy_gr_field_n.o spll_modd_dyn_n.o
+# spll_mode_sum_ll.o
+$(OBJS_O0) : OPT = -g $(OPT_BASE) $(OPT_PERF0)
+
+OBJS_O2= spll_mode_device.o
+$(OBJS_O2) : OPT = $(OPT_BASE) $(OPT_OPENACC) $(OPT_PERF2)
+
+ifneq "$(findstring 8,$(LFI_INT))" ""
+OBJS_I8=spll_NEWLFI_ALL.o
+$(OBJS_I8) : OPT = $(OPT_BASE) $(OPT_PERF2) $(OPT_I8)
+endif
+
+ifeq "$(MNH_INT)" "8"
+OBJS_I4=spll_modd_netcdf.o
+$(OBJS_I4) : OPT = $(OPT_BASE_I4)
+endif
diff --git a/src/ZSOLVER/anel_balancen.f90 b/src/ZSOLVER/anel_balancen.f90
new file mode 100644
index 0000000000000000000000000000000000000000..c1659356c3616b260ddda416eb328e07ddb3faca
--- /dev/null
+++ b/src/ZSOLVER/anel_balancen.f90
@@ -0,0 +1,334 @@
+!MNH_LIC Copyright 1994-2020 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.
+!-----------------------------------------------------------------
+! ##########################
+ MODULE MODI_ANEL_BALANCE_n
+! ##########################
+!
+INTERFACE
+!
+SUBROUTINE ANEL_BALANCE_n(PRESIDUAL)
+!
+REAL, OPTIONAL :: PRESIDUAL
+END SUBROUTINE ANEL_BALANCE_n
+!
+END INTERFACE
+!
+END MODULE MODI_ANEL_BALANCE_n
+!
+!
+!
+! ################################
+ SUBROUTINE ANEL_BALANCE_n(PRESIDUAL)
+!
+! ################################
+!
+!
+!!**** *ANEL_BALANCE_n* - routine to apply an anelastic correction
+!!
+!!
+!! PURPOSE
+!! -------
+! The purpose of this routine is to fulfill the anelastic balance
+! in case of non-vanishing orography
+!
+!
+!
+!!** METHOD
+!! ------
+!! The coefficients for the flat operator are first computed. Then the
+!! pressure equation is solved and the pressure gradient is added to the wind
+!! components in order to render this wind field non-divergent.
+!!
+!! EXTERNAL
+!! --------
+!! TRID : to compute coefficients for the flat operator
+!! PRESSURE : to solve the pressure equation and add the pressure term to
+!! wind
+!! MXM,MYM,MZM : to average a field at mass point in the x,y,z directions
+!!
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!! Module MODD_CONF : contains configuration variables for all models.
+!! NVERB : verbosity level for output-listing
+!!
+!! Module MODD_GRID_n : contains grid variables
+!! XMAP,XXHAT,XYHAT,XZZ
+!!
+!! Module MODD_REF_n : contains reference state variables
+!! XRHODJ,XTHVREF,XEXNREF,XRHODREF,XRVREF
+!!
+!! Module MODD_REF_n : contains reference state variables
+!! XLINMASS : lineic mass along the lateral boundaries
+!!
+!! Module MODD_FIELD_n : contains prognostic variables
+!! XUT,XVT,XWT,XTHT,XRT
+!!
+!! Module MODD_DYN_n : contains parameters for the dynamics
+!! CPRESOPT : option for the pressure solver
+!! NITR : number of iterations for the solver
+!! XRELAX : relaxation coefficient used in the Richardson method
+!!
+!! Module MODD_LBC_n : contains parameters relative to the boundaries
+!! CLBCX : choice of lateral boundary condition along x
+!! CLBCY : choice of lateral boundary condition along y
+!!
+!! REFERENCE
+!! ---------
+!! NONE
+!!
+!!
+!! AUTHOR
+!! ------
+!! V. Ducrocq * Meteo France *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 6/09/94
+!! J. Stein 4/11/94 put the pressure solver parameters in namelist
+!! J. Stein 2/12/94 source cleaning
+!! J.P. Lafore 03/01/95 call to PRESSURE to account for absolute pressure
+!! J. Stein 17/01/95 bug in the pressure call
+!! J. Stein 15/03/95 remove R from the historical variables
+!! J.Stein and J.P. lafore 17/04/96 new version including the way to choose
+!! the model number and the instant where the projection is performed
+!! Stein,Lafore 14/01/97 new anelastic equations
+!! M.Faivre 2014
+!! M.Moge 08/2015 removing UPDATE_HALO_ll(XRHODJ) + EXTRAPOL on ZRU and ZRV in part 3.1
+!! J.Escobar : 15/09/2015 : WENO5 & JPHEXT <> 1
+!! Philippe Wautelet: 05/2016-04/2018: new data structures and calls for I/O
+! P. Wautelet 20/05/2019: add name argument to ADDnFIELD_ll + new ADD4DFIELD_ll subroutine
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+!
+USE MODE_ll
+USE MODE_MODELN_HANDLER
+!
+USE MODD_CONF ! declarative modules
+USE MODD_PARAMETERS
+USE MODD_GRID_n
+USE MODD_DIM_n
+USE MODD_METRICS_n
+USE MODD_REF_n
+USE MODD_FIELD_n
+USE MODD_DYN_n
+USE MODD_LBC_n
+!
+USE MODI_TRIDZ ! interface modules
+USE MODI_PRESSUREZ
+USE MODE_SPLITTINGZ_ll
+USE MODI_SHUMAN
+!
+USE MODD_ARGSLIST_ll, ONLY : LIST_ll
+USE MODE_MPPDB
+USE MODE_EXTRAPOL
+!
+IMPLICIT NONE
+!
+!* 0.1 Declarations of arguments :
+!
+REAL, OPTIONAL :: PRESIDUAL
+!
+!* 0.2 Declarations of local variables :
+!
+INTEGER :: IRESP ! return code
+INTEGER :: IIY,IJY ! same variable for Y decomposition
+INTEGER :: ITCOUNT ! counter value of temporal loop set to 1 ( this
+ ! means that no guess of the pressure is available for
+ ! the pressure solver
+REAL :: ZDXHATM ! mean grid increment in the x direction
+REAL :: ZDYHATM ! mean grid increment in the y direction
+REAL, DIMENSION (SIZE(XRHODJ,3)) :: ZRHOM ! mean of XRHODJ on the plane x y
+ ! localized at a mass level
+!
+REAL, DIMENSION(SIZE(XRHODJ,3)) :: ZAF,ZCF ! vector giving the nonvanishing
+REAL, DIMENSION(:,:,:), ALLOCATABLE :: ZBFY ! elements of the tri-diag matrix
+ ! in the pressure equation
+REAL, DIMENSION(:), ALLOCATABLE :: ZTRIGSX ! arrays of sin or cos values for
+REAL, DIMENSION(:), ALLOCATABLE :: ZTRIGSY ! the FFT in x and y directions
+INTEGER, DIMENSION(19) :: IIFAXX ! decomposition in prime numbers
+INTEGER, DIMENSION(19) :: IIFAXY ! for the FFT in x and y
+ ! directions
+REAL, DIMENSION(SIZE(XRHODJ,1),SIZE(XRHODJ,2),SIZE(XRHODJ,3)) :: ZPABST
+ ! Potential at time t
+REAL, DIMENSION(SIZE(XRHODJ,1),SIZE(XRHODJ,2),SIZE(XRHODJ,3)) :: ZRU,ZRV,ZRW
+ ! Rhod * (U,V,W)
+REAL, DIMENSION(SIZE(XRHODJ,1),SIZE(XRHODJ,2),SIZE(XRHODJ,3)) :: ZTH
+REAL, DIMENSION(:,:,:,:), ALLOCATABLE :: ZRR
+!
+INTEGER :: IRR ! Total number of water variables
+INTEGER :: IRRL ! Number of liquid water variables
+INTEGER :: IRRI ! Number of solid water variables
+REAL :: ZDRYMASST ! Mass of dry air Md
+REAL :: ZREFMASS ! Total mass of the ref. atmosphere
+REAL :: ZMASS_O_PHI0 ! Mass / Phi0
+LOGICAL :: GCLOSE_OUT ! switch for the LFI writing
+CHARACTER (LEN= 28) :: YFMFILE ! virtual FM file
+INTEGER :: IMI ! model index
+!JUAN
+INTEGER :: IIU_B,IJU_B,IKU
+INTEGER :: IIU_SXP2_YP1_Z_ll,IJU_SXP2_YP1_Z_ll,IKU_SXP2_YP1_Z_ll
+REAL, DIMENSION(:,:,:), ALLOCATABLE :: ZBFB,ZBF_SXP2_YP1_Z
+REAL, DIMENSION(:,:,:), ALLOCATABLE :: ZAF_ZS,ZBF_ZS,ZCF_ZS
+REAL, DIMENSION(:,:) , ALLOCATABLE :: ZDXATH_ZS,ZDYATH_ZS
+REAL, DIMENSION(:,:,:), ALLOCATABLE :: ZRHO_ZS
+REAL, DIMENSION(:), ALLOCATABLE :: ZA_K,ZB_K,ZC_K,ZD_K
+!JUAN
+!
+INTEGER :: IINFO_ll
+TYPE(LIST_ll), POINTER :: TZFIELDS_ll=>NULL() ! list of fields to exchange
+!
+!-------------------------------------------------------------------------------
+!
+!* 1. PROLOGUE :
+! --------
+!
+CALL GET_DIM_EXT_ll('Y',IIY,IJY)
+IF (L2D) THEN
+ ALLOCATE(ZBFY(IIY,IJY,SIZE(XRHODJ,3)))
+ELSE
+ ALLOCATE(ZBFY(IJY,IIY,SIZE(XRHODJ,3)))
+ENDIF
+ALLOCATE(ZTRIGSX(3*(NIMAX_ll+2*JPHEXT)))
+ALLOCATE(ZTRIGSY(3*(NJMAX_ll+2*JPHEXT)))
+!JUAN Z_SPLITING
+IKU=SIZE(XRHODJ,3)
+CALL GET_DIM_EXT_ll('B',IIU_B,IJU_B)
+ALLOCATE(ZBFB(IIU_B,IJU_B,IKU))
+!
+ALLOCATE(ZAF_ZS(IIU_B,IJU_B,IKU))
+ALLOCATE(ZBF_ZS(IIU_B,IJU_B,IKU))
+ALLOCATE(ZCF_ZS(IIU_B,IJU_B,IKU))
+ALLOCATE(ZDXATH_ZS(IIU_B,IJU_B))
+ALLOCATE(ZDYATH_ZS(IIU_B,IJU_B))
+ALLOCATE(ZRHO_ZS(IIU_B,IJU_B,IKU))
+ALLOCATE(ZA_K(IKU))
+ALLOCATE(ZB_K(IKU))
+ALLOCATE(ZC_K(IKU))
+ALLOCATE(ZD_K(IKU))
+!
+CALL GET_DIM_EXTZ_ll('SXP2_YP1_Z',IIU_SXP2_YP1_Z_ll,IJU_SXP2_YP1_Z_ll,IKU_SXP2_YP1_Z_ll)
+ALLOCATE(ZBF_SXP2_YP1_Z(IIU_SXP2_YP1_Z_ll,IJU_SXP2_YP1_Z_ll,IKU_SXP2_YP1_Z_ll))
+!
+!JUAN Z_SPLITING
+CALL MPPDB_CHECK3D(XRHODJ,"anel_balancen1-::XRHODJ",PRECISION)
+CALL MPPDB_CHECK3D(XUT,"anel_balancen1-::XUT",PRECISION)
+!
+!-------------------------------------------------------------------------------
+!
+!* 2. PRESSURE SOLVER INITIALIZATION :
+! -------------------------------
+!
+!
+CALL TRIDZ(CLBCX,CLBCY,XMAP,XDXHAT,XDYHAT,CPRESOPT, &
+ ZDXHATM,ZDYHATM,ZRHOM, &
+ ZAF,ZCF,ZTRIGSX,ZTRIGSY,IIFAXX,IIFAXY,XRHODJ,XTHVREF,XZZ,ZBFY,&
+ ZBFB,ZBF_SXP2_YP1_Z, &
+ ZAF_ZS,ZBF_ZS,ZCF_ZS, &
+ ZDXATH_ZS,ZDYATH_ZS,ZRHO_ZS, &
+ ZA_K,ZB_K,ZC_K,ZD_K) !JUAN FULL ZSOLVER
+CALL MPPDB_CHECK3D(XRHODJ,"anel_balancen1-after TRIDZ::XRHODJ",PRECISION)
+!
+!-------------------------------------------------------------------------------
+!
+!* 3. ANELASTIC CORRECTION :
+! ---------------------
+!
+!
+!* 3.1 multiplication by RHODJ
+!
+!$20140710 UPHALO on XRHODJ
+!CALL ADD3DFIELD_ll( TZFIELDS_ll, XRHODJ, 'ANEL_BALANCE_n::XRHODJ' )
+!CALL UPDATE_HALO_ll(TZFIELDS_ll,IINFO_ll)
+!CALL CLEANLIST_ll(TZFIELDS_ll)
+CALL MPPDB_CHECK3D(XRHODJ,"anel_balancen3.1-after update halo::XRHODJ",PRECISION)
+CALL MPPDB_CHECK3D(XUT,"anel_balancen3.1-after update halo::XUT",PRECISION)
+CALL MPPDB_CHECK3D(XWT,"anel_balancen3.1-after update halo::XWT",PRECISION)
+!
+ZRU(:,:,:) = MXM(XRHODJ) * XUT(:,:,:)
+ZRV(:,:,:) = MYM(XRHODJ) * XVT(:,:,:)
+ZRW(:,:,:) = MZM(XRHODJ) * XWT(:,:,:)
+ZTH(:,:,:) = XTHT(:,:,:)
+ALLOCATE(ZRR(SIZE(XRHODJ,1),SIZE(XRHODJ,2),SIZE(XRHODJ,3),SIZE(XRT,4)))
+ZRR(:,:,:,:) = XRT(:,:,:,:)
+!20131112 appli update_halo_ll
+CALL ADD3DFIELD_ll( TZFIELDS_ll, ZRU, 'ANEL_BALANCE_n::ZRU' )
+CALL ADD3DFIELD_ll( TZFIELDS_ll, ZRV, 'ANEL_BALANCE_n::ZRV' )
+CALL ADD3DFIELD_ll( TZFIELDS_ll, ZRW, 'ANEL_BALANCE_n::ZRW' )
+CALL ADD3DFIELD_ll( TZFIELDS_ll, ZTH, 'ANEL_BALANCE_n::ZTH' )
+CALL UPDATE_HALO_ll(TZFIELDS_ll,IINFO_ll)
+CALL CLEANLIST_ll(TZFIELDS_ll)
+CALL MPPDB_CHECK3D(ZRU,"anel_balancen3.1-after1stupdhalo::ZRU",PRECISION)
+!$20131125 add extrapol on ZRU to have correct boundaries
+!CALL EXTRAPOL('W',ZRU) ! ZRU boundaries now correct
+CALL MPPDB_CHECK3D(ZRU,"anel_balancen3.1-afterextrapol W::ZRU",PRECISION)
+!20131126 add extrapol on ZRV to have correct boundaries
+!CALL EXTRAPOL('S',ZRV) ! ZRV boundaries now correct
+CALL MPPDB_CHECK3D(ZRV,"anel_balancen3.1-afterextrapol S::ZRV",PRECISION)
+CALL MPPDB_CHECK3D(ZRW,"anel_balancen3.1-afterextrapol S::ZRW",PRECISION)
+!
+!
+!
+!
+!* 3.2 satisfy the anelastic constraint
+!
+ITCOUNT =-1 ! no first guess of the pressure is available
+ZPABST(:,:,:)= 0. ! ==================CAUTION=====================
+ZDRYMASST = 0. ! | Initialization necessary for the |
+ZREFMASS = 0. ! | computation of the absolute pressure, |
+ZMASS_O_PHI0 = 1. ! | which is here not needed |
+IRR = 0 ! | |
+IRRL = 0 ! | |
+IRRI = 0 ! ==============================================
+GCLOSE_OUT=.FALSE.
+YFMFILE='UNUSED'
+!
+IMI = GET_CURRENT_MODEL_INDEX()
+CALL PRESSUREZ(CLBCX,CLBCY,CPRESOPT,NITR,LITRADJ,ITCOUNT,XRELAX,IMI, &
+ XRHODJ,XDXX,XDYY,XDZZ,XDZX,XDZY,ZDXHATM,ZDYHATM,ZRHOM, &
+ ZAF,ZBFY,ZCF,ZTRIGSX,ZTRIGSY,IIFAXX,IIFAXY, &
+ IRR,IRRL,IRRI,ZDRYMASST,ZREFMASS,ZMASS_O_PHI0, &
+ ZTH,ZRR,XRHODREF,XTHVREF,XRVREF,XEXNREF, XLINMASS, &
+ ZRU,ZRV,ZRW,ZPABST, &
+ ZBFB,ZBF_SXP2_YP1_Z, &
+ XAF_ZS,XBF_ZS,XCF_ZS, &
+ XDXATH_ZS,XDYATH_ZS,XRHO_ZS, &
+ XA_K,XB_K,XC_K,XD_K, &
+ PRESIDUAL )
+!
+CALL MPPDB_CHECK3D(XRHODJ,"anel_balancen3.2-after pressurez halo::XRHODJ",PRECISION)
+CALL MPPDB_CHECK3D(ZRU,"anel_balancen3.2-after pressurez::ZRU",PRECISION)
+CALL MPPDB_CHECK3D(ZRV,"anel_balancen3.2-after pressurez::ZRV",PRECISION)
+!
+DEALLOCATE(ZBFY,ZTRIGSX,ZTRIGSY,ZRR,ZBF_SXP2_YP1_Z)
+!* 3.2 return to the historical variables
+!
+!20131112 appli update_halo_ll and associated operations
+XUT(:,:,:) = ZRU(:,:,:) / MXM(XRHODJ)
+XVT(:,:,:) = ZRV(:,:,:) / MYM(XRHODJ)
+XWT(:,:,:) = ZRW(:,:,:) / MZM(XRHODJ)
+!20131112 appli update_halo_ll to XUT,XVT,XWT
+CALL ADD3DFIELD_ll( TZFIELDS_ll, XUT, 'ANEL_BALANCE_n::XUT' )
+CALL ADD3DFIELD_ll( TZFIELDS_ll, XVT, 'ANEL_BALANCE_n::XVT' )
+CALL ADD3DFIELD_ll( TZFIELDS_ll, XWT, 'ANEL_BALANCE_n::XWT' )
+CALL UPDATE_HALO_ll(TZFIELDS_ll,IINFO_ll)
+CALL CLEANLIST_ll(TZFIELDS_ll)
+CALL MPPDB_CHECK3D(XUT,"anel_balancen3.2-afterupdhalo::XUT",PRECISION)
+CALL MPPDB_CHECK3D(XVT,"anel_balancen3.2-afterupdhalo::XVT",PRECISION)
+!20131125 apply extrapol to fix boundary issue in //
+CALL EXTRAPOL('W',XUT)
+CALL EXTRAPOL('S',XVT)
+CALL MPPDB_CHECK3D(XUT,"anel_balancen3.2-after extrapolW::XUT",PRECISION)
+CALL MPPDB_CHECK3D(XVT,"anel_balancen3.2-after extrapolS::XVT",PRECISION)
+!
+!
+!-------------------------------------------------------------------------------
+!
+END SUBROUTINE ANEL_BALANCE_n
diff --git a/src/ZSOLVER/contrav.f90 b/src/ZSOLVER/contrav.f90
new file mode 100644
index 0000000000000000000000000000000000000000..ebef79590bb7b5f6faa48cb6a8a680d0525a4f3e
--- /dev/null
+++ b/src/ZSOLVER/contrav.f90
@@ -0,0 +1,896 @@
+!MNH_LIC Copyright 1994-2020 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.
+!-----------------------------------------------------------------
+! ####################
+ MODULE MODI_CONTRAV
+! ####################
+!
+INTERFACE
+!
+ SUBROUTINE CONTRAV(HLBCX,HLBCY,PRUT,PRVT,PRWT,PDXX,PDYY,PDZZ,PDZX,PDZY, &
+ PRUCT,PRVCT,PRWCT,KADV_ORDER )
+!
+!
+CHARACTER (LEN=4), DIMENSION(2), INTENT(IN) :: HLBCX ! X direction LBC type
+CHARACTER (LEN=4), DIMENSION(2), INTENT(IN) :: HLBCY ! Y direction LBC type
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRUT ! Cartesian comp along x
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRVT ! Cartesian comp along y
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRWT ! Cartesian comp along z
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDXX ! Metric coefficients
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDYY ! Metric coefficients
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDZZ ! Metric coefficients
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDZX ! Metric coefficients
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDZY ! Metric coefficients
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PRUCT ! Contrav comp along x-bar
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PRVCT ! Contrav comp along y-bar
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PRWCT ! Contrav comp along z-bar
+INTEGER, INTENT(IN) :: KADV_ORDER ! Order of the advection scheme
+!
+END SUBROUTINE CONTRAV
+!
+#ifdef MNH_OPENACC
+ SUBROUTINE CONTRAV_DEVICE(HLBCX,HLBCY,PRUT,PRVT,PRWT,PDXX,PDYY,PDZZ,PDZX,PDZY, &
+ PRUCT,PRVCT,PRWCT,KADV_ORDER,Z1,Z2,ODATA_ON_DEVICE )
+!
+!
+CHARACTER (LEN=4), DIMENSION(2), INTENT(IN) :: HLBCX ! X direction LBC type
+CHARACTER (LEN=4), DIMENSION(2), INTENT(IN) :: HLBCY ! Y direction LBC type
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRUT ! Cartesian comp along x
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRVT ! Cartesian comp along y
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRWT ! Cartesian comp along z
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDXX ! Metric coefficients
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDYY ! Metric coefficients
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDZZ ! Metric coefficients
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDZX ! Metric coefficients
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDZY ! Metric coefficients
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PRUCT ! Contrav comp along x-bar
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PRVCT ! Contrav comp along y-bar
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PRWCT ! Contrav comp along z-bar
+INTEGER, INTENT(IN) :: KADV_ORDER ! Order of the advection scheme
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: Z1,Z2 ! Work arrays
+LOGICAL, OPTIONAL, INTENT(IN) :: ODATA_ON_DEVICE ! Is some of the data on the accelerator device
+!
+!
+END SUBROUTINE CONTRAV_DEVICE
+#endif
+!
+END INTERFACE
+!
+END MODULE MODI_CONTRAV
+!
+!
+!
+! ##############################################################
+ SUBROUTINE CONTRAV(HLBCX,HLBCY,PRUT,PRVT,PRWT,PDXX,PDYY,PDZZ,PDZX,PDZY, &
+ PRUCT,PRVCT,PRWCT,KADV_ORDER )
+! ##############################################################
+!
+!!**** *CONTRAV * - computes the contravariant components from the
+!! cartesian components
+!!
+!! PURPOSE
+!! -------
+! This routine computes the contravariant components of vector
+! defined by its cartesian components (U,V,W) , using the following
+! formulae:
+! UC = U / DXX
+! VC = V / DYY
+! ( ----------x ----------y )
+! ( ---z ---z )
+! 1 ( U V )
+! WC = --- ( W - DZX * --- - DZY * --- )
+! DZZ ( DXX DYY )
+!
+!
+! In the no-topography case, WC = W / DZZ
+!
+!
+!!** METHOD
+!! ------
+!! We employ the Shuman operators to compute the averages. The metric
+!! coefficients PDXX, PDYY, PDZX, PDZY, PDZZ are dummy arguments
+!!
+!!
+!! EXTERNAL
+!! --------
+!!
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!! Module MODD_CONF : contains configuration variable
+!! LFLAT : Logical for topography
+!! = .TRUE. if Zs = 0 (Flat terrain)
+!!
+!! REFERENCE
+!! ---------
+!! Book2 of documentation (subroutine CONTRAV)
+!!
+!!
+!! AUTHOR
+!! ------
+!! J.L. Redelsperger * CNRM *
+!! J.-P. Pinty * Laboratoire d'Aerologie*
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 27/07/94
+!! Corrections 3/08/94 (by J.P. Lafore)
+!! Corrections 17/10/94 (by J.P. Lafore) WC modified for w-advection
+!! Corrections 19/01/11 (by J.P. Pinty) WC 4th order
+!! Corrections 28/03/11 (by V.Masson) // of WC 4th order
+!! J.Escobar 21/03/2013: for HALOK comment all NHALO=1 test
+! P. Wautelet 20/05/2019: add name argument to ADDnFIELD_ll + new ADD4DFIELD_ll subroutine
+!----------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+USE MODD_CONF
+USE MODD_PARAMETERS
+USE MODD_GRID_n, ONLY: XZZ
+!
+USE MODD_ARGSLIST_ll, ONLY : HALO2LIST_ll
+USE MODE_ll
+!
+USE MODI_GET_HALO
+!
+USE MODE_MPPDB
+!
+IMPLICIT NONE
+!
+!* 0.1 declarations of arguments
+!
+CHARACTER (LEN=4), DIMENSION(2), INTENT(IN) :: HLBCX ! X direction LBC type
+CHARACTER (LEN=4), DIMENSION(2), INTENT(IN) :: HLBCY ! Y direction LBC type
+!
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRUT ! Cartesian comp along x
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRVT ! Cartesian comp along y
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRWT ! Cartesian comp along z
+!
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDXX ! Metric coefficients
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDYY ! Metric coefficients
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDZZ ! Metric coefficients
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDZX ! Metric coefficients
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDZY ! Metric coefficients
+!
+!
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PRUCT ! Contrav comp along x-bar
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PRVCT ! Contrav comp along y-bar
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PRWCT ! Contrav comp along z-bar
+INTEGER, INTENT(IN) :: KADV_ORDER ! Order of the advection scheme
+!
+!
+!* 0.2 declarations of local variables
+!
+REAL, DIMENSION(SIZE(PDXX,1),SIZE(PDXX,2),SIZE(PDXX,3)):: Z1,Z2
+INTEGER :: IIB,IIE,IJB,IJE,IKB,IKE
+INTEGER :: IIU, IJU, IKU
+INTEGER:: IW,IE,IS,IN ! Coordinate of forth order diffusion area
+!
+TYPE(LIST_ll), POINTER :: TZFIELD_U, TZFIELD_V, TZFIELD_DZX, TZFIELD_DZY
+TYPE(HALO2LIST_ll), POINTER :: TZHALO2_U, TZHALO2_V, TZHALO2_DZX, TZHALO2_DZY
+INTEGER :: IINFO_ll
+!-----------------------------------------------------------------------
+!
+!* 1. Compute the horizontal contravariant components
+! -----------------------------------------------
+!
+IF (MPPDB_INITIALIZED) THEN
+ !Check all IN arrays
+ CALL MPPDB_CHECK(PRUT,"CONTRAV beg:PRUT")
+ CALL MPPDB_CHECK(PRVT,"CONTRAV beg:PRVT")
+ CALL MPPDB_CHECK(PRWT,"CONTRAV beg:PRWT")
+ CALL MPPDB_CHECK(PDXX,"CONTRAV beg:PDXX")
+ CALL MPPDB_CHECK(PDYY,"CONTRAV beg:PDYY")
+ CALL MPPDB_CHECK(PDZZ,"CONTRAV beg:PDZZ")
+ CALL MPPDB_CHECK(PDZX,"CONTRAV beg:PDZX")
+ CALL MPPDB_CHECK(PDZY,"CONTRAV beg:PDZY")
+END IF
+!
+IIU= SIZE(PDXX,1)
+IJU= SIZE(PDXX,2)
+IKU= SIZE(PDXX,3)
+!
+CALL GET_INDICE_ll( IIB,IJB,IIE,IJE)
+!
+IKB=1+JPVEXT
+IKE=IKU - JPVEXT
+!
+PRUCT(:,:,:) = PRUT(:,:,:) / PDXX(:,:,:)
+PRVCT(:,:,:) = PRVT(:,:,:) / PDYY(:,:,:)
+!
+IF (KADV_ORDER == 4 ) THEN
+ IF( .NOT. LFLAT) THEN
+ NULLIFY(TZFIELD_U)
+ NULLIFY(TZFIELD_V)
+ CALL ADD3DFIELD_ll( TZFIELD_U, PRUCT, 'CONTRAV::PRUCT' )
+ CALL ADD3DFIELD_ll( TZFIELD_V, PRVCT, 'CONTRAV::PRVCT' )
+ CALL UPDATE_HALO_ll(TZFIELD_U,IINFO_ll)
+ CALL UPDATE_HALO_ll(TZFIELD_V,IINFO_ll)
+!!$ IF( NHALO==1 ) THEN
+ NULLIFY(TZFIELD_DZX)
+ NULLIFY(TZFIELD_DZY)
+ CALL ADD3DFIELD_ll( TZFIELD_DZX, PDZX, 'CONTRAV::PDZX' )
+ CALL ADD3DFIELD_ll( TZFIELD_DZY, PDZY, 'CONTRAV::PDZY' )
+ NULLIFY(TZHALO2_U)
+ NULLIFY(TZHALO2_V)
+ NULLIFY(TZHALO2_DZX)
+ NULLIFY(TZHALO2_DZY)
+ CALL INIT_HALO2_ll(TZHALO2_U,1,IIU,IJU,IKU)
+ CALL INIT_HALO2_ll(TZHALO2_V,1,IIU,IJU,IKU)
+ CALL INIT_HALO2_ll(TZHALO2_DZX,1,IIU,IJU,IKU)
+ CALL INIT_HALO2_ll(TZHALO2_DZY,1,IIU,IJU,IKU)
+ CALL UPDATE_HALO2_ll(TZFIELD_U, TZHALO2_U, IINFO_ll)
+ CALL UPDATE_HALO2_ll(TZFIELD_V, TZHALO2_V, IINFO_ll)
+ CALL UPDATE_HALO2_ll(TZFIELD_DZX, TZHALO2_DZX, IINFO_ll)
+ CALL UPDATE_HALO2_ll(TZFIELD_DZY, TZHALO2_DZY, IINFO_ll)
+!!$ END IF
+ END IF
+END IF
+!
+!
+!* 2. Compute the vertical contravariant components (flat case)
+! ------------------------------------
+!
+IF (LFLAT) THEN
+ PRWCT(:,:,:) = PRWT(:,:,:) / PDZZ(:,:,:)
+ RETURN
+END IF
+!
+!* 3. Compute the vertical contravariant components (general case)
+! ------------------------------------
+!
+Z1 = 0.
+Z2 = 0.
+!
+IF (KADV_ORDER == 2 ) THEN
+!
+ Z1(IIB:IIE,:,IKB:IKE+1)= &
+ (PRUCT(IIB:IIE,:,IKB:IKE+1)+PRUCT(IIB:IIE,:,IKB-1:IKE) ) &
+ *PDZX(IIB:IIE,:,IKB:IKE+1) *0.25 &
+ +(PRUCT(IIB+1:IIE+1,:,IKB:IKE+1)+PRUCT(IIB+1:IIE+1,:,IKB-1:IKE) ) &
+ *PDZX(IIB+1:IIE+1,:,IKB:IKE+1) *0.25
+
+ Z2(:,IJB:IJE,IKB:IKE+1)= &
+ (PRVCT(:,IJB:IJE,IKB:IKE+1)+PRVCT(:,IJB:IJE,IKB-1:IKE) ) &
+ *PDZY(:,IJB:IJE,IKB:IKE+1) *0.25 &
+ +(PRVCT(:,IJB+1:IJE+1,IKB:IKE+1)+PRVCT(:,IJB+1:IJE+1,IKB-1:IKE) ) &
+ *PDZY(:,IJB+1:IJE+1,IKB:IKE+1) *0.25
+ PRWCT=0.
+ PRWCT(IIB:IIE,IJB:IJE,IKB:IKE+1) = &
+ ( PRWT(IIB:IIE,IJB:IJE,IKB:IKE+1) &
+ - Z1(IIB:IIE,IJB:IJE,IKB:IKE+1) &
+ - Z2(IIB:IIE,IJB:IJE,IKB:IKE+1) &
+ ) / PDZZ(IIB:IIE,IJB:IJE,IKB:IKE+1)
+!
+ELSE IF (KADV_ORDER == 4 ) THEN
+!
+!!$ IF (NHALO == 1) THEN
+ IF ( LWEST_ll() .AND. HLBCX(1)/='CYCL' ) THEN
+ IW=IIB+2 -1
+ ELSE
+ IW=IIB+1 -1
+ END IF
+ IE=IIE-1
+!!$ ELSE
+!!$ IF (LWEST_ll()) THEN
+!!$ IW=IIB+1
+!!$ ELSE
+!!$ IW=IIB
+!!$ END IF
+!!$ IF (LEAST_ll() .AND. HLBCX(2)/='CYCL' ) THEN
+!!$ IE=IIE-1
+!!$ ELSE
+!!$ IE=IIE
+!!$ END IF
+!!$ END IF
+ !
+!!$ IF(NHALO == 1) THEN
+ IF ( LSOUTH_ll() .AND. HLBCY(1)/='CYCL' ) THEN
+ IS=IJB+2 -1
+ ELSE
+ IS=IJB+1 -1
+ END IF
+ IN=IJE-1
+!!$ ELSE
+!!$ IF (LSOUTH_ll()) THEN
+!!$ IS=IJB+1
+!!$ ELSE
+!!$ IS=IJB
+!!$ END IF
+!!$ IF (LNORTH_ll() .AND. HLBCY(2)/='CYCL' ) THEN
+!!$ IN=IJE-1
+!!$ ELSE
+!!$ IN=IJE
+!!$ END IF
+!!$ END IF
+ !
+ !
+ !* 3.1 interior of the process subdomain
+!
+!
+ Z1(IW:IE,:,IKB:IKE+1)= &
+ 7.0*( (PRUCT(IW:IE,:,IKB:IKE+1)+PRUCT(IW:IE,:,IKB-1:IKE)) &
+ *( 9.0*PDZX(IW:IE,:,IKB:IKE+1)-(PDZX(IW+1:IE+1,:,IKB:IKE+1) &
+ +PDZX(IW:IE,:,IKB:IKE+1)+PDZX(IW-1:IE-1,:,IKB:IKE+1))/3.0)/8.0 * 0.5 &
+ +(PRUCT(IW+1:IE+1,:,IKB:IKE+1)+PRUCT(IW+1:IE+1,:,IKB-1:IKE)) &
+ *( 9.0*PDZX(IW+1:IE+1,:,IKB:IKE+1)-(PDZX(IW+2:IE+2,:,IKB:IKE+1) &
+ +PDZX(IW+1:IE+1,:,IKB:IKE+1)+PDZX(IW:IE,:,IKB:IKE+1))/3.0)/8.0 * 0.5 )/12.0 &
+ -( (PRUCT(IW-1:IE-1,:,IKB:IKE+1)+PRUCT(IW-1:IE-1,:,IKB-1:IKE)) &
+ *PDZX(IW-1:IE-1,:,IKB:IKE+1) *0.5 &
+ +(PRUCT(IW+2:IE+2,:,IKB:IKE+1)+PRUCT(IW+2:IE+2,:,IKB-1:IKE)) &
+ *PDZX(IW+2:IE+2,:,IKB:IKE+1) *0.5)/12.0
+
+!
+ Z2(:,IS:IN,IKB:IKE+1)= &
+ 7.0*( (PRVCT(:,IS:IN,IKB:IKE+1)+PRVCT(:,IS:IN,IKB-1:IKE)) &
+ *( 9.0*PDZY(:,IS:IN,IKB:IKE+1)-(PDZY(:,IS+1:IN+1,IKB:IKE+1) &
+ +PDZY(:,IS:IN,IKB:IKE+1)+PDZY(:,IS-1:IN-1,IKB:IKE+1))/3.0)/8.0 * 0.5 &
+ +(PRVCT(:,IS+1:IN+1,IKB:IKE+1)+PRVCT(:,IS+1:IN+1,IKB-1:IKE)) &
+ *( 9.0*PDZY(:,IS+1:IN+1,IKB:IKE+1)-(PDZY(:,IS+2:IN+2,IKB:IKE+1) &
+ +PDZY(:,IS+1:IN+1,IKB:IKE+1)+PDZY(:,IS:IN,IKB:IKE+1))/3.0)/8.0 * 0.5 )/12.0 &
+ -( (PRVCT(:,IS-1:IN-1,IKB:IKE+1)+PRVCT(:,IS-1:IN-1,IKB-1:IKE)) &
+ *PDZY(:,IS-1:IN-1,IKB:IKE+1) *0.5 &
+ +(PRVCT(:,IS+2:IN+2,IKB:IKE+1)+PRVCT(:,IS+2:IN+2,IKB-1:IKE)) &
+ *PDZY(:,IS+2:IN+2,IKB:IKE+1) *0.5)/12.0
+!
+!* 3.2 limits of the process subdomain (inside the whole domain or in cyclic conditions)
+!
+!!$ IF (NHALO==1) THEN
+
+ Z1(IIE,:,IKB:IKE+1)= &
+ 7.0*( (PRUCT(IIE,:,IKB:IKE+1)+PRUCT(IIE,:,IKB-1:IKE)) &
+ *( 9.0*PDZX(IIE,:,IKB:IKE+1)-(PDZX(IIE+1,:,IKB:IKE+1) &
+ +PDZX(IIE,:,IKB:IKE+1)+PDZX(IIE-1,:,IKB:IKE+1))/3.0)/8.0 * 0.5 &
+ +(PRUCT(IIE+1,:,IKB:IKE+1)+PRUCT(IIE+1,:,IKB-1:IKE)) &
+ *( 9.0*PDZX(IIE+1,:,IKB:IKE+1)-(TZHALO2_DZX%HALO2%EAST(:,IKB:IKE+1) &
+ +PDZX(IIE+1,:,IKB:IKE+1)+PDZX(IIE,:,IKB:IKE+1))/3.0)/8.0 * 0.5 )/12.0 &
+ -( (PRUCT(IIE-1,:,IKB:IKE+1)+PRUCT(IIE-1,:,IKB-1:IKE)) &
+ *PDZX(IIE-1,:,IKB:IKE+1) *0.5 &
+ +(TZHALO2_U%HALO2%EAST(:,IKB:IKE+1)+TZHALO2_U%HALO2%EAST(:,IKB-1:IKE)) &
+ *TZHALO2_DZX%HALO2%EAST(:,IKB:IKE+1) *0.5)/12.0
+!
+ Z2(:,IJE,IKB:IKE+1)= &
+ 7.0*( (PRVCT(:,IJE,IKB:IKE+1)+PRVCT(:,IJE,IKB-1:IKE)) &
+ *( 9.0*PDZY(:,IJE,IKB:IKE+1)-(PDZY(:,IJE+1,IKB:IKE+1) &
+ +PDZY(:,IJE,IKB:IKE+1)+PDZY(:,IJE-1,IKB:IKE+1))/3.0)/8.0 * 0.5 &
+ +(PRVCT(:,IJE+1,IKB:IKE+1)+PRVCT(:,IJE+1,IKB-1:IKE)) &
+ *( 9.0*PDZY(:,IJE+1,IKB:IKE+1)-(TZHALO2_DZY%HALO2%NORTH(:,IKB:IKE+1) &
+ +PDZY(:,IJE+1,IKB:IKE+1)+PDZY(:,IJE,IKB:IKE+1))/3.0)/8.0 * 0.5 )/12.0 &
+ -( (PRVCT(:,IJE-1,IKB:IKE+1)+PRVCT(:,IJE-1,IKB-1:IKE)) &
+ *PDZY(:,IJE-1,IKB:IKE+1) *0.5 &
+ +(TZHALO2_V%HALO2%NORTH(:,IKB:IKE+1)+TZHALO2_V%HALO2%NORTH(:,IKB-1:IKE)) &
+ *TZHALO2_DZY%HALO2%NORTH(:,IKB:IKE+1) *0.5)/12.0
+!!$ END IF
+!
+!* 3.3 non-CYCLIC CASE IN THE X DIRECTION: 2nd order case
+!
+ IF (HLBCX(1)/='CYCL' .AND. LWEST_ll()) THEN
+!
+ Z1(IIB,:,IKB:IKE+1)= &
+ (PRUCT(IIB,:,IKB:IKE+1)+PRUCT(IIB,:,IKB-1:IKE) ) &
+ *PDZX(IIB,:,IKB:IKE+1) *0.25 &
+ +(PRUCT(IIB+1,:,IKB:IKE+1)+PRUCT(IIB+1,:,IKB-1:IKE) ) &
+ *PDZX(IIB+1,:,IKB:IKE+1) *0.25
+ END IF
+!
+ IF (HLBCX(2)/='CYCL' .AND. LEAST_ll()) THEN
+!
+ Z1(IIE,:,IKB:IKE+1)= &
+ (PRUCT(IIE,:,IKB:IKE+1)+PRUCT(IIE,:,IKB-1:IKE) ) &
+ *PDZX(IIE,:,IKB:IKE+1) *0.25 &
+ +(PRUCT(IIE+1,:,IKB:IKE+1)+PRUCT(IIE+1,:,IKB-1:IKE) ) &
+ *PDZX(IIE+1,:,IKB:IKE+1) *0.25
+ END IF
+!
+!* 3.4 non-CYCLIC CASE IN THE Y DIRECTION: 2nd order case
+!
+ IF (HLBCY(1)/='CYCL' .AND. LSOUTH_ll()) THEN
+!
+ Z2(:,IJB,IKB:IKE+1)= &
+ (PRVCT(:,IJB,IKB:IKE+1)+PRVCT(:,IJB,IKB-1:IKE) ) &
+ *PDZY(:,IJB,IKB:IKE+1) *0.25 &
+ +(PRVCT(:,IJB+1,IKB:IKE+1)+PRVCT(:,IJB+1,IKB-1:IKE) ) &
+ *PDZY(:,IJB+1,IKB:IKE+1) *0.25
+!
+ END IF
+!
+ IF (HLBCY(2)/='CYCL' .AND. LNORTH_ll()) THEN
+!
+ Z2(:,IJE,IKB:IKE+1)= &
+ (PRVCT(:,IJE,IKB:IKE+1)+PRVCT(:,IJE,IKB-1:IKE) ) &
+ *PDZY(:,IJE,IKB:IKE+1) *0.25 &
+ +(PRVCT(:,IJE+1,IKB:IKE+1)+PRVCT(:,IJE+1,IKB-1:IKE) ) &
+ *PDZY(:,IJE+1,IKB:IKE+1) *0.25
+!
+ END IF
+!
+!* 3.5 Vertical contyravariant wind
+!
+!
+!!$ CALL GET_HALO(Z1)
+!!$ CALL GET_HALO(Z2)
+!!$
+!!$ CALL MPPDB_CHECK3DM("contrav ::Z1/Z2/ PDZZ",PRECISION,Z1,Z2,PDZZ)
+ PRWCT=0.
+ PRWCT(IIB:IIE,IJB:IJE,IKB:IKE+1) = &
+ ( PRWT(IIB:IIE,IJB:IJE,IKB:IKE+1) &
+ - Z1(IIB:IIE,IJB:IJE,IKB:IKE+1) &
+ - Z2(IIB:IIE,IJB:IJE,IKB:IKE+1) &
+ ) / PDZZ(IIB:IIE,IJB:IJE,IKB:IKE+1)
+!
+END IF
+!
+PRWCT(:,:,1) = - PRWCT(:,:,3) ! Mirror hypothesis
+!
+IF (KADV_ORDER == 4 ) THEN
+ CALL CLEANLIST_ll(TZFIELD_U)
+ CALL CLEANLIST_ll(TZFIELD_V)
+!!$ IF (NHALO==1) THEN
+ CALL CLEANLIST_ll(TZFIELD_DZX)
+ CALL CLEANLIST_ll(TZFIELD_DZY)
+ CALL DEL_HALO2_ll(TZHALO2_U)
+ CALL DEL_HALO2_ll(TZHALO2_V)
+ CALL DEL_HALO2_ll(TZHALO2_DZX)
+ CALL DEL_HALO2_ll(TZHALO2_DZY)
+!!$ END IF
+END IF
+!-----------------------------------------------------------------------
+IF (MPPDB_INITIALIZED) THEN
+ !Check all OUT arrays
+ CALL MPPDB_CHECK(PRUCT,"CONTRAV end:PRUCT")
+ CALL MPPDB_CHECK(PRVCT,"CONTRAV end:PRVCT")
+ CALL MPPDB_CHECK(PRWCT,"CONTRAV end:PRWCT")
+END IF
+!
+END SUBROUTINE CONTRAV
+!
+#ifdef MNH_OPENACC
+! ##############################################################
+ SUBROUTINE CONTRAV_DEVICE(HLBCX,HLBCY,PRUT,PRVT,PRWT,PDXX,PDYY,PDZZ,PDZX,PDZY, &
+ PRUCT,PRVCT,PRWCT,KADV_ORDER,Z1,Z2,ODATA_ON_DEVICE )
+! ##############################################################
+!
+!!**** *CONTRAV * - computes the contravariant components from the
+!! cartesian components
+!!
+!! PURPOSE
+!! -------
+! This routine computes the contravariant components of vector
+! defined by its cartesian components (U,V,W) , using the following
+! formulae:
+! UC = U / DXX
+! VC = V / DYY
+! ( ----------x ----------y )
+! ( ---z ---z )
+! 1 ( U V )
+! WC = --- ( W - DZX * --- - DZY * --- )
+! DZZ ( DXX DYY )
+!
+!
+! In the no-topography case, WC = W / DZZ
+!
+!
+!!** METHOD
+!! ------
+!! We employ the Shuman operators to compute the averages. The metric
+!! coefficients PDXX, PDYY, PDZX, PDZY, PDZZ are dummy arguments
+!!
+!!
+!! EXTERNAL
+!! --------
+!! MXF, MYF, MZM : Shuman functions (mean operators)
+!!
+!! Module MODI_SHUMAN : Interface for Shuman functions
+!!
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!! Module MODD_CONF : contains configuration variable
+!! LFLAT : Logical for topography
+!! = .TRUE. if Zs = 0 (Flat terrain)
+!!
+!! REFERENCE
+!! ---------
+!! Book2 of documentation (subroutine CONTRAV)
+!!
+!!
+!! AUTHOR
+!! ------
+!! J.L. Redelsperger * CNRM *
+!! J.-P. Pinty * Laboratoire d'Aerologie*
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 27/07/94
+!! Corrections 3/08/94 (by J.P. Lafore)
+!! Corrections 17/10/94 (by J.P. Lafore) WC modified for w-advection
+!! Corrections 19/01/11 (by J.P. Pinty) WC 4th order
+!! Corrections 28/03/11 (by V.Masson) // of WC 4th order
+!! J.Escobar 21/03/2013: for HALOK comment all NHALO=1 test
+! P. Wautelet 26/06/2019: optimisation for GPU + improve readability
+!----------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+USE MODD_ARGSLIST_ll, ONLY: HALO2LIST_ll
+USE MODD_CONF
+USE MODD_GRID_n, ONLY: XZZ
+USE MODD_PARAMETERS
+!
+USE MODE_ll
+USE MODE_MPPDB
+#ifdef MNH_OPENACC
+use mode_msg
+#endif
+!
+USE MODI_GET_HALO
+USE MODI_SHUMAN
+!
+IMPLICIT NONE
+!
+!* 0.1 declarations of arguments
+!
+CHARACTER (LEN=4), DIMENSION(2), INTENT(IN) :: HLBCX ! X direction LBC type
+CHARACTER (LEN=4), DIMENSION(2), INTENT(IN) :: HLBCY ! Y direction LBC type
+!
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRUT ! Cartesian comp along x
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRVT ! Cartesian comp along y
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRWT ! Cartesian comp along z
+!
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDXX ! Metric coefficients
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDYY ! Metric coefficients
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDZZ ! Metric coefficients
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDZX ! Metric coefficients
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDZY ! Metric coefficients
+!
+!
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PRUCT ! Contrav comp along x-bar
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PRVCT ! Contrav comp along y-bar
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PRWCT ! Contrav comp along z-bar
+INTEGER, INTENT(IN) :: KADV_ORDER ! Order of the advection scheme
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: Z1,Z2 ! Work arrays
+LOGICAL, OPTIONAL, INTENT(IN) :: ODATA_ON_DEVICE ! Is some of the data on the accelerator device
+!
+!
+!* 0.2 declarations of local variables
+!
+integer :: ji, jj, jk
+INTEGER :: IIB, IIE, IJB, IJE, IKB, IKE
+INTEGER :: IIU, IJU, IKU
+INTEGER :: IW, IE, IS, IN ! Coordinate of fourth order diffusion area
+INTEGER :: IINFO_ll
+LOGICAL :: GDATA_ON_DEVICE
+real :: ZTMP1, ZTMP2 ! Intermediate work variables
+REAL, DIMENSION(:,:), POINTER , CONTIGUOUS :: ZU_EAST, ZV_NORTH, ZDZX_EAST, ZDZY_NORTH
+TYPE(LIST_ll), POINTER :: TZFIELD_U, TZFIELD_V, TZFIELD_DZX, TZFIELD_DZY
+TYPE(HALO2LIST_ll), POINTER :: TZHALO2_U, TZHALO2_V, TZHALO2_DZX, TZHALO2_DZY
+!
+LOGICAL :: GWEST,GEAST,GSOUTH,GNORTH
+!
+!$acc data present( PRUT, PRVT, PRWT, PDXX, PDYY, PDZZ, PDZX, PDZY, PRUCT, PRVCT, PRWCT, Z1, Z2 )
+
+IF ( PRESENT(ODATA_ON_DEVICE) ) THEN
+ GDATA_ON_DEVICE = ODATA_ON_DEVICE
+ELSE
+ GDATA_ON_DEVICE = .FALSE.
+END IF
+!-----------------------------------------------------------------------
+!
+!* 1. Compute the horizontal contravariant components
+! -----------------------------------------------
+!
+IF (MPPDB_INITIALIZED) THEN
+ !Check all IN arrays
+ CALL MPPDB_CHECK(PRUT,"CONTRAV beg:PRUT")
+ CALL MPPDB_CHECK(PRVT,"CONTRAV beg:PRVT")
+ CALL MPPDB_CHECK(PRWT,"CONTRAV beg:PRWT")
+ CALL MPPDB_CHECK(PDXX,"CONTRAV beg:PDXX")
+ CALL MPPDB_CHECK(PDYY,"CONTRAV beg:PDYY")
+ CALL MPPDB_CHECK(PDZZ,"CONTRAV beg:PDZZ")
+ CALL MPPDB_CHECK(PDZX,"CONTRAV beg:PDZX")
+ CALL MPPDB_CHECK(PDZY,"CONTRAV beg:PDZY")
+END IF
+!
+IIU= SIZE(PDXX,1)
+IJU= SIZE(PDXX,2)
+IKU= SIZE(PDXX,3)
+!
+GWEST = ( HLBCX(1) /= 'CYCL' .AND. LWEST_ll() )
+GEAST = ( HLBCX(2) /= 'CYCL' .AND. LEAST_ll() )
+GSOUTH = ( HLBCY(1) /= 'CYCL' .AND. LSOUTH_ll() )
+GNORTH = ( HLBCY(2) /= 'CYCL' .AND. LNORTH_ll() )
+!
+CALL GET_INDICE_ll( IIB,IJB,IIE,IJE)
+!
+IKB=1+JPVEXT
+IKE=IKU - JPVEXT
+!
+IF (GDATA_ON_DEVICE) THEN
+!PW TODO:remplacer (ailleurs aussi...) 1/PDXX... par PINV_PDXX (fait pour la turbulence...) cfr MNH/turb_hor_splt.f90
+!$acc kernels
+ PRUCT(:,:,:) = PRUT(:,:,:) / PDXX(:,:,:)
+ PRVCT(:,:,:) = PRVT(:,:,:) / PDYY(:,:,:)
+!$acc end kernels
+!$acc update self(PRUCT,PRVCT)
+ELSE
+ PRUCT(:,:,:) = PRUT(:,:,:) / PDXX(:,:,:)
+ PRVCT(:,:,:) = PRVT(:,:,:) / PDYY(:,:,:)
+END IF
+!
+IF (KADV_ORDER == 4 ) THEN
+ IF( .NOT. LFLAT) THEN
+!!$ NULLIFY(TZFIELD_U)
+!!$ NULLIFY(TZFIELD_V)
+!!$ CALL ADD3DFIELD_ll( TZFIELD_U, PRUCT, 'CONTRAV::PRUCT' )
+!!$ CALL ADD3DFIELD_ll( TZFIELD_V, PRVCT, 'CONTRAV::PRVCT' )
+!!$ CALL UPDATE_HALO_ll(TZFIELD_U,IINFO_ll)
+!!$ CALL UPDATE_HALO_ll(TZFIELD_V,IINFO_ll)
+!!$ !!$ IF( NHALO==1 ) THEN
+!!$ NULLIFY(TZFIELD_DZX)
+!!$ NULLIFY(TZFIELD_DZY)
+!!$ CALL ADD3DFIELD_ll( TZFIELD_DZX, PDZX, 'CONTRAV::PDZX' )
+!!$ CALL ADD3DFIELD_ll( TZFIELD_DZY, PDZY, 'CONTRAV::PDZY' )
+!!$ NULLIFY(TZHALO2_U)
+!!$ NULLIFY(TZHALO2_V)
+!!$ NULLIFY(TZHALO2_DZX)
+!!$ NULLIFY(TZHALO2_DZY)
+!!$ CALL INIT_HALO2_ll(TZHALO2_U,1,IIU,IJU,IKU)
+!!$ CALL INIT_HALO2_ll(TZHALO2_V,1,IIU,IJU,IKU)
+!!$ CALL INIT_HALO2_ll(TZHALO2_DZX,1,IIU,IJU,IKU)
+!!$ CALL INIT_HALO2_ll(TZHALO2_DZY,1,IIU,IJU,IKU)
+!!$ CALL UPDATE_HALO2_ll(TZFIELD_U, TZHALO2_U, IINFO_ll)
+!!$ CALL UPDATE_HALO2_ll(TZFIELD_V, TZHALO2_V, IINFO_ll)
+!!$ CALL UPDATE_HALO2_ll(TZFIELD_DZX, TZHALO2_DZX, IINFO_ll)
+!!$ CALL UPDATE_HALO2_ll(TZFIELD_DZY, TZHALO2_DZY, IINFO_ll)
+ !
+ CALL GET_HALO2_D(PRUCT,TZHALO2_U,'CONTRAV::PRUCT')
+ CALL GET_HALO2_D(PRVCT,TZHALO2_V,'CONTRAV::PRVCT')
+ CALL GET_HALO2_D(PDZX,TZHALO2_DZX,'CONTRAV::PDZX')
+ CALL GET_HALO2_D(PDZY,TZHALO2_DZY,'CONTRAV::PDZY')
+
+!!$!$acc update device(PRUCT,PRVCT)
+!!$ !!$ END IF
+!
+ !PW: necessary because pointers does not work with OpenACC (PGI 16.1)
+!!$ ALLOCATE(ZU_EAST(IJU,IKU),ZV_NORTH(IIU,IKU),ZDZX_EAST(IJU,IKU),ZDZY_NORTH(IIU,IKU))
+!!$ !$acc enter data create( zu_east, zv_north, zdzx_east, zdzy_north )
+!!$ !$acc kernels
+ ZU_EAST => TZHALO2_U%HALO2%EAST
+ ZDZX_EAST => TZHALO2_DZX%HALO2%EAST
+ ZV_NORTH => TZHALO2_V%HALO2%NORTH
+ ZDZY_NORTH => TZHALO2_DZY%HALO2%NORTH
+!!$ !$acc end kernels
+!!$!$acc update device(ZU_EAST,ZV_NORTH,ZDZX_EAST,ZDZY_NORTH)
+ END IF
+END IF
+!
+!
+!* 2. Compute the vertical contravariant components (flat case)
+! ------------------------------------
+!
+FLAT: IF (LFLAT) THEN
+ IF (GDATA_ON_DEVICE) THEN
+!$acc kernels
+ PRWCT(:,:,:) = PRWT(:,:,:) / PDZZ(:,:,:)
+!$acc end kernels
+!$acc update self(PRWCT)
+ ELSE
+ PRWCT(:,:,:) = PRWT(:,:,:) / PDZZ(:,:,:)
+ END IF
+ELSE
+!
+!* 3. Compute the vertical contravariant components (general case)
+! ------------------------------------
+!
+! Z1(:,:,:) = 0.
+! Z2(:,:,:) = 0.
+!
+IF (KADV_ORDER == 2 ) THEN
+#ifdef MNH_OPENACC
+ call Print_msg( NVERB_WARNING, 'GEN', 'CONTRAV', 'OpenACC: KADV_ORDER=2 and LFLAT=.TRUE. not yet tested' )
+#endif
+!$acc kernels
+!
+!$acc loop independent collapse(3)
+ do concurrent (ji=iib:iie,jj=1:iju,jk=ikb:ike+1)
+ Z1(ji, jj, jk ) = ( PRUCT(ji, jj, jk ) + PRUCT(ji, jj, jk - 1 ) ) * PDZX (ji, jj, jk ) * 0.25 &
+ + ( PRUCT(ji + 1, jj, jk ) + PRUCT(ji + 1, jj, jk - 1 ) ) * PDZX (ji + 1, jj, jk ) * 0.25
+ end do
+!$acc loop independent collapse(3)
+ do concurrent (ji=1:iiu,jj=ijb:ije,jk=ikb:ike+1)
+ Z2(ji, jj, jk ) = ( PRVCT(ji, jj, jk) + PRVCT( ji, jj, jk - 1) ) * PDZY(ji, jj, jk) * 0.25 &
+ + ( PRVCT(ji, jj + 1, jk) + PRVCT( ji, jj + 1,jk - 1) ) * PDZY(ji, jj + 1, jk) * 0.25
+ end do
+
+ PRWCT(:,:,:)=0.
+
+!$acc loop independent collapse(3)
+ do concurrent (ji=iib:iie,jj=ijb:ije,jk=ikb:ike+1)
+ PRWCT(ji ,jj, jk ) = ( PRWT(ji ,jj, jk ) - Z1(ji ,jj, jk ) - Z2(ji ,jj, jk ) ) / PDZZ(ji ,jj, jk )
+ end do
+!
+!$acc end kernels
+ELSE IF (KADV_ORDER == 4 ) THEN
+!
+!!$ IF (NHALO == 1) THEN
+ IF ( GWEST ) THEN
+ IW=IIB+2 -1
+ ELSE
+ IW=IIB+1 -1
+ END IF
+ IE=IIE-1
+!!$ ELSE
+!!$ IF (LWEST_ll()) THEN
+!!$ IW=IIB+1
+!!$ ELSE
+!!$ IW=IIB
+!!$ END IF
+!!$ IF (LEAST_ll() .AND. HLBCX(2)/='CYCL' ) THEN
+!!$ IE=IIE-1
+!!$ ELSE
+!!$ IE=IIE
+!!$ END IF
+!!$ END IF
+ !
+!!$ IF(NHALO == 1) THEN
+ IF ( GSOUTH ) THEN
+ IS=IJB+2 -1
+ ELSE
+ IS=IJB+1 -1
+ END IF
+ IN=IJE-1
+!!$ ELSE
+!!$ IF (LSOUTH_ll()) THEN
+!!$ IS=IJB+1
+!!$ ELSE
+!!$ IS=IJB
+!!$ END IF
+!!$ IF (LNORTH_ll() .AND. HLBCY(2)/='CYCL' ) THEN
+!!$ IN=IJE-1
+!!$ ELSE
+!!$ IN=IJE
+!!$ END IF
+!!$ END IF
+ !
+ !
+ !* 3.1 interior of the process subdomain
+!$acc kernels
+!
+!
+!PW: OpenACC remarks: *computing only ztmp2 and reusing it at next iteration works
+! but ji loop can not be collapsed -> 10x slower on GPU
+! *ztmp1 and ztmp2 are not necessary but improve readability (no impact on performance)
+!$acc loop independent collapse(3) private(ztmp1, ztmp2)
+ do concurrent(ji=IW:IE,jj=1:iju,jk=IKB:IKE+1)
+ ztmp1 = ( 9.0 * PDZX(ji, jj, jk ) - ( PDZX(ji+1, jj, jk ) + PDZX(ji, jj, jk ) + PDZX(ji-1, jj, jk ) ) / 3.0 ) / 16.0
+ ztmp2 = ( 9.0 * PDZX(ji+1, jj, jk ) - ( PDZX(ji+2, jj, jk ) + PDZX(ji+1, jj, jk ) + PDZX(ji, jj, jk ) ) / 3.0 ) / 16.0
+ Z1(ji, jj, jk ) = 7.0 * ( ( PRUCT(ji, jj, jk ) + PRUCT(ji, jj, jk-1 ) ) * ztmp1 &
+ + ( PRUCT(ji+1, jj, jk ) + PRUCT(ji+1, jj, jk-1 ) ) * ztmp2 ) / 12.0 &
+ - 0.5 * ( ( PRUCT(ji-1, jj, jk ) + PRUCT(ji-1, jj, jk-1 ) ) * PDZX(ji-1, jj, jk) &
+ + ( PRUCT(ji+2, jj, jk ) + PRUCT(ji+2, jj, jk-1 ) ) * PDZX(ji+2, jj, jk) ) / 12.0
+ end do
+!
+!$acc loop independent collapse(3)
+ do concurrent(ji=1:iiu,jj=is:in,jk=IKB:IKE+1)
+ ztmp1 = ( 9.0 * PDZY(ji, jj, jk ) - ( PDZY(ji, jj+1, jk ) + PDZY(ji, jj, jk ) + PDZY(ji, jj-1, jk ) ) / 3.0 ) / 16.0
+ ztmp2 = ( 9.0 * PDZY(ji, jj+1, jk ) - ( PDZY(ji, jj+2, jk ) + PDZY(ji, jj+1, jk ) + PDZY(ji, jj, jk ) ) / 3.0 ) / 16.0
+ Z2(ji, jj, jk ) = 7.0 * ( ( PRVCT(ji, jj, jk ) + PRVCT(ji, jj, jk-1 ) ) * ztmp1 &
+ + ( PRVCT(ji, jj+1, jk ) + PRVCT(ji, jj+1, jk-1 ) ) * ztmp2 ) / 12.0 &
+ - 0.5 * ( ( PRVCT(ji, jj-1, jk ) + PRVCT(ji, jj-1, jk-1 ) ) * PDZY(ji, jj-1, jk ) &
+ + ( PRVCT(ji, jj+2, jk ) + PRVCT(ji, jj+2, jk-1 ) ) * PDZY(ji, jj+2, jk ) ) / 12.0
+ end do
+!$acc end kernels
+!
+!* 3.2 limits of the process subdomain (inside the whole domain or in cyclic conditions)
+!
+!!$ IF (NHALO==1) THEN
+!$acc parallel loop independent collapse(2) async
+ do concurrent(jj=1:iju,jk=IKB:IKE+1)
+ ztmp1 = ( 9.0 * PDZX(IIE, jj, jk ) - ( PDZX(IIE+1, jj, jk ) + PDZX(IIE, jj, jk ) + PDZX(IIE-1, jj, jk ) ) / 3.0 ) / 16.0
+ ztmp2 = ( 9.0 * PDZX(IIE+1, jj, jk ) - ( ZDZX_EAST(jj, jk ) + PDZX(IIE+1, jj, jk ) + PDZX(IIE, jj, jk ) ) / 3.0 ) / 16.0
+ Z1(IIE, jj, jk ) = 7.0 * ( ( PRUCT(IIE, jj, jk ) + PRUCT(IIE, jj, jk-1 ) ) * ztmp1 &
+ + ( PRUCT(IIE+1, jj, jk ) + PRUCT(IIE+1, jj, jk-1 ) ) * ztmp2 ) / 12.0 &
+ - 0.5 * ( ( PRUCT(IIE-1, jj, jk ) + PRUCT(IIE-1, jj, jk-1 ) ) * PDZX(IIE-1, jj, jk) &
+ + ( ZU_EAST (jj, jk ) + ZU_EAST (jj, jk-1 ) ) * ZDZX_EAST (jj, jk) ) / 12.0
+ end do
+!
+!$acc parallel loop independent collapse(2) async
+ do concurrent(ji=1:iiu,jk=IKB:IKE+1)
+ ztmp1 = ( 9.0 * PDZY(ji, IJE, jk) - ( PDZY (ji, IJE+1, jk) + PDZY(ji, IJE, jk) + PDZY(ji, IJE-1, jk) ) / 3.0 ) / 16.0
+ ztmp2 = ( 9.0 * PDZY(ji, IJE+1, jk) - ( ZDZY_NORTH(ji, jk) + PDZY(ji, IJE+1, jk) + PDZY(ji, IJE, jk) ) / 3.0 ) / 16.0
+ Z2(ji, IJE, jk ) = 7.0 * ( ( PRVCT (ji, IJE, jk ) + PRVCT (ji, IJE, jk-1 ) ) * ztmp1 &
+ + ( PRVCT (ji, IJE+1, jk ) + PRVCT (ji, IJE+1, jk-1 ) ) * ztmp2 ) / 12.0 &
+ - 0.5 * ( ( PRVCT (ji, IJE-1, jk ) + PRVCT (ji, IJE-1, jk-1 ) ) * PDZY (ji, IJE-1, jk ) &
+ + ( ZV_NORTH(ji, jk ) + ZV_NORTH(ji, jk-1 ) ) * ZDZY_NORTH(ji, jk ) ) / 12.0
+ end do
+!$acc wait
+!!$ END IF
+!
+!* 3.3 non-CYCLIC CASE IN THE X DIRECTION: 2nd order case
+!
+ IF ( GWEST ) THEN
+ !$acc kernels async
+ Z1(IIB, :, IKB:IKE+1 ) = ( PRUCT(IIB, :, IKB:IKE+1 ) + PRUCT(IIB, :, IKB-1:IKE ) ) * PDZX(IIB, :, IKB:IKE+1 ) * 0.25 &
+ + ( PRUCT(IIB+1, :, IKB:IKE+1 ) + PRUCT(IIB+1, :, IKB-1:IKE ) ) * PDZX(IIB+1, :, IKB:IKE+1 ) * 0.25
+ !$acc end kernels
+ END IF
+!
+ IF ( GEAST ) THEN
+ !$acc kernels async
+ Z1(IIE, :, IKB:IKE+1 ) = ( PRUCT(IIE, :, IKB:IKE+1 ) + PRUCT(IIE, :, IKB-1:IKE ) ) * PDZX(IIE, :, IKB:IKE+1 ) * 0.25 &
+ + ( PRUCT(IIE+1, :, IKB:IKE+1 ) + PRUCT(IIE+1, :, IKB-1:IKE ) ) * PDZX(IIE+1, :, IKB:IKE+1 ) * 0.25
+ !$acc end kernels
+ END IF
+!
+!* 3.4 non-CYCLIC CASE IN THE Y DIRECTION: 2nd order case
+!
+ IF ( GSOUTH ) THEN
+ !$acc kernels async
+ Z2(:, IJB, IKB:IKE+1 ) = ( PRVCT(:, IJB, IKB:IKE+1 ) + PRVCT(:, IJB, IKB-1:IKE ) ) * PDZY(:, IJB, IKB:IKE+1 ) * 0.25 &
+ + ( PRVCT(:, IJB+1, IKB:IKE+1 ) + PRVCT(:, IJB+1, IKB-1:IKE ) ) * PDZY(:, IJB+1, IKB:IKE+1 ) * 0.25
+ !$acc end kernels
+ END IF
+!
+ IF ( GNORTH ) THEN
+ !$acc kernels async
+ Z2(:, IJE, IKB:IKE+1 ) = ( PRVCT(:, IJE, IKB:IKE+1 ) + PRVCT(:, IJE, IKB-1:IKE ) ) * PDZY(:, IJE, IKB:IKE+1 ) * 0.25 &
+ + ( PRVCT(:, IJE+1, IKB:IKE+1 ) + PRVCT(:, IJE+1, IKB-1:IKE ) ) * PDZY(:, IJE+1, IKB:IKE+1 ) * 0.25
+ !$acc end kernels
+ END IF
+!$acc wait
+!
+!* 3.5 Vertical contyravariant wind
+!
+!
+!$acc kernels
+!!$ CALL GET_HALO(Z1)
+!!$ CALL GET_HALO(Z2)
+!!$
+!!$ CALL MPPDB_CHECK3DM("contrav_device ::Z1/Z2/ PDZZ",PRECISION,Z1,Z2,PDZZ)
+ PRWCT(:,:,:)=0.
+!$acc loop independent collapse(3)
+ do concurrent (ji=iib:iie,jj=ijb:ije,jk=ikb:ike+1)
+ PRWCT(ji ,jj, jk ) = ( PRWT(ji ,jj, jk ) - Z1(ji ,jj, jk ) - Z2(ji ,jj, jk ) ) / PDZZ(ji ,jj, jk )
+ end do
+!$acc end kernels
+!
+!
+END IF
+!
+!$acc kernels
+PRWCT(:,:,1) = - PRWCT(:,:,3) ! Mirror hypothesis
+!$acc end kernels
+!$acc update self(PRWCT)
+!
+IF (KADV_ORDER == 4 ) THEN
+!!$!$acc exit data delete( zu_east, zv_north, zdzx_east, zdzy_north )
+!!$ DEALLOCATE(ZU_EAST,ZV_NORTH,ZDZX_EAST,ZDZY_NORTH)
+!!$ CALL CLEANLIST_ll(TZFIELD_U)
+!!$ CALL CLEANLIST_ll(TZFIELD_V)
+!!$ !!$ IF (NHALO==1) THEN
+!!$ CALL CLEANLIST_ll(TZFIELD_DZX)
+!!$ CALL CLEANLIST_ll(TZFIELD_DZY)
+ CALL DEL_HALO2_ll(TZHALO2_U)
+ CALL DEL_HALO2_ll(TZHALO2_V)
+ CALL DEL_HALO2_ll(TZHALO2_DZX)
+ CALL DEL_HALO2_ll(TZHALO2_DZY)
+!!$ !!$ END IF
+END IF
+
+END IF FLAT
+!-----------------------------------------------------------------------
+IF (MPPDB_INITIALIZED) THEN
+ !Check all OUT arrays
+ CALL MPPDB_CHECK(PRUCT,"CONTRAV end:PRUCT")
+ CALL MPPDB_CHECK(PRVCT,"CONTRAV end:PRVCT")
+ CALL MPPDB_CHECK(PRWCT,"CONTRAV end:PRWCT")
+END IF
+
+!$acc end data
+
+END SUBROUTINE CONTRAV_DEVICE
+#endif
diff --git a/src/ZSOLVER/dotprod.f90 b/src/ZSOLVER/dotprod.f90
new file mode 100644
index 0000000000000000000000000000000000000000..ec920cc5191fe74c3876981858b20aeb001a996c
--- /dev/null
+++ b/src/ZSOLVER/dotprod.f90
@@ -0,0 +1,188 @@
+!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 solver 2006/05/18 13:07:25
+!-----------------------------------------------------------------
+! ###################
+ MODULE MODI_DOTPROD
+! ###################
+!
+INTERFACE
+!
+ FUNCTION DOTPROD(PA,PB,HLBCX,HLBCY) RESULT(PDOTPROD)
+!
+IMPLICIT NONE
+!
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PA, PB ! input vectors
+!
+CHARACTER (LEN=4), DIMENSION(2), INTENT(IN) :: HLBCX ! x-direction LBC type
+CHARACTER (LEN=4), DIMENSION(2), INTENT(IN) :: HLBCY ! y-direction LBC type
+!
+REAL :: PDOTPROD ! dot product
+!
+END FUNCTION DOTPROD
+!
+END INTERFACE
+!
+END MODULE MODI_DOTPROD
+!
+!
+!
+! #####################################################
+ FUNCTION DOTPROD(PA,PB,HLBCX,HLBCY) RESULT(PDOTPROD)
+! #####################################################
+!
+!!**** *DOTPROD* - compute the dot product of two vectors
+!!
+!! PURPOSE
+!! -------
+! The purpose of this function is to compute dot product of the vectors
+! stored in the arrays PA, PB. The elements of PA and PB are localized at
+! mass points.
+!
+!!** METHOD
+!! ------
+!! The scalar product DOTPROD of 2 vectors A and B is defined by :
+!! DOTPROD = SUM( A(i,j,k)* B(i,j,k) )
+!! The bounds for the summation depend on the l.b.c.
+!!
+!! EXTERNAL
+!! --------
+!! NONE
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module MODD_PARAMETERS: declaration of parameter variables
+!! JPHEXT, JPVEXT: define the number of marginal points out of the
+!! physical domain along horizontal and vertical directions respectively
+!! Module MODD_CONF: model configurations
+!! L2D: logical switch for 2D model version
+!!
+!! REFERENCE
+!! ---------
+!! Book2 of documentation of Meso-NH (function DOTPROD)
+!!
+!! AUTHOR
+!! ------
+!! P. Hereil and J. Stein * Meteo France *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 25/07/94
+!! J.-P. Pinty 12/11/99 Parallelization
+!!
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_PARAMETERS
+USE MODD_CONF
+!
+USE MODE_ll
+!JUAN
+USE MODE_REPRO_SUM
+!JUAN
+!
+IMPLICIT NONE
+!
+!* 0.1 Declarations of arguments and result
+! ------------------------------------
+!
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PA, PB ! input vectors
+!
+CHARACTER (LEN=4), DIMENSION(2), INTENT(IN) :: HLBCX ! x-direction LBC type
+CHARACTER (LEN=4), DIMENSION(2), INTENT(IN) :: HLBCY ! y-direction LBC type
+!
+REAL :: PDOTPROD ! dot product
+!
+!* 0.2 Declarations of local variables
+! -------------------------------
+!
+INTEGER :: JK,JI,JJ ! loop indexes
+!
+INTEGER :: IIB ! indice I for the first inner mass point along x
+INTEGER :: IIE ! indice I for the last inner mass point along x
+INTEGER :: IJB ! indice J for the first inner mass point along y
+INTEGER :: IJE ! indice J for the last inner mass point along y
+INTEGER :: IKB ! indice K for the first inner mass point along z
+INTEGER :: IKE ! indice K for the last inner mass point along z
+!
+INTEGER :: ILBXB,ILBYB,ILBXE,ILBYE ! loop indices depending on the
+ ! lateral boundary conditions
+!
+INTEGER :: IINFO_ll
+!JUAN16
+REAL, ALLOCATABLE, DIMENSION(:,:) :: ZDOTPROD
+!JUAN16
+!
+!-------------------------------------------------------------------------------
+!
+!* 1. COMPUTE LOOP BOUNDS
+! -------------------
+!
+CALL GET_INDICE_ll(IIB,IJB,IIE,IJE)
+!
+IKB=1+JPVEXT
+IKE=SIZE(PA,3) - JPVEXT
+!
+IF(HLBCX(1)/='CYCL' .AND. LWEST_ll()) THEN
+ ILBXB = IIB-1 ! non cyclic condition at the physical boundary
+ELSE
+ ILBXB = IIB
+ENDIF
+!
+IF(HLBCX(2)/='CYCL' .AND. LEAST_ll()) THEN
+ ILBXE = IIE+1 ! non cyclic condition at the physical boundary
+ELSE
+ ILBXE = IIE
+ENDIF
+!
+ILBYB = IJB
+ILBYE = IJE
+!
+IF (.NOT.L2D) THEN ! 3d version
+ IF(HLBCY(1)/='CYCL' .AND. LSOUTH_ll()) THEN
+ ILBYB = IJB-1 ! non cyclic condition at the physical boundary
+ ELSE
+ ILBYB = IJB
+ ENDIF
+!
+ IF(HLBCY(2)/='CYCL' .AND. LNORTH_ll()) THEN
+ ILBYE = IJE+1 ! non cyclic condition at the physical boundary
+ ELSE
+ ILBYE = IJE
+ ENDIF
+ELSE ! 2d version
+ ILBYB = IJB
+ ILBYE = IJB
+ENDIF
+!
+!* 2. COMPUTE THE DOT PRODUCT
+! -----------------------
+!
+!JUAN16
+ALLOCATE(ZDOTPROD(ILBXB:ILBXE,ILBYB:ILBYE))
+!$acc kernels
+ZDOTPROD = 0.
+!$acc loop seq
+DO JK = IKB-1,IKE+1
+ !$acc loop independent collapse(2)
+ DO JJ = ILBYB,ILBYE
+ DO JI = ILBXB,ILBXE
+ ZDOTPROD(JI,JJ) = ZDOTPROD(JI,JJ) + PA(JI,JJ,JK) * PB(JI,JJ,JK)
+ END DO
+ END DO
+END DO
+!$acc end kernels
+PDOTPROD = SUM_DD_R2_ll(ZDOTPROD)
+!JUAN16
+!
+!-------------------------------------------------------------------------------
+!
+END FUNCTION DOTPROD
diff --git a/src/ZSOLVER/flat_inv.f90 b/src/ZSOLVER/flat_inv.f90
new file mode 100644
index 0000000000000000000000000000000000000000..38fd8718dff9fbfb46dee6c8b59de4b1b6d8d94a
--- /dev/null
+++ b/src/ZSOLVER/flat_inv.f90
@@ -0,0 +1,702 @@
+!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 solver 2006/05/18 13:07:25
+!-----------------------------------------------------------------
+! ####################
+ MODULE MODI_FLAT_INV
+! ####################
+!
+INTERFACE
+!
+ SUBROUTINE FLAT_INV(HLBCX,HLBCY,PDXHATM,PDYHATM,PRHOM,PAF,PBF,PCF, &
+ PTRIGSX,PTRIGSY,KIFAXX,KIFAXY,PY,PF_1_Y)
+!
+!
+IMPLICIT NONE
+!
+CHARACTER (LEN=4), DIMENSION(2), INTENT(IN) :: HLBCX ! x-direction LBC type
+CHARACTER (LEN=4), DIMENSION(2), INTENT(IN) :: HLBCY ! y-direction LBC type
+!
+REAL, INTENT(IN) :: PDXHATM ! mean grid increment in the x
+ ! direction
+REAL, INTENT(IN) :: PDYHATM ! mean grid increment in the y
+ ! direction
+!
+REAL, DIMENSION (:), INTENT(IN) :: PRHOM ! mean of XRHODJ on the plane x y
+ ! localized at a mass level
+!
+REAL, DIMENSION(:), INTENT(IN) :: PAF,PCF ! vectors giving the nonvanishing
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PBF ! elements of the tri-diag.
+ ! matrix in the pressure eq.
+!
+ ! arrays of sin or cos values
+ ! for the FFT :
+REAL, DIMENSION(:), INTENT(IN) :: PTRIGSX ! - along x
+REAL, DIMENSION(:), INTENT(IN) :: PTRIGSY ! - along y
+!
+ ! decomposition in prime
+ ! numbers for the FFT:
+INTEGER, DIMENSION(19), INTENT(IN) :: KIFAXX ! - along x
+INTEGER, DIMENSION(19), INTENT(IN) :: KIFAXY ! - along y
+!
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PY ! RHS of the equation
+!
+REAL, DIMENSION(:,:,:), INTENT(OUT):: PF_1_Y ! solution of the equation
+!
+END SUBROUTINE FLAT_INV
+!
+END INTERFACE
+!
+END MODULE MODI_FLAT_INV
+! ######################################################################
+ SUBROUTINE FLAT_INV(HLBCX,HLBCY,PDXHATM,PDYHATM,PRHOM,PAF,PBF,PCF, &
+ PTRIGSX,PTRIGSY,KIFAXX,KIFAXY,PY,PF_1_Y)
+! ######################################################################
+!
+!!**** *FLAT_INV * - Invert the flat quasi-laplacian operator
+!!
+!! PURPOSE
+!! -------
+! This routine solves the following equation:
+! F ( F_1_Y ) = Y
+! where F represents the quasi-laplacian without orography. The solution is
+! F_1_Y.
+!
+!!** METHOD
+!! ------
+!! The horizontal part of F is inverted with a FFT transform. For each
+!! horizontal direction, the FFT form depends on the lateral boundary
+!! conditions :
+!! - CRAY intrinsic function RFFTMLT in the cyclic case
+!! - fast cosine transform called FFT55 for all other boundary condtions.
+!! Then, in the wavenumber space, we invert for each
+!! horizontal mode i,j a tridiagonal matrix by a classical double sweep
+!! method. The singular mean mode (i,j)=(0,0) corresponds to the
+!! undetermination of the pressure to within a constant and is treated apart.
+!! To fix this degree of freedom, we set the horizontal mean value of the
+!! pressure perturbation to 0 at the upper level of the model.
+!!
+!! EXTERNAL
+!! --------
+!! Subroutine FFT55 : aplly multiple fast real staggered (shifted)
+!! cosine transform
+!! Subroutine RFFTMLT : apply real-to-complex or complex-to-real Fast
+!! Fourier Transform (FFT) on multiple input vectors.
+!! Subroutine FFT991 : equivalent to RFFTMLT
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module MODD_PARAMETERS: declaration of parameter variables
+!! JPHEXT, JPVEXT: define the number of marginal points out of the
+!! physical domain along horizontal and vertical directions respectively
+!! Module MODD_CONF: model configurations
+!! L2D: logical for 2D model version
+!!
+!! REFERENCE
+!! ---------
+!! Book2 of documentation (subroutine FLAT_INV)
+!!
+!! AUTHOR
+!! ------
+!! P. Hereil and J. Stein * Meteo France *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 20/07/94
+!! Revision Jabouille (juillet 96) replace the CRAY intrinsic function
+!! RFFTMLT by the arpege routine FFT991
+!! 17/07/97 ( J. Stein and V. Masson) initialize the corner
+!! verticals
+!! 17/07/97 ( J. Stein and V. Masson) initialize the corner
+!! verticals
+!! Revision Jabouille (septembre 97) suppress the particular case for
+!! tridiagonal inversion
+!! Stein ( January 98 ) faster computation for the unused
+!! points under the ground and out of the domain
+!! Modification Lugato, Guivarch (June 1998) Parallelisation
+!! Escobar, Stein (July 2000) optimisation
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_PARAMETERS
+USE MODD_CONF
+!
+USE MODE_ll
+USE MODD_ARGSLIST_ll, ONLY : LIST_ll
+!
+USE MODI_FFT55
+!
+IMPLICIT NONE
+!
+!* 0.1 declarations of arguments
+!
+CHARACTER (LEN=4), DIMENSION(2), INTENT(IN) :: HLBCX ! x-direction LBC type
+CHARACTER (LEN=4), DIMENSION(2), INTENT(IN) :: HLBCY ! y-direction LBC type
+!
+REAL, INTENT(IN) :: PDXHATM ! mean grid increment in the x
+ ! direction
+REAL, INTENT(IN) :: PDYHATM ! mean grid increment in the y
+ ! direction
+!
+REAL, DIMENSION (:), INTENT(IN) :: PRHOM ! mean of XRHODJ on the plane x y
+ ! localized at a mass level
+!
+REAL, DIMENSION(:), INTENT(IN) :: PAF,PCF ! vectors giving the nonvanishing
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PBF ! elements of the tri-diag.
+ ! matrix in the pressure eq.
+!
+ ! arrays of sin or cos values
+ ! for the FFT :
+REAL, DIMENSION(:), INTENT(IN) :: PTRIGSX ! - along x
+REAL, DIMENSION(:), INTENT(IN) :: PTRIGSY ! - along y
+!
+ ! decomposition in prime
+ ! numbers for the FFT:
+INTEGER, DIMENSION(19), INTENT(IN) :: KIFAXX ! - along x
+INTEGER, DIMENSION(19), INTENT(IN) :: KIFAXY ! - along y
+!
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PY ! RHS of the equation
+!
+REAL, DIMENSION(:,:,:), INTENT(OUT):: PF_1_Y ! solution of the equation
+!
+!* 0.2 declaration of local variables
+!
+REAL, DIMENSION(SIZE(PY,1),SIZE(PY,2),SIZE(PY,3)) :: ZY ! work array to store
+ ! the RHS of the equation
+!
+!REAL, DIMENSION(SIZE(PY,1),SIZE(PY,2),SIZE(PY,3)) :: ZWORK ! work array used by
+! the FFT. It has been enlarged in order to be sufficient for 2D and 3D cases
+!
+REAL, DIMENSION(SIZE(PBF,1),SIZE(PBF,2),SIZE(PBF,3)) :: ZAF ! work array to
+! ! expand PAF
+INTEGER :: IIB ! indice I for the first inner mass point along x
+INTEGER :: IIE ! indice I for the last inner mass point along x
+INTEGER :: IIMAX ! number of inner mass points along the x direction
+INTEGER :: IJB ! indice J for the first inner mass point along y
+INTEGER :: IJE ! indice J for the last inner mass point along y
+INTEGER :: IJMAX ! number of inner mass points along the y direction
+INTEGER :: IKB ! indice K for the first inner mass point along z
+INTEGER :: IKE ! indice K for the last inner mass point along z
+INTEGER :: IKU ! size of the arrays along z
+INTEGER :: IKMAX ! number of inner mass points along the z direction
+!
+REAL :: ZDXM2,ZDYM2 ! respectively equal to PDXHATM*PDXHATM
+ ! and PDYHATM*PDYHATM
+INTEGER :: JI,JJ,JK ! loop indexes along x, y, z respectively
+!
+!
+INTEGER :: IIE_INT,IJE_INT ! highest indice I and J values for the x y modes.
+ ! They depend on the l.b.c. !
+!
+INTEGER :: ILOTX,ILOTY ! number of data vectors along x, y resp. computed
+ ! in parallel during the FFT process
+!
+INTEGER :: INC1X,INC1Y ! increment within each data vector for the FFT along
+ ! x, y resp.
+!
+INTEGER :: INC2X,INC2Y ! increment between the start of one data vector and
+ ! the next for the FFT along x,y resp.
+!
+!
+REAL, DIMENSION(:,:,:), ALLOCATABLE :: ZWORKX ! work array used by
+! the FFT. It has been enlarged in order to be sufficient for 2D and 3D cases
+REAL, DIMENSION(:,:,:), ALLOCATABLE :: ZWORKY ! work array used by
+! the FFT. It has been enlarged in order to be sufficient for 2D and 3D cases
+!
+REAL, DIMENSION(:,:,:), ALLOCATABLE :: ZGAM
+ ! intermediate arrays
+REAL, DIMENSION(:,:), ALLOCATABLE :: ZBETX ! for the tridiag.
+ ! matrix inversion
+REAL, DIMENSION(:,:,:), ALLOCATABLE :: ZBAND_X ! array in X slices distribution
+REAL, DIMENSION(:,:,:), ALLOCATABLE :: ZBAND_Y ! array in Y slices distribution
+REAL, DIMENSION(:,:,:), ALLOCATABLE :: ZBAND_YR ! array in Y slices distribution
+!
+INTEGER :: IINFO_ll ! return code of parallel routine
+!
+INTEGER :: IIX,IJX,IIY,IJY ! dimensions of the extended x or y slices subdomain
+!
+REAL, DIMENSION(:,:,:), ALLOCATABLE :: ZBAND_YT ! array in Y slices distribution transpose
+REAL, DIMENSION(:,:,:), ALLOCATABLE :: ZBAND_YRT ! array in Y slices distribution transpose
+!-------------------------------------------------------------------------------
+!
+!* 1. COMPUTE LOOP BOUNDS
+! -------------------
+!
+CALL GET_PHYSICAL_ll(IIB,IJB,IIE,IJE)
+CALL GET_DIM_EXT_ll('X',IIX,IJX)
+CALL GET_DIM_EXT_ll('Y',IIY,IJY)
+IIMAX = IIX-2*JPHEXT
+IJMAX = IJY-2*JPHEXT
+!
+IKU=SIZE(PY,3)
+IKB=1+JPVEXT
+IKE=IKU - JPVEXT
+IKMAX=IKE-IKB+1
+!
+!!
+ALLOCATE(ZBAND_X(IIX,IJX,IKU))
+ALLOCATE(ZBAND_Y(IIY,IJY,IKU))
+ALLOCATE(ZBAND_YR(IIY,IJY,IKU))
+ALLOCATE(ZWORKX(IIX,IJX,IKU))
+ALLOCATE(ZWORKY(IIY,IJY,IKU))
+ALLOCATE(ZBETX(IIY,IJY))
+ALLOCATE(ZGAM(IIY,IJY,IKU))
+IF (.NOT. L2D) THEN
+ ALLOCATE(ZBAND_YT(IJY,IIY,IKU))
+ ALLOCATE(ZBAND_YRT(IJY,IIY,IKU))
+END IF
+!
+!-------------------------------------------------------------------------------
+!
+!* 2. COMPUTE THE ARRAY INCREMENTS FOR THE FFT
+! ----------------------------------------
+!
+IF(.NOT. L2D) THEN
+!
+ ILOTX = IJX*IKU
+ INC1X = 1
+ INC2X = IIX
+!
+ ILOTY = IIY*IKU
+ INC1Y = 1
+ INC2Y = IJY
+!
+ELSE
+!
+ ILOTX = IKU
+ INC1X = 1
+ INC2X = IIX*IJX
+ENDIF
+!
+!-------------------------------------------------------------------------------
+!
+!* 3. FORM HOMOGENEOUS BOUNDARY CONDITIONS FOR A NONCYCLIC CASE
+! ---------------------------------------------------------
+!
+!
+!* 3.1 copy the RHS in a local array REMAP functions will shift the indices for the FFT
+!
+PF_1_Y = 0.
+ZY = PY
+!
+!* 3.2 form homogeneous boundary condition used by the FFT for non-periodic
+! cases
+!
+! modify the RHS in the x direction
+!
+IF (HLBCX(1) /= 'CYCL') THEN
+!
+ IF (LWEST_ll(HSPLITTING='B')) THEN
+ DO JK=IKB,IKE
+ DO JJ = IJB, IJE
+ ZY(IIB,JJ,JK) = ZY(IIB,JJ,JK) + PY(IIB-1,JJ,JK)
+ END DO
+ END DO
+ END IF
+!
+ IF (LEAST_ll(HSPLITTING='B')) THEN
+ DO JK=IKB,IKE
+ DO JJ = IJB, IJE
+ ZY(IIE,JJ,JK) = ZY(IIE,JJ,JK) - PY(IIE+1,JJ,JK)
+ END DO
+ END DO
+ END IF
+END IF
+!
+! modify the RHS in the same way along y
+!
+IF (HLBCY(1) /= 'CYCL'.AND. (.NOT. L2D)) THEN
+ IF (LSOUTH_ll(HSPLITTING='B')) THEN
+ DO JK=IKB,IKE
+ DO JI = IIB, IIE
+ ZY(JI,IJB,JK) = ZY(JI,IJB,JK) + PY(JI,IJB-1,JK)
+ END DO
+ END DO
+ END IF
+!
+ IF (LNORTH_ll(HSPLITTING='B')) THEN
+ DO JK=IKB,IKE
+ DO JI = IIB, IIE
+ ZY(JI,IJE,JK) = ZY(JI,IJE,JK) - PY(JI,IJE+1,JK)
+ END DO
+ END DO
+ END IF
+END IF
+!
+!
+!* 3.3 2way structure -> xslice structure, + data shift
+!
+ZBAND_X=0.
+CALL REMAP_2WAY_X_ll(ZY,ZBAND_X,IINFO_ll)
+!
+!
+!-------------------------------------------------------------------------------
+!
+!* 4. APPLY A REAL TO COMPLEX FFT
+! ---------------------------
+!
+!
+IF (HLBCX(1) == 'CYCL') THEN
+ CALL FFT991(ZBAND_X(1,1,IKB-1),ZWORKX,PTRIGSX,KIFAXX,INC1X,INC2X, &
+ IIMAX,ILOTX,-1 )
+ELSE
+ CALL FFT55(ZBAND_X(1,1,IKB-1),ZWORKX,PTRIGSX,KIFAXX,INC1X,INC2X, &
+ IIMAX,ILOTX,-1 )
+END IF
+!
+!
+ZBAND_Y=0.
+CALL REMAP_X_Y_ll(ZBAND_X,ZBAND_Y,IINFO_ll)
+!
+IF (.NOT. L2D) THEN
+!
+! array transposition I --> J
+!
+ CALL FAST_TRANSPOSE(ZBAND_Y,ZBAND_YT,IIY,IJY,IKU)
+!
+ IF (HLBCY(1) == 'CYCL') THEN
+ CALL FFT991(ZBAND_YT(1,1,IKB-1),ZWORKY,PTRIGSY,KIFAXY,INC1Y,INC2Y, &
+ IJMAX,ILOTY,-1 )
+ ELSE
+ CALL FFT55(ZBAND_YT(1,1,IKB-1),ZWORKY,PTRIGSY,KIFAXY,INC1Y,INC2Y, &
+ IJMAX,ILOTY,-1 )
+ END IF
+!
+END IF
+!
+! singular matrix case : the last term is computed by setting the
+! average of the pressure field equal to zero.
+IF (LWEST_ll(HSPLITTING='Y')) THEN
+ IF (L2D) THEN
+ ZBAND_Y(1,1,IKE+1)=0
+ ELSE
+ ZBAND_YT(1,1,IKE+1)=0.
+ END IF
+END IF
+!
+!-------------------------------------------------------------------------------
+!
+!* 5. MATRIX INVERSION FOR THE FLAT OPERATOR
+! --------------------------------------
+!
+CALL FAST_SPREAD(PAF,ZAF,IIY,IJY,IKU)
+!
+IF (LWEST_ll(HSPLITTING='Y')) THEN
+ ZAF(1,1,IKE+1)=0. !singular matrix corresponding to the horizontal average
+END IF
+!
+IF (L2D) THEN
+ CALL FAST_SUBSTITUTION_2D(ZBAND_YR,ZBETX,PBF,ZGAM,PCF,ZAF &
+ ,ZBAND_Y,IIY,IJY,IKU)
+ELSE
+ CALL FAST_SUBSTITUTION_3D(ZBAND_YRT,ZBETX,PBF,ZGAM,PCF,ZAF &
+ ,ZBAND_YT,IIY,IJY,IKU)
+END IF
+!
+!
+!-------------------------------------------------------------------------------
+!
+!* 6. APPLY A COMPLEX TO REAL FFT
+! ---------------------------
+!
+!
+IF (.NOT. L2D) THEN
+ IF (HLBCY(1) == 'CYCL') THEN
+ CALL FFT991( ZBAND_YRT(1,1,IKB-1),ZWORKY,PTRIGSY,KIFAXY,INC1Y,INC2Y, &
+ IJMAX,ILOTY,+1 )
+ ELSE
+ CALL FFT55( ZBAND_YRT(1,1,IKB-1),ZWORKY,PTRIGSY,KIFAXY,INC1Y,INC2Y, &
+ IJMAX,ILOTY,+1 )
+ END IF
+ ! array transposition J --> I
+ CALL FAST_TRANSPOSE(ZBAND_YRT,ZBAND_YR,IJY,IIY,IKU)
+ENDIF
+!
+! Transposition Y-> X
+!
+ZBAND_X=0.
+CALL REMAP_Y_X_ll(ZBAND_YR,ZBAND_X,IINFO_ll)
+!
+!
+IF (HLBCX(1) == 'CYCL') THEN
+ CALL FFT991( ZBAND_X(1,1,IKB-1),ZWORKX,PTRIGSX,KIFAXX,INC1X,INC2X, &
+ IIMAX,ILOTX,+1 )
+ELSE
+ CALL FFT55( ZBAND_X(1,1,IKB-1),ZWORKX,PTRIGSX,KIFAXX,INC1X,INC2X, &
+ IIMAX,ILOTX,+1 )
+END IF
+!
+!-------------------------------------------------------------------------------
+!
+!* 7. RETURN TO A NON HOMOGENEOUS NEUMAN CONDITION FOR NON-CYCLIC CASES
+! -----------------------------------------------------------------
+!
+!* 7.1 Transposition + shift X -> 2way
+!
+CALL REMAP_X_2WAY_ll(ZBAND_X,PF_1_Y,IINFO_ll)
+!
+!* 7.2 complete the lateral boundaries
+!
+IF (HLBCX(1) /= 'CYCL') THEN
+!
+!* 7.2.1 return to a non-homogeneous case in the x direction
+!
+ ZDXM2 = PDXHATM*PDXHATM
+!
+ IF (LWEST_ll(HSPLITTING='B')) THEN
+ DO JK=IKB,IKE
+ DO JJ = IJB,IJE
+ PF_1_Y(IIB-1,JJ,JK) = PF_1_Y(IIB,JJ,JK) - PY(IIB-1,JJ,JK)*ZDXM2/PRHOM(JK)
+ END DO
+ END DO
+ END IF
+!
+ IF (LEAST_ll(HSPLITTING='B')) THEN
+ DO JK=IKB,IKE
+ DO JJ = IJB,IJE
+ PF_1_Y(IIE+1,JJ,JK) = PF_1_Y(IIE,JJ,JK) + PY(IIE+1,JJ,JK)*ZDXM2/PRHOM(JK)
+ END DO
+ END DO
+ END IF
+!
+! we set the solution at the corner point by the condition:
+! dxm ( P ) = 0
+ IF (LWEST_ll(HSPLITTING='B')) THEN
+ DO JJ = IJB,IJE
+ PF_1_Y(IIB-1,JJ,IKB-1) = PF_1_Y(IIB,JJ,IKB-1)
+ PF_1_Y(IIB-1,JJ,IKE+1) = PF_1_Y(IIB,JJ,IKE+1)
+ END DO
+ END IF
+ IF (LEAST_ll(HSPLITTING='B')) THEN
+ DO JJ = IJB,IJE
+ PF_1_Y(IIE+1,JJ,IKB-1) = PF_1_Y(IIE,JJ,IKB-1)
+ PF_1_Y(IIE+1,JJ,IKE+1) = PF_1_Y(IIE,JJ,IKE+1)
+ END DO
+ END IF
+!
+ELSE
+!
+!* 7.2.2 periodize the pressure function field along the x direction
+!
+! in fact this part is useless because it is done in the routine
+! REMAP_X_2WAY.
+!
+END IF
+!
+IF (.NOT.L2D) THEN
+ IF (HLBCY(1) /= 'CYCL') THEN
+!
+!* 7.2.3 return to a non-homogeneous case in the y direction
+!
+ ZDYM2 = PDYHATM*PDYHATM
+!
+ IF (LSOUTH_ll(HSPLITTING='B')) THEN
+ DO JK=IKB,IKE
+ DO JI = IIB,IIE
+ PF_1_Y(JI,IJB-1,JK) = PF_1_Y(JI,IJB,JK) - PY(JI,IJB-1,JK)*ZDYM2/PRHOM(JK)
+ END DO
+ END DO
+ END IF
+!
+ IF (LNORTH_ll(HSPLITTING='B')) THEN
+ DO JK=IKB,IKE
+ DO JI = IIB,IIE
+ PF_1_Y(JI,IJE+1,JK) = PF_1_Y(JI,IJE,JK) + PY(JI,IJE+1,JK)*ZDYM2/PRHOM(JK)
+ END DO
+ END DO
+ END IF
+! we set the solution at the corner point by the condition:
+! dym ( P ) = 0
+!
+ IF (LSOUTH_ll(HSPLITTING='B')) THEN
+ DO JI = IIB,IIE
+ PF_1_Y(JI,IJB-1,IKB-1) = PF_1_Y(JI,IJB,IKB-1)
+ PF_1_Y(JI,IJB-1,IKE+1) = PF_1_Y(JI,IJB,IKE+1)
+ END DO
+ END IF
+!
+ IF (LNORTH_ll(HSPLITTING='B')) THEN
+ DO JI = IIB,IIE
+ PF_1_Y(JI,IJE+1,IKB-1) = PF_1_Y(JI,IJE,IKB-1)
+ PF_1_Y(JI,IJE+1,IKE+1) = PF_1_Y(JI,IJE,IKE+1)
+ END DO
+ END IF
+ ELSE
+!
+!* 7.2.4 periodize the pressure function field along the y direction
+!
+!
+! in fact this part is useless because it is done in the routine
+! REMAP_X_2WAY.
+!
+ END IF
+!
+END IF
+!
+IF (.NOT. L2D .AND. HLBCX(1)/='CYCL' .AND. HLBCY(1)/='CYCL') THEN
+! the following verticals are not used
+ IF ( (LWEST_ll(HSPLITTING='B')).AND.(LSOUTH_ll(HSPLITTING='B')) ) THEN
+ PF_1_Y(IIB-1,IJB-1,:)=PF_1_Y(IIB,IJB,:)
+ END IF
+!
+ IF ( (LWEST_ll(HSPLITTING='B')).AND.(LNORTH_ll(HSPLITTING='B')) ) THEN
+ PF_1_Y(IIB-1,IJE+1,:)=PF_1_Y(IIB,IJE,:)
+ END IF
+!
+ IF ( (LEAST_ll(HSPLITTING='B')).AND.(LSOUTH_ll(HSPLITTING='B')) ) THEN
+ PF_1_Y(IIE+1,IJB-1,:)=PF_1_Y(IIE,IJB,:)
+ END IF
+!
+ IF ( (LEAST_ll(HSPLITTING='B')).AND.(LNORTH_ll(HSPLITTING='B')) ) THEN
+ PF_1_Y(IIE+1,IJE+1,:)=PF_1_Y(IIE,IJE,:)
+ END IF
+END IF
+!
+DEALLOCATE(ZBAND_X)
+DEALLOCATE(ZBAND_Y)
+IF (.NOT. L2D) THEN
+ DEALLOCATE(ZBAND_YT)
+ DEALLOCATE(ZBAND_YRT)
+END IF
+DEALLOCATE(ZBAND_YR)
+DEALLOCATE(ZWORKX)
+DEALLOCATE(ZWORKY)
+DEALLOCATE(ZBETX)
+DEALLOCATE(ZGAM)
+!
+!-------------------------------------------------------------------------------
+!
+CONTAINS
+ SUBROUTINE FAST_TRANSPOSE(PX,PXT,KNI,KNJ,KNK)
+ INTEGER :: KNI,KNJ,KNK ! 3D dimension of X and XT
+ REAL, DIMENSION(KNI*KNJ,KNK) :: PX
+ REAL, DIMENSION(KNJ*KNI,KNK) :: PXT
+ !
+ INTEGER :: IJI,II,IJ,IIJ ! index in array X and XT
+ INTEGER :: JK
+!
+ DO JK=1,KNK
+ ! PERMUTATION(PX,PXT)
+ !CDIR NODEP
+ !OCL NOVREC
+ DO IJI = 1, KNJ*KNI
+ ! I,J Indice in XT array from linearised index IJI
+ II = 1 + (IJI-1)/KNJ
+ IJ = IJI - (II-1)*KNJ
+ ! linearised index in X
+ IIJ = II + (IJ-1)*KNI
+ ! transposition
+ PXT(IJI,JK) = PX(IIJ,JK)
+
+ END DO
+ END DO
+!
+END SUBROUTINE FAST_TRANSPOSE
+
+SUBROUTINE FAST_SUBSTITUTION_3D(PBAND_YR,PBETX,PPBF,PGAM,PPCF,PAF &
+ ,PBAND_Y,KIY,KJY,KKU)
+INTEGER :: KIY,KJY,KKU
+REAL, DIMENSION (KIY*KJY,KKU) :: PBAND_YR,PBAND_Y,PPBF,PGAM,PAF
+REAL, DIMENSION (KIY*KJY) :: PBETX
+REAL, DIMENSION (KKU) :: PPCF
+INTEGER :: JK
+!
+!
+! initialization
+!
+!
+PBAND_YR = 0.0
+PBETX(:) = PPBF(:,IKB-1)
+PBAND_YR(:,IKB-1) = PBAND_Y(:,IKB-1) &
+ / PBETX(:)
+!
+! decomposition and forward substitution
+!
+DO JK = IKB,IKE+1
+ PGAM(:,JK) = PPCF(JK-1) / PBETX(:)
+!
+ PBETX(:) = PPBF(:,JK) - &
+ PAF(:,JK)*PGAM(:,JK)
+!
+ PBAND_YR(:,JK) = ( PBAND_Y(:,JK) - &
+ PAF(:,JK)*PBAND_YR(:,JK- 1) ) &
+ /PBETX(:)
+!
+END DO
+!
+! backsubstitution
+!
+DO JK = IKE,IKB-1,-1
+ PBAND_YR(:,JK) = PBAND_YR(:,JK) - &
+ PGAM(:,JK+1)*PBAND_YR(:,JK+1)
+END DO
+!
+!
+END SUBROUTINE FAST_SUBSTITUTION_3D
+!
+SUBROUTINE FAST_SUBSTITUTION_2D(PBAND_YR,PBETX,PPBF,PGAM,PPCF,PAF &
+ ,PBAND_Y,KIY,KJY,KKU)
+INTEGER :: KIY,KJY,KKU
+REAL, DIMENSION (KIY,KJY,KKU) :: PBAND_YR,PBAND_Y,PPBF,PGAM,PAF
+REAL, DIMENSION (KIY,KJY) :: PBETX
+REAL, DIMENSION (KKU) :: PPCF
+INTEGER :: JK
+!
+!
+! initialization
+!
+!
+PBAND_YR = 0.0
+PBETX(:,1) = PPBF(:,1,IKB-1)
+PBAND_YR(:,1,IKB-1) = PBAND_Y(:,1,IKB-1) &
+ / PBETX(:,1)
+!
+! decomposition and forward substitution
+!
+DO JK = IKB,IKE+1
+ PGAM(:,1,JK) = PPCF(JK-1) / PBETX(:,1)
+!
+ PBETX(:,1) = PPBF(:,1,JK) - &
+ PAF(:,1,JK)*PGAM(:,1,JK)
+!
+ PBAND_YR(:,1,JK) = ( PBAND_Y(:,1,JK) - &
+ PAF(:,1,JK)*PBAND_YR(:,1,JK- 1) ) &
+ /PBETX(:,1)
+!
+END DO
+!
+! backsubstitution
+!
+DO JK = IKE,IKB-1,-1
+ PBAND_YR(:,1,JK) = PBAND_YR(:,1,JK) - &
+ PGAM(:,1,JK+1)*PBAND_YR(:,1,JK+1)
+END DO
+!
+!
+END SUBROUTINE FAST_SUBSTITUTION_2D
+
+SUBROUTINE FAST_SPREAD(PTAB1D,PTAB3D,KIY,KJY,KKU)
+INTEGER :: KIY,KJY,KKU
+REAL, DIMENSION (KKU) :: PTAB1D
+REAL, DIMENSION (KIY*KJY,KKU) :: PTAB3D
+
+INTEGER :: JIJ,JK
+!
+DO JK=1,KKU
+ DO JIJ=1,KIY*KJY
+ PTAB3D(JIJ,JK) = PTAB1D(JK)
+ ENDDO
+ENDDO
+!
+END SUBROUTINE FAST_SPREAD
+!
+!------------------------------------------------------------------------------
+END SUBROUTINE FLAT_INV
diff --git a/src/ZSOLVER/gdiv.f90 b/src/ZSOLVER/gdiv.f90
new file mode 100644
index 0000000000000000000000000000000000000000..5bfd218bf519a7bf8bbbcae521aeffcf7e33ff0e
--- /dev/null
+++ b/src/ZSOLVER/gdiv.f90
@@ -0,0 +1,353 @@
+!MNH_LIC Copyright 1994-2020 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.
+!-----------------------------------------------------------------
+! ################
+ MODULE MODI_GDIV
+! ################
+!
+INTERFACE
+!
+ SUBROUTINE GDIV(HLBCX,HLBCY,PDXX,PDYY,PDZX,PDZY,PDZZ,PU,PV,PW,PGDIV)
+!
+IMPLICIT NONE
+!
+CHARACTER (LEN=4), DIMENSION(2), INTENT(IN) :: HLBCX ! x-direction LBC type
+CHARACTER (LEN=4), DIMENSION(2), INTENT(IN) :: HLBCY ! y-direction LBC type
+!
+ ! Metric coefficients:
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDXX ! d*xx
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDYY ! d*yy
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDZX ! d*zx
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDZY ! d*zy
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDZZ ! d*zz
+!
+ ! Field components
+REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PU ! along x
+REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PV ! along y
+REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PW ! along z
+!
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PGDIV ! divergence at
+ ! a mass point
+!
+END SUBROUTINE GDIV
+!
+END INTERFACE
+!
+END MODULE MODI_GDIV
+!
+! ####################################################################
+ SUBROUTINE GDIV(HLBCX,HLBCY,PDXX,PDYY,PDZX,PDZY,PDZZ,PU,PV,PW,PGDIV)
+! ####################################################################
+!
+!!**** *GDIV * - Compute J times the divergence of 1/J times a vector defined
+!! by its cartesian components
+!!
+!! PURPOSE
+!! -------
+! The purpose of this function is to compute J times the divergence of
+! 1/J times a vector which cartesian components are (U, V, W). The result
+! is localized at a mass point:
+!
+! GDIV = dxf (UC) + dyf (VC) + dzf (WC)
+!
+! where UC, VC, WC are the contravariant components of the vector.
+! The array is completed outside the physical domain by the value of the
+! normal component at the boundary.
+!
+!!** METHOD
+!! ------
+!! First, we compute the contravariant components by using
+!! the suboutine CONTRAV (The metric coefficients are dummy arguments). Then
+!! we use the Shuman finite difference operators DXF, DYF, DZF to compute
+!! the divergence. The result is localized at a mass point.
+!!
+!! EXTERNAL
+!! --------
+!! SUBROUTINE CONTRAV : compute the contavariant components
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module MODD_PARAMETERS: declaration of parameter variables
+!! JPHEXT, JPVEXT: define the number of marginal points out of the
+!! physical domain along horizontal and vertical directions respectively
+!! Module MODD_CONF: model configurations
+!! L2D: logical for 2D model version
+!! Module MODI_SHUMAN : interface for the Shuman operators
+!! Module MODI_CONTRAV : interface for the contravariant components
+!!
+!! REFERENCE
+!! ---------
+!! Book2 of documentation (routine GDIV)
+!!
+!!
+!! AUTHOR
+!! ------
+!! P. Hereil and J. Stein * Meteo France *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 11/07/94
+!! 17/07/97 ( J. Stein and V. Masson) initialize the corner
+!! verticals
+!! 30/09/97 ( J. Stein ) bug correction for the case of
+!! non-vanishing oro. at the open lbc
+!! Modification 15/06/98 (D.Lugato, R.Guivarch) Parallelisation
+!! 22/08/02 (P Jabouille) simplification of parallel coding
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_PARAMETERS
+USE MODD_CONF
+USE MODI_CONTRAV
+!
+USE MODE_ll
+!
+#ifdef MNH_OPENACC
+USE MODE_MNH_ZWORK , ONLY : MNH_ALLOCATE_ZT3D , MNH_REL_ZT3D
+#endif
+!
+IMPLICIT NONE
+!
+!* 0.1 declarations of arguments
+!
+CHARACTER (LEN=4), DIMENSION(2), INTENT(IN) :: HLBCX ! x-direction LBC type
+CHARACTER (LEN=4), DIMENSION(2), INTENT(IN) :: HLBCY ! y-direction LBC type
+!
+ ! Metric coefficients:
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDXX ! d*xx
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDYY ! d*yy
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDZX ! d*zx
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDZY ! d*zy
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDZZ ! d*zz
+!
+ ! Field components
+REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PU ! along x
+REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PV ! along y
+REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PW ! along z
+!
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PGDIV ! divergence at
+ ! a mass point
+!
+!* 0.2 declarations of local variables
+!
+ ! Contravariant components along:
+REAL, DIMENSION(:,:,:) , POINTER , CONTIGUOUS :: ZUC ! x
+REAL, DIMENSION(:,:,:) , POINTER , CONTIGUOUS :: ZVC ! y
+REAL, DIMENSION(:,:,:) , POINTER , CONTIGUOUS :: ZWC ! z
+REAL, DIMENSION(:,:,:) , POINTER , CONTIGUOUS :: Z1,Z2,Z3 !work arrays
+INTEGER :: IZUC,IZVC,IZWC,IZ1,IZ2,IZ3
+!
+INTEGER :: IIB ! indice I for the first inner mass point along x
+INTEGER :: IIE ! indice I for the last inner mass point along x
+INTEGER :: IJB ! indice J for the first inner mass point along y
+INTEGER :: IJE ! indice J for the last inner mass point along y
+INTEGER :: IKB ! indice K for the first inner mass point along z
+INTEGER :: IKE ! indice K for the last inner mass point along z
+!
+INTEGER :: JI,JJ,JK ! loop indexes
+!
+#ifdef MNH_OPENACC
+INTEGER :: IIU,IJU,IKU
+!
+REAL, DIMENSION(:,:,:) , POINTER , CONTIGUOUS :: ZTMP1,ZTMP2
+INTEGER :: IZTMP1,IZTMP2
+#endif
+!
+LOGICAL :: GWEST,GEAST,GSOUTH,GNORTH
+!
+!-------------------------------------------------------------------------------
+!
+!* 1. COMPUTE LOOP BOUNDS
+! -------------------
+!
+!
+CALL GET_INDICE_ll(IIB,IJB,IIE,IJE)
+IKB=1+JPVEXT
+IKE=SIZE(PU,3) - JPVEXT
+!
+!
+IIU=SIZE(PU,1)
+IJU=SIZE(PU,2)
+IKU=SIZE(PU,3)
+!
+#ifndef MNH_OPENACC
+ALLOCATE(ZUC(IIU,IJU,IKU),ZVC(IIU,IJU,IKU),ZWC(IIU,IJU,IKU))
+ALLOCATE(Z1(IIU,IJU,IKU),Z2(IIU,IJU,IKU),Z2(IIU,IJU,IKU))
+#else
+IZUC = MNH_ALLOCATE_ZT3D(ZUC,IIU,IJU,IKU )
+IZVC = MNH_ALLOCATE_ZT3D(ZVC,IIU,IJU,IKU )
+IZWC = MNH_ALLOCATE_ZT3D(ZWC,IIU,IJU,IKU )
+IZ1 = MNH_ALLOCATE_ZT3D(Z1,IIU,IJU,IKU )
+IZ2 = MNH_ALLOCATE_ZT3D(Z2,IIU,IJU,IKU )
+IZ3 = MNH_ALLOCATE_ZT3D(Z3,IIU,IJU,IKU )
+!
+IZTMP1 = MNH_ALLOCATE_ZT3D( ZTMP1,IIU,IJU,IKU )
+IZTMP2 = MNH_ALLOCATE_ZT3D( ZTMP2,IIU,IJU,IKU )
+#endif
+!
+GWEST = ( HLBCX(1) /= 'CYCL' .AND. LWEST_ll() )
+GEAST = ( HLBCX(2) /= 'CYCL' .AND. LEAST_ll() )
+GSOUTH = ( .NOT. L2D .AND. HLBCY(1) /= 'CYCL' .AND. LSOUTH_ll() )
+GNORTH = ( .NOT. L2D .AND. HLBCY(2) /= 'CYCL' .AND. LNORTH_ll() )
+!
+!-------------------------------------------------------------------------------
+!
+!* 2. COMPUTE THE CONTRAVARIANT COMPONENTS
+! ------------------------------------
+!
+!* 2.1 prepare the boundary conditions
+!
+!
+!$acc kernels
+ DO CONCURRENT ( JI=1:IIU,JJ=1:IJU )
+ PU(JI,JJ,IKB-1)=PU(JI,JJ,IKB)
+ PU(JI,JJ,IKE+1)=PU(JI,JJ,IKE)
+ PV(JI,JJ,IKB-1)=PV(JI,JJ,IKB)
+ PV(JI,JJ,IKE+1)=PV(JI,JJ,IKE)
+ END DO
+!$acc end kernels
+!
+!
+!* 2.1 compute the contravariant components
+!
+#ifndef MNH_OPENACC
+CALL CONTRAV(HLBCX,HLBCY,PU,PV,PW,PDXX,PDYY,PDZZ,PDZX,PDZY,ZUC,ZVC,ZWC,4)
+#else
+CALL CONTRAV_DEVICE(HLBCX,HLBCY,PU,PV,PW,PDXX,PDYY,PDZZ,PDZX,PDZY,ZUC,ZVC,ZWC,4, &
+ ZTMP1,ZTMP2,ODATA_ON_DEVICE=.TRUE.)
+#endif
+!
+!-------------------------------------------------------------------------------
+!
+!* 3. COMPUTE THE DIVERGENCE
+! ----------------------
+!
+!$acc kernels
+PGDIV=0. !usefull for the four corners and halo zones
+!
+Z1(IIB:IIE,:,:)=ZUC(IIB+1:IIE+1,:,:)-ZUC(IIB:IIE,:,:)
+Z2(:,IJB:IJE,:)=ZVC(:,IJB+1:IJE+1,:)-ZVC(:,IJB:IJE,:)
+Z3(:,:,IKB:IKE)=ZWC(:,:,IKB+1:IKE+1)-ZWC(:,:,IKB:IKE)
+!
+PGDIV(IIB:IIE,IJB:IJE,IKB:IKE)= Z1(IIB:IIE,IJB:IJE,IKB:IKE) + &
+ Z2(IIB:IIE,IJB:IJE,IKB:IKE) + &
+ Z3(IIB:IIE,IJB:IJE,IKB:IKE)
+ ! only the divergences computed
+ ! in the inner mass points are meaningful
+!$acc end kernels
+!
+!-------------------------------------------------------------------------------
+!
+!* 4. SET DIVERGENCE AT THE OUTER POINTS
+! ----------------------------------
+!
+!* 4.1 set divergence at the upper and lower boundary
+!
+! we set the divergence equal to the vertical contravariant component above
+! and under the physical domain
+!$acc kernels async
+DO JJ=IJB,IJE
+ DO JI=IIB,IIE
+ PGDIV(JI,JJ,IKB-1)=ZWC(JI,JJ,IKB)
+ PGDIV(JI,JJ,IKE+1)=ZWC(JI,JJ,IKE+1)
+ END DO
+END DO
+!$acc end kernels
+!
+!* 4.2 set divergence at the lateral boundaries
+!
+! we set the divergence equal to the horizontal contravariant component at
+! the right and the left of the physical domain in both horizontal directions
+! for non-periodic cases
+!
+IF( GWEST ) THEN
+ !$acc kernels async
+ DO JK=IKB,IKE
+ DO JJ=IJB,IJE
+ PGDIV(IIB-1,JJ,JK)=ZUC(IIB,JJ,JK)
+ END DO
+ END DO
+ !$acc end kernels
+END IF
+!
+IF( GEAST ) THEN
+ !$acc kernels async
+ DO JK=IKB,IKE
+ DO JJ=IJB,IJE
+ PGDIV(IIE+1,JJ,JK)=ZUC(IIE+1,JJ,JK)
+ END DO
+ END DO
+ !$acc end kernels
+END IF
+!
+!
+IF ( GSOUTH ) THEN
+ !$acc kernels async
+ DO JK=IKB,IKE
+ DO JI=IIB,IIE
+ PGDIV(JI,IJB-1,JK)=ZVC(JI,IJB,JK)
+ END DO
+ END DO
+ !$acc end kernels
+END IF
+!
+IF ( GNORTH ) THEN
+ !$acc kernels async
+ DO JK=IKB,IKE
+ DO JI=IIB,IIE
+ PGDIV(JI,IJE+1,JK)=ZVC(JI,IJE+1,JK)
+ END DO
+ END DO
+ !$acc end kernels
+END IF
+!
+! wait on GPU for all boundary condition update
+!$acc wait
+!
+!* 4.3 set divergence at the corner points
+!
+! it is the following of the condition of copy the horizontal component
+! under the bottom of the model
+!
+IF( GWEST ) THEN
+ !$acc kernels async
+ PGDIV(IIB-1,IJB:IJE,IKB-1)=PGDIV(IIB-1,IJB:IJE,IKB)
+ PGDIV(IIB-1,IJB:IJE,IKE+1)=PGDIV(IIB-1,IJB:IJE,IKE)
+ !$acc end kernels
+END IF
+!
+IF ( GEAST ) THEN
+ !$acc kernels async
+ PGDIV(IIE+1,IJB:IJE,IKB-1)=PGDIV(IIE+1,IJB:IJE,IKB)
+ PGDIV(IIE+1,IJB:IJE,IKE+1)=PGDIV(IIE+1,IJB:IJE,IKE)
+ !$acc end kernels
+END IF
+!
+IF ( GSOUTH ) THEN
+ !$acc kernels async
+ PGDIV(IIB:IIE,IJB-1,IKB-1)=PGDIV(IIB:IIE,IJB-1,IKB)
+ PGDIV(IIB:IIE,IJB-1,IKE+1)=PGDIV(IIB:IIE,IJB-1,IKE)
+ !$acc end kernels
+END IF
+!
+IF ( GNORTH ) THEN
+ !$acc kernels async
+ PGDIV(IIB:IIE,IJE+1,IKB-1)=PGDIV(IIB:IIE,IJE+1,IKB)
+ PGDIV(IIB:IIE,IJE+1,IKE+1)=PGDIV(IIB:IIE,IJE+1,IKE)
+ !$acc end kernels
+END IF
+!
+! wait on GPU for all corner update
+!$acc wait
+!
+#ifdef MNH_OPENACC
+CALL MNH_REL_ZT3D (IZUC,IZVC,IZWC,IZ1,IZ2,IZ3,IZTMP1,IZTMP2)
+#endif
+!
+!-------------------------------------------------------------------------------
+!
+END SUBROUTINE GDIV
diff --git a/src/ZSOLVER/get_halo.f90 b/src/ZSOLVER/get_halo.f90
new file mode 100644
index 0000000000000000000000000000000000000000..784b664f64a3842ce6a230d8fad1f047258b2fa3
--- /dev/null
+++ b/src/ZSOLVER/get_halo.f90
@@ -0,0 +1,1274 @@
+!MNH_LIC Copyright 1994-2019 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.
+!-----------------------------------------------------------------
+! Modifications:
+! P. Wautelet 20/05/2019: add name argument to ADDnFIELD_ll + new ADD4DFIELD_ll subroutine
+! P. Wautelet 18/07/2019: add optional dummy argument with name of the field
+!-----------------------------------------------------------------
+! ####################
+ MODULE MODI_GET_HALO
+! ####################
+!
+INTERFACE
+ SUBROUTINE GET_HALO2(PSRC, TP_PSRC_HALO2_ll, HNAME)
+ !
+ USE MODD_ARGSLIST_ll, ONLY : HALO2LIST_ll
+ !
+ IMPLICIT NONE
+ !
+ REAL, DIMENSION(:,:,:), INTENT(IN) :: PSRC ! variable at t
+ TYPE(HALO2LIST_ll), POINTER :: TP_PSRC_HALO2_ll ! halo2 for SRC
+ character(len=*), optional, intent(in) :: HNAME ! Name of the field to be added
+ !
+ END SUBROUTINE GET_HALO2
+END INTERFACE
+!
+INTERFACE
+ SUBROUTINE GET_HALO(PSRC, HDIR, HNAME)
+ IMPLICIT NONE
+ !
+ REAL, DIMENSION(:,:,:), INTENT(IN) :: PSRC ! variable at t
+ CHARACTER(len=4), OPTIONAL :: HDIR ! to send only halo on X or Y direction
+ character(len=*), optional, intent(in) :: HNAME ! Name of the field to be added
+ !
+ END SUBROUTINE GET_HALO
+END INTERFACE
+!
+#ifdef MNH_OPENACC
+INTERFACE
+ SUBROUTINE GET_HALO2_D(PSRC, TP_PSRC_HALO2_ll, HNAME)
+ !
+ USE MODD_ARGSLIST_ll, ONLY : HALO2LIST_ll
+ !
+ IMPLICIT NONE
+ !
+ REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PSRC ! variable at t
+ TYPE(HALO2LIST_ll), POINTER :: TP_PSRC_HALO2_ll ! halo2 for SRC
+ character(len=*), optional, intent(in) :: HNAME ! Name of the field to be added
+ !
+ END SUBROUTINE GET_HALO2_D
+END INTERFACE
+INTERFACE
+ SUBROUTINE GET_HALO2_DD(PSRC, TP_PSRC_HALO2_ll, HNAME)
+ !
+ USE MODD_ARGSLIST_ll, ONLY : HALO2LIST_ll
+ !
+ IMPLICIT NONE
+ !
+ REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PSRC ! variable at t
+ TYPE(HALO2LIST_ll), POINTER :: TP_PSRC_HALO2_ll ! halo2 for SRC
+ character(len=*), optional, intent(in) :: HNAME ! Name of the field to be added
+ !
+ END SUBROUTINE GET_HALO2_DD
+END INTERFACE
+INTERFACE
+ SUBROUTINE GET_HALO_D(PSRC, HDIR, HNAME)
+ IMPLICIT NONE
+ !
+ REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PSRC ! variable at t
+ CHARACTER(len=4), OPTIONAL :: HDIR ! to send only halo on X or Y direction
+ character(len=*), optional, intent(in) :: HNAME ! Name of the field to be added
+ !
+ END SUBROUTINE GET_HALO_D
+END INTERFACE
+!
+INTERFACE
+ SUBROUTINE GET_HALO_START_D(PSRC,KNB_REQ,KREQ,HDIR)
+ IMPLICIT NONE
+ !
+ REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PSRC ! variable at t
+ !$acc declare present (PSRC)
+ INTEGER :: KNB_REQ , KREQ(8)
+ CHARACTER(len=4), OPTIONAL :: HDIR ! to send only halo on X or Y direction
+ !
+ END SUBROUTINE GET_HALO_START_D
+END INTERFACE
+INTERFACE
+ SUBROUTINE GET_HALO_STOP_D(PSRC,KNB_REQ,KREQ,HDIR)
+ IMPLICIT NONE
+ REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PSRC ! variable at t
+ !$acc declare present (PSRC)
+ INTEGER :: KNB_REQ , KREQ(8)
+ CHARACTER(len=4), OPTIONAL :: HDIR ! to send only halo on X or Y direction
+ END SUBROUTINE GET_HALO_STOP_D
+END INTERFACE
+INTERFACE
+ SUBROUTINE GET_HALO_DD(PSRC, HDIR, HNAME)
+ IMPLICIT NONE
+ !
+ REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PSRC ! variable at t
+ CHARACTER(len=4), OPTIONAL :: HDIR ! to send only halo on X or Y direction
+ character(len=*), optional, intent(in) :: HNAME ! Name of the field to be added
+ !
+ END SUBROUTINE GET_HALO_DD
+END INTERFACE
+#endif
+!
+INTERFACE
+ SUBROUTINE DEL_HALO2_ll(TPHALO2LIST)
+ !
+ USE MODD_ARGSLIST_ll, ONLY : HALO2LIST_ll
+ !
+ IMPLICIT NONE
+ !
+ TYPE(HALO2LIST_ll), POINTER :: TPHALO2LIST ! list of HALO2_lls
+ !
+ END SUBROUTINE DEL_HALO2_ll
+ !
+END INTERFACE
+!
+END MODULE MODI_GET_HALO
+!
+! ###################################################
+ SUBROUTINE GET_HALO2(PSRC, TP_PSRC_HALO2_ll, HNAME)
+! ###################################################
+!
+USE MODE_ll
+USE MODD_ARGSLIST_ll, ONLY : LIST_ll, HALO2LIST_ll
+!
+IMPLICIT NONE
+!
+REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PSRC ! variable at t
+TYPE(HALO2LIST_ll), POINTER :: TP_PSRC_HALO2_ll ! halo2 for SRC
+character(len=*), optional, intent(in) :: HNAME ! Name of the field to be added
+!
+character(len=:), allocatable :: yname
+INTEGER :: IIU,IJU,IKU ! domain sizes
+TYPE(LIST_ll) , POINTER :: TZ_PSRC_ll ! halo
+INTEGER :: IERROR ! error return code
+!
+IIU = SIZE(PSRC,1)
+IJU = SIZE(PSRC,2)
+IKU = SIZE(PSRC,3)
+
+if ( present ( hname ) ) then
+ yname = hname
+else
+ yname = 'PSRC'
+end if
+
+NULLIFY( TZ_PSRC_ll,TP_PSRC_HALO2_ll)
+CALL INIT_HALO2_ll(TP_PSRC_HALO2_ll,1,IIU,IJU,IKU)
+!
+CALL ADD3DFIELD_ll( TZ_PSRC_ll, PSRC, 'GET_HALO2::'//trim( yname ) )
+CALL UPDATE_HALO_ll(TZ_PSRC_ll,IERROR)
+CALL UPDATE_HALO2_ll(TZ_PSRC_ll,TP_PSRC_HALO2_ll,IERROR)
+!
+! clean local halo list
+!
+CALL CLEANLIST_ll(TZ_PSRC_ll)
+!
+END SUBROUTINE GET_HALO2
+!-------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------
+! ######################################
+ SUBROUTINE GET_HALO(PSRC, HDIR, HNAME)
+! ######################################
+!
+USE MODE_ll
+USE MODD_ARGSLIST_ll, ONLY : LIST_ll
+!
+IMPLICIT NONE
+!
+REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PSRC ! variable at t
+CHARACTER(len=4), OPTIONAL :: HDIR ! to send only halo on X or Y direction
+character(len=*), optional, intent(in) :: HNAME ! Name of the field to be added
+!
+character(len=:), allocatable :: yname
+TYPE(LIST_ll) , POINTER :: TZ_PSRC_ll ! halo
+INTEGER :: IERROR ! error return code
+!
+NULLIFY( TZ_PSRC_ll)
+
+if ( present ( hname ) ) then
+ yname = hname
+else
+ yname = 'PSRC'
+end if
+
+CALL ADD3DFIELD_ll( TZ_PSRC_ll, PSRC, 'GET_HALO::'//trim( yname ) )
+CALL UPDATE_HALO_ll(TZ_PSRC_ll,IERROR, HDIR=HDIR )
+CALL CLEANLIST_ll(TZ_PSRC_ll)
+!
+END SUBROUTINE GET_HALO
+!-----------------------------------------------------------------------
+#ifdef MNH_OPENACC
+MODULE MODD_HALO_D
+
+ IMPLICIT NONE
+
+ REAL, SAVE , ALLOCATABLE, DIMENSION(:,:,:) :: ZNORTH_IN, ZSOUTH_IN, ZWEST_IN, ZEAST_IN
+ REAL, SAVE , ALLOCATABLE, DIMENSION(:,:,:) :: ZNORTH_OUT, ZSOUTH_OUT, ZWEST_OUT, ZEAST_OUT
+
+ REAL, SAVE , ALLOCATABLE, DIMENSION(:,:) :: ZNORTH2_IN, ZSOUTH2_IN, ZWEST2_IN, ZEAST2_IN
+ REAL, SAVE , ALLOCATABLE, DIMENSION(:,:) :: ZNORTH2_OUT, ZSOUTH2_OUT, ZWEST2_OUT, ZEAST2_OUT
+
+ LOGICAL, SAVE :: GFIRST_GET_HALO_D = .TRUE.
+
+ LOGICAL, SAVE :: GFIRST_INIT_HALO_D = .TRUE.
+ INTEGER, SAVE :: IHALO_1
+ INTEGER, SAVE :: NP_NORTH,NP_SOUTH,NP_WEST,NP_EAST
+
+CONTAINS
+
+ SUBROUTINE INIT_HALO_D()
+
+ USE MODE_MNH_ZWORK, ONLY : IIU,IJU,IKU
+ USE MODE_MNH_ZWORK, ONLY : IIB,IJB ,IIE,IJE
+ USE MODE_MNH_ZWORK, ONLY : GWEST , GEAST, GSOUTH , GNORTH
+ USE MODD_CONF, ONLY : NHALO
+
+ USE MODD_VAR_ll, ONLY : IP,NPROC,NP1,NP2
+
+
+ IMPLICIT NONE
+
+ IF (GFIRST_INIT_HALO_D) THEN
+ !
+ IHALO_1 = NHALO-1
+ !
+ ! Init HALO
+ !
+ ALLOCATE ( ZSOUTH_IN ( IIB:IIE , IJB:IJB+IHALO_1 , IKU ) )
+ ALLOCATE ( ZNORTH_IN ( IIB:IIE , IJE-IHALO_1:IJE , IKU ) )
+ ALLOCATE ( ZWEST_IN ( IIB:IIB+IHALO_1 , IJB:IJE , IKU ) )
+ ALLOCATE ( ZEAST_IN ( IIE-IHALO_1:IIE , IJB:IJE , IKU ) )
+ !$acc enter data create (ZNORTH_IN, ZSOUTH_IN, ZWEST_IN, ZEAST_IN)
+ !
+ ALLOCATE ( ZSOUTH_OUT ( IIB:IIE , 1:IJB-1 , IKU ) )
+ ALLOCATE ( ZNORTH_OUT ( IIB:IIE , IJE+1:IJU , IKU ) )
+ ALLOCATE ( ZWEST_OUT ( 1:IIB-1 , IJB:IJE , IKU ) )
+ ALLOCATE ( ZEAST_OUT ( IIE+1:IIU , IJB:IJE , IKU ) )
+ !$acc enter data create (ZNORTH_OUT, ZSOUTH_OUT, ZWEST_OUT, ZEAST_OUT)
+ !
+ ! Init HALO2
+ !
+ ALLOCATE ( ZSOUTH2_IN ( IIU , IKU ) )
+ ALLOCATE ( ZNORTH2_IN ( IIU , IKU ) )
+ ALLOCATE ( ZWEST2_IN ( IJU , IKU ) )
+ ALLOCATE ( ZEAST2_IN ( IJU , IKU ) )
+ !$acc enter data create (ZNORTH2_IN, ZSOUTH2_IN, ZWEST2_IN, ZEAST2_IN)
+ !
+ ALLOCATE ( ZSOUTH2_OUT ( IIU , IKU ) )
+ ALLOCATE ( ZNORTH2_OUT ( IIU , IKU ) )
+ ALLOCATE ( ZWEST2_OUT ( IJU , IKU ) )
+ ALLOCATE ( ZEAST2_OUT ( IJU , IKU ) )
+ !$acc enter data create (ZNORTH2_OUT, ZSOUTH2_OUT, ZWEST2_OUT, ZEAST2_OUT)
+
+ IF (.NOT. GWEST ) THEN
+ NP_WEST = ( IP-1 -1 ) + 1
+ ELSE
+ NP_WEST = 0
+ ENDIF
+ IF (.NOT. GEAST ) THEN
+ NP_EAST = ( IP-1 +1 ) + 1
+ ELSE
+ NP_EAST = 0
+ ENDIF
+ IF (.NOT. GSOUTH ) THEN
+ NP_SOUTH = ( IP-1 -NP1 ) + 1
+ ELSE
+ NP_SOUTH = 0
+ ENDIF
+ IF (.NOT. GNORTH ) THEN
+ NP_NORTH = ( IP-1 +NP1 ) + 1
+ ELSE
+ NP_NORTH = 0
+ ENDIF
+
+ !print*,"PROC=",IP, GWEST,NP_WEST, GEAST,NP_EAST, GSOUTH,NP_SOUTH , GNORTH,NP_NORTH
+
+ GFIRST_INIT_HALO_D = .FALSE.
+
+ END IF
+
+ END SUBROUTINE INIT_HALO_D
+
+END MODULE MODD_HALO_D
+! #########################
+ SUBROUTINE GET_HALO_D(PSRC,HDIR,HNAME)
+! #########################
+#define MNH_GPUDIRECT
+!
+USE MODD_HALO_D
+
+!USE MODE_MNH_ZWORK, ONLY : GWEST , GEAST, GSOUTH , GNORTH
+!USE MODE_MNH_ZWORK, ONLY : IIU,IJU,IKU
+!USE MODE_MNH_ZWORK, ONLY : IIB,IJB ,IIE,IJE
+!!
+!USE MODE_DEVICE
+USE MODE_MPPDB
+USE MODI_GET_HALO, ONLY : GET_HALO_START_D,GET_HALO_STOP_D
+!
+IMPLICIT NONE
+!
+REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PSRC ! variable at t
+!$acc declare present (PSRC)
+CHARACTER(len=4), OPTIONAL :: HDIR ! to send only halo on X or Y direction
+character(len=*), optional, intent(in) :: HNAME ! Name of the field to be added
+!
+INTEGER :: INB_REQ , IREQ(8)
+!
+CALL GET_HALO_START_D(PSRC,INB_REQ,IREQ,HDIR)
+CALL GET_HALO_STOP_D(PSRC,INB_REQ,IREQ,HDIR)
+!
+END SUBROUTINE GET_HALO_D
+! #########################
+ SUBROUTINE GET_HALO_START_D(PSRC,KNB_REQ,KREQ,HDIR)
+! #########################
+#define MNH_GPUDIRECT
+!
+USE MODD_HALO_D
+
+USE MODE_MNH_ZWORK, ONLY : GWEST , GEAST, GSOUTH , GNORTH
+USE MODE_MNH_ZWORK, ONLY : IIU,IJU,IKU
+USE MODE_MNH_ZWORK, ONLY : IIB,IJB ,IIE,IJE
+!
+USE MODD_VAR_ll, ONLY : NMNH_COMM_WORLD
+USE MODD_MPIF, ONLY : MPI_STATUSES_IGNORE
+USE MODD_PRECISION, ONLY : MNHREAL_MPI
+!
+USE MODE_DEVICE
+USE MODE_MPPDB
+!
+IMPLICIT NONE
+!
+REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PSRC ! variable at t
+!$acc declare present (PSRC)
+INTEGER :: KNB_REQ , KREQ(8)
+CHARACTER(len=4), OPTIONAL :: HDIR ! to send only halo on X or Y direction
+!
+INTEGER :: IERROR ! error return code
+
+INTEGER,PARAMETER :: IS_WEST=1 , IS_EAST=2, IS_SOUTH=3, IS_NORTH=4
+LOGICAL :: LX , LY
+INTEGER :: NB_REQ, IERR
+!
+
+CALL INIT_HALO_D()
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+!$acc data present (ZNORTH_IN, ZSOUTH_IN, ZWEST_IN, ZEAST_IN) &
+!$acc present (ZNORTH_OUT, ZSOUTH_OUT, ZWEST_OUT, ZEAST_OUT)
+
+LX = .FALSE.
+LY = .FALSE.
+
+IF (.NOT. PRESENT(HDIR) ) THEN
+LX = .TRUE.
+LY = .TRUE.
+ELSE
+!!$LX = ( HDIR == "01_X" .OR. HDIR == "S0_X" )
+!!$LY = ( HDIR == "01_Y" .OR. HDIR == "S0_Y" )
+LX = ( HDIR == "01_X" .OR. HDIR == "S0_X" .OR. HDIR == "S0_Y" )
+LY = ( HDIR == "01_Y" .OR. HDIR == "S0_Y" .OR. HDIR == "S0_X" )
+!!$print *,"IIB=",IIB," HDIR=",HDIR," LX=",LX," LY=",LY ; call flush(6)
+END IF
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+NB_REQ = 0
+
+!
+! Post the recieve of Zxxxx_IN buffer first via MPI(Gpu_direct)
+!
+
+IF (LX) THEN
+ IF (.NOT. GWEST) THEN
+#ifdef MNH_GPUDIRECT
+ !$acc host_data use_device(ZWEST_OUT)
+#endif
+ NB_REQ = NB_REQ + 1
+ CALL MPI_IRECV(ZWEST_OUT,SIZE(ZWEST_OUT),MNHREAL_MPI,NP_WEST-1,1000+IS_EAST,NMNH_COMM_WORLD,KREQ(NB_REQ),IERR)
+#ifdef MNH_GPUDIRECT
+ !$acc end host_data
+#endif
+ END IF
+ IF (.NOT.GEAST) THEN
+#ifdef MNH_GPUDIRECT
+ !$acc host_data use_device(ZEAST_OUT)
+#endif
+ NB_REQ = NB_REQ + 1
+ CALL MPI_IRECV(ZEAST_OUT,SIZE(ZEAST_OUT),MNHREAL_MPI,NP_EAST-1,1000+IS_WEST,NMNH_COMM_WORLD,KREQ(NB_REQ),IERR)
+#ifdef MNH_GPUDIRECT
+ !$acc end host_data
+#endif
+ ENDIF
+END IF
+
+IF (LY) THEN
+ IF (.NOT.GSOUTH) THEN
+#ifdef MNH_GPUDIRECT
+ !$acc host_data use_device(ZSOUTH_OUT)
+#endif
+ NB_REQ = NB_REQ + 1
+ CALL MPI_IRECV(ZSOUTH_OUT,SIZE(ZSOUTH_OUT),MNHREAL_MPI,NP_SOUTH-1,1000+IS_NORTH,NMNH_COMM_WORLD,KREQ(NB_REQ),IERR)
+#ifdef MNH_GPUDIRECT
+ !$acc end host_data
+#endif
+ ENDIF
+ IF (.NOT.GNORTH) THEN
+#ifdef MNH_GPUDIRECT
+ !$acc host_data use_device(ZNORTH_OUT)
+#endif
+ NB_REQ = NB_REQ + 1
+ CALL MPI_IRECV(ZNORTH_OUT,SIZE(ZNORTH_OUT),MNHREAL_MPI,NP_NORTH-1,1000+IS_SOUTH,NMNH_COMM_WORLD,KREQ(NB_REQ),IERR)
+#ifdef MNH_GPUDIRECT
+ !$acc end host_data
+#endif
+ ENDIF
+END IF
+
+!
+! Copy the halo(async) on the device PSRC to Zxxxx_IN buffer
+!
+
+IF (LX) THEN
+ IF (.NOT. GWEST) THEN
+ !$acc kernels async(IS_WEST)
+ ZWEST_IN ( IIB:IIB+IHALO_1 , IJB:IJE , : ) = PSRC( IIB:IIB+IHALO_1 , IJB:IJE , : )
+ !$acc end kernels
+ END IF
+ IF (.NOT.GEAST) THEN
+ !$acc kernels async(IS_EAST)
+ ZEAST_IN ( IIE-IHALO_1:IIE , IJB:IJE , : ) = PSRC( IIE-IHALO_1:IIE , IJB:IJE , : )
+ !$acc end kernels
+ ENDIF
+END IF
+
+IF (LY) THEN
+ IF (.NOT.GSOUTH) THEN
+ !$acc kernels async(IS_SOUTH)
+ ZSOUTH_IN ( IIB:IIE , IJB:IJB+IHALO_1 , : ) = PSRC( IIB:IIE , IJB:IJB+IHALO_1 , : )
+ !$acc end kernels
+ ENDIF
+ IF (.NOT.GNORTH) THEN
+ !$acc kernels async(IS_NORTH)
+ ZNORTH_IN ( IIB:IIE , IJE-IHALO_1:IJE , : ) = PSRC( IIB:IIE , IJE-IHALO_1:IJE , : )
+ !$acc end kernels
+ ENDIF
+ENDIF
+
+!$acc wait
+
+!
+! Send Zxxxx_IN buffer via MPI(Gpu_direct)
+!
+IF (LX) THEN
+ IF (.NOT. GWEST) THEN
+#ifdef MNH_GPUDIRECT
+ !$acc host_data use_device(ZWEST_IN)
+#else
+ !$acc update host(ZWEST_IN)
+#endif
+ NB_REQ = NB_REQ + 1
+ CALL MPI_ISEND(ZWEST_IN,SIZE(ZWEST_IN) ,MNHREAL_MPI,NP_WEST-1,1000+IS_WEST,NMNH_COMM_WORLD,KREQ(NB_REQ),IERR)
+#ifdef MNH_GPUDIRECT
+ !$acc end host_data
+#endif
+ END IF
+ IF (.NOT.GEAST) THEN
+#ifdef MNH_GPUDIRECT
+ !$acc host_data use_device(ZEAST_IN)
+#else
+ !$acc update host(ZEAST_IN)
+#endif
+ NB_REQ = NB_REQ + 1
+ CALL MPI_ISEND(ZEAST_IN,SIZE(ZEAST_IN) ,MNHREAL_MPI,NP_EAST-1,1000+IS_EAST,NMNH_COMM_WORLD,KREQ(NB_REQ),IERR)
+#ifdef MNH_GPUDIRECT
+ !$acc end host_data
+#endif
+ ENDIF
+END IF
+
+IF (LY) THEN
+ IF (.NOT.GSOUTH) THEN
+#ifdef MNH_GPUDIRECT
+ !$acc host_data use_device(ZSOUTH_IN)
+#else
+ !$acc update host(ZSOUTH_IN)
+#endif
+ NB_REQ = NB_REQ + 1
+ CALL MPI_ISEND(ZSOUTH_IN,SIZE(ZSOUTH_IN) ,MNHREAL_MPI,NP_SOUTH-1,1000+IS_SOUTH,NMNH_COMM_WORLD,KREQ(NB_REQ),IERR)
+#ifdef MNH_GPUDIRECT
+ !$acc end host_data
+#endif
+ ENDIF
+ IF (.NOT.GNORTH) THEN
+#ifdef MNH_GPUDIRECT
+ !$acc host_data use_device(ZNORTH_IN)
+#else
+ !$acc update host(ZNORTH_IN)
+#endif
+ NB_REQ = NB_REQ + 1
+ CALL MPI_ISEND(ZNORTH_IN,SIZE(ZNORTH_IN) ,MNHREAL_MPI,NP_NORTH-1,1000+IS_NORTH,NMNH_COMM_WORLD,KREQ(NB_REQ),IERR)
+#ifdef MNH_GPUDIRECT
+ !$acc end host_data
+#endif
+ ENDIF
+ENDIF
+
+!$acc end data
+
+KNB_REQ = NB_REQ
+!
+END SUBROUTINE GET_HALO_START_D
+!
+! #########################
+ SUBROUTINE GET_HALO_STOP_D(PSRC,KNB_REQ,KREQ,HDIR)
+! #########################
+#define MNH_GPUDIRECT
+!
+USE MODD_HALO_D
+
+USE MODE_MNH_ZWORK, ONLY : GWEST , GEAST, GSOUTH , GNORTH
+USE MODE_MNH_ZWORK, ONLY : IIU,IJU,IKU
+USE MODE_MNH_ZWORK, ONLY : IIB,IJB ,IIE,IJE
+!
+USE MODD_VAR_ll, ONLY : NMNH_COMM_WORLD
+USE MODD_MPIF, ONLY : MPI_STATUSES_IGNORE
+USE MODD_PRECISION, ONLY : MNHREAL_MPI
+!
+USE MODE_DEVICE
+USE MODE_MPPDB
+!
+IMPLICIT NONE
+!
+REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PSRC ! variable at t
+!$acc declare present (PSRC)
+INTEGER :: KNB_REQ , KREQ(8)
+CHARACTER(len=4), OPTIONAL :: HDIR ! to send only halo on X or Y direction
+!
+INTEGER :: IERROR ! error return code
+
+INTEGER,PARAMETER :: IS_WEST=1 , IS_EAST=2, IS_SOUTH=3, IS_NORTH=4
+LOGICAL :: LX , LY
+INTEGER :: NB_REQ, IERR
+!
+
+CALL INIT_HALO_D()
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+!$acc data present (ZNORTH_IN, ZSOUTH_IN, ZWEST_IN, ZEAST_IN) &
+!$acc present (ZNORTH_OUT, ZSOUTH_OUT, ZWEST_OUT, ZEAST_OUT)
+
+LX = .FALSE.
+LY = .FALSE.
+
+IF (.NOT. PRESENT(HDIR) ) THEN
+LX = .TRUE.
+LY = .TRUE.
+ELSE
+!!$LX = ( HDIR == "01_X" .OR. HDIR == "S0_X" )
+!!$LY = ( HDIR == "01_Y" .OR. HDIR == "S0_Y" )
+LX = ( HDIR == "01_X" .OR. HDIR == "S0_X" .OR. HDIR == "S0_Y" )
+LY = ( HDIR == "01_Y" .OR. HDIR == "S0_Y" .OR. HDIR == "S0_X" )
+!!$print *,"IIB=",IIB," HDIR=",HDIR," LX=",LX," LY=",LY ; call flush(6)
+END IF
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+NB_REQ = KNB_REQ
+
+CALL MPI_WAITALL(NB_REQ,KREQ,MPI_STATUSES_IGNORE,IERR)
+
+!
+! Copy back the Zxxx_OUT buffer recv via MPI(gpu_direct) to PSRC halo
+!
+
+IF (LX) THEN
+ IF (.NOT.GWEST) THEN
+#ifndef MNH_GPUDIRECT
+ !$acc update device(ZWEST_OUT) async(IS_WEST)
+#endif
+ !$acc kernels async(IS_WEST)
+ PSRC( 1:IIB-1 , IJB:IJE , : ) = ZWEST_OUT( 1:IIB-1 , IJB:IJE , : )
+ !$acc end kernels
+ ENDIF
+ IF (.NOT.GEAST) THEN
+#ifndef MNH_GPUDIRECT
+ !$acc update device(ZEAST_OUT) async(IS_EAST)
+#endif
+ !$acc kernels async(IS_EAST)
+ PSRC( IIE+1:IIU , IJB:IJE , : ) = ZEAST_OUT( IIE+1:IIU , IJB:IJE , : )
+ !$acc end kernels
+ ENDIF
+END IF
+IF (LY) THEN
+ IF (.NOT.GSOUTH) THEN
+#ifndef MNH_GPUDIRECT
+ !$acc update device(ZSOUTH_OUT) async(IS_SOUTH)
+#endif
+ !$acc kernels async(IS_SOUTH)
+ PSRC( IIB:IIE , 1:IJB-1 , : ) = ZSOUTH_OUT( IIB:IIE , 1:IJB-1 , : )
+ !$acc end kernels
+ ENDIF
+ IF (.NOT.GNORTH) THEN
+#ifndef MNH_GPUDIRECT
+ !$acc update device(ZNORTH_OUT) async(IS_NORTH)
+#endif
+ !$acc kernels async(IS_NORTH)
+ PSRC( IIB:IIE , IJE+1:IJU , : ) = ZNORTH_OUT ( IIB:IIE , IJE+1:IJU , : )
+ !$acc end kernels
+ ENDIF
+END IF
+!$acc wait
+
+!$acc end data
+!
+END SUBROUTINE GET_HALO_STOP_D
+!-------------------------------------------------------------------------------
+! ########################################
+ SUBROUTINE GET_HALO_DD(PSRC, HDIR, HNAME)
+! ########################################
+#define MNH_GPUDIRECT
+!
+USE MODD_HALO_D
+USE MODE_ll
+USE MODD_ARGSLIST_ll, ONLY : LIST_ll
+USE MODD_PARAMETERS, ONLY : JPHEXT
+!
+USE MODD_IO, ONLY : GSMONOPROC
+USE MODE_MNH_ZWORK, ONLY : GWEST , GEAST, GSOUTH , GNORTH
+!
+USE MODD_CONF, ONLY : NHALO
+USE MODE_DEVICE
+USE MODE_MPPDB
+
+USE MODD_VAR_ll, ONLY : IP,NPROC,NP1,NP2
+USE MODD_VAR_ll, ONLY : NMNH_COMM_WORLD
+USE MODD_MPIF, ONLY : MPI_STATUSES_IGNORE
+USE MODD_PRECISION, ONLY : MNHREAL_MPI
+!
+USE MODE_MNH_ZWORK, ONLY : IIU,IJU,IKU
+USE MODE_MNH_ZWORK, ONLY : IIB,IJB ,IIE,IJE
+!
+IMPLICIT NONE
+!
+REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PSRC ! variable at t
+CHARACTER(len=4), OPTIONAL :: HDIR ! to send only halo on X or Y direction
+character(len=*), optional, intent(in) :: HNAME ! Name of the field to be added
+!
+character(len=:), allocatable :: yname
+TYPE(LIST_ll) , POINTER :: TZ_PSRC_ll ! halo
+INTEGER :: IERROR ! error return code
+
+INTEGER,PARAMETER :: IS_WEST=1 , IS_EAST=2, IS_SOUTH=3, IS_NORTH=4
+
+LOGICAL :: LX , LY
+
+INTEGER :: INB_REQ , IREQ(8)
+INTEGER :: IERR
+
+if ( NPROC == 1 ) RETURN
+
+CALL INIT_HALO_D()
+
+!$acc data present ( PSRC )
+
+NULLIFY( TZ_PSRC_ll)
+!
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+LX = .FALSE.
+LY = .FALSE.
+
+IF (.NOT. PRESENT(HDIR) ) THEN
+LX = .TRUE.
+LY = .TRUE.
+ELSE
+ !
+ ! Problem of reproductibility in ppm_s0_x/y if only S0_X or S0_Y
+ ! so add S0_X + S0_Y for ppm_s0*
+ !
+!!$LX = ( HDIR == "01_X" .OR. HDIR == "S0_X" )
+!!$LY = ( HDIR == "01_Y" .OR. HDIR == "S0_Y" )
+LX = ( HDIR == "01_X" .OR. HDIR == "S0_X" .OR. HDIR == "S0_Y" )
+LY = ( HDIR == "01_Y" .OR. HDIR == "S0_Y" .OR. HDIR == "S0_X" )
+END IF
+
+!!$LX = .TRUE.
+!!$LY = .TRUE.
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+INB_REQ = 0
+
+!
+! Post the recieve of Zxxxx_IN buffer first via MPI(Gpu_direct)
+!
+
+IF (LX) THEN
+ IF (.NOT. GWEST) THEN
+#ifdef MNH_GPUDIRECT
+ !$acc host_data use_device(ZWEST_OUT)
+#endif
+ INB_REQ = INB_REQ + 1
+ CALL MPI_IRECV(ZWEST_OUT,SIZE(ZWEST_OUT),MNHREAL_MPI,NP_WEST-1,1000+IS_EAST,NMNH_COMM_WORLD,IREQ(INB_REQ),IERR)
+#ifdef MNH_GPUDIRECT
+ !$acc end host_data
+#endif
+ END IF
+ IF (.NOT.GEAST) THEN
+#ifdef MNH_GPUDIRECT
+ !$acc host_data use_device(ZEAST_OUT)
+#endif
+ INB_REQ = INB_REQ + 1
+ CALL MPI_IRECV(ZEAST_OUT,SIZE(ZEAST_OUT),MNHREAL_MPI,NP_EAST-1,1000+IS_WEST,NMNH_COMM_WORLD,IREQ(INB_REQ),IERR)
+#ifdef MNH_GPUDIRECT
+ !$acc end host_data
+#endif
+ ENDIF
+END IF
+
+IF (LY) THEN
+ IF (.NOT.GSOUTH) THEN
+#ifdef MNH_GPUDIRECT
+ !$acc host_data use_device(ZSOUTH_OUT)
+#endif
+ INB_REQ = INB_REQ + 1
+ CALL MPI_IRECV(ZSOUTH_OUT,SIZE(ZSOUTH_OUT),MNHREAL_MPI,NP_SOUTH-1,1000+IS_NORTH,NMNH_COMM_WORLD,IREQ(INB_REQ),IERR)
+#ifdef MNH_GPUDIRECT
+ !$acc end host_data
+#endif
+ ENDIF
+ IF (.NOT.GNORTH) THEN
+#ifdef MNH_GPUDIRECT
+ !$acc host_data use_device(ZNORTH_OUT)
+#endif
+ INB_REQ = INB_REQ + 1
+ CALL MPI_IRECV(ZNORTH_OUT,SIZE(ZNORTH_OUT),MNHREAL_MPI,NP_NORTH-1,1000+IS_SOUTH,NMNH_COMM_WORLD,IREQ(INB_REQ),IERR)
+#ifdef MNH_GPUDIRECT
+ !$acc end host_data
+#endif
+ ENDIF
+END IF
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+!Copy the halo on the device PSRC to Zxxxx_IN
+
+IF (LX) THEN
+ IF (.NOT. GWEST) THEN
+ !$acc kernels async(IS_WEST)
+ ZWEST_IN ( IIB:IIB+IHALO_1 , IJB:IJE , : ) = PSRC( IIB:IIB+IHALO_1 , IJB:IJE , : )
+ !$acc end kernels
+ END IF
+ IF (.NOT.GEAST) THEN
+ !$acc kernels async(IS_EAST)
+ ZEAST_IN ( IIE-IHALO_1:IIE , IJB:IJE , : ) = PSRC( IIE-IHALO_1:IIE , IJB:IJE , : )
+ !$acc end kernels
+ ENDIF
+END IF
+IF (LY) THEN
+ IF (.NOT.GSOUTH) THEN
+ !$acc kernels async(IS_SOUTH)
+ ZSOUTH_IN ( IIB:IIE , IJB:IJB+IHALO_1 , : ) = PSRC( IIB:IIE , IJB:IJB+IHALO_1 , : )
+ !$acc end kernels
+ ENDIF
+ IF (.NOT.GNORTH) THEN
+ !$acc kernels async(IS_NORTH)
+ ZNORTH_IN ( IIB:IIE , IJE-IHALO_1:IJE , : ) = PSRC( IIB:IIE , IJE-IHALO_1:IJE , : )
+ !$acc end kernels
+ ENDIF
+ENDIF
+!$acc wait
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!
+! Send Zxxxx_IN buffer via MPI(Gpu_direct) or copy to host
+!
+IF (LX) THEN
+ IF (.NOT. GWEST) THEN
+#ifdef MNH_GPUDIRECT
+ !$acc host_data use_device(ZWEST_IN)
+#else
+ !$acc update host(ZWEST_IN)
+#endif
+ INB_REQ = INB_REQ + 1
+ CALL MPI_ISEND(ZWEST_IN,SIZE(ZWEST_IN) ,MNHREAL_MPI,NP_WEST-1,1000+IS_WEST,NMNH_COMM_WORLD,IREQ(INB_REQ),IERR)
+#ifdef MNH_GPUDIRECT
+ !$acc end host_data
+#endif
+ END IF
+ IF (.NOT.GEAST) THEN
+#ifdef MNH_GPUDIRECT
+ !$acc host_data use_device(ZEAST_IN)
+#else
+ !$acc update host(ZEAST_IN)
+#endif
+ INB_REQ = INB_REQ + 1
+ CALL MPI_ISEND(ZEAST_IN,SIZE(ZEAST_IN) ,MNHREAL_MPI,NP_EAST-1,1000+IS_EAST,NMNH_COMM_WORLD,IREQ(INB_REQ),IERR)
+#ifdef MNH_GPUDIRECT
+ !$acc end host_data
+#endif
+ ENDIF
+END IF
+
+IF (LY) THEN
+ IF (.NOT.GSOUTH) THEN
+#ifdef MNH_GPUDIRECT
+ !$acc host_data use_device(ZSOUTH_IN)
+#else
+ !$acc update host(ZSOUTH_IN)
+#endif
+ INB_REQ = INB_REQ + 1
+ CALL MPI_ISEND(ZSOUTH_IN,SIZE(ZSOUTH_IN) ,MNHREAL_MPI,NP_SOUTH-1,1000+IS_SOUTH,NMNH_COMM_WORLD,IREQ(INB_REQ),IERR)
+#ifdef MNH_GPUDIRECT
+ !$acc end host_data
+#endif
+ ENDIF
+ IF (.NOT.GNORTH) THEN
+#ifdef MNH_GPUDIRECT
+ !$acc host_data use_device(ZNORTH_IN)
+#else
+ !$acc update host(ZNORTH_IN)
+#endif
+ INB_REQ = INB_REQ + 1
+ CALL MPI_ISEND(ZNORTH_IN,SIZE(ZNORTH_IN) ,MNHREAL_MPI,NP_NORTH-1,1000+IS_NORTH,NMNH_COMM_WORLD,IREQ(INB_REQ),IERR)
+#ifdef MNH_GPUDIRECT
+ !$acc end host_data
+#endif
+ ENDIF
+ENDIF
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+IF ( INB_REQ > 0 ) THEN
+ CALL MPI_WAITALL(INB_REQ,IREQ,MPI_STATUSES_IGNORE,IERR)
+END IF
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! Is update halo
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+
+IF (LX) THEN
+ IF (.NOT.GWEST) THEN
+#ifndef MNH_GPUDIRECT
+ !$acc update device(ZWEST_OUT) async(IS_WEST)
+#endif
+ !$acc kernels async(IS_WEST)
+ PSRC( 1:IIB-1 , IJB:IJE , : ) = ZWEST_OUT( 1:IIB-1 , IJB:IJE , : )
+ !$acc end kernels
+ ENDIF
+ IF (.NOT.GEAST) THEN
+#ifndef MNH_GPUDIRECT
+ !$acc update device(ZEAST_OUT) async(IS_EAST)
+#endif
+ !$acc kernels async(IS_EAST)
+ PSRC( IIE+1:IIU , IJB:IJE , : ) = ZEAST_OUT( IIE+1:IIU , IJB:IJE , : )
+ !$acc end kernels
+ ENDIF
+END IF
+IF (LY) THEN
+ IF (.NOT.GSOUTH) THEN
+#ifndef MNH_GPUDIRECT
+ !$acc update device(ZSOUTH_OUT) async(IS_SOUTH)
+#endif
+ !$acc kernels async(IS_SOUTH)
+ PSRC( IIB:IIE , 1:IJB-1 , : ) = ZSOUTH_OUT( IIB:IIE , 1:IJB-1 , : )
+ !$acc end kernels
+ ENDIF
+ IF (.NOT.GNORTH) THEN
+#ifndef MNH_GPUDIRECT
+ !$acc update device(ZNORTH_OUT) async(IS_NORTH)
+#endif
+ !$acc kernels async(IS_NORTH)
+ PSRC( IIB:IIE , IJE+1:IJU , : ) = ZNORTH_OUT ( IIB:IIE , IJE+1:IJU , : )
+ !$acc end kernels
+ ENDIF
+END IF
+!$acc wait
+
+!$acc end data
+
+END SUBROUTINE GET_HALO_DD
+
+!-------------------------------------------------------------------------------
+! ########################################
+ SUBROUTINE GET_HALO2_DD(PSRC, TP_PSRC_HALO2_ll, HNAME)
+! ########################################
+#define MNH_GPUDIRECT
+!
+USE MODD_HALO_D
+USE MODE_ll
+USE MODD_ARGSLIST_ll, ONLY : LIST_ll
+USE MODD_PARAMETERS, ONLY : JPHEXT
+!
+USE MODD_IO, ONLY : GSMONOPROC
+USE MODE_MNH_ZWORK, ONLY : GWEST , GEAST, GSOUTH , GNORTH
+USE MODE_MNH_ZWORK, ONLY : IIU,IJU,IKU
+USE MODE_MNH_ZWORK, ONLY : IIB,IJB ,IIE,IJE
+!
+USE MODD_CONF, ONLY : NHALO
+USE MODE_DEVICE
+USE MODE_MPPDB
+!
+USE MODD_VAR_ll, ONLY : IP,NPROC,NP1,NP2
+USE MODD_VAR_ll, ONLY : NMNH_COMM_WORLD
+USE MODD_MPIF, ONLY : MPI_STATUSES_IGNORE
+USE MODD_PRECISION, ONLY : MNHREAL_MPI
+!
+IMPLICIT NONE
+!
+REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PSRC ! variable at t
+TYPE(HALO2LIST_ll), POINTER :: TP_PSRC_HALO2_ll ! halo2 for SRC
+character(len=*), optional, intent(in) :: HNAME ! Name of the field to be added
+!
+character(len=:), allocatable :: yname
+INTEGER :: IERROR ! error return code
+
+INTEGER,PARAMETER :: IS_WEST=1 , IS_EAST=2, IS_SOUTH=3, IS_NORTH=4
+
+LOGICAL :: LX , LY
+
+INTEGER :: INB_REQ , IREQ(8)
+INTEGER :: IERR
+
+REAL , DIMENSION(:,:) , POINTER , CONTIGUOUS :: ZH2_EAST,ZH2_WEST,ZH2_NORTH,ZH2_SOUTH
+
+if ( NPROC == 1 ) RETURN
+
+!$acc data present ( PSRC ) &
+!$acc present (ZNORTH2_IN, ZSOUTH2_IN, ZWEST2_IN, ZEAST2_IN) &
+!$acc present (ZNORTH2_OUT, ZSOUTH2_OUT, ZWEST2_OUT, ZEAST2_OUT)
+!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+LX = .TRUE.
+LY = .TRUE.
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+INB_REQ = 0
+
+!
+! Post the recieve of Zxxxx_IN buffer first via MPI(Gpu_direct)
+!
+
+IF (LX) THEN
+ IF (.NOT. GWEST) THEN
+#ifdef MNH_GPUDIRECT
+ !$acc host_data use_device(ZWEST2_OUT)
+#endif
+ INB_REQ = INB_REQ + 1
+ CALL MPI_IRECV(ZWEST2_OUT,SIZE(ZWEST2_OUT),MNHREAL_MPI,NP_WEST-1,1000+IS_EAST,NMNH_COMM_WORLD,IREQ(INB_REQ),IERR)
+#ifdef MNH_GPUDIRECT
+ !$acc end host_data
+#endif
+ END IF
+ IF (.NOT.GEAST) THEN
+#ifdef MNH_GPUDIRECT
+ !$acc host_data use_device(ZEAST2_OUT)
+#endif
+ INB_REQ = INB_REQ + 1
+ CALL MPI_IRECV(ZEAST2_OUT,SIZE(ZEAST2_OUT),MNHREAL_MPI,NP_EAST-1,1000+IS_WEST,NMNH_COMM_WORLD,IREQ(INB_REQ),IERR)
+#ifdef MNH_GPUDIRECT
+ !$acc end host_data
+#endif
+ ENDIF
+END IF
+
+IF (LY) THEN
+ IF (.NOT.GSOUTH) THEN
+#ifdef MNH_GPUDIRECT
+ !$acc host_data use_device(ZSOUTH2_OUT)
+#endif
+ INB_REQ = INB_REQ + 1
+ CALL MPI_IRECV(ZSOUTH2_OUT,SIZE(ZSOUTH2_OUT),MNHREAL_MPI,NP_SOUTH-1,1000+IS_NORTH,NMNH_COMM_WORLD,IREQ(INB_REQ),IERR)
+#ifdef MNH_GPUDIRECT
+ !$acc end host_data
+#endif
+ ENDIF
+ IF (.NOT.GNORTH) THEN
+#ifdef MNH_GPUDIRECT
+ !$acc host_data use_device(ZNORTH2_OUT)
+#endif
+ INB_REQ = INB_REQ + 1
+ CALL MPI_IRECV(ZNORTH2_OUT,SIZE(ZNORTH2_OUT),MNHREAL_MPI,NP_NORTH-1,1000+IS_SOUTH,NMNH_COMM_WORLD,IREQ(INB_REQ),IERR)
+#ifdef MNH_GPUDIRECT
+ !$acc end host_data
+#endif
+ ENDIF
+END IF
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+!Copy the halo on the device PSRC to Zxxxx_IN
+
+IF (LX) THEN
+ IF (.NOT. GWEST) THEN
+ !$acc kernels async(IS_WEST)
+!!$ ZWEST2_IN ( IIB:IIB+IHALO_1 , IJB:IJE , : ) = PSRC( IIB:IIB+IHALO_1 , IJB:IJE , : )
+ ZWEST2_IN ( : , : ) = PSRC( IIB+1 , : , : )
+ !$acc end kernels
+ END IF
+ IF (.NOT.GEAST) THEN
+ !$acc kernels async(IS_EAST)
+!!$ ZEAST2_IN ( IIE-IHALO_1:IIE , IJB:IJE , : ) = PSRC( IIE-IHALO_1:IIE , IJB:IJE , : )
+ ZEAST2_IN ( : , : ) = PSRC( IIE-1 , : , : )
+ !$acc end kernels
+ ENDIF
+END IF
+IF (LY) THEN
+ IF (.NOT.GSOUTH) THEN
+ !$acc kernels async(IS_SOUTH)
+!!$ ZSOUTH2_IN ( IIB:IIE , IJB:IJB+IHALO_1 , : ) = PSRC( IIB:IIE , IJB:IJB+IHALO_1 , : )
+ ZSOUTH2_IN ( : , : ) = PSRC( : , IJB+1 , : )
+ !$acc end kernels
+ ENDIF
+ IF (.NOT.GNORTH) THEN
+ !$acc kernels async(IS_NORTH)
+!!$ ZNORTH2_IN ( IIB:IIE , IJE-IHALO_1:IJE , : ) = PSRC( IIB:IIE , IJE-IHALO_1:IJE , : )
+ ZNORTH2_IN ( : , : ) = PSRC( : , IJE-1 , : )
+ !$acc end kernels
+ ENDIF
+ENDIF
+!$acc wait
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!
+! Send Zxxxx2_IN buffer via MPI(Gpu_direct) or copy to host
+!
+IF (LX) THEN
+ IF (.NOT. GWEST) THEN
+#ifdef MNH_GPUDIRECT
+ !$acc host_data use_device(ZWEST2_IN)
+#else
+ !$acc update host(ZWEST2_IN)
+#endif
+ INB_REQ = INB_REQ + 1
+ CALL MPI_ISEND(ZWEST2_IN,SIZE(ZWEST2_IN) ,MNHREAL_MPI,NP_WEST-1,1000+IS_WEST,NMNH_COMM_WORLD,IREQ(INB_REQ),IERR)
+#ifdef MNH_GPUDIRECT
+ !$acc end host_data
+#endif
+ END IF
+ IF (.NOT.GEAST) THEN
+#ifdef MNH_GPUDIRECT
+ !$acc host_data use_device(ZEAST2_IN)
+#else
+ !$acc update host(ZEAST2_IN)
+#endif
+ INB_REQ = INB_REQ + 1
+ CALL MPI_ISEND(ZEAST2_IN,SIZE(ZEAST2_IN) ,MNHREAL_MPI,NP_EAST-1,1000+IS_EAST,NMNH_COMM_WORLD,IREQ(INB_REQ),IERR)
+#ifdef MNH_GPUDIRECT
+ !$acc end host_data
+#endif
+ ENDIF
+END IF
+
+IF (LY) THEN
+ IF (.NOT.GSOUTH) THEN
+#ifdef MNH_GPUDIRECT
+ !$acc host_data use_device(ZSOUTH2_IN)
+#else
+ !$acc update host(ZSOUTH2_IN)
+#endif
+ INB_REQ = INB_REQ + 1
+ CALL MPI_ISEND(ZSOUTH2_IN,SIZE(ZSOUTH2_IN) ,MNHREAL_MPI,NP_SOUTH-1,1000+IS_SOUTH,NMNH_COMM_WORLD,IREQ(INB_REQ),IERR)
+#ifdef MNH_GPUDIRECT
+ !$acc end host_data
+#endif
+ ENDIF
+ IF (.NOT.GNORTH) THEN
+#ifdef MNH_GPUDIRECT
+ !$acc host_data use_device(ZNORTH2_IN)
+#else
+ !$acc update host(ZNORTH2_IN)
+#endif
+ INB_REQ = INB_REQ + 1
+ CALL MPI_ISEND(ZNORTH2_IN,SIZE(ZNORTH2_IN) ,MNHREAL_MPI,NP_NORTH-1,1000+IS_NORTH,NMNH_COMM_WORLD,IREQ(INB_REQ),IERR)
+#ifdef MNH_GPUDIRECT
+ !$acc end host_data
+#endif
+ ENDIF
+ENDIF
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+IF ( INB_REQ > 0 ) THEN
+ CALL MPI_WAITALL(INB_REQ,IREQ,MPI_STATUSES_IGNORE,IERR)
+END IF
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! Is update halo
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+
+IF (LX) THEN
+ IF (.NOT.GWEST) THEN
+#ifndef MNH_GPUDIRECT
+ !$acc update device(ZWEST2_OUT) async(IS_WEST)
+#endif
+ ZH2_WEST => TP_PSRC_HALO2_ll%HALO2%WEST
+ !$acc kernels async(IS_WEST)
+!!$ PSRC( 1:IIB-1 , IJB:IJE , : ) = ZWEST2_OUT( 1:IIB-1 , IJB:IJE , : )
+ ZH2_WEST( : , : ) = ZWEST2_OUT( : , : )
+ !$acc end kernels
+ ENDIF
+ IF (.NOT.GEAST) THEN
+#ifndef MNH_GPUDIRECT
+ !$acc update device(ZEAST2_OUT) async(IS_EAST)
+#endif
+ ZH2_EAST => TP_PSRC_HALO2_ll%HALO2%EAST
+ !$acc kernels async(IS_EAST)
+!!$ PSRC( IIE+1:IIU , IJB:IJE , : ) = ZEAST2_OUT( IIE+1:IIU , IJB:IJE , : )
+ ZH2_EAST( : , : ) = ZEAST2_OUT( : , : )
+ !$acc end kernels
+ ENDIF
+END IF
+IF (LY) THEN
+ IF (.NOT.GSOUTH) THEN
+#ifndef MNH_GPUDIRECT
+ !$acc update device(ZSOUTH2_OUT) async(IS_SOUTH)
+#endif
+ ZH2_SOUTH => TP_PSRC_HALO2_ll%HALO2%SOUTH
+ !$acc kernels async(IS_SOUTH)
+!!$ PSRC( IIB:IIE , 1:IJB-1 , : ) = ZSOUTH2_OUT( IIB:IIE , 1:IJB-1 , : )
+ ZH2_SOUTH( : , : ) = ZSOUTH2_OUT( : , : )
+ !$acc end kernels
+ ENDIF
+ IF (.NOT.GNORTH) THEN
+#ifndef MNH_GPUDIRECT
+ !$acc update device(ZNORTH2_OUT) async(IS_NORTH)
+#endif
+ ZH2_NORTH => TP_PSRC_HALO2_ll%HALO2%NORTH
+ !$acc kernels async(IS_NORTH)
+!!$ PSRC( IIB:IIE , IJE+1:IJU , : ) = ZNORTH2_OUT ( IIB:IIE , IJE+1:IJU , : )
+ ZH2_NORTH( : , : ) = ZNORTH2_OUT ( : , : )
+ !$acc end kernels
+ ENDIF
+END IF
+!$acc wait
+
+!$acc end data
+
+END SUBROUTINE GET_HALO2_DD
+!
+! ###################################################
+ SUBROUTINE GET_HALO2_D(PSRC, TP_PSRC_HALO2_ll, HNAME)
+! ###################################################
+!
+USE MODE_ll
+USE MODD_ARGSLIST_ll, ONLY : LIST_ll, HALO2LIST_ll
+USE MODI_GET_HALO, ONLY : GET_HALO_D,GET_HALO_DD,GET_HALO2_DD
+!
+IMPLICIT NONE
+!
+REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PSRC ! variable at t
+TYPE(HALO2LIST_ll), POINTER :: TP_PSRC_HALO2_ll ! halo2 for SRC
+character(len=*), optional, intent(in) :: HNAME ! Name of the field to be added
+!
+character(len=:), allocatable :: yname
+INTEGER :: IIU,IJU,IKU ! domain sizes
+TYPE(LIST_ll) , POINTER :: TZ_PSRC_ll ! halo
+INTEGER :: IERROR ! error return code
+!
+IIU = SIZE(PSRC,1)
+IJU = SIZE(PSRC,2)
+IKU = SIZE(PSRC,3)
+
+if ( present ( hname ) ) then
+ yname = hname
+else
+ yname = 'PSRC'
+end if
+
+CALL GET_HALO_DD(PSRC,HNAME=yname)
+
+!!$NULLIFY( TZ_PSRC_ll,TP_PSRC_HALO2_ll)
+CALL INIT_HALO2_ll(TP_PSRC_HALO2_ll,1,IIU,IJU,IKU)
+!
+!!$CALL ADD3DFIELD_ll( TZ_PSRC_ll, PSRC, 'GET_HALO2_D::'//trim( yname ) )
+!!$CALL UPDATE_HALO2_ll(TZ_PSRC_ll,TP_PSRC_HALO2_ll,IERROR)
+CALL GET_HALO2_DD(PSRC,TP_PSRC_HALO2_ll,'GET_HALO2_DD::'//trim( yname ) )
+!
+! clean local halo list
+!
+!!$CALL CLEANLIST_ll(TZ_PSRC_ll)
+!
+END SUBROUTINE GET_HALO2_D
+!
+#endif
+!-----------------------------------------------------------------------
+!
+!
+! ####################################
+ SUBROUTINE DEL_HALO2_ll(TPHALO2LIST)
+! ####################################
+!
+!!**** *DEL_HALO2_ll* delete the second layer of the halo
+!!
+!!
+!! Purpose
+!! -------
+! The purpose of this routine is to deallocate the
+! TPHALO2LIST variable which contains the second layer of the
+! halo for each variable.
+!
+!! Implicit Arguments
+!! ------------------
+! Module MODD_ARGSLIST_ll
+! type HALO2LIST_ll
+!!
+!! Reference
+!! ---------
+!
+!! Author
+!! ------
+! J. Escobar * LA - CNRS *
+!
+! Modification :
+! -------------
+! Juan 11/03/2010 : Memory Leak add DEALLOCATE(TZHALO2LIST%HALO2)
+!
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+ USE MODD_ARGSLIST_ll, ONLY : HALO2LIST_ll
+!
+ IMPLICIT NONE
+!
+!* 0.1 Declarations of dummy arguments :
+!
+ TYPE(HALO2LIST_ll), POINTER :: TPHALO2LIST ! list of HALO2_lls
+!
+!
+!* 0.2 Declarations of local variables :
+!
+ TYPE(HALO2LIST_ll), POINTER :: TZHALO2LIST
+!
+!-------------------------------------------------------------------------------
+!
+!* 1. Deallocate the list of HALO2_lls
+!
+ TZHALO2LIST => TPHALO2LIST
+!
+ DO WHILE(ASSOCIATED(TZHALO2LIST))
+!
+ TPHALO2LIST => TZHALO2LIST%NEXT
+ DEALLOCATE(TZHALO2LIST%HALO2%WEST)
+ DEALLOCATE(TZHALO2LIST%HALO2%EAST)
+ DEALLOCATE(TZHALO2LIST%HALO2%SOUTH)
+ DEALLOCATE(TZHALO2LIST%HALO2%NORTH)
+ DEALLOCATE(TZHALO2LIST%HALO2)
+ DEALLOCATE(TZHALO2LIST)
+ TZHALO2LIST => TPHALO2LIST
+!
+ ENDDO
+!
+!-------------------------------------------------------------------------------
+!
+ END SUBROUTINE DEL_HALO2_ll
diff --git a/src/ZSOLVER/ini_dynamics.f90 b/src/ZSOLVER/ini_dynamics.f90
new file mode 100644
index 0000000000000000000000000000000000000000..40aa0eb77eb2b9006ff0fba76d8f24366581a555
--- /dev/null
+++ b/src/ZSOLVER/ini_dynamics.f90
@@ -0,0 +1,640 @@
+!MNH_LIC Copyright 1994-2018 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.
+!-----------------------------------------------------------------
+! ########################
+ MODULE MODI_INI_DYNAMICS
+! ########################
+INTERFACE
+SUBROUTINE INI_DYNAMICS(PLON,PLAT,PRHODJ,PTHVREF,PMAP,PZZ, &
+ PDXHAT,PDYHAT,PZHAT,HLBCX,HLBCY,PTSTEP,HPRESOPT, &
+ OVE_RELAX,OVE_RELAX_GRD,OHORELAX_UVWTH,OHORELAX_RV, &
+ OHORELAX_RC,OHORELAX_RR,OHORELAX_RI,OHORELAX_RS,OHORELAX_RG, &
+ OHORELAX_RH,OHORELAX_TKE,OHORELAX_SV, &
+ OHORELAX_SVC2R2,OHORELAX_SVC1R3,OHORELAX_SVELEC,OHORELAX_SVLG,&
+ OHORELAX_SVCHEM,OHORELAX_SVAER,OHORELAX_SVDST,OHORELAX_SVSLT, &
+ OHORELAX_SVPP,OHORELAX_SVCS, OHORELAX_SVCHIC,OHORELAX_SVSNW, &
+#ifdef MNH_FOREFIRE
+ OHORELAX_SVFF, &
+#endif
+ PRIMKMAX,KRIMX,KRIMY,PALKTOP,PALKGRD,PALZBOT,PALZBAS, &
+ PT4DIFU,PT4DIFTH,PT4DIFSV, &
+ PCORIOX,PCORIOY,PCORIOZ,PCURVX,PCURVY, &
+ PDXHATM,PDYHATM,PRHOM,PAF,PBFY,PCF, &
+ PTRIGSX,PTRIGSY,KIFAXX,KIFAXY, &
+ PALK,PALKW,KALBOT,PALKBAS,PALKWBAS,KALBAS, &
+ OMASK_RELAX,PKURELAX, PKVRELAX, PKWRELAX, &
+ PDK2U,PDK4U,PDK2TH,PDK4TH,PDK2SV,PDK4SV,OZDIFFU,PZDIFFU_HALO2,&
+ PBFB, &
+ PBF_SXP2_YP1_Z, &
+ PAF_ZS,PBF_ZS,PCF_ZS, &
+ PDXATH_ZS,PDYATH_ZS,PRHO_ZS, &
+ A_K,B_K,C_K,D_K) !JUAN FULL ZSOLVER
+! intent in arguments
+!
+USE MODE_TYPE_ZDIFFU
+IMPLICIT NONE
+!
+REAL, DIMENSION(:,:), INTENT(IN) :: PLON,PLAT !Longitude and latitude
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODJ ! rho J
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PTHVREF ! virtual potential
+ ! temperature of the reference state
+REAL, DIMENSION(:,:), INTENT(IN) :: PMAP ! Map factor
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PZZ ! height
+REAL, DIMENSION(:), INTENT(IN) :: PDXHAT ! Stretching in x direction
+REAL, DIMENSION(:), INTENT(IN) :: PDYHAT ! Stretching in y direction
+REAL, DIMENSION(:), INTENT(IN) :: PZHAT ! Gal-Chen Height
+CHARACTER(LEN=4), DIMENSION(:), INTENT(IN) :: HLBCX ! x-direction LBC type
+CHARACTER(LEN=4), DIMENSION(:), INTENT(IN) :: HLBCY ! y-direction LBC type
+LOGICAL, INTENT(IN) :: OVE_RELAX ! logical
+ ! switch to activate the VErtical RELAXation
+LOGICAL, INTENT(IN) :: OVE_RELAX_GRD ! logical
+ ! switch to activate the VErtical RELAXation (ground layer)
+LOGICAL, INTENT(IN) :: OHORELAX_UVWTH ! switch for the
+ ! horizontal relaxation for U,V,W,TH
+LOGICAL, INTENT(IN) :: OHORELAX_RV ! switch for the
+ ! horizontal relaxation for Rv
+LOGICAL, INTENT(IN) :: OHORELAX_RC ! switch for the
+ ! horizontal relaxation for Rc
+LOGICAL, INTENT(IN) :: OHORELAX_RR ! switch for the
+ ! horizontal relaxation for Rr
+LOGICAL, INTENT(IN) :: OHORELAX_RI ! switch for the
+ ! horizontal relaxation for Ri
+LOGICAL, INTENT(IN) :: OHORELAX_RS ! switch for the
+ ! horizontal relaxation for Rs
+LOGICAL, INTENT(IN) :: OHORELAX_RG ! switch for the
+ ! horizontal relaxation for Rg
+LOGICAL, INTENT(IN) :: OHORELAX_RH ! switch for the
+ ! horizontal relaxation for Rh
+LOGICAL, INTENT(IN) :: OHORELAX_TKE ! switch for the
+ ! horizontal relaxation for tke
+LOGICAL,DIMENSION(:),INTENT(IN):: OHORELAX_SV ! switch for the
+ ! horizontal relaxation for sv variables
+LOGICAL, INTENT(IN):: OHORELAX_SVC2R2 ! switch for the
+ ! horizontal relaxation for c2r2 variables
+LOGICAL, INTENT(IN):: OHORELAX_SVC1R3 ! switch for the
+ ! horizontal relaxation for c1r3 variables
+LOGICAL, INTENT(IN):: OHORELAX_SVELEC ! switch for the
+ ! horizontal relaxation for elec variables
+LOGICAL, INTENT(IN):: OHORELAX_SVLG ! switch for the
+ ! horizontal relaxation for lg variables
+LOGICAL, INTENT(IN):: OHORELAX_SVCHEM ! switch for the
+ ! horizontal relaxation for chem variables
+LOGICAL, INTENT(IN):: OHORELAX_SVCHIC ! switch for the
+ ! horizontal relaxation for ice chem variables
+LOGICAL, INTENT(IN):: OHORELAX_SVAER ! switch for the
+ ! horizontal relaxation for aer variables
+LOGICAL, INTENT(IN):: OHORELAX_SVDST ! switch for the
+ ! horizontal relaxation for dst variables
+LOGICAL, INTENT(IN):: OHORELAX_SVSLT ! switch for the
+ ! horizontal relaxation for slt variables
+LOGICAL, INTENT(IN):: OHORELAX_SVPP ! switch for the
+ ! horizontal relaxation for passive pollutants
+LOGICAL, INTENT(IN):: OHORELAX_SVSNW ! switch for the
+ ! horizontal relaxation for blowing snow variables
+#ifdef MNH_FOREFIRE
+LOGICAL, INTENT(IN):: OHORELAX_SVFF ! switch for the
+ ! horizontal relaxation for ForeFire variables
+#endif
+LOGICAL, INTENT(IN):: OHORELAX_SVCS ! switch for the
+ ! horizontal relaxation for conditional sampling
+REAL, INTENT(IN) :: PRIMKMAX !Max. value of the horiz.
+ ! relaxation coefficients
+INTEGER, INTENT(IN) :: KRIMX,KRIMY ! Number of points in
+ ! the rim zone in the x and y directions
+REAL, INTENT(IN) :: PALKTOP ! Damping coef. at the top of the absorbing
+ ! layer
+REAL, INTENT(IN) :: PALKGRD ! Damping coef. at the top of the absorbing
+ ! layer
+REAL, INTENT(IN) :: PALZBOT ! Height of the absorbing layer base
+REAL, INTENT(IN) :: PALZBAS ! Height of the absorbing layer base
+REAL, INTENT(IN) :: PT4DIFU ! Damping time scale for 2*dx wavelength
+ ! specified for the 4nd order num. diffusion
+ ! for momentum
+REAL, INTENT(IN) :: PT4DIFTH ! for meteorological scalar variables
+REAL, INTENT(IN) :: PT4DIFSV ! for tracer scalar variables
+
+REAL, INTENT(IN) :: PTSTEP ! Time step
+CHARACTER (LEN=5), INTENT(IN) :: HPRESOPT ! choice of the pressure solver
+!
+! intent out arguments
+!
+REAL, INTENT(OUT) :: PDXHATM ! mean grid increment in the x
+ ! direction
+REAL, INTENT(OUT) :: PDYHATM ! mean grid increment in the y
+ ! direction
+!
+REAL, DIMENSION (:), INTENT(OUT) :: PRHOM ! mean of XRHODJ on the plane x y
+ ! localized at a mass level
+!
+REAL, DIMENSION(:,:), INTENT(OUT) :: PCORIOX,PCORIOY ! Hor. Coriolis parameters
+REAL, DIMENSION(:,:), INTENT(OUT) :: PCORIOZ ! Vert. Coriolis parameter
+REAL, DIMENSION(:,:), INTENT(OUT) :: PCURVX,PCURVY ! Curvature coefficients
+!
+REAL, DIMENSION(:), INTENT(OUT) :: PAF ! vectors giving the non-vanishing
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PBFY ! elements of the tri-diag matrix
+ ! on an y-slice of global physical domain
+REAL, DIMENSION(:), INTENT(OUT) :: PCF ! in the pressure equation
+REAL, DIMENSION(:), INTENT(OUT) :: PTRIGSX ! Arrays for sinus or cosinus
+REAL, DIMENSION(:), INTENT(OUT) :: PTRIGSY ! values for the FFT in x and
+ ! y directions
+INTEGER, DIMENSION(:), INTENT(OUT) :: KIFAXX ! Decomposition in prime numbers
+INTEGER, DIMENSION(:), INTENT(OUT) :: KIFAXY ! for the FFT in x and y
+ ! direction
+INTEGER , INTENT(OUT) :: KALBOT ! Vertical index corresponding
+ ! to the absorbing layer base
+!
+REAL, DIMENSION(:), INTENT(OUT) :: PALK ! Function of the absorbing
+ ! layer damping coefficient
+ ! defined for u,v,and theta
+REAL, DIMENSION(:), INTENT(OUT) :: PALKW ! Idem but defined for w
+INTEGER , INTENT(OUT) :: KALBAS ! Vertical index corresponding
+ ! to the absorbing layer base
+!
+REAL, DIMENSION(:), INTENT(OUT) :: PALKBAS ! Function of the absorbing
+ ! layer damping coefficient
+ ! defined for u,v,and theta
+REAL, DIMENSION(:), INTENT(OUT) :: PALKWBAS ! Idem but defined for w
+LOGICAL, DIMENSION(:,:), INTENT(OUT) :: OMASK_RELAX ! True where the
+ ! lateral relax. has to be performed
+REAL, DIMENSION(:,:), INTENT(OUT) :: PKURELAX ! Horizontal relaxation
+REAL, DIMENSION(:,:), INTENT(OUT) :: PKVRELAX ! coefficients for the
+REAL, DIMENSION(:,:), INTENT(OUT) :: PKWRELAX ! u, v and mass locations
+REAL, INTENT(OUT) :: PDK2U ! 2nd order num. diffusion coef. /dx2
+REAL, INTENT(OUT) :: PDK4U ! 4nd order num. diffusion coef. /dx4
+ ! for momentum
+REAL, INTENT(OUT) :: PDK2TH! for meteorological scalar variables
+REAL, INTENT(OUT) :: PDK4TH!
+REAL, INTENT(OUT) :: PDK2SV! for tracer scalar variables
+REAL, INTENT(OUT) :: PDK4SV!
+!
+LOGICAL, INTENT(IN) :: OZDIFFU
+TYPE(TYPE_ZDIFFU_HALO2) :: PZDIFFU_HALO2
+!
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PBFB ! elements of the tri-diag matrix
+ ! on an b-slice of global physical domain
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PBF_SXP2_YP1_Z ! elements of the tri-diag. SXP2_YP1_Z-slide
+ ! matrix in the pressure eq.
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PAF_ZS,PBF_ZS,PCF_ZS
+REAL, DIMENSION(:,:) , INTENT(OUT) :: PDXATH_ZS,PDYATH_ZS
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PRHO_ZS
+REAL, DIMENSION(:) , INTENT(OUT) :: A_K,B_K,C_K,D_K
+
+END SUBROUTINE INI_DYNAMICS
+!
+END INTERFACE
+!
+END MODULE MODI_INI_DYNAMICS
+! ######################################################################
+SUBROUTINE INI_DYNAMICS(PLON,PLAT,PRHODJ,PTHVREF,PMAP,PZZ, &
+ PDXHAT,PDYHAT,PZHAT,HLBCX,HLBCY,PTSTEP,HPRESOPT, &
+ OVE_RELAX,OVE_RELAX_GRD,OHORELAX_UVWTH,OHORELAX_RV, &
+ OHORELAX_RC,OHORELAX_RR,OHORELAX_RI,OHORELAX_RS,OHORELAX_RG, &
+ OHORELAX_RH,OHORELAX_TKE,OHORELAX_SV, &
+ OHORELAX_SVC2R2,OHORELAX_SVC1R3,OHORELAX_SVELEC,OHORELAX_SVLG,&
+ OHORELAX_SVCHEM,OHORELAX_SVAER,OHORELAX_SVDST,OHORELAX_SVSLT, &
+ OHORELAX_SVPP,OHORELAX_SVCS, OHORELAX_SVCHIC,OHORELAX_SVSNW, &
+#ifdef MNH_FOREFIRE
+ OHORELAX_SVFF, &
+#endif
+ PRIMKMAX,KRIMX,KRIMY,PALKTOP,PALKGRD,PALZBOT,PALZBAS, &
+ PT4DIFU,PT4DIFTH,PT4DIFSV, &
+ PCORIOX,PCORIOY,PCORIOZ,PCURVX,PCURVY, &
+ PDXHATM,PDYHATM,PRHOM,PAF,PBFY,PCF, &
+ PTRIGSX,PTRIGSY,KIFAXX,KIFAXY, &
+ PALK,PALKW,KALBOT,PALKBAS,PALKWBAS,KALBAS, &
+ OMASK_RELAX,PKURELAX, PKVRELAX, PKWRELAX, &
+ PDK2U,PDK4U,PDK2TH,PDK4TH,PDK2SV,PDK4SV,OZDIFFU,PZDIFFU_HALO2,&
+ PBFB, &
+ PBF_SXP2_YP1_Z, &
+ PAF_ZS,PBF_ZS,PCF_ZS, &
+ PDXATH_ZS,PDYATH_ZS,PRHO_ZS, &
+ A_K,B_K,C_K,D_K) !JUAN FULL ZSOLVER
+! ######################################################################
+!
+!!**** *INI_DYNAMICS* - routine to initialize the parameters for the dynamics
+!!
+!! PURPOSE
+!! -------
+! The purpose of this routine is to set or compute the parameters used
+! by the MESONH dynamics :
+! * Coriolis parameters
+! * Curvature coefficients
+! * Pressure solver coefficients
+! * Absorbing layer coefficients
+! * Numerical difussion coefficients
+!
+!!** METHOD
+!! ------
+!! - Coriolis parameters and curvature terms :
+!! Horizontal Coriolis parameters are not initialized if thinshell
+!! approximation is made (LTHINSHELL=.TRUE.).
+!! Curvature coefficients are not initialized if Cartesian geometry
+!! (LCARTESIAN=.TRUE.)
+!! - Coefficients and variables for pressure solver :
+!! This is done by TRID
+!! - Coefficients and variables for the absorbing layer
+!! ( upper and lateral) : This is done by RELAXDEF
+!! - Coefficients for the numerical diffusion
+!!
+!! EXTERNAL
+!! --------
+!! TRID : to initialize pressure solver
+!! RELAXDEF: to compute the relaxation coefficients
+!! GET_DIM_EXT_ll : get extended sub-domain sizes
+!!
+!! Module MODI_TRID : interface for routine TRID
+!! Module MODI_RELAXDEF : interface for routine RELAXDEF
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module MODD_CONF : contains declaration of configuration variables
+!!
+!! LTHINSHELL : Logical for THINSHELL approximation
+!! .TRUE. = thinshell approximation
+!! LCARTESIAN : Logical for cartesian geometry :
+!! .TRUE. = cartesian geometry
+!! L1D : Logical for 1D configuration :
+!! .TRUE. = 1D model
+!!
+!! Module MODD_CST : contains physical constants
+!!
+!! XPI : Pi
+!! XOMEGA : Earth rotation
+!!
+!! Module MODD_GRID : contains grid variables
+!!
+!! XLON0 : Reference longitude for the conformal projection
+!! XLAT0 : Reference latitude for the conformal projection
+!! XBETA : Rotation angle for the conformal projection
+!! XRPK : Projection parameter for the conformal projection
+!!
+!! REFERENCE
+!! ---------
+!! Book2 of documentation (routine INI_DYNAMICS)
+!!
+!!
+!! AUTHOR
+!! ------
+!! V. Ducrocq * Meteo France *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 01/07/94
+!! Modification 18/10/94 (J. Stein) to add the abs. layer
+!! Modification 16/11/94 (Lafore+Pinty) to add the num. diffusion
+!! Modification 06/12/94 (J.Stein) add the switch LABSLAYER
+!! Modification 12/12/94 (J.Stein) add the lateral relaxation
+!! Modification 16/01/95 (J.Stein) conditional CALL to trid for 1D case
+!! Modification 13/08/98 (N.Asencio) add parallel code
+!! Modification 20/05/06 Remove KEPS
+!! Modification 07/2013 (Bosseur & Filippi) Adds Forefire
+!! Philippe Wautelet: 05/2016-04/2018: new data structures and calls for I/O
+!! Vionnet 07/2017 : blow snow
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+USE MODD_CONF
+USE MODD_CST
+USE MODD_GRID
+USE MODD_LUNIT_n, ONLY: TLUOUT
+!
+USE MODI_RELAXDEF
+! USE MODI_TRID
+USE MODI_TRIDZ
+USE MODI_ZDIFFUSETUP
+!
+USE MODE_ll
+USE MODE_TYPE_ZDIFFU
+#ifdef MNH_BITREP
+USE MODI_BITREP
+#define SIN BR_SIN
+#define COS BR_COS
+#endif
+!
+USE MODE_MPPDB
+!
+IMPLICIT NONE
+!
+!* 0.1 declarations of argument
+!
+! intent in arguments
+!
+REAL, DIMENSION(:,:), INTENT(IN) :: PLON,PLAT !Longitude and latitude
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODJ ! rho J
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PTHVREF ! virtual potential
+ ! temperature of the reference state
+REAL, DIMENSION(:,:), INTENT(IN) :: PMAP ! Map factor
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PZZ ! height
+REAL, DIMENSION(:), INTENT(IN) :: PDXHAT ! Stretching in x direction
+REAL, DIMENSION(:), INTENT(IN) :: PDYHAT ! Stretching in y direction
+REAL, DIMENSION(:), INTENT(IN) :: PZHAT ! Gal-Chen Height
+CHARACTER(LEN=4), DIMENSION(:), INTENT(IN) :: HLBCX ! x-direction LBC type
+CHARACTER(LEN=4), DIMENSION(:), INTENT(IN) :: HLBCY ! y-direction LBC type
+LOGICAL, INTENT(IN) :: OVE_RELAX ! logical
+ ! switch to activate the VErtical RELAXation
+LOGICAL, INTENT(IN) :: OVE_RELAX_GRD ! logical
+ ! switch to activate the VErtical RELAXation (ground layer)
+LOGICAL, INTENT(IN) :: OHORELAX_UVWTH ! switch for the
+ ! horizontal relaxation for U,V,W,TH
+LOGICAL, INTENT(IN) :: OHORELAX_RV ! switch for the
+ ! horizontal relaxation for Rv
+LOGICAL, INTENT(IN) :: OHORELAX_RC ! switch for the
+ ! horizontal relaxation for Rc
+LOGICAL, INTENT(IN) :: OHORELAX_RR ! switch for the
+ ! horizontal relaxation for Rr
+LOGICAL, INTENT(IN) :: OHORELAX_RI ! switch for the
+ ! horizontal relaxation for Ri
+LOGICAL, INTENT(IN) :: OHORELAX_RS ! switch for the
+ ! horizontal relaxation for Rs
+LOGICAL, INTENT(IN) :: OHORELAX_RG ! switch for the
+ ! horizontal relaxation for Rg
+LOGICAL, INTENT(IN) :: OHORELAX_RH ! switch for the
+ ! horizontal relaxation for Rh
+LOGICAL, INTENT(IN) :: OHORELAX_TKE ! switch for the
+ ! horizontal relaxation for tke
+LOGICAL,DIMENSION(:),INTENT(IN):: OHORELAX_SV ! switch for the
+ ! horizontal relaxation for sv variables
+LOGICAL, INTENT(IN):: OHORELAX_SVC2R2 ! switch for the
+ ! horizontal relaxation for c2r2 variables
+LOGICAL, INTENT(IN):: OHORELAX_SVC1R3 ! switch for the
+ ! horizontal relaxation for c1r3 variables
+LOGICAL, INTENT(IN):: OHORELAX_SVELEC ! switch for the
+ ! horizontal relaxation for elec variables
+LOGICAL, INTENT(IN):: OHORELAX_SVLG ! switch for the
+ ! horizontal relaxation for lg variables
+LOGICAL, INTENT(IN):: OHORELAX_SVCHEM ! switch for the
+ ! horizontal relaxation for chem variables
+LOGICAL, INTENT(IN):: OHORELAX_SVCHIC ! switch for the
+ ! horizontal relaxation for ice chem variables
+LOGICAL, INTENT(IN):: OHORELAX_SVAER ! switch for the
+ ! horizontal relaxation for aer variables
+LOGICAL, INTENT(IN):: OHORELAX_SVDST ! switch for the
+ ! horizontal relaxation for dst variables
+LOGICAL, INTENT(IN):: OHORELAX_SVSLT ! switch for the
+ ! horizontal relaxation for slt variables
+LOGICAL, INTENT(IN):: OHORELAX_SVPP ! switch for the
+ ! horizontal relaxation for passive pollutants
+LOGICAL, INTENT(IN):: OHORELAX_SVSNW ! switch for the
+ ! horizontal relaxation for blowing snow variables
+#ifdef MNH_FOREFIRE
+LOGICAL, INTENT(IN):: OHORELAX_SVFF ! switch for the
+ ! horizontal relaxation for ForeFire variables
+#endif
+LOGICAL, INTENT(IN):: OHORELAX_SVCS ! switch for the
+ ! horizontal relaxation for conditional sampling
+REAL, INTENT(IN) :: PRIMKMAX !Max. value of the horiz.
+ ! relaxation coefficients
+INTEGER, INTENT(IN) :: KRIMX,KRIMY ! Number of points in
+ ! the rim zone in the x and y directions
+REAL, INTENT(IN) :: PALKTOP ! Damping coef. at the top of the absorbing
+ ! layer
+REAL, INTENT(IN) :: PALZBOT ! Height of the absorbing layer base
+REAL, INTENT(IN) :: PALKGRD ! Damping coef. at the top of the absorbing
+ ! layer
+REAL, INTENT(IN) :: PALZBAS ! Height of the absorbing layer base
+REAL, INTENT(IN) :: PT4DIFU ! Damping time scale for 2*dx wavelength
+ ! specified for the 4nd order num. diffusion
+ ! for momentum
+REAL, INTENT(IN) :: PT4DIFTH ! for meteorological scalar variables
+REAL, INTENT(IN) :: PT4DIFSV ! for tracer scalar variables
+
+REAL, INTENT(IN) :: PTSTEP ! Time step
+CHARACTER (LEN=5), INTENT(IN) :: HPRESOPT ! choice of the pressure solver
+!
+! intent out arguments
+!
+REAL, INTENT(OUT) :: PDXHATM ! mean grid increment in the x
+ ! direction
+REAL, INTENT(OUT) :: PDYHATM ! mean grid increment in the y
+ ! direction
+!
+REAL, DIMENSION (:), INTENT(OUT) :: PRHOM ! mean of XRHODJ on the plane x y
+ ! localized at a mass level
+!
+REAL, DIMENSION(:,:), INTENT(OUT) :: PCORIOX,PCORIOY ! Hor. Coriolis parameters
+REAL, DIMENSION(:,:), INTENT(OUT) :: PCORIOZ ! Vert. Coriolis parameter
+REAL, DIMENSION(:,:), INTENT(OUT) :: PCURVX,PCURVY ! Curvature coefficients
+!
+REAL, DIMENSION(:), INTENT(OUT) :: PAF ! vectors giving the non-vanishing
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PBFY ! elements of the tri-diag matrix
+ ! on an y-slice of global physical domain
+REAL, DIMENSION(:), INTENT(OUT) :: PCF ! in the pressure equation
+REAL, DIMENSION(:), INTENT(OUT) :: PTRIGSX ! Arrays for sinus or cosinus
+REAL, DIMENSION(:), INTENT(OUT) :: PTRIGSY ! values for the FFT in x and
+ ! y directions
+INTEGER, DIMENSION(:), INTENT(OUT) :: KIFAXX ! Decomposition in prime numbers
+INTEGER, DIMENSION(:), INTENT(OUT) :: KIFAXY ! for the FFT in x and y
+ ! direction
+INTEGER , INTENT(OUT) :: KALBOT ! Vertical index corresponding
+ ! to the absorbing layer base
+!
+REAL, DIMENSION(:), INTENT(OUT) :: PALK ! Function of the absorbing
+ ! layer damping coefficient
+ ! defined for u,v,and theta
+REAL, DIMENSION(:), INTENT(OUT) :: PALKW ! Idem but defined for w
+INTEGER , INTENT(OUT) :: KALBAS ! Vertical index corresponding
+ ! to the absorbing layer base
+!
+REAL, DIMENSION(:), INTENT(OUT) :: PALKBAS ! Function of the absorbing
+ ! layer damping coefficient
+ ! defined for u,v,and theta
+REAL, DIMENSION(:), INTENT(OUT) :: PALKWBAS ! Idem but defined for w
+LOGICAL, DIMENSION(:,:), INTENT(OUT) :: OMASK_RELAX ! True where the
+ ! lateral relax. has to be performed
+REAL, DIMENSION(:,:), INTENT(OUT) :: PKURELAX ! Horizontal relaxation
+REAL, DIMENSION(:,:), INTENT(OUT) :: PKVRELAX ! coefficients for the
+REAL, DIMENSION(:,:), INTENT(OUT) :: PKWRELAX ! u, v and mass locations
+REAL, INTENT(OUT) :: PDK2U ! 2nd order num. diffusion coef. /dx2
+REAL, INTENT(OUT) :: PDK4U ! 4nd order num. diffusion coef. /dx4
+ ! for momentum
+REAL, INTENT(OUT) :: PDK2TH! for meteorological scalar variables
+REAL, INTENT(OUT) :: PDK4TH!
+REAL, INTENT(OUT) :: PDK2SV! for tracer scalar variables
+REAL, INTENT(OUT) :: PDK4SV!
+LOGICAL, INTENT(IN) :: OZDIFFU
+TYPE(TYPE_ZDIFFU_HALO2) :: PZDIFFU_HALO2
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PBFB ! elements of the tri-diag matrix
+ ! on an b-slice of global physical domain
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PBF_SXP2_YP1_Z ! elements of the tri-diag. SXP2_YP1_Z-slide
+ ! matrix in the pressure eq.
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PAF_ZS,PBF_ZS,PCF_ZS
+REAL, DIMENSION(:,:) , INTENT(OUT) :: PDXATH_ZS,PDYATH_ZS
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PRHO_ZS
+REAL, DIMENSION(:) , INTENT(OUT) :: A_K,B_K,C_K,D_K
+!
+!* 0.2 declarations of local variables
+!
+REAL, DIMENSION(SIZE(PRHODJ,1),SIZE(PRHODJ,2)) :: ZGAMMA ! Gamma =K(lambda-lambda0) - beta
+REAL :: ZMBETA ! -beta
+REAL :: ZCDR ! to convert degrees in
+ ! radians
+INTEGER :: ILUOUT ! Logical unit number for output_listing file
+INTEGER :: IIU,IJU ! Upper bounds in x,y directions
+LOGICAL :: GHORELAX
+LOGICAL, DIMENSION(7) :: GHORELAXR ! local array of logical
+#ifdef MNH_FOREFIRE
+LOGICAL, DIMENSION(13):: GHORELAXSV! local array of logical
+#else
+LOGICAL, DIMENSION(12):: GHORELAXSV! local array of logical
+#endif
+!
+!-------------------------------------------------------------------------------
+!
+!* 1. COMPUTES CORIOLIS PARAMETERS AND CURVATURE COEFFICIENTS
+! -------------------------------------------------------
+!
+ZCDR = XPI/180.
+IF (.NOT.LCARTESIAN) THEN
+ ZGAMMA(:,:) = XRPK * ((PLON(:,:) - XLON0)*ZCDR) - (XBETA*ZCDR)
+ IF (.NOT.LTHINSHELL) THEN
+ PCORIOX(:,:) = - 2. * XOMEGA * COS(PLAT(:,:)*ZCDR) * SIN(ZGAMMA(:,:))
+ PCORIOY(:,:) = 2. * XOMEGA * COS(PLAT(:,:)*ZCDR) * COS(ZGAMMA(:,:))
+ END IF
+ PCORIOZ(:,:) = 2. * XOMEGA * SIN(PLAT(:,:)*ZCDR)
+ PCURVX (:,:) = COS(ZGAMMA(:,:)) * (SIN(PLAT(:,:)*ZCDR) -XRPK) &
+ / COS(PLAT(:,:)*ZCDR)
+ PCURVY (:,:) = SIN(ZGAMMA(:,:)) * (SIN(PLAT(:,:)*ZCDR) -XRPK) &
+ / COS(PLAT(:,:)*ZCDR)
+ !
+ CALL MPPDB_CHECK2D(PCORIOX,"ini_dynamics:PCORIOX",PRECISION)
+ CALL MPPDB_CHECK2D(PCORIOY,"ini_dynamics:PCORIOY",PRECISION)
+ CALL MPPDB_CHECK2D(PCORIOZ,"ini_dynamics:PCORIOZ",PRECISION)
+ !
+ELSE
+ ZMBETA = - (XBETA*ZCDR)
+ PCORIOX(:,:) = - 2. * XOMEGA * COS(XLAT0*ZCDR) * SIN(ZMBETA)
+ PCORIOY(:,:) = 2. * XOMEGA * COS(XLAT0*ZCDR) * COS(ZMBETA)
+ PCORIOZ(:,:) = 2. * XOMEGA * SIN(XLAT0*ZCDR)
+END IF
+!
+!-------------------------------------------------------------------------------
+!
+!* 2. INITIALIZATION OF PRESSURE SOLVER
+! ---------------------------------
+!
+IF (.NOT.L1D) THEN
+! CALL TRID(HLBCX,HLBCY, &
+! PMAP,PDXHAT,PDYHAT,PDXHATM,PDYHATM,PRHOM,PAF, &
+! PCF,PTRIGSX,PTRIGSY,KIFAXX,KIFAXY, &
+! PRHODJ,PTHVREF,PZZ,PBFY)
+ CALL TRIDZ(HLBCX,HLBCY, &
+ PMAP,PDXHAT,PDYHAT,HPRESOPT, &
+ PDXHATM,PDYHATM,PRHOM,PAF, &
+ PCF,PTRIGSX,PTRIGSY,KIFAXX,KIFAXY, &
+ PRHODJ,PTHVREF,PZZ,PBFY,PBFB, &
+ PBF_SXP2_YP1_Z, &
+ PAF_ZS,PBF_ZS,PCF_ZS, &
+ PDXATH_ZS,PDYATH_ZS,PRHO_ZS, &
+ A_K,B_K,C_K,D_K) !JUAN FULL ZSOLVER
+END IF
+!
+!
+!
+!-------------------------------------------------------------------------------
+!
+!* 3. COMPUTE THE ABSORBING LAYER COEFFICIENTS
+! ----------------------------------------
+!
+GHORELAXR(1) = OHORELAX_RV
+GHORELAXR(2) = OHORELAX_RC
+GHORELAXR(3) = OHORELAX_RR
+GHORELAXR(4) = OHORELAX_RI
+GHORELAXR(5) = OHORELAX_RS
+GHORELAXR(6) = OHORELAX_RG
+GHORELAXR(7) = OHORELAX_RH
+!
+GHORELAXSV(1) = OHORELAX_SVC2R2
+GHORELAXSV(2) = OHORELAX_SVC1R3
+GHORELAXSV(3) = OHORELAX_SVELEC
+GHORELAXSV(4) = OHORELAX_SVLG
+GHORELAXSV(5) = OHORELAX_SVCHEM
+GHORELAXSV(6) = OHORELAX_SVAER
+GHORELAXSV(7) = OHORELAX_SVDST
+GHORELAXSV(8) = OHORELAX_SVSLT
+GHORELAXSV(9) = OHORELAX_SVPP
+GHORELAXSV(10)= OHORELAX_SVCS
+GHORELAXSV(11) = OHORELAX_SVCHIC
+GHORELAXSV(12) = OHORELAX_SVSNW
+#ifdef MNH_FOREFIRE
+GHORELAXSV(13) = OHORELAX_SVFF
+#endif
+!
+GHORELAX=ANY(GHORELAXR) .OR. ANY(GHORELAXSV) .OR. ANY(OHORELAX_SV) &
+ .OR. OHORELAX_UVWTH .OR. OHORELAX_TKE
+!
+IF (GHORELAX .OR. OVE_RELAX.OR.OVE_RELAX_GRD) THEN
+ CALL RELAXDEF( OVE_RELAX,OVE_RELAX_GRD,OHORELAX_UVWTH,OHORELAX_RV, &
+ OHORELAX_RC,OHORELAX_RR,OHORELAX_RI,OHORELAX_RS,OHORELAX_RG, &
+ OHORELAX_RH,OHORELAX_TKE,OHORELAX_SV, &
+ OHORELAX_SVC2R2,OHORELAX_SVC1R3,OHORELAX_SVELEC,OHORELAX_SVLG, &
+ OHORELAX_SVCHEM, OHORELAX_SVAER, OHORELAX_SVDST, OHORELAX_SVSLT, &
+ OHORELAX_SVPP, OHORELAX_SVCS, OHORELAX_SVCHIC,OHORELAX_SVSNW, &
+ PALKTOP,PALKGRD, PALZBOT,PALZBAS, &
+ PZZ, PZHAT, PTSTEP, &
+ PRIMKMAX,KRIMX,KRIMY, &
+ PALK, PALKW, KALBOT, &
+ PALKBAS, PALKWBAS, KALBAS, &
+ OMASK_RELAX,PKURELAX, PKVRELAX, PKWRELAX )
+END IF
+!
+!
+!
+!-------------------------------------------------------------------------------
+!
+!* 4. COMPUTE THE NUMERICAL DIFFUSION COEFFICIENTS
+! --------------------------------------------
+!
+PDK4U = 1.0/(16.0*PT4DIFU) ! The damping rate for the 2*dx wavelength is the same
+PDK2U = 2.0*PDK4U ! for the 2nd and the 4th order diffusion schemes
+ ! for momentum
+PDK4TH= 1.0/(16.0*PT4DIFTH) ! for meteorological scalar variables
+PDK2TH= 2.0*PDK4TH
+PDK4SV= 1.0/(16.0*PT4DIFSV) ! for tracer scalar variables
+PDK2SV= 2.0*PDK4SV
+!
+! Call ZDIFFUSETUP if OZDIFFU is true (parameters for truly horizontal diffusion)
+!
+IF (OZDIFFU) THEN
+ CALL ZDIFFUSETUP (PZZ,&
+ PZDIFFU_HALO2)
+ENDIF
+!
+!-------------------------------------------------------------------------------
+!
+!* 5. PRINT ON OUTPUT_LISTING
+! -----------------------
+!
+IF (NVERB >= 10) THEN
+ CALL GET_DIM_EXT_ll ('B',IIU,IJU)
+ ILUOUT = TLUOUT%NLU
+!
+ WRITE(ILUOUT,*) 'INI_DYNAMICS : Some PCORIOZ values'
+ WRITE(ILUOUT,*) '(1,1) (IIU/2,IJU/2) (IIU,IJU) '
+ WRITE(ILUOUT,*) PCORIOZ(1,1),PCORIOZ(IIU/2,IJU/2),PCORIOZ(IIU,IJU)
+!
+ IF (.NOT.LTHINSHELL) THEN
+ WRITE(ILUOUT,*) 'INI_DYNAMICS : Some PCORIOX values'
+ WRITE(ILUOUT,*) '(1,1) (IIU/2,IJU/2) (IIU,IJU) '
+ WRITE(ILUOUT,*) PCORIOX(1,1),PCORIOX(IIU/2,IJU/2),PCORIOX(IIU,IJU)
+!
+ WRITE(ILUOUT,*) 'INI_DYNAMICS : Some PCORIOY values'
+ WRITE(ILUOUT,*) '(1,1) (IIU/2,IJU/2) (IIU,IJU) '
+ WRITE(ILUOUT,*) PCORIOY(1,1),PCORIOY(IIU/2,IJU/2),PCORIOY(IIU,IJU)
+ END IF
+!
+ IF ( .NOT. LCARTESIAN ) THEN
+ WRITE(ILUOUT,*) 'INI_DYNAMICS : Some PCURVX values'
+ WRITE(ILUOUT,*) '(1,1) (IIU/2,IJU/2) (IIU,IJU) '
+ WRITE(ILUOUT,*) PCURVX(1,1),PCURVX(IIU/2,IJU/2),PCURVX(IIU,IJU)
+!
+ WRITE(ILUOUT,*) 'INI_DYNAMICS : Some PCURVY values'
+ WRITE(ILUOUT,*) '(1,1) (IIU/2,IJU/2) (IIU,IJU) '
+ WRITE(ILUOUT,*) PCURVY(1,1),PCURVY(IIU/2,IJU/2),PCURVY(IIU,IJU)
+ END IF
+END IF
+!-------------------------------------------------------------------------------
+!
+END SUBROUTINE INI_DYNAMICS
diff --git a/src/ZSOLVER/ini_modeln.f90 b/src/ZSOLVER/ini_modeln.f90
new file mode 100644
index 0000000000000000000000000000000000000000..8203f0ada7d3d47b9a065697b8587553b551aa77
--- /dev/null
+++ b/src/ZSOLVER/ini_modeln.f90
@@ -0,0 +1,2525 @@
+!MNH_LIC Copyright 1994-2019 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.
+!-----------------------------------------------------------------
+! #######################
+ MODULE MODI_INI_MODEL_n
+! #######################
+!
+INTERFACE
+!
+ SUBROUTINE INI_MODEL_n(KMI,TPINIFILE)
+!
+USE MODD_IO, ONLY: TFILEDATA
+!
+INTEGER, INTENT(IN) :: KMI ! Model Index
+TYPE(TFILEDATA), INTENT(IN) :: TPINIFILE ! Initial file
+!
+END SUBROUTINE INI_MODEL_n
+!
+END INTERFACE
+!
+END MODULE MODI_INI_MODEL_n
+! ############################################
+ SUBROUTINE INI_MODEL_n(KMI,TPINIFILE)
+! ############################################
+!
+!!**** *INI_MODEL_n* - routine to initialize the nested model _n
+!!
+!! PURPOSE
+!! -------
+! The purpose of this routine is to initialize the variables
+! of the nested model _n.
+!
+!!** METHOD
+!! ------
+!! The initialization of the model _n is performed as follows :
+!! - Memory for arrays are then allocated :
+!! * If turbulence kinetic energy variable is not needed
+!! (CTURB='NONE'), XTKET, XTKEM and XTKES are zero-size arrays.
+!! * If dissipation of TKE variable is not needed
+!! (CTURBLEN /='KEPS'), XEPST, XEPSM and XREPSS are zero-size arrays.
+!! * Memory for mixing ratio arrays is allocated according to the
+!! value of logicals LUSERn (the number NRR of moist variables is deduced).
+!! * The latitude (XLAT), longitude (XLON) and map factor (XMAP)
+!! arrays are zero-size arrays if Cartesian geometry (LCARTESIAN=.TRUE.)
+!! * Memory for reference state without orography ( XRHODREFZ and
+!! XTHVREFZ) is only allocated in INI_MODEL1
+!! * The horizontal Coriolis parameters (XCORIOX and XCORIOY) arrays
+!! are zero-size arrays if thinshell approximation (LTHINSHELL=.TRUE.)
+!! * The Curvature coefficients (XCURVX and XCURVY) arrays
+!! are zero-size arrays if Cartesian geometry (LCARTESIAN=.TRUE.)
+!! * Memory for the Jacobian (ZJ) local array is allocated
+!! (This variable is computed in SET_GRID and used in SET_REF).
+!! - The spatial and temporal grid variables are initialized by SET_GRID.
+!! - The metric coefficients are computed by METRICS (they are using in
+!! the SET-REF call).
+!! - The prognostic variables and are read in initial
+!! LFIFM file (in READ_FIELD)
+!! - The reference state variables are initialized by SET_REF.
+!! - The temporal indexes of the outputs are computed by SET_OUTPUT_TIMES
+!! - The large scale sources are computed in case of coupling case by
+!! INI_CPL.
+!! - The initialization of the parameters needed for the dynamics
+!! of the model n is realized in INI_DYNAMICS.
+!! - Then the initial file (DESFM+LFIFM files) is closed by IO_File_close.
+!! - The initialization of the parameters needed for the ECMWF radiation
+!! code is realized in INI_RADIATIONS.
+!! - The contents of the scalar variables are overwritten by
+!! the chemistry initialization subroutine CH_INIT_FIELDn when
+!! the flags LUSECHEM and LCH_INIT_FIELD are set to TRUE.
+!! This allows easy initialization of the chemical fields at a
+!! restart of the model.
+!!
+!! EXTERNAL
+!! --------
+!! SET_DIM : to initialize dimensions
+!! SET_GRID : to initialize grid
+!! METRICS : to compute metric coefficients
+!! READ_FIELD : to initialize field
+!! FMCLOS : to close a FM-file
+!! SET_REF : to initialize reference state for anelastic approximation
+!! INI_DYNAMICS: to initialize parameters for the dynamics
+!! INI_TKE_EPS : to initialize the TKE
+!! SET_DIRCOS : to compute the director cosinus of the orography
+!! INI_RADIATIONS : to initialize radiation computations
+!! CH_INIT_CCS: to initialize the chemical core system
+!! CH_INIT_FIELDn: to (re)initialize the scalar variables
+!! INI_DEEP_CONVECTION : to initialize the deep convection scheme
+!! CLEANLIST_ll : deaalocate a list
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!! Module MODD_PARAMETERS : contains declaration of parameter variables
+!! JPHEXT : Horizontal external points number
+!! JPVEXT : Vertical external points number
+!!
+!! Module MODD_MODD_DYN : contains declaration of parameters
+!! for the dynamics
+!! Module MODD_CONF : contains declaration of configuration variables
+!! for all models
+!! NMODEL : Number of nested models
+!! NVERB : Level of informations on output-listing
+!! 0 for minimum prints
+!! 5 for intermediate level of prints
+!! 10 for maximum prints
+!!
+!! Module MODD_REF : contains declaration of reference state
+!! variables for all models
+!! Module MODD_FIELD_n : contains declaration of prognostic fields
+!! Module MODD_LSFIELD_n : contains declaration of Larger Scale fields
+!! Module MODD_GRID_n : contains declaration of spatial grid variables
+!! Module MODD_TIME_n : contains declaration of temporal grid variables
+!! Module MODD_REF_n : contains declaration of reference state
+!! variables
+!! Module MODD_CURVCOR_n : contains declaration of curvature and Coriolis
+!! variables
+!! Module MODD_BUDGET : contains declarations of the budget parameters
+!! Module MODD_RADIATIONS_n:contains declaration of the variables of the
+!! radiation interface scheme
+!! Module MODD_STAND_ATM : contains declaration of the 5 standard
+!! atmospheres used for the ECMWF-radiation code
+!! Module MODD_FRC : contains declaration of the control variables
+!! and of the forcing fields
+!! Module MODD_CH_MNHC_n : contains the control parameters for chemistry
+!! Module MODD_DEEP_CONVECTION_n: contains declaration of the variables of
+!! the deep convection scheme
+!!
+!!
+!!
+!!
+!! Module MODN_CONF_n : contains declaration of namelist NAM_CONFn and
+!! uses module MODD_CONF_n (configuration variables)
+!! Module MODN_LUNIT_n : contains declaration of namelist NAM_LUNITn and
+!! uses module MODD_LUNIT_n (Logical units)
+!! Module MODN_DYN_n : contains declaration of namelist NAM_DYNn and
+!! uses module MODD_DYN_n (control of dynamics)
+!! Module MODN_PARAM_n : contains declaration of namelist NAM_PARAMn and
+!! uses module MODD_PARAM_n (control of physical
+!! parameterization)
+!! Module MODN_LBC_n : contains declaration of namelist NAM_LBCn and
+!! uses module MODD_LBC_n (lateral boundaries)
+!! Module MODN_TURB_n : contains declaration of namelist NAM_TURBn and
+!! uses module MODD_TURB_n (turbulence scheme)
+!! Module MODN_PARAM_RAD_n: contains declaration of namelist NAM_PARAM_RADn
+!!
+!! REFERENCE
+!! ---------
+!! Book2 of documentation (routine INI_MODEL_n)
+!!
+!!
+!! AUTHOR
+!! ------
+!! V. Ducrocq * Meteo France *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 10/06/94
+!! Modification 17/10/94 (Stein) For LCORIO
+!! Modification 20/10/94 (Stein) For SET_GRID and NAMOUTN
+!! Modification 26/10/94 (Stein) Modifications of the namelist names
+!! Modification 10/11/94 (Lafore) allocatation of tke fields
+!! Modification 22/11/94 (Stein) change the READ_FIELDS call ( add
+!! pressure function
+!! Modification 06/12/94 (Stein) add the LS fields
+!! 12/12/94 (Stein) rename END_INI in INI_DYNAMICS
+!! Modification 09/01/95 (Stein) add the turbulence scheme
+!! Modification Jan 19, 1995 (J. Cuxart) add the TKE initialization
+!! Jan 23, 1995 (J. Stein ) remove the condition
+!! LTHINSHELL=T LCARTESIAN=T => stop
+!! Modification Feb 16, 1995 (I.Mallet) add the METRICS call and
+!! change the SET_REF call (add
+!! the lineic mass)
+!! Modification Mar 10, 1995 (I. Mallet) add the COUPLING initialization
+!! June 29,1995 (Ph. Hereil, J. Stein) add the budget init.
+!! Modification Sept. 1, 1995 (S. Belair) Reading of the surface variables
+!! and parameters for ISBA (i.e., add a
+!! CALL READ_GR_FIELD)
+!! Modification 18/08/95 (J.P.Lafore) time step change case
+!! 25/09/95 (J. Cuxart and J.Stein) add LES variables
+!! and the diachronic file initialization
+!! Modification Sept 20,1995 (Lafore) coupling for the dry mass Md
+!! Modification Sept. 12, 1995 (J.-P. Pinty) add the initialization of
+!! the ECMWF radiation code
+!! Modification Sept. 13, 1995 (J.-P. Pinty) control the allocation of the
+!! arrays of MODD_GR_FIELD_n
+!! Modification Nove. 17, 1995 (J.Stein) control of the control !!
+!! March 01, 1996 (J. Stein) add the cloud fraction
+!! April 03, 1996 (J. Stein) unify the ISBA and TSZ0 cases
+!! Modification 13/12/95 (M. Georgelin) add the forcing variables in
+!! the call read_field, and their
+!! allocation.
+!! Mai 23, 1996 (J. Stein) allocate XSEA in the TSZ0 case
+!! June 11, 1996 (V. Masson) add XSILT and XLAKE of
+!! MODD_GR_FIELD_n
+!! August 7, 1996 (K. Suhre) add (re)initialization of
+!! chemistry
+!! Octo. 11, 1996 (J. Stein ) add XSRCT and XSRCM
+!! October 8, 1996 (J. Cuxart, E. Sanchez) Moist LES diagnostics
+!! and control on TKE initialization.
+!! Modification 19/12/96 (J.-P. Pinty) add the ice parameterization and
+!! the precipitation fields
+!! Modification 11/01/97 (J.-P. Pinty) add the deep convection
+!! Nov. 1, 1996 (V. Masson) Read the vertical grid kind
+!! Nov. 20, 1996 (V. Masson) control of convection calling time
+!! July 16, 1996 (J.P.Lafore) update of EXSEG file reading
+!! Oct. 08, 1996 (J.P.Lafore, V.Masson)
+!! MY_NAME and DAD_NAME reading and check
+!! Oct. 30, 1996 (J.P.Lafore) resolution ratio reading for nesting
+!! and Bikhardt interpolation coef. initialization
+!! Nov. 22, 1996 (J.P.Lafore) allocation of LS sources for nesting
+!! Feb. 26, 1997 (J.P.Lafore) allocation of "surfacic" LS fields
+!! March 10, 1997 (J.P.Lafore) forcing only for model 1
+!! June 22, 1997 (J. Stein) add the absolute pressure
+!! July 09, 1997 (V. Masson) add directional z0 and SSO
+!! Aug. 18, 1997 (V. Masson) consistency between storage
+!! type and CCONF
+!! Dec. 22, 1997 (J. Stein) add the LS field spawning
+!! Jan. 24, 1998 (P.Bechtold) change MODD_FRC and MODD_DEEP_CONVECTION
+!! Dec. 24, 1997 (V.Masson) directional z0 parameters
+!! Aug. 13, 1998 (V. Ducrocq P Jabouille) //
+!! Mai. 26, 1998 (J. Stein) remove NXEND,NYEND
+!! Feb. 1, 1999 (J. Stein) compute the Bikhardt
+!! interpolation coeff. before the call to set_grid
+!! April 5, 1999 (V. Ducrocq) change the DXRATIO_ALL init.
+!! April 12, 1999 (J. Stein) cleaning + INI_SPAWN_LS
+!! Apr. 7, 1999 (P Jabouille) store the metric coefficients
+!! in modd_metrics_n
+!! Jui. 15,1999 (P Jabouille) split the routines in two parts
+!! Jan. 04,2000 (V. Masson) removes the TSZ0 case
+!! Apr. 15,2000 (P Jabouille) parallelization of grid nesting
+!! Aug. 20,2000 (J Stein ) tranpose XBFY
+!! Jui 01,2000 (F.solmon ) adapatation for patch approach
+!! Jun. 15,2000 (J.-P. Pinty) add C2R2 initialization
+!! Nov. 15,2000 (V.Masson) use of ini_modeln in prep_real_case
+!! Nov. 15,2000 (V.Masson) call of LES routines
+!! Nov. 15,2000 (V.Masson) aircraft and balloon initialization routines
+!! Jan. 22,2001 (D.Gazen) update_nsv set NSV_* var. for current model
+!! Mar. 04,2002 (V.Ducrocq) initialization to temporal series
+!! Mar. 15,2002 (F.Solmon) modification of ini_radiation interface
+!! Nov. 29,2002 (JP Pinty) add C3R5, ICE2, ICE4, ELEC
+!! Jan. 2004 (V.Masson) externalization of surface
+!! May 2006 Remove KEPS
+!! Apr. 2010 (M. Leriche) add pH for aqueous phase chemistry
+!! Jul. 2010 (M. Leriche) add Ice phase chemistry
+!! Oct. 2010 (J.Escobar) check if local domain not to small for NRIMX NRIMY
+!! Nov. 2010 (J.Escobar) PGI BUG , add SIZE(CSV) to init_ground routine
+!! Nov. 2009 (C. Barthe) add call to INI_ELEC_n
+!! Mar. 2010 (M. Chong) add small ions
+!! Apr. 2011 (M. Chong) correction of RESTART (ELEC)
+!! June 2011 (B.Aouizerats) Prognostic aerosols
+!! June 2011 (P.Aumond) Drag of the vegetation
+!! + Mean fields
+!! July 2013 (Bosseur & Filippi) Adds Forefire
+!! P. Tulet Nov 2014 accumulated moles of aqueous species that fall at the surface
+!! JAn. 2015 (F. Brosse) bug in allocate XACPRAQ
+!! Dec 2014 (C.Lac) : For reproducibility START/RESTA
+!! J.Escobar : 15/09/2015 : WENO5 & JPHEXT <> 1
+!! V. Masson Feb 2015 replaces, for aerosols, cover fractions by sea, town, bare soil fractions
+!! J.Escobar : 19/04/2016 : Pb IOZ/NETCDF , missing OPARALLELIO=.FALSE. for PGD files
+!! J.Escobar : 01/06/2016 : correct check limit of NRIM versus local subdomain size IDIM
+!! 06/2016 (G.Delautier) phasage surfex 8
+!! Modification 01/2016 (JP Pinty) Add LIMA
+!! Aug. 2016 (J.Pianezze) Add SFX_OASIS_READ_NAM function from SurfEx
+!! M.Leriche 2016 Chemistry
+!! 10/2016 M.Mazoyer New KHKO output fields
+!! 10/2016 (C.Lac) Add max values
+!! F. Brosse Oct. 2016 add prod/loss terms computation for chemistry
+!! M.Leriche 2016 Chemistry
+!! M.Leriche 10/02/17 prevent negative values in LBX(Y)SVS
+!! M.Leriche 01/07/2017 Add DIAG chimical surface fluxes
+!! 09/2017 Q.Rodier add LTEND_UV_FRC
+!! 02/2018 Q.Libois ECRAD
+!! Philippe Wautelet: 05/2016-04/2018: new data structures and calls for I/O
+!! V. Vionnet : 18/07/2017 : add blowing snow scheme
+!! 01/18 J.Colin Add DRAG
+! P. Wautelet 29/01/2019: bug: add missing zero-size allocations
+! P. Wautelet 07/02/2019: force TYPE to a known value for IO_File_add2list
+! P. Wautelet 13/02/2019: initialize XALBUV even if no radiation (needed in CH_INTERP_JVALUES)
+! P. Wautelet 13/02/2019: removed PPABSM and PTSTEP dummy arguments of READ_FIELD
+! P. Wautelet 14/02/2019: remove CLUOUT/CLUOUT0 and associated variables
+! P. Wautelet 14/02/2019: remove HINIFILE dummy argument from INI_RADIATIONS_ECMWF/ECRAD
+!! 02/2019 C.Lac add rain fraction as an output field
+!! Bielli S. 02/2019 Sea salt : significant sea wave height influences salt emission; 5 salt modes
+! P. Wautelet 14/03/2019: correct ZWS when variable not present in file (set to XZWS_DEFAULT)
+! P. Wautelet 10/04/2019: replace ABORT and STOP calls by Print_msg
+! P. Wautelet 19/04/2019: removed unused dummy arguments and variables
+! P. Wautelet 07/06/2019: allocate lookup tables for optical properties only when needed
+!---------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+#ifdef MNH_ECRAD
+USE YOERDI, only: RCCO2
+#endif
+
+USE MODD_2D_FRC
+USE MODD_ADVFRC_n
+USE MODD_ADV_n
+use MODD_AEROSET, only: POLYTAU, POLYSSA, POLYG
+USE MODD_ARGSLIST_ll, only: LIST_ll
+USE MODD_BIKHARDT_n
+USE MODD_BLOWSNOW
+USE MODD_BLOWSNOW_n
+USE MODD_BUDGET
+USE MODD_CH_AERO_n, only: XSOLORG,XMI
+USE MODD_CH_AEROSOL, only: LORILAM
+USE MODD_CH_BUDGET_n
+USE MODD_CH_FLX_n, only: XCHFLX
+USE MODD_CH_M9_n, only:NNONZEROTERMS
+USE MODD_CH_MNHC_n, only: LUSECHEM, LUSECHAQ, LUSECHIC, LCH_INIT_FIELD, &
+ LCH_CONV_LINOX, XCH_TUV_DOBNEW, LCH_PH
+USE MODD_CH_PH_n
+USE MODD_CH_PRODLOSSTOT_n
+USE MODD_CLOUD_MF_n
+USE MODD_CONF
+USE MODD_CONF_n
+USE MODD_CST
+USE MODD_CTURB
+USE MODD_CURVCOR_n
+USE MODD_DEEP_CONVECTION_n
+USE MODD_DEF_EDDY_FLUX_n ! for VT and WT fluxes
+USE MODD_DEF_EDDYUV_FLUX_n ! FOR UV
+USE MODD_DIAG_FLAG, only: LCHEMDIAG, CSPEC_BU_DIAG
+USE MODD_DIM_n
+USE MODD_DRAG_n
+USE MODD_DRAGTREE
+USE MODD_DUST
+use MODD_DUST_OPT_LKT, only: NMAX_RADIUS_LKT_DUST=>NMAX_RADIUS_LKT, NMAX_SIGMA_LKT_DUST=>NMAX_SIGMA_LKT, &
+ NMAX_WVL_SW_DUST=>NMAX_WVL_SW, &
+ XEXT_COEFF_WVL_LKT_DUST=>XEXT_COEFF_WVL_LKT, XEXT_COEFF_550_LKT_DUST=>XEXT_COEFF_550_LKT, &
+ XPIZA_LKT_DUST=>XPIZA_LKT, XCGA_LKT_DUST=>XCGA_LKT
+USE MODD_DYN
+USE MODD_DYN_n
+USE MODD_DYNZD
+USE MODD_DYNZD_n
+USE MODD_ELEC_n, only: XCION_POS_FW, XCION_NEG_FW
+USE MODD_FIELD_n
+#ifdef MNH_FOREFIRE
+USE MODD_FOREFIRE
+USE MODD_FOREFIRE_n
+#endif
+USE MODD_FRC
+USE MODD_FRC_n
+USE MODD_GET_n
+USE MODD_GRID_n
+USE MODD_GRID, only: XLONORI,XLATORI
+USE MODD_IO, only: CIO_DIR, TFILEDATA, TFILE_DUMMY
+USE MODD_IO_SURF_MNH, only: IO_SURF_MNH_MODEL
+USE MODD_LATZ_EDFLX
+USE MODD_LBC_n, only: CLBCX, CLBCY
+USE MODD_LSFIELD_n
+USE MODD_LUNIT_n
+USE MODD_MEAN_FIELD
+USE MODD_MEAN_FIELD_n
+USE MODD_METRICS_n
+USE MODD_MNH_SURFEX_n
+USE MODD_NESTING, only: CDAD_NAME, NDAD, NDT_2_WAY, NDTRATIO, NDXRATIO_ALL, NDYRATIO_ALL
+USE MODD_NSV
+USE MODD_NSV
+USE MODD_NUDGING_n, only: LNUDGING
+USE MODD_OUT_n
+USE MODD_PARAMETERS
+USE MODD_PARAM_KAFR_n
+USE MODD_PARAM_MFSHALL_n
+USE MODD_PARAM_n
+USE MODD_PARAM_RAD_n, only: CAER, CAOP, CLW
+USE MODD_PASPOL
+USE MODD_PASPOL_n
+USE MODD_PAST_FIELD_n
+use modd_precision, only: LFIINT
+USE MODD_RADIATIONS_n
+USE MODD_REF
+USE MODD_REF_n
+USE MODD_RELFRC_n
+use MODD_SALT, only: LSALT
+use MODD_SALT_OPT_LKT, only: NMAX_RADIUS_LKT_SALT=>NMAX_RADIUS_LKT, NMAX_SIGMA_LKT_SALT=>NMAX_SIGMA_LKT, &
+ NMAX_WVL_SW_SALT=>NMAX_WVL_SW, &
+ XEXT_COEFF_WVL_LKT_SALT=>XEXT_COEFF_WVL_LKT, XEXT_COEFF_550_LKT_SALT=>XEXT_COEFF_550_LKT, &
+ XPIZA_LKT_SALT=>XPIZA_LKT, XCGA_LKT_SALT=>XCGA_LKT
+USE MODD_SERIES, only: LSERIES
+USE MODD_SHADOWS_n
+USE MODD_STAND_ATM, only: XSTROATM, XSMLSATM, XSMLWATM, XSPOSATM, XSPOWATM
+USE MODD_TIME
+USE MODD_TIME_n
+USE MODD_TURB_CLOUD, only: NMODEL_CLOUD, CTURBLEN_CLOUD,XCEI
+USE MODD_TURB_n
+USE MODD_VAR_ll, only: IP
+
+USE MODE_GATHER_ll
+USE MODE_INI_ONE_WAY_n
+USE MODE_IO
+USE MODE_IO_FIELD_READ, only: IO_Field_read
+USE MODE_IO_FILE, only: IO_File_open
+USE MODE_IO_MANAGE_STRUCT, only: IO_File_add2list
+USE MODE_ll
+USE MODE_MODELN_HANDLER
+USE MODE_MPPDB
+USE MODE_MSG
+USE MODE_SPLITTINGZ_ll, only: GET_DIM_EXTZ_ll
+USE MODE_TYPE_ZDIFFU
+
+USE MODI_CH_AER_MOD_INIT
+USE MODI_CH_INIT_BUDGET_n
+USE MODI_CH_INIT_FIELD_n
+USE MODI_CH_INIT_JVALUES
+USE MODI_CH_INIT_PRODLOSSTOT_n
+USE MODI_GET_SIZEX_LB
+USE MODI_GET_SIZEY_LB
+USE MODI_INI_AEROSET1
+USE MODI_INI_AEROSET2
+USE MODI_INI_AEROSET3
+USE MODI_INI_AEROSET4
+USE MODI_INI_AEROSET5
+USE MODI_INI_AEROSET6
+USE MODI_INI_AIRCRAFT_BALLOON
+USE MODI_INI_AIRCRAFT_BALLOON
+USE MODI_INI_BIKHARDT_n
+USE MODI_INI_BUDGET
+USE MODI_INI_CPL
+USE MODI_INI_DEEP_CONVECTION
+USE MODI_INI_DRAG
+USE MODI_INI_DYNAMICS
+USE MODI_INI_ELEC_n
+USE MODI_INI_LES_N
+USE MODI_INI_LG
+USE MODI_INI_LW_SETUP
+USE MODI_INI_MICRO_n
+USE MODI_INI_POSPROFILER_n
+USE MODI_INI_RADIATIONS
+USE MODI_INI_RADIATIONS_ECMWF
+USE MODI_INI_RADIATIONS_ECRAD
+USE MODI_INI_SERIES_N
+USE MODI_INI_SPAWN_LS_n
+USE MODI_INI_SURF_RAD
+USE MODI_INI_SURFSTATION_n
+USE MODI_INI_SW_SETUP
+USE MODI_INIT_AEROSOL_PROPERTIES
+#ifdef MNH_FOREFIRE
+USE MODI_INIT_FOREFIRE_n
+#endif
+USE MODI_INIT_GROUND_PARAM_n
+USE MODI_INI_TKE_EPS
+USE MODI_METRICS
+USE MODI_MNHGET_SURF_PARAM_n
+USE MODI_MNHREAD_ZS_DUMMY_n
+USE MODI_READ_FIELD
+USE MODI_SET_DIRCOS
+USE MODI_SET_GRID
+USE MODI_SET_REF
+#ifdef CPLOASIS
+USE MODI_SFX_OASIS_READ_NAM
+#endif
+USE MODI_SUNPOS_n
+USE MODI_SURF_SOLAR_GEOM
+USE MODI_UPDATE_METRICS
+USE MODI_UPDATE_NSV
+!
+IMPLICIT NONE
+!
+!* 0.1 declarations of arguments
+!
+!
+INTEGER, INTENT(IN) :: KMI ! Model Index
+TYPE(TFILEDATA), INTENT(IN) :: TPINIFILE ! Initial file
+!
+!* 0.2 declarations of local variables
+!
+REAL, PARAMETER :: NALBUV_DEFAULT = 0.01 ! Arbitrary low value for XALBUV
+!
+INTEGER :: JSV ! Loop index
+INTEGER :: IRESP ! Return code of FM routines
+INTEGER :: ILUOUT ! Logical unit number of output-listing
+CHARACTER(LEN=28) :: YNAME
+INTEGER :: IIU ! Upper dimension in x direction (local)
+INTEGER :: IJU ! Upper dimension in y direction (local)
+INTEGER :: IIU_ll ! Upper dimension in x direction (global)
+INTEGER :: IJU_ll ! Upper dimension in y direction (global)
+INTEGER :: IKU ! Upper dimension in z direction
+REAL, DIMENSION(:,:,:), ALLOCATABLE :: ZJ ! Jacobian
+LOGICAL :: GINIDCONV ! logical switch for the deep convection
+ ! initialization
+LOGICAL :: GINIRAD ! logical switch for the radiation
+ ! initialization
+!
+!
+TYPE(LIST_ll), POINTER :: TZINITHALO2D_ll ! pointer for the list of 2D fields
+ ! which must be communicated in INIT
+TYPE(LIST_ll), POINTER :: TZINITHALO3D_ll ! pointer for the list of 3D fields
+ ! which must be communicated in INIT
+!
+INTEGER :: IISIZEXF,IJSIZEXF,IISIZEXFU,IJSIZEXFU ! dimensions of the
+INTEGER :: IISIZEX4,IJSIZEX4,IISIZEX2,IJSIZEX2 ! West-east LB arrays
+INTEGER :: IISIZEYF,IJSIZEYF,IISIZEYFV,IJSIZEYFV ! dimensions of the
+INTEGER :: IISIZEY4,IJSIZEY4,IISIZEY2,IJSIZEY2 ! North-south LB arrays
+INTEGER :: IINFO_ll ! Return code of //routines
+INTEGER :: IIY,IJY
+INTEGER :: IIU_B,IJU_B
+INTEGER :: IIU_SXP2_YP1_Z_ll,IJU_SXP2_YP1_Z_ll,IKU_SXP2_YP1_Z_ll
+!
+REAL, DIMENSION(:,:), ALLOCATABLE :: ZCO2 ! CO2 concentration near the surface
+REAL, DIMENSION(:,:), ALLOCATABLE :: ZSEA ! sea fraction
+REAL, DIMENSION(:,:), ALLOCATABLE :: ZTOWN ! town fraction
+REAL, DIMENSION(:,:), ALLOCATABLE :: ZBARE ! bare soil fraction
+!
+REAL, DIMENSION(:,:,:), ALLOCATABLE :: ZDIR_ALB ! direct albedo
+REAL, DIMENSION(:,:,:), ALLOCATABLE :: ZSCA_ALB ! diffuse albedo
+REAL, DIMENSION(:,:,:), ALLOCATABLE :: ZEMIS ! emissivity
+REAL, DIMENSION(:,:), ALLOCATABLE :: ZTSRAD ! surface temperature
+!
+!
+INTEGER, DIMENSION(:,:),ALLOCATABLE :: IINDEX ! indices of non-zero terms
+INTEGER, DIMENSION(:),ALLOCATABLE :: IIND
+INTEGER :: JM
+!
+!------------------------------------------
+! Dummy pointers needed to correct an ifort Bug
+REAL, DIMENSION(:), POINTER :: DPTR_XZHAT
+REAL, DIMENSION(:), POINTER :: DPTR_XBMX1,DPTR_XBMX2,DPTR_XBMX3,DPTR_XBMX4
+REAL, DIMENSION(:), POINTER :: DPTR_XBMY1,DPTR_XBMY2,DPTR_XBMY3,DPTR_XBMY4
+REAL, DIMENSION(:), POINTER :: DPTR_XBFX1,DPTR_XBFX2,DPTR_XBFX3,DPTR_XBFX4
+REAL, DIMENSION(:), POINTER :: DPTR_XBFY1,DPTR_XBFY2,DPTR_XBFY3,DPTR_XBFY4
+CHARACTER(LEN=4), DIMENSION(:), POINTER :: DPTR_CLBCX,DPTR_CLBCY
+INTEGER, DIMENSION(:,:,:), POINTER :: DPTR_NKLIN_LBXU,DPTR_NKLIN_LBYU,DPTR_NKLIN_LBXV,DPTR_NKLIN_LBYV
+INTEGER, DIMENSION(:,:,:), POINTER :: DPTR_NKLIN_LBXW,DPTR_NKLIN_LBYW,DPTR_NKLIN_LBXM,DPTR_NKLIN_LBYM
+REAL, DIMENSION(:,:,:), POINTER :: DPTR_XCOEFLIN_LBXU,DPTR_XCOEFLIN_LBYU
+REAL, DIMENSION(:,:,:), POINTER :: DPTR_XCOEFLIN_LBXV,DPTR_XCOEFLIN_LBYV
+REAL, DIMENSION(:,:,:), POINTER :: DPTR_XCOEFLIN_LBXW,DPTR_XCOEFLIN_LBYW
+REAL, DIMENSION(:,:,:), POINTER :: DPTR_XCOEFLIN_LBXM,DPTR_XCOEFLIN_LBYM
+REAL, DIMENSION(:,:,:), POINTER :: DPTR_XLBXUM,DPTR_XLBYUM,DPTR_XLBXVM,DPTR_XLBYVM
+REAL, DIMENSION(:,:,:), POINTER :: DPTR_XLBXWM,DPTR_XLBYWM,DPTR_XLBXTHM,DPTR_XLBYTHM
+REAL, DIMENSION(:,:,:), POINTER :: DPTR_XLBXTKEM,DPTR_XLBYTKEM
+REAL, DIMENSION(:,:,:,:), POINTER :: DPTR_XLBXSVM,DPTR_XLBYSVM
+REAL, DIMENSION(:,:,:,:), POINTER :: DPTR_XLBXRM,DPTR_XLBYRM
+REAL, DIMENSION(:,:,:), POINTER :: DPTR_XZZ
+REAL, DIMENSION(:,:,:), POINTER :: DPTR_XLSUM,DPTR_XLSVM,DPTR_XLSWM,DPTR_XLSTHM,DPTR_XLSRVM
+REAL, DIMENSION(:,:,:), POINTER :: DPTR_XLSUS,DPTR_XLSVS,DPTR_XLSWS,DPTR_XLSTHS,DPTR_XLSRVS
+REAL, DIMENSION(:,:), POINTER :: DPTR_XLSZWSM,DPTR_XLSZWSS
+!
+INTEGER :: IIB,IJB,IIE,IJE,IDIMX,IDIMY,IMI
+!
+!-------------------------------------------------------------------------------
+!
+!* 0. PROLOGUE
+! --------
+! Compute relaxation coefficients without changing INI_DYNAMICS nor RELAXDEF
+!
+IF (CCLOUD == 'LIMA') THEN
+ LHORELAX_SVC1R3=LHORELAX_SVLIMA
+END IF
+!
+!
+NULLIFY(TZINITHALO2D_ll)
+NULLIFY(TZINITHALO3D_ll)
+!
+!* 1. RETRIEVE LOGICAL UNIT NUMBER
+! ----------------------------
+!
+ILUOUT = TLUOUT%NLU
+!
+!-------------------------------------------------------------------------------
+!
+!* 2. END OF READING
+! --------------
+!* 2.1 Read number of forcing fields
+!
+IF (LFORCING) THEN ! Retrieve the number of time-dependent forcings.
+ CALL IO_Field_read(TPINIFILE,'FRC',NFRC,IRESP)
+ IF ( (IRESP /= 0) .OR. (NFRC <=0) ) THEN
+ WRITE(ILUOUT,'(A/A)') &
+ "INI_MODEL_n ERROR: you want to read forcing variables from FMfile", &
+ " but no fields have been found by IO_Field_read"
+!callabortstop
+ CALL PRINT_MSG(NVERB_FATAL,'GEN','INI_MODEL_n','')
+ END IF
+END IF
+!
+! Modif PP for time evolving adv forcing
+ IF ( L2D_ADV_FRC ) THEN ! Retrieve the number of time-dependent forcings.
+ WRITE(ILUOUT,FMT=*) "INI_MODEL_n ENTER ADV_FORCING"
+ CALL IO_Field_read(TPINIFILE,'NADVFRC1',NADVFRC,IRESP)
+ IF ( (IRESP /= 0) .OR. (NADVFRC <=0) ) THEN
+ WRITE(ILUOUT,'(A/A)') &
+ "INI_MODELn ERROR: you want to read forcing ADV variables from FMfile", &
+ " but no fields have been found by IO_Field_read"
+ !callabortstop
+ CALL PRINT_MSG(NVERB_FATAL,'GEN','INI_MODEL_n','')
+ END IF
+ WRITE(ILUOUT,*) 'NADVFRC = ', NADVFRC
+END IF
+!
+IF ( L2D_REL_FRC ) THEN ! Retrieve the number of time-dependent forcings.
+ WRITE(ILUOUT,FMT=*) "INI_MODEL_n ENTER REL_FORCING"
+ CALL IO_Field_read(TPINIFILE,'NRELFRC1',NRELFRC,IRESP)
+ IF ( (IRESP /= 0) .OR. (NRELFRC <=0) ) THEN
+ WRITE(ILUOUT,'(A/A)') &
+ "INI_MODELn ERROR: you want to read forcing REL variables from FMfile", &
+ " but no fields have been found by IO_Field_read"
+ !callabortstop
+ CALL PRINT_MSG(NVERB_FATAL,'GEN','INI_MODEL_n','')
+ END IF
+ WRITE(ILUOUT,*) 'NRELFRC = ', NRELFRC
+END IF
+!* 2.2 Checks the position of vertical absorbing layer
+!
+IKU=NKMAX+2*JPVEXT
+!
+ALLOCATE(XZHAT(IKU))
+CALL IO_Field_read(TPINIFILE,'ZHAT',XZHAT)
+CALL IO_Field_read(TPINIFILE,'ZTOP',XZTOP)
+IF (XALZBOT>=XZHAT(IKU) .AND. LVE_RELAX) THEN
+ WRITE(ILUOUT,FMT=*) "INI_MODEL_n ERROR: you want to use vertical relaxation"
+ WRITE(ILUOUT,FMT=*) " but bottom of layer XALZBOT(",XALZBOT,")"
+ WRITE(ILUOUT,FMT=*) " is upper than model top (",XZHAT(IKU),")"
+!callabortstop
+ CALL PRINT_MSG(NVERB_FATAL,'GEN','INI_MODEL_n','')
+END IF
+IF (LVE_RELAX) THEN
+ IF (XALZBOT>=XZHAT(IKU-4) ) THEN
+ WRITE(ILUOUT,FMT=*) "INI_MODEL_n WARNING: you want to use vertical relaxation"
+ WRITE(ILUOUT,FMT=*) " but the layer defined by XALZBOT(",XALZBOT,")"
+ WRITE(ILUOUT,FMT=*) " contains less than 5 model levels"
+ END IF
+END IF
+DEALLOCATE(XZHAT)
+!
+!* 2.3 Compute sizes of arrays of the extended sub-domain
+!
+CALL GET_DIM_EXT_ll('B',IIU,IJU)
+IIU_ll=NIMAX_ll + 2 * JPHEXT
+IJU_ll=NJMAX_ll + 2 * JPHEXT
+! initialize NIMAX and NJMAX for not updated versions regarding the parallelism
+! spawning,...
+CALL GET_DIM_PHYS_ll('B',NIMAX,NJMAX)
+!
+CALL GET_INDICE_ll( IIB,IJB,IIE,IJE)
+IDIMX = IIE - IIB + 1
+IDIMY = IJE - IJB + 1
+!
+NRR=0
+NRRL=0
+NRRI=0
+IF (CGETRVT /= 'SKIP' ) THEN
+ NRR = NRR+1
+ IDX_RVT = NRR
+END IF
+IF (CGETRCT /= 'SKIP' ) THEN
+ NRR = NRR+1
+ NRRL = NRRL+1
+ IDX_RCT = NRR
+END IF
+IF (CGETRRT /= 'SKIP' ) THEN
+ NRR = NRR+1
+ NRRL = NRRL+1
+ IDX_RRT = NRR
+END IF
+IF (CGETRIT /= 'SKIP' ) THEN
+ NRR = NRR+1
+ NRRI = NRRI+1
+ IDX_RIT = NRR
+END IF
+IF (CGETRST /= 'SKIP' ) THEN
+ NRR = NRR+1
+ NRRI = NRRI+1
+ IDX_RST = NRR
+END IF
+IF (CGETRGT /= 'SKIP' ) THEN
+ NRR = NRR+1
+ NRRI = NRRI+1
+ IDX_RGT = NRR
+END IF
+IF (CGETRHT /= 'SKIP' ) THEN
+ NRR = NRR+1
+ NRRI = NRRI+1
+ IDX_RHT = NRR
+END IF
+IF (NVERB >= 5) THEN
+ WRITE (UNIT=ILUOUT,FMT='("THERE ARE ",I2," WATER VARIABLES")') NRR
+ WRITE (UNIT=ILUOUT,FMT='("THERE ARE ",I2," LIQUID VARIABLES")') NRRL
+ WRITE (UNIT=ILUOUT,FMT='("THERE ARE ",I2," SOLID VARIABLES")') NRRI
+END IF
+!
+!* 2.4 Update NSV and floating indices for the current model
+!
+!
+CALL UPDATE_NSV(KMI)
+!
+!-------------------------------------------------------------------------------
+!
+!* 3. ALLOCATE MEMORY
+! -----------------
+!
+!* 3.1 Module MODD_FIELD_n
+!
+IF (LMEAN_FIELD) THEN
+!
+ MEAN_COUNT = 0
+!
+ ALLOCATE(XUM_MEAN(IIU,IJU,IKU)) ; XUM_MEAN = 0.0
+ ALLOCATE(XVM_MEAN(IIU,IJU,IKU)) ; XVM_MEAN = 0.0
+ ALLOCATE(XWM_MEAN(IIU,IJU,IKU)) ; XWM_MEAN = 0.0
+ ALLOCATE(XTHM_MEAN(IIU,IJU,IKU)) ; XTHM_MEAN = 0.0
+ ALLOCATE(XTEMPM_MEAN(IIU,IJU,IKU)) ; XTEMPM_MEAN = 0.0
+ IF (CTURB/='NONE') THEN
+ ALLOCATE(XTKEM_MEAN(IIU,IJU,IKU))
+ XTKEM_MEAN = 0.0
+ ELSE
+ ALLOCATE(XTKEM_MEAN(0,0,0))
+ END IF
+ ALLOCATE(XPABSM_MEAN(IIU,IJU,IKU)) ; XPABSM_MEAN = 0.0
+!
+ ALLOCATE(XU2_MEAN(IIU,IJU,IKU)) ; XU2_MEAN = 0.0
+ ALLOCATE(XV2_MEAN(IIU,IJU,IKU)) ; XV2_MEAN = 0.0
+ ALLOCATE(XW2_MEAN(IIU,IJU,IKU)) ; XW2_MEAN = 0.0
+ ALLOCATE(XTH2_MEAN(IIU,IJU,IKU)) ; XTH2_MEAN = 0.0
+ ALLOCATE(XTEMP2_MEAN(IIU,IJU,IKU)) ; XTEMP2_MEAN = 0.0
+ ALLOCATE(XPABS2_MEAN(IIU,IJU,IKU)) ; XPABS2_MEAN = 0.0
+!
+ ALLOCATE(XUM_MAX(IIU,IJU,IKU)) ; XUM_MAX = -1.E20
+ ALLOCATE(XVM_MAX(IIU,IJU,IKU)) ; XVM_MAX = -1.E20
+ ALLOCATE(XWM_MAX(IIU,IJU,IKU)) ; XWM_MAX = -1.E20
+ ALLOCATE(XTHM_MAX(IIU,IJU,IKU)) ; XTHM_MAX = 0.0
+ ALLOCATE(XTEMPM_MAX(IIU,IJU,IKU)) ; XTEMPM_MAX = 0.0
+ IF (CTURB/='NONE') THEN
+ ALLOCATE(XTKEM_MAX(IIU,IJU,IKU))
+ XTKEM_MAX = 0.0
+ ELSE
+ ALLOCATE(XTKEM_MAX(0,0,0))
+ END IF
+ ALLOCATE(XPABSM_MAX(IIU,IJU,IKU)) ; XPABSM_MAX = 0.0
+ELSE
+ ALLOCATE(XUM_MEAN(0,0,0))
+ ALLOCATE(XVM_MEAN(0,0,0))
+ ALLOCATE(XWM_MEAN(0,0,0))
+ ALLOCATE(XTHM_MEAN(0,0,0))
+ ALLOCATE(XTEMPM_MEAN(0,0,0))
+ ALLOCATE(XTKEM_MEAN(0,0,0))
+ ALLOCATE(XPABSM_MEAN(0,0,0))
+!
+ ALLOCATE(XU2_MEAN(0,0,0))
+ ALLOCATE(XV2_MEAN(0,0,0))
+ ALLOCATE(XW2_MEAN(0,0,0))
+ ALLOCATE(XTH2_MEAN(0,0,0))
+ ALLOCATE(XTEMP2_MEAN(0,0,0))
+ ALLOCATE(XPABS2_MEAN(0,0,0))
+!
+ ALLOCATE(XUM_MAX(0,0,0))
+ ALLOCATE(XVM_MAX(0,0,0))
+ ALLOCATE(XWM_MAX(0,0,0))
+ ALLOCATE(XTHM_MAX(0,0,0))
+ ALLOCATE(XTEMPM_MAX(0,0,0))
+ ALLOCATE(XTKEM_MAX(0,0,0))
+ ALLOCATE(XPABSM_MAX(0,0,0))
+END IF
+!
+IF ((CUVW_ADV_SCHEME(1:3)=='CEN') .AND. (CTEMP_SCHEME == 'LEFR') ) THEN
+ ALLOCATE(XUM(IIU,IJU,IKU))
+ ALLOCATE(XVM(IIU,IJU,IKU))
+ ALLOCATE(XWM(IIU,IJU,IKU))
+ ALLOCATE(XDUM(IIU,IJU,IKU))
+ ALLOCATE(XDVM(IIU,IJU,IKU))
+ ALLOCATE(XDWM(IIU,IJU,IKU))
+ IF (CCONF == 'START') THEN
+ XUM = 0.0
+ XVM = 0.0
+ XWM = 0.0
+ XDUM = 0.0
+ XDVM = 0.0
+ XDWM = 0.0
+ END IF
+ELSE
+ ALLOCATE(XUM(0,0,0))
+ ALLOCATE(XVM(0,0,0))
+ ALLOCATE(XWM(0,0,0))
+ ALLOCATE(XDUM(0,0,0))
+ ALLOCATE(XDVM(0,0,0))
+ ALLOCATE(XDWM(0,0,0))
+END IF
+!
+ALLOCATE(XUT(IIU,IJU,IKU)) ; XUT = 0.0
+ALLOCATE(XVT(IIU,IJU,IKU)) ; XVT = 0.0
+ALLOCATE(XWT(IIU,IJU,IKU)) ; XWT = 0.0
+ALLOCATE(XTHT(IIU,IJU,IKU)) ; XTHT = 0.0
+ALLOCATE(XRUS(IIU,IJU,IKU)) ; XRUS = 0.0
+ALLOCATE(XRVS(IIU,IJU,IKU)) ; XRVS = 0.0
+ALLOCATE(XRWS(IIU,IJU,IKU)) ; XRWS = 0.0
+ALLOCATE(XRUS_PRES(IIU,IJU,IKU)); XRUS_PRES = 0.0
+ALLOCATE(XRVS_PRES(IIU,IJU,IKU)); XRVS_PRES = 0.0
+ALLOCATE(XRWS_PRES(IIU,IJU,IKU)); XRWS_PRES = 0.0
+ALLOCATE(XRTHS(IIU,IJU,IKU)) ; XRTHS = 0.0
+!$acc enter data copyin(XRTHS)
+ALLOCATE(XRTHS_CLD(IIU,IJU,IKU)); XRTHS_CLD = 0.0
+IF (CTURB /= 'NONE') THEN
+ ALLOCATE(XTKET(IIU,IJU,IKU))
+ ALLOCATE(XRTKES(IIU,IJU,IKU))
+ ALLOCATE(XRTKEMS(IIU,IJU,IKU)); XRTKEMS = 0.0
+ ALLOCATE(XWTHVMF(IIU,IJU,IKU))
+ ALLOCATE(XDYP(IIU,IJU,IKU))
+ ALLOCATE(XTHP(IIU,IJU,IKU))
+ ALLOCATE(XTR(IIU,IJU,IKU))
+ ALLOCATE(XDISS(IIU,IJU,IKU))
+ ALLOCATE(XLEM(IIU,IJU,IKU))
+ XTKEMIN=XKEMIN
+ XCED =XCEDIS
+ELSE
+ ALLOCATE(XTKET(0,0,0))
+ ALLOCATE(XRTKES(0,0,0))
+ ALLOCATE(XRTKEMS(0,0,0))
+ ALLOCATE(XWTHVMF(0,0,0))
+ ALLOCATE(XDYP(0,0,0))
+ ALLOCATE(XTHP(0,0,0))
+ ALLOCATE(XTR(0,0,0))
+ ALLOCATE(XDISS(0,0,0))
+ ALLOCATE(XLEM(0,0,0))
+END IF
+IF (CTOM == 'TM06') THEN
+ ALLOCATE(XBL_DEPTH(IIU,IJU))
+ELSE
+ ALLOCATE(XBL_DEPTH(0,0))
+END IF
+IF (LRMC01) THEN
+ ALLOCATE(XSBL_DEPTH(IIU,IJU))
+ELSE
+ ALLOCATE(XSBL_DEPTH(0,0))
+END IF
+!
+ALLOCATE(XPABSM(IIU,IJU,IKU)) ; XPABSM = 0.0
+ALLOCATE(XPABST(IIU,IJU,IKU)) ; XPABST = 0.0
+!
+ALLOCATE(XRT(IIU,IJU,IKU,NRR)) ; XRT = 0.0
+ALLOCATE(XRRS(IIU,IJU,IKU,NRR)) ; XRRS = 0.0
+ALLOCATE(XRRS_CLD(IIU,IJU,IKU,NRR)); XRRS_CLD = 0.0
+!
+IF (CTURB /= 'NONE' .AND. NRR>1) THEN
+ ALLOCATE(XSRCT(IIU,IJU,IKU))
+ ALLOCATE(XSIGS(IIU,IJU,IKU))
+ELSE
+ ALLOCATE(XSRCT(0,0,0))
+ ALLOCATE(XSIGS(0,0,0))
+END IF
+!
+IF (NRR>1) THEN
+ ALLOCATE(XCLDFR(IIU,IJU,IKU))
+ ALLOCATE(XRAINFR(IIU,IJU,IKU))
+ELSE
+ ALLOCATE(XCLDFR(0,0,0))
+ ALLOCATE(XRAINFR(0,0,0))
+END IF
+!
+ALLOCATE(XSVT(IIU,IJU,IKU,NSV)) ; XSVT = 0.
+ALLOCATE(XRSVS(IIU,IJU,IKU,NSV)); XRSVS = 0.
+ALLOCATE(XRSVS_CLD(IIU,IJU,IKU,NSV)); XRSVS_CLD = 0.0
+ALLOCATE(XZWS(IIU,IJU)) ; XZWS(:,:) = XZWS_DEFAULT
+!
+IF (LPASPOL) THEN
+ ALLOCATE( XATC(IIU,IJU,IKU,NSV_PP) )
+ XATC = 0.
+ELSE
+ ALLOCATE( XATC(0,0,0,0))
+END IF
+!
+IF(LBLOWSNOW) THEN
+ ALLOCATE(XSNWCANO(IIU,IJU,NBLOWSNOW_2D))
+ ALLOCATE(XRSNWCANOS(IIU,IJU,NBLOWSNOW_2D))
+ XSNWCANO(:,:,:) = 0.0
+ XRSNWCANOS(:,:,:) = 0.0
+ELSE
+ ALLOCATE(XSNWCANO(0,0,0))
+ ALLOCATE(XRSNWCANOS(0,0,0))
+END IF
+!
+!* 3.2 Module MODD_GRID_n and MODD_METRICS_n
+!
+IF (LCARTESIAN) THEN
+ ALLOCATE(XLON(0,0))
+ ALLOCATE(XLAT(0,0))
+ ALLOCATE(XMAP(0,0))
+ELSE
+ ALLOCATE(XLON(IIU,IJU))
+ ALLOCATE(XLAT(IIU,IJU))
+ ALLOCATE(XMAP(IIU,IJU))
+END IF
+ALLOCATE(XXHAT(IIU))
+ALLOCATE(XDXHAT(IIU))
+ALLOCATE(XYHAT(IJU))
+ALLOCATE(XDYHAT(IJU))
+ALLOCATE(XZS(IIU,IJU))
+ALLOCATE(XZSMT(IIU,IJU))
+ALLOCATE(XZZ(IIU,IJU,IKU))
+ALLOCATE(XZHAT(IKU))
+ALLOCATE(XDIRCOSZW(IIU,IJU))
+ALLOCATE(XDIRCOSXW(IIU,IJU))
+ALLOCATE(XDIRCOSYW(IIU,IJU))
+ALLOCATE(XCOSSLOPE(IIU,IJU))
+ALLOCATE(XSINSLOPE(IIU,IJU))
+!
+ALLOCATE(XDXX(IIU,IJU,IKU))
+ALLOCATE(XDYY(IIU,IJU,IKU))
+ALLOCATE(XDZX(IIU,IJU,IKU))
+ALLOCATE(XDZY(IIU,IJU,IKU))
+ALLOCATE(XDZZ(IIU,IJU,IKU))
+!$acc enter data create(XDXX,XDYY,XDZZ,XDZX,XDZY)
+!
+!* 3.3 Modules MODD_REF and MODD_REF_n
+!
+IF (KMI == 1) THEN
+ ALLOCATE(XRHODREFZ(IKU),XTHVREFZ(IKU))
+ELSE
+ !Do not allocate XRHODREFZ and XTHVREFZ because they are the same on all grids (not 'n' variables)
+END IF
+ALLOCATE(XRHODREF(IIU,IJU,IKU))
+ALLOCATE(XTHVREF(IIU,IJU,IKU))
+ALLOCATE(XEXNREF(IIU,IJU,IKU))
+ALLOCATE(XRHODJ(IIU,IJU,IKU))
+!$acc enter data create(XRHODJ)
+IF (CEQNSYS=='DUR' .AND. LUSERV) THEN
+ ALLOCATE(XRVREF(IIU,IJU,IKU))
+ELSE
+ ALLOCATE(XRVREF(0,0,0))
+END IF
+!
+!* 3.4 Module MODD_CURVCOR_n
+!
+IF (LTHINSHELL) THEN
+ ALLOCATE(XCORIOX(0,0))
+ ALLOCATE(XCORIOY(0,0))
+ELSE
+ ALLOCATE(XCORIOX(IIU,IJU))
+ ALLOCATE(XCORIOY(IIU,IJU))
+END IF
+ ALLOCATE(XCORIOZ(IIU,IJU))
+IF (LCARTESIAN) THEN
+ ALLOCATE(XCURVX(0,0))
+ ALLOCATE(XCURVY(0,0))
+ELSE
+ ALLOCATE(XCURVX(IIU,IJU))
+ ALLOCATE(XCURVY(IIU,IJU))
+END IF
+!
+!* 3.5 Module MODD_DYN_n
+!
+CALL GET_DIM_EXT_ll('Y',IIY,IJY)
+IF (L2D) THEN
+ ALLOCATE(XBFY(IIY,IJY,IKU))
+ELSE
+ ALLOCATE(XBFY(IJY,IIY,IKU)) ! transposition needed by the optimisation of the
+ ! FFT solver
+END IF
+CALL GET_DIM_EXT_ll('B',IIU_B,IJU_B)
+ALLOCATE(XBFB(IIU_B,IJU_B,IKU))
+ALLOCATE(XAF_ZS(IIU_B,IJU_B,IKU))
+ALLOCATE(XBF_ZS(IIU_B,IJU_B,IKU))
+ALLOCATE(XCF_ZS(IIU_B,IJU_B,IKU))
+ALLOCATE(XDXATH_ZS(IIU_B,IJU_B))
+ALLOCATE(XDYATH_ZS(IIU_B,IJU_B))
+ALLOCATE(XRHO_ZS(IIU_B,IJU_B,IKU))
+ALLOCATE(XA_K(IKU))
+ALLOCATE(XB_K(IKU))
+ALLOCATE(XC_K(IKU))
+ALLOCATE(XD_K(IKU))
+
+CALL GET_DIM_EXTZ_ll('SXP2_YP1_Z',IIU_SXP2_YP1_Z_ll,IJU_SXP2_YP1_Z_ll,IKU_SXP2_YP1_Z_ll)
+ALLOCATE(XBF_SXP2_YP1_Z(IIU_SXP2_YP1_Z_ll,IJU_SXP2_YP1_Z_ll,IKU_SXP2_YP1_Z_ll))
+ALLOCATE(XAF(IKU),XCF(IKU))
+ALLOCATE(XTRIGSX(3*IIU_ll))
+ALLOCATE(XTRIGSY(3*IJU_ll))
+ALLOCATE(XRHOM(IKU))
+ALLOCATE(XALK(IKU))
+ALLOCATE(XALKW(IKU))
+ALLOCATE(XALKBAS(IKU))
+ALLOCATE(XALKWBAS(IKU))
+!
+IF ( LHORELAX_UVWTH .OR. LHORELAX_RV .OR. &
+ LHORELAX_RC .OR. LHORELAX_RR .OR. LHORELAX_RI .OR. LHORELAX_RS .OR. &
+ LHORELAX_RG .OR. LHORELAX_RH .OR. LHORELAX_TKE .OR. &
+ ANY(LHORELAX_SV) ) THEN
+ ALLOCATE(XKURELAX(IIU,IJU))
+ ALLOCATE(XKVRELAX(IIU,IJU))
+ ALLOCATE(XKWRELAX(IIU,IJU))
+ ALLOCATE(LMASK_RELAX(IIU,IJU))
+ELSE
+ ALLOCATE(XKURELAX(0,0))
+ ALLOCATE(XKVRELAX(0,0))
+ ALLOCATE(XKWRELAX(0,0))
+ ALLOCATE(LMASK_RELAX(0,0))
+END IF
+!
+! Additional fields for truly horizontal diffusion (Module MODD_DYNZD$n)
+IF (LZDIFFU) THEN
+ CALL INIT_TYPE_ZDIFFU_HALO2(XZDIFFU_HALO2)
+ELSE
+ CALL INIT_TYPE_ZDIFFU_HALO2(XZDIFFU_HALO2,0)
+ENDIF
+!
+!* 3.6 Larger Scale variables (Module MODD_LSFIELD$n)
+!
+!
+! upper relaxation part
+!
+ALLOCATE(XLSUM(IIU,IJU,IKU)) ; XLSUM = 0.0
+ALLOCATE(XLSVM(IIU,IJU,IKU)) ; XLSVM = 0.0
+ALLOCATE(XLSWM(IIU,IJU,IKU)) ; XLSWM = 0.0
+ALLOCATE(XLSTHM(IIU,IJU,IKU)) ; XLSTHM = 0.0
+IF ( NRR > 0 ) THEN
+ ALLOCATE(XLSRVM(IIU,IJU,IKU)) ; XLSRVM = 0.0
+ELSE
+ ALLOCATE(XLSRVM(0,0,0))
+END IF
+ALLOCATE(XLSZWSM(IIU,IJU)) ; XLSZWSM = -1.
+!
+! lbc part
+!
+IF ( L1D) THEN ! 1D case
+!
+ NSIZELBX_ll=0
+ NSIZELBXU_ll=0
+ NSIZELBY_ll=0
+ NSIZELBYV_ll=0
+ NSIZELBXTKE_ll=0
+ NSIZELBXR_ll=0
+ NSIZELBXSV_ll=0
+ NSIZELBYTKE_ll=0
+ NSIZELBYR_ll=0
+ NSIZELBYSV_ll=0
+ ALLOCATE(XLBXUM(0,0,0))
+ ALLOCATE(XLBYUM(0,0,0))
+ ALLOCATE(XLBXVM(0,0,0))
+ ALLOCATE(XLBYVM(0,0,0))
+ ALLOCATE(XLBXWM(0,0,0))
+ ALLOCATE(XLBYWM(0,0,0))
+ ALLOCATE(XLBXTHM(0,0,0))
+ ALLOCATE(XLBYTHM(0,0,0))
+ ALLOCATE(XLBXTKEM(0,0,0))
+ ALLOCATE(XLBYTKEM(0,0,0))
+ ALLOCATE(XLBXRM(0,0,0,0))
+ ALLOCATE(XLBYRM(0,0,0,0))
+ ALLOCATE(XLBXSVM(0,0,0,0))
+ ALLOCATE(XLBYSVM(0,0,0,0))
+!
+ELSEIF( L2D ) THEN ! 2D case
+!
+ NSIZELBY_ll=0
+ NSIZELBYV_ll=0
+ NSIZELBYTKE_ll=0
+ NSIZELBYR_ll=0
+ NSIZELBYSV_ll=0
+ ALLOCATE(XLBYUM(0,0,0))
+ ALLOCATE(XLBYVM(0,0,0))
+ ALLOCATE(XLBYWM(0,0,0))
+ ALLOCATE(XLBYTHM(0,0,0))
+ ALLOCATE(XLBYTKEM(0,0,0))
+ ALLOCATE(XLBYRM(0,0,0,0))
+ ALLOCATE(XLBYSVM(0,0,0,0))
+!
+ CALL GET_SIZEX_LB(NIMAX_ll,NJMAX_ll,NRIMX, &
+ IISIZEXF,IJSIZEXF,IISIZEXFU,IJSIZEXFU, &
+ IISIZEX4,IJSIZEX4,IISIZEX2,IJSIZEX2)
+!
+ IF ( LHORELAX_UVWTH ) THEN
+ NSIZELBX_ll=2*NRIMX+2*JPHEXT
+ NSIZELBXU_ll=2*NRIMX+2*JPHEXT
+ ALLOCATE(XLBXUM(IISIZEXFU,IJSIZEXFU,IKU))
+ ALLOCATE(XLBXVM(IISIZEXF,IJSIZEXF,IKU))
+ ALLOCATE(XLBXWM(IISIZEXF,IJSIZEXF,IKU))
+ ALLOCATE(XLBXTHM(IISIZEXF,IJSIZEXF,IKU))
+ ELSE
+ NSIZELBX_ll=2*JPHEXT ! 2
+ NSIZELBXU_ll=2*(JPHEXT+1) ! 4
+ ALLOCATE(XLBXUM(IISIZEX4,IJSIZEX4,IKU))
+ ALLOCATE(XLBXVM(IISIZEX2,IJSIZEX2,IKU))
+ ALLOCATE(XLBXWM(IISIZEX2,IJSIZEX2,IKU))
+ ALLOCATE(XLBXTHM(IISIZEX2,IJSIZEX2,IKU))
+ END IF
+!
+ IF (CTURB /= 'NONE') THEN
+ IF ( LHORELAX_TKE) THEN
+ NSIZELBXTKE_ll=2* NRIMX+2*JPHEXT
+ ALLOCATE(XLBXTKEM(IISIZEXF,IJSIZEXF,IKU))
+ ELSE
+ NSIZELBXTKE_ll=2*JPHEXT ! 2
+ ALLOCATE(XLBXTKEM(IISIZEX2,IJSIZEX2,IKU))
+ END IF
+ ELSE
+ NSIZELBXTKE_ll=0
+ ALLOCATE(XLBXTKEM(0,0,0))
+ END IF
+ !
+ IF ( NRR > 0 ) THEN
+ IF (LHORELAX_RV .OR. LHORELAX_RC .OR. LHORELAX_RR .OR. LHORELAX_RI &
+ .OR. LHORELAX_RS .OR. LHORELAX_RG .OR. LHORELAX_RH &
+ ) THEN
+ NSIZELBXR_ll=2* NRIMX+2*JPHEXT
+ ALLOCATE(XLBXRM(IISIZEXF,IJSIZEXF,IKU,NRR))
+ ELSE
+ NSIZELBXR_ll=2*JPHEXT ! 2
+ ALLOCATE(XLBXRM(IISIZEX2,IJSIZEX2,IKU,NRR))
+ ENDIF
+ ELSE
+ NSIZELBXR_ll=0
+ ALLOCATE(XLBXRM(0,0,0,0))
+ END IF
+ !
+ IF ( NSV > 0 ) THEN
+ IF ( ANY( LHORELAX_SV(:)) ) THEN
+ NSIZELBXSV_ll=2* NRIMX+2*JPHEXT
+ ALLOCATE(XLBXSVM(IISIZEXF,IJSIZEXF,IKU,NSV))
+ ELSE
+ NSIZELBXSV_ll=2*JPHEXT ! 2
+ ALLOCATE(XLBXSVM(IISIZEX2,IJSIZEX2,IKU,NSV))
+ END IF
+ ELSE
+ NSIZELBXSV_ll=0
+ ALLOCATE(XLBXSVM(0,0,0,0))
+ END IF
+!
+ELSE ! 3D case
+!
+!
+ CALL GET_SIZEX_LB(NIMAX_ll,NJMAX_ll,NRIMX, &
+ IISIZEXF,IJSIZEXF,IISIZEXFU,IJSIZEXFU, &
+ IISIZEX4,IJSIZEX4,IISIZEX2,IJSIZEX2)
+ CALL GET_SIZEY_LB(NIMAX_ll,NJMAX_ll,NRIMY, &
+ IISIZEYF,IJSIZEYF,IISIZEYFV,IJSIZEYFV, &
+ IISIZEY4,IJSIZEY4,IISIZEY2,IJSIZEY2)
+!
+! check if local domain not to small for NRIMX NRIMY
+!
+ IF ( CLBCX(1) /= 'CYCL' ) THEN
+ IF ( NRIMX .GT. IDIMX ) THEN
+ WRITE(*,'(A,I8,A/A,2I8,/A)') "Processor=", IP-1, &
+ " :: INI_MODEL_n ERROR: ( NRIMX > IDIMX ) ", &
+ " Local domain to small for relaxation NRIMX,IDIMX ", &
+ NRIMX,IDIMX ,&
+ " change relaxation parameters or number of processors "
+ call Print_msg(NVERB_FATAL,'GEN','INI_MODEL_n','')
+ END IF
+ END IF
+ IF ( CLBCY(1) /= 'CYCL' ) THEN
+ IF ( NRIMY .GT. IDIMY ) THEN
+ WRITE(*,'(A,I8,A/A,2I8,/A)') "Processor=", IP-1, &
+ " :: INI_MODEL_n ERROR: ( NRIMY > IDIMY ) ", &
+ " Local domain to small for relaxation NRIMY,IDIMY ", &
+ NRIMY,IDIMY ,&
+ " change relaxation parameters or number of processors "
+ call Print_msg(NVERB_FATAL,'GEN','INI_MODEL_n','')
+ END IF
+ END IF
+IF ( LHORELAX_UVWTH ) THEN
+ NSIZELBX_ll=2*NRIMX+2*JPHEXT
+ NSIZELBXU_ll=2*NRIMX+2*JPHEXT
+ NSIZELBY_ll=2*NRIMY+2*JPHEXT
+ NSIZELBYV_ll=2*NRIMY+2*JPHEXT
+ ALLOCATE(XLBXUM(IISIZEXFU,IJSIZEXFU,IKU))
+ ALLOCATE(XLBYUM(IISIZEYF,IJSIZEYF,IKU))
+ ALLOCATE(XLBXVM(IISIZEXF,IJSIZEXF,IKU))
+ ALLOCATE(XLBYVM(IISIZEYFV,IJSIZEYFV,IKU))
+ ALLOCATE(XLBXWM(IISIZEXF,IJSIZEXF,IKU))
+ ALLOCATE(XLBYWM(IISIZEYF,IJSIZEYF,IKU))
+ ALLOCATE(XLBXTHM(IISIZEXF,IJSIZEXF,IKU))
+ ALLOCATE(XLBYTHM(IISIZEYF,IJSIZEYF,IKU))
+ ELSE
+ NSIZELBX_ll=2*JPHEXT ! 2
+ NSIZELBXU_ll=2*(JPHEXT+1) ! 4
+ NSIZELBY_ll=2*JPHEXT ! 2
+ NSIZELBYV_ll=2*(JPHEXT+1) ! 4
+ ALLOCATE(XLBXUM(IISIZEX4,IJSIZEX4,IKU))
+ ALLOCATE(XLBYUM(IISIZEY2,IJSIZEY2,IKU))
+ ALLOCATE(XLBXVM(IISIZEX2,IJSIZEX2,IKU))
+ ALLOCATE(XLBYVM(IISIZEY4,IJSIZEY4,IKU))
+ ALLOCATE(XLBXWM(IISIZEX2,IJSIZEX2,IKU))
+ ALLOCATE(XLBYWM(IISIZEY2,IJSIZEY2,IKU))
+ ALLOCATE(XLBXTHM(IISIZEX2,IJSIZEX2,IKU))
+ ALLOCATE(XLBYTHM(IISIZEY2,IJSIZEY2,IKU))
+ END IF
+ !
+ IF (CTURB /= 'NONE') THEN
+ IF ( LHORELAX_TKE) THEN
+ NSIZELBXTKE_ll=2*NRIMX+2*JPHEXT
+ NSIZELBYTKE_ll=2*NRIMY+2*JPHEXT
+ ALLOCATE(XLBXTKEM(IISIZEXF,IJSIZEXF,IKU))
+ ALLOCATE(XLBYTKEM(IISIZEYF,IJSIZEYF,IKU))
+ ELSE
+ NSIZELBXTKE_ll=2*JPHEXT ! 2
+ NSIZELBYTKE_ll=2*JPHEXT ! 2
+ ALLOCATE(XLBXTKEM(IISIZEX2,IJSIZEX2,IKU))
+ ALLOCATE(XLBYTKEM(IISIZEY2,IJSIZEY2,IKU))
+ END IF
+ ELSE
+ NSIZELBXTKE_ll=0
+ NSIZELBYTKE_ll=0
+ ALLOCATE(XLBXTKEM(0,0,0))
+ ALLOCATE(XLBYTKEM(0,0,0))
+ END IF
+ !
+ IF ( NRR > 0 ) THEN
+ IF (LHORELAX_RV .OR. LHORELAX_RC .OR. LHORELAX_RR .OR. LHORELAX_RI &
+ .OR. LHORELAX_RS .OR. LHORELAX_RG .OR. LHORELAX_RH &
+ ) THEN
+ NSIZELBXR_ll=2*NRIMX+2*JPHEXT
+ NSIZELBYR_ll=2*NRIMY+2*JPHEXT
+ ALLOCATE(XLBXRM(IISIZEXF,IJSIZEXF,IKU,NRR))
+ ALLOCATE(XLBYRM(IISIZEYF,IJSIZEYF,IKU,NRR))
+ ELSE
+ NSIZELBXR_ll=2*JPHEXT ! 2
+ NSIZELBYR_ll=2*JPHEXT ! 2
+ ALLOCATE(XLBXRM(IISIZEX2,IJSIZEX2,IKU,NRR))
+ ALLOCATE(XLBYRM(IISIZEY2,IJSIZEY2,IKU,NRR))
+ ENDIF
+ ELSE
+ NSIZELBXR_ll=0
+ NSIZELBYR_ll=0
+ ALLOCATE(XLBXRM(0,0,0,0))
+ ALLOCATE(XLBYRM(0,0,0,0))
+ END IF
+ !
+ IF ( NSV > 0 ) THEN
+ IF ( ANY( LHORELAX_SV(:)) ) THEN
+ NSIZELBXSV_ll=2*NRIMX+2*JPHEXT
+ NSIZELBYSV_ll=2*NRIMY+2*JPHEXT
+ ALLOCATE(XLBXSVM(IISIZEXF,IJSIZEXF,IKU,NSV))
+ ALLOCATE(XLBYSVM(IISIZEYF,IJSIZEYF,IKU,NSV))
+ ELSE
+ NSIZELBXSV_ll=2*JPHEXT ! 2
+ NSIZELBYSV_ll=2*JPHEXT ! 2
+ ALLOCATE(XLBXSVM(IISIZEX2,IJSIZEX2,IKU,NSV))
+ ALLOCATE(XLBYSVM(IISIZEY2,IJSIZEY2,IKU,NSV))
+ END IF
+ ELSE
+ NSIZELBXSV_ll=0
+ NSIZELBYSV_ll=0
+ ALLOCATE(XLBXSVM(0,0,0,0))
+ ALLOCATE(XLBYSVM(0,0,0,0))
+ END IF
+END IF ! END OF THE IF STRUCTURE ON THE MODEL DIMENSION
+!
+!
+IF ( KMI > 1 ) THEN
+ ! it has been assumed that the THeta field used the largest rim area compared
+ ! to the others prognostic variables, if it is not the case, you must change
+ ! these lines
+ ALLOCATE(XCOEFLIN_LBXM(SIZE(XLBXTHM,1),SIZE(XLBXTHM,2),SIZE(XLBXTHM,3)))
+ ALLOCATE( NKLIN_LBXM(SIZE(XLBXTHM,1),SIZE(XLBXTHM,2),SIZE(XLBXTHM,3)))
+ ALLOCATE(XCOEFLIN_LBYM(SIZE(XLBYTHM,1),SIZE(XLBYTHM,2),SIZE(XLBYTHM,3)))
+ ALLOCATE( NKLIN_LBYM(SIZE(XLBYTHM,1),SIZE(XLBYTHM,2),SIZE(XLBYTHM,3)))
+ ALLOCATE(XCOEFLIN_LBXU(SIZE(XLBXUM,1),SIZE(XLBXUM,2),SIZE(XLBXUM,3)))
+ ALLOCATE( NKLIN_LBXU(SIZE(XLBXUM,1),SIZE(XLBXUM,2),SIZE(XLBXUM,3)))
+ ALLOCATE(XCOEFLIN_LBYU(SIZE(XLBYUM,1),SIZE(XLBYUM,2),SIZE(XLBYUM,3)))
+ ALLOCATE( NKLIN_LBYU(SIZE(XLBYUM,1),SIZE(XLBYUM,2),SIZE(XLBYUM,3)))
+ ALLOCATE(XCOEFLIN_LBXV(SIZE(XLBXVM,1),SIZE(XLBXVM,2),SIZE(XLBXVM,3)))
+ ALLOCATE( NKLIN_LBXV(SIZE(XLBXVM,1),SIZE(XLBXVM,2),SIZE(XLBXVM,3)))
+ ALLOCATE(XCOEFLIN_LBYV(SIZE(XLBYVM,1),SIZE(XLBYVM,2),SIZE(XLBYVM,3)))
+ ALLOCATE( NKLIN_LBYV(SIZE(XLBYVM,1),SIZE(XLBYVM,2),SIZE(XLBYVM,3)))
+ ALLOCATE(XCOEFLIN_LBXW(SIZE(XLBXWM,1),SIZE(XLBXWM,2),SIZE(XLBXWM,3)))
+ ALLOCATE( NKLIN_LBXW(SIZE(XLBXWM,1),SIZE(XLBXWM,2),SIZE(XLBXWM,3)))
+ ALLOCATE(XCOEFLIN_LBYW(SIZE(XLBYWM,1),SIZE(XLBYWM,2),SIZE(XLBYWM,3)))
+ ALLOCATE( NKLIN_LBYW(SIZE(XLBYWM,1),SIZE(XLBYWM,2),SIZE(XLBYWM,3)))
+ELSE
+ ALLOCATE(XCOEFLIN_LBXM(0,0,0))
+ ALLOCATE( NKLIN_LBXM(0,0,0))
+ ALLOCATE(XCOEFLIN_LBYM(0,0,0))
+ ALLOCATE( NKLIN_LBYM(0,0,0))
+ ALLOCATE(XCOEFLIN_LBXU(0,0,0))
+ ALLOCATE( NKLIN_LBXU(0,0,0))
+ ALLOCATE(XCOEFLIN_LBYU(0,0,0))
+ ALLOCATE( NKLIN_LBYU(0,0,0))
+ ALLOCATE(XCOEFLIN_LBXV(0,0,0))
+ ALLOCATE( NKLIN_LBXV(0,0,0))
+ ALLOCATE(XCOEFLIN_LBYV(0,0,0))
+ ALLOCATE( NKLIN_LBYV(0,0,0))
+ ALLOCATE(XCOEFLIN_LBXW(0,0,0))
+ ALLOCATE( NKLIN_LBXW(0,0,0))
+ ALLOCATE(XCOEFLIN_LBYW(0,0,0))
+ ALLOCATE( NKLIN_LBYW(0,0,0))
+END IF
+!
+! allocation of the LS fields for vertical relaxation and numerical diffusion
+IF( .NOT. LSTEADYLS ) THEN
+!
+ ALLOCATE(XLSUS(SIZE(XLSUM,1),SIZE(XLSUM,2),SIZE(XLSUM,3)))
+ ALLOCATE(XLSVS(SIZE(XLSVM,1),SIZE(XLSVM,2),SIZE(XLSVM,3)))
+ ALLOCATE(XLSWS(SIZE(XLSWM,1),SIZE(XLSWM,2),SIZE(XLSWM,3)))
+ ALLOCATE(XLSTHS(SIZE(XLSTHM,1),SIZE(XLSTHM,2),SIZE(XLSTHM,3)))
+ ALLOCATE(XLSRVS(SIZE(XLSRVM,1),SIZE(XLSRVM,2),SIZE(XLSRVM,3)))
+ ALLOCATE(XLSZWSS(SIZE(XLSZWSM,1),SIZE(XLSZWSM,2)))
+!
+ELSE
+!
+ ALLOCATE(XLSUS(0,0,0))
+ ALLOCATE(XLSVS(0,0,0))
+ ALLOCATE(XLSWS(0,0,0))
+ ALLOCATE(XLSTHS(0,0,0))
+ ALLOCATE(XLSRVS(0,0,0))
+ ALLOCATE(XLSZWSS(0,0))
+!
+END IF
+! allocation of the LB fields for horizontal relaxation and Lateral Boundaries
+IF( .NOT. ( LSTEADYLS .AND. KMI==1 ) ) THEN
+!
+ ALLOCATE(XLBXTKES(SIZE(XLBXTKEM,1),SIZE(XLBXTKEM,2),SIZE(XLBXTKEM,3)))
+ ALLOCATE(XLBYTKES(SIZE(XLBYTKEM,1),SIZE(XLBYTKEM,2),SIZE(XLBYTKEM,3)))
+ ALLOCATE(XLBXUS(SIZE(XLBXUM,1),SIZE(XLBXUM,2),SIZE(XLBXUM,3)))
+ ALLOCATE(XLBYUS(SIZE(XLBYUM,1),SIZE(XLBYUM,2),SIZE(XLBYUM,3)))
+ ALLOCATE(XLBXVS(SIZE(XLBXVM,1),SIZE(XLBXVM,2),SIZE(XLBXVM,3)))
+ ALLOCATE(XLBYVS(SIZE(XLBYVM,1),SIZE(XLBYVM,2),SIZE(XLBYVM,3)))
+ ALLOCATE(XLBXWS(SIZE(XLBXWM,1),SIZE(XLBXWM,2),SIZE(XLBXWM,3)))
+ ALLOCATE(XLBYWS(SIZE(XLBYWM,1),SIZE(XLBYWM,2),SIZE(XLBYWM,3)))
+ ALLOCATE(XLBXTHS(SIZE(XLBXTHM,1),SIZE(XLBXTHM,2),SIZE(XLBXTHM,3)))
+ ALLOCATE(XLBYTHS(SIZE(XLBYTHM,1),SIZE(XLBYTHM,2),SIZE(XLBYTHM,3)))
+ ALLOCATE(XLBXRS(SIZE(XLBXRM,1),SIZE(XLBXRM,2),SIZE(XLBXRM,3),SIZE(XLBXRM,4)))
+ ALLOCATE(XLBYRS(SIZE(XLBYRM,1),SIZE(XLBYRM,2),SIZE(XLBYRM,3),SIZE(XLBYRM,4)))
+ ALLOCATE(XLBXSVS(SIZE(XLBXSVM,1),SIZE(XLBXSVM,2),SIZE(XLBXSVM,3),SIZE(XLBXSVM,4)))
+ ALLOCATE(XLBYSVS(SIZE(XLBYSVM,1),SIZE(XLBYSVM,2),SIZE(XLBYSVM,3),SIZE(XLBYSVM,4)))
+!
+ELSE
+!
+ ALLOCATE(XLBXTKES(0,0,0))
+ ALLOCATE(XLBYTKES(0,0,0))
+ ALLOCATE(XLBXUS(0,0,0))
+ ALLOCATE(XLBYUS(0,0,0))
+ ALLOCATE(XLBXVS(0,0,0))
+ ALLOCATE(XLBYVS(0,0,0))
+ ALLOCATE(XLBXWS(0,0,0))
+ ALLOCATE(XLBYWS(0,0,0))
+ ALLOCATE(XLBXTHS(0,0,0))
+ ALLOCATE(XLBYTHS(0,0,0))
+ ALLOCATE(XLBXRS(0,0,0,0))
+ ALLOCATE(XLBYRS(0,0,0,0))
+ ALLOCATE(XLBXSVS(0,0,0,0))
+ ALLOCATE(XLBYSVS(0,0,0,0))
+!
+END IF
+!
+!
+!* 3.7 Module MODD_RADIATIONS_n (except XOZON and XAER)
+!
+! Initialization of SW bands
+NSWB_OLD = 6 ! Number of bands in ECMWF original scheme (from Fouquart et Bonnel (1980))
+ ! then modified through INI_RADIATIONS_ECMWF but remains equal to 6 practically
+IF (CRAD == 'ECRA') THEN
+ NSWB_MNH = 14
+ELSE
+ NSWB_MNH = NSWB_OLD
+END IF
+
+NLWB_MNH = 16 ! For XEMIS initialization (should be spectral in the future)
+
+
+ALLOCATE(XSW_BANDS (NSWB_MNH))
+ALLOCATE(XLW_BANDS (NLWB_MNH))
+ALLOCATE(XZENITH (IIU,IJU))
+ALLOCATE(XAZIM (IIU,IJU))
+ALLOCATE(XALBUV (IIU,IJU))
+XALBUV(:,:) = NALBUV_DEFAULT !Set to an arbitrary low value (XALBUV is needed in CH_INTERP_JVALUES even if no radiation)
+ALLOCATE(XDIRSRFSWD(IIU,IJU,NSWB_MNH))
+ALLOCATE(XSCAFLASWD(IIU,IJU,NSWB_MNH))
+ALLOCATE(XFLALWD (IIU,IJU))
+!
+IF (CRAD /= 'NONE') THEN
+ ALLOCATE(XSLOPANG(IIU,IJU))
+ ALLOCATE(XSLOPAZI(IIU,IJU))
+ ALLOCATE(XDTHRAD(IIU,IJU,IKU))
+ ALLOCATE(XDIRFLASWD(IIU,IJU,NSWB_MNH))
+ ALLOCATE(XDIR_ALB(IIU,IJU,NSWB_MNH))
+ ALLOCATE(XSCA_ALB(IIU,IJU,NSWB_MNH))
+ ALLOCATE(XEMIS (IIU,IJU,NLWB_MNH))
+ ALLOCATE(XTSRAD (IIU,IJU)) ; XTSRAD = 0.0
+ ALLOCATE(XSEA (IIU,IJU))
+ ALLOCATE(XZS_XY (IIU,IJU))
+ ALLOCATE(NCLEARCOL_TM1(IIU,IJU))
+ ALLOCATE(XSWU(IIU,IJU,IKU))
+ ALLOCATE(XSWD(IIU,IJU,IKU))
+ ALLOCATE(XLWU(IIU,IJU,IKU))
+ ALLOCATE(XLWD(IIU,IJU,IKU))
+ ALLOCATE(XDTHRADSW(IIU,IJU,IKU))
+ ALLOCATE(XDTHRADLW(IIU,IJU,IKU))
+ ALLOCATE(XRADEFF(IIU,IJU,IKU))
+ELSE
+ ALLOCATE(XSLOPANG(0,0))
+ ALLOCATE(XSLOPAZI(0,0))
+ ALLOCATE(XDTHRAD(0,0,0))
+ ALLOCATE(XDIRFLASWD(0,0,0))
+ ALLOCATE(XDIR_ALB(0,0,0))
+ ALLOCATE(XSCA_ALB(0,0,0))
+ ALLOCATE(XEMIS (0,0,0))
+ ALLOCATE(XTSRAD (0,0))
+ ALLOCATE(XSEA (0,0))
+ ALLOCATE(XZS_XY (0,0))
+ ALLOCATE(NCLEARCOL_TM1(0,0))
+ ALLOCATE(XSWU(0,0,0))
+ ALLOCATE(XSWD(0,0,0))
+ ALLOCATE(XLWU(0,0,0))
+ ALLOCATE(XLWD(0,0,0))
+ ALLOCATE(XDTHRADSW(0,0,0))
+ ALLOCATE(XDTHRADLW(0,0,0))
+ ALLOCATE(XRADEFF(0,0,0))
+END IF
+
+IF (CRAD == 'ECMW' .OR. CRAD == 'ECRA') THEN
+ ALLOCATE(XSTROATM(31,6))
+ ALLOCATE(XSMLSATM(31,6))
+ ALLOCATE(XSMLWATM(31,6))
+ ALLOCATE(XSPOSATM(31,6))
+ ALLOCATE(XSPOWATM(31,6))
+ ALLOCATE(XSTATM(31,6))
+ELSE
+ ALLOCATE(XSTROATM(0,0))
+ ALLOCATE(XSMLSATM(0,0))
+ ALLOCATE(XSMLWATM(0,0))
+ ALLOCATE(XSPOSATM(0,0))
+ ALLOCATE(XSPOWATM(0,0))
+ ALLOCATE(XSTATM(0,0))
+END IF
+!
+!* 3.8 Module MODD_DEEP_CONVECTION_n
+!
+IF (CDCONV /= 'NONE' .OR. CSCONV == 'KAFR') THEN
+ ALLOCATE(NCOUNTCONV(IIU,IJU))
+ ALLOCATE(XDTHCONV(IIU,IJU,IKU))
+ ALLOCATE(XDRVCONV(IIU,IJU,IKU))
+ ALLOCATE(XDRCCONV(IIU,IJU,IKU))
+ ALLOCATE(XDRICONV(IIU,IJU,IKU))
+ ALLOCATE(XPRCONV(IIU,IJU))
+ ALLOCATE(XPACCONV(IIU,IJU))
+ ALLOCATE(XPRSCONV(IIU,IJU))
+ ! diagnostics
+ IF (LCH_CONV_LINOX) THEN
+ ALLOCATE(XIC_RATE(IIU,IJU))
+ ALLOCATE(XCG_RATE(IIU,IJU))
+ ALLOCATE(XIC_TOTAL_NUMBER(IIU,IJU))
+ ALLOCATE(XCG_TOTAL_NUMBER(IIU,IJU))
+ ELSE
+ ALLOCATE(XIC_RATE(0,0))
+ ALLOCATE(XCG_RATE(0,0))
+ ALLOCATE(XIC_TOTAL_NUMBER(0,0))
+ ALLOCATE(XCG_TOTAL_NUMBER(0,0))
+ END IF
+ IF ( LDIAGCONV ) THEN
+ ALLOCATE(XUMFCONV(IIU,IJU,IKU))
+ ALLOCATE(XDMFCONV(IIU,IJU,IKU))
+ ALLOCATE(XPRLFLXCONV(IIU,IJU,IKU))
+ ALLOCATE(XPRSFLXCONV(IIU,IJU,IKU))
+ ALLOCATE(XCAPE(IIU,IJU))
+ ALLOCATE(NCLTOPCONV(IIU,IJU))
+ ALLOCATE(NCLBASCONV(IIU,IJU))
+ ELSE
+ ALLOCATE(XUMFCONV(0,0,0))
+ ALLOCATE(XDMFCONV(0,0,0))
+ ALLOCATE(XPRLFLXCONV(0,0,0))
+ ALLOCATE(XPRSFLXCONV(0,0,0))
+ ALLOCATE(XCAPE(0,0))
+ ALLOCATE(NCLTOPCONV(0,0))
+ ALLOCATE(NCLBASCONV(0,0))
+ END IF
+ELSE
+ ALLOCATE(NCOUNTCONV(0,0))
+ ALLOCATE(XDTHCONV(0,0,0))
+ ALLOCATE(XDRVCONV(0,0,0))
+ ALLOCATE(XDRCCONV(0,0,0))
+ ALLOCATE(XDRICONV(0,0,0))
+ ALLOCATE(XPRCONV(0,0))
+ ALLOCATE(XPACCONV(0,0))
+ ALLOCATE(XPRSCONV(0,0))
+ ALLOCATE(XIC_RATE(0,0))
+ ALLOCATE(XCG_RATE(0,0))
+ ALLOCATE(XIC_TOTAL_NUMBER(0,0))
+ ALLOCATE(XCG_TOTAL_NUMBER(0,0))
+ ALLOCATE(XUMFCONV(0,0,0))
+ ALLOCATE(XDMFCONV(0,0,0))
+ ALLOCATE(XPRLFLXCONV(0,0,0))
+ ALLOCATE(XPRSFLXCONV(0,0,0))
+ ALLOCATE(XCAPE(0,0))
+ ALLOCATE(NCLTOPCONV(0,0))
+ ALLOCATE(NCLBASCONV(0,0))
+END IF
+!
+IF ((CDCONV == 'KAFR' .OR. CSCONV == 'KAFR') &
+ .AND. LSUBG_COND .AND. LSIG_CONV) THEN
+ ALLOCATE(XMFCONV(IIU,IJU,IKU))
+ELSE
+ ALLOCATE(XMFCONV(0,0,0))
+ENDIF
+!
+IF ((CDCONV == 'KAFR' .OR. CSCONV == 'KAFR') &
+ .AND. LCHTRANS .AND. NSV > 0 ) THEN
+ ALLOCATE(XDSVCONV(IIU,IJU,IKU,NSV))
+ELSE
+ ALLOCATE(XDSVCONV(0,0,0,0))
+END IF
+!
+ALLOCATE(XCF_MF(IIU,IJU,IKU)) ; XCF_MF=0.0
+ALLOCATE(XRC_MF(IIU,IJU,IKU)) ; XRC_MF=0.0
+ALLOCATE(XRI_MF(IIU,IJU,IKU)) ; XRI_MF=0.0
+!
+!* 3.9 Local variables
+!
+ALLOCATE(ZJ(IIU,IJU,IKU))
+!
+!* 3.10 Forcing variables (Module MODD_FRC)
+!
+IF (KMI == 1) THEN
+ IF ( LFORCING ) THEN
+ ALLOCATE(TDTFRC(NFRC))
+ ALLOCATE(XUFRC(IKU,NFRC))
+ ALLOCATE(XVFRC(IKU,NFRC))
+ ALLOCATE(XWFRC(IKU,NFRC))
+ ALLOCATE(XTHFRC(IKU,NFRC))
+ ALLOCATE(XRVFRC(IKU,NFRC))
+ ALLOCATE(XTENDTHFRC(IKU,NFRC))
+ ALLOCATE(XTENDRVFRC(IKU,NFRC))
+ ALLOCATE(XGXTHFRC(IKU,NFRC))
+ ALLOCATE(XGYTHFRC(IKU,NFRC))
+ ALLOCATE(XPGROUNDFRC(NFRC))
+ ALLOCATE(XTENDUFRC(IKU,NFRC))
+ ALLOCATE(XTENDVFRC(IKU,NFRC))
+ ELSE
+ ALLOCATE(TDTFRC(0))
+ ALLOCATE(XUFRC(0,0))
+ ALLOCATE(XVFRC(0,0))
+ ALLOCATE(XWFRC(0,0))
+ ALLOCATE(XTHFRC(0,0))
+ ALLOCATE(XRVFRC(0,0))
+ ALLOCATE(XTENDTHFRC(0,0))
+ ALLOCATE(XTENDRVFRC(0,0))
+ ALLOCATE(XGXTHFRC(0,0))
+ ALLOCATE(XGYTHFRC(0,0))
+ ALLOCATE(XPGROUNDFRC(0))
+ ALLOCATE(XTENDUFRC(0,0))
+ ALLOCATE(XTENDVFRC(0,0))
+ END IF
+ IF ( LFORCING ) THEN
+ ALLOCATE(XWTFRC(IIU,IJU,IKU))
+ ALLOCATE(XUFRC_PAST(IIU,IJU,IKU)) ; XUFRC_PAST = XUNDEF
+ ALLOCATE(XVFRC_PAST(IIU,IJU,IKU)) ; XVFRC_PAST = XUNDEF
+ ELSE
+ ALLOCATE(XWTFRC(0,0,0))
+ ALLOCATE(XUFRC_PAST(0,0,0))
+ ALLOCATE(XVFRC_PAST(0,0,0))
+ END IF
+ELSE
+ !Do not allocate because they are the same on all grids (not 'n' variables)
+END IF
+! ----------------------------------------------------------------------
+!
+IF (L2D_ADV_FRC) THEN
+ WRITE(ILUOUT,*) 'L2D_ADV_FRC IS SET TO', L2D_ADV_FRC
+ WRITE(ILUOUT,*) 'ADV FRC WILL BE SET'
+ ALLOCATE(TDTADVFRC(NADVFRC))
+ ALLOCATE(XDTHFRC(IIU,IJU,IKU,NADVFRC)) ; XDTHFRC=0.
+ ALLOCATE(XDRVFRC(IIU,IJU,IKU,NADVFRC)) ; XDRVFRC=0.
+ELSE
+ ALLOCATE(TDTADVFRC(0))
+ ALLOCATE(XDTHFRC(0,0,0,0))
+ ALLOCATE(XDRVFRC(0,0,0,0))
+ENDIF
+
+IF (L2D_REL_FRC) THEN
+ WRITE(ILUOUT,*) 'L2D_REL_FRC IS SET TO', L2D_REL_FRC
+ WRITE(ILUOUT,*) 'REL FRC WILL BE SET'
+ ALLOCATE(TDTRELFRC(NRELFRC))
+ ALLOCATE(XTHREL(IIU,IJU,IKU,NRELFRC)) ; XTHREL=0.
+ ALLOCATE(XRVREL(IIU,IJU,IKU,NRELFRC)) ; XRVREL=0.
+ELSE
+ ALLOCATE(TDTRELFRC(0))
+ ALLOCATE(XTHREL(0,0,0,0))
+ ALLOCATE(XRVREL(0,0,0,0))
+ENDIF
+!
+!* 4.11 BIS: Eddy fluxes allocation
+!
+IF ( LTH_FLX ) THEN
+ ALLOCATE(XVTH_FLUX_M(IIU,IJU,IKU)) ; XVTH_FLUX_M = 0.
+ ALLOCATE(XWTH_FLUX_M(IIU,IJU,IKU)) ; XWTH_FLUX_M = 0.
+ IF (KMI /= 1) THEN
+ ALLOCATE(XRTHS_EDDY_FLUX(IIU,IJU,IKU))
+ XRTHS_EDDY_FLUX = 0.
+ ELSE
+ ALLOCATE(XRTHS_EDDY_FLUX(0,0,0))
+ ENDIF
+ELSE
+ ALLOCATE(XVTH_FLUX_M(0,0,0))
+ ALLOCATE(XWTH_FLUX_M(0,0,0))
+ ALLOCATE(XRTHS_EDDY_FLUX(0,0,0))
+END IF
+!
+IF ( LUV_FLX) THEN
+ ALLOCATE(XVU_FLUX_M(IIU,IJU,IKU)) ; XVU_FLUX_M = 0.
+ IF (KMI /= 1) THEN
+ ALLOCATE(XRVS_EDDY_FLUX(IIU,IJU,IKU))
+ XRVS_EDDY_FLUX = 0.
+ ELSE
+ ALLOCATE(XRVS_EDDY_FLUX(0,0,0))
+ ENDIF
+ELSE
+ ALLOCATE(XVU_FLUX_M(0,0,0))
+ ALLOCATE(XRVS_EDDY_FLUX(0,0,0))
+END IF
+!
+!* 3.11 Module MODD_ICE_CONC_n
+!
+IF ( (CCLOUD == 'ICE3'.OR.CCLOUD == 'ICE4') .AND. &
+ (CPROGRAM == 'DIAG '.OR.CPROGRAM == 'MESONH')) THEN
+ ALLOCATE(XCIT(IIU,IJU,IKU))
+ELSE
+ ALLOCATE(XCIT(0,0,0))
+END IF
+!
+IF ( CCLOUD == 'KHKO' .OR. CCLOUD == 'C2R2') THEN
+ ALLOCATE(XSUPSAT(IIU,IJU,IKU))
+ ALLOCATE(XNACT(IIU,IJU,IKU))
+ ALLOCATE(XNPRO(IIU,IJU,IKU))
+ ALLOCATE(XSSPRO(IIU,IJU,IKU))
+ELSE
+ ALLOCATE(XSUPSAT(0,0,0))
+ ALLOCATE(XNACT(0,0,0))
+ ALLOCATE(XNPRO(0,0,0))
+ ALLOCATE(XSSPRO(0,0,0))
+END IF
+!
+!* 3.12 Module MODD_TURB_CLOUD
+!
+IF (.NOT.(ALLOCATED(XCEI))) ALLOCATE(XCEI(0,0,0))
+IF (KMI == NMODEL_CLOUD .AND. CTURBLEN_CLOUD/='NONE' ) THEN
+ DEALLOCATE(XCEI)
+ ALLOCATE(XCEI(IIU,IJU,IKU))
+ENDIF
+!
+!* 3.13 Module MODD_CH_PH_n
+!
+IF (LUSECHAQ.AND.(CPROGRAM == 'DIAG '.OR.CPROGRAM == 'MESONH')) THEN
+ IF (LCH_PH) THEN
+ ALLOCATE(XPHC(IIU,IJU,IKU))
+ IF (NRRL==2) THEN
+ ALLOCATE(XPHR(IIU,IJU,IKU))
+ ALLOCATE(XACPHR(IIU,IJU))
+ XACPHR(:,:) = 0.
+ ENDIF
+ ENDIF
+ IF (NRRL==2) THEN
+ ALLOCATE(XACPRAQ(IIU,IJU,NSV_CHAC/2))
+ XACPRAQ(:,:,:) = 0.
+ ENDIF
+ENDIF
+IF (.NOT.(ASSOCIATED(XPHC))) ALLOCATE(XPHC(0,0,0))
+IF (.NOT.(ASSOCIATED(XPHR))) ALLOCATE(XPHR(0,0,0))
+IF (.NOT.(ASSOCIATED(XACPHR))) ALLOCATE(XACPHR(0,0))
+IF (.NOT.(ASSOCIATED(XACPRAQ))) ALLOCATE(XACPRAQ(0,0,0))
+IF ((LUSECHEM).AND.(CPROGRAM == 'DIAG ')) THEN
+ ALLOCATE(XCHFLX(IIU,IJU,NSV_CHEM))
+ XCHFLX(:,:,:) = 0.
+ELSE
+ ALLOCATE(XCHFLX(0,0,0))
+END IF
+!
+!* 3.14 Module MODD_DRAG
+!
+IF (LDRAG) THEN
+ ALLOCATE(XDRAG(IIU,IJU))
+ELSE
+ ALLOCATE(XDRAG(0,0))
+ENDIF
+!
+!-------------------------------------------------------------------------------
+!
+!* 4. INITIALIZE BUDGET VARIABLES
+! ---------------------------
+!
+IF ( CBUTYPE /= "NONE" .AND. NBUMOD == KMI ) THEN
+ CALL INI_BUDGET(ILUOUT,XTSTEP,NSV,NRR, &
+ LNUMDIFU,LNUMDIFTH,LNUMDIFSV, &
+ LHORELAX_UVWTH,LHORELAX_RV, LHORELAX_RC,LHORELAX_RR, &
+ LHORELAX_RI,LHORELAX_RS,LHORELAX_RG, LHORELAX_RH,LHORELAX_TKE, &
+ LHORELAX_SV,LVE_RELAX,LCHTRANS,LNUDGING,LDRAGTREE,LDEPOTREE, &
+ CRAD,CDCONV,CSCONV,CTURB,CTURBDIM,CCLOUD )
+END IF
+!
+!-------------------------------------------------------------------------------
+!
+!
+!* 5. INITIALIZE INTERPOLATION COEFFICIENTS
+!
+CALL INI_BIKHARDT_n (NDXRATIO_ALL(KMI),NDYRATIO_ALL(KMI),KMI)
+!
+!-------------------------------------------------------------------------------
+!
+!* 6. BUILT THE GENERIC OUTPUT NAME
+! ----------------------------
+!
+IF (KMI == 1) THEN
+ DO IMI = 1 , NMODEL
+ WRITE(IO_SURF_MNH_MODEL(IMI)%COUTFILE,'(A,".",I1,".",A)') CEXP,IMI,TRIM(ADJUSTL(CSEG))
+ WRITE(YNAME, '(A,".",I1,".",A)') CEXP,IMI,TRIM(ADJUSTL(CSEG))//'.000'
+ CALL IO_File_add2list(LUNIT_MODEL(IMI)%TDIAFILE,YNAME,'MNHDIACHRONIC','WRITE', &
+ HDIRNAME=CIO_DIR, &
+ KLFINPRAR=INT(50,KIND=LFIINT),KLFITYPE=1,KLFIVERB=NVERB, &
+ TPDADFILE=LUNIT_MODEL(NDAD(IMI))%TDIAFILE )
+ END DO
+ !
+ TDIAFILE => LUNIT_MODEL(KMI)%TDIAFILE !Necessary because no call to GOTO_MODEL before needing it
+ !
+ IF (CPROGRAM=='MESONH') THEN
+ IF ( NDAD(KMI) == 1) CDAD_NAME(KMI) = CEXP//'.1.'//CSEG
+ IF ( NDAD(KMI) == 2) CDAD_NAME(KMI) = CEXP//'.2.'//CSEG
+ IF ( NDAD(KMI) == 3) CDAD_NAME(KMI) = CEXP//'.3.'//CSEG
+ IF ( NDAD(KMI) == 4) CDAD_NAME(KMI) = CEXP//'.4.'//CSEG
+ IF ( NDAD(KMI) == 5) CDAD_NAME(KMI) = CEXP//'.5.'//CSEG
+ IF ( NDAD(KMI) == 6) CDAD_NAME(KMI) = CEXP//'.6.'//CSEG
+ IF ( NDAD(KMI) == 7) CDAD_NAME(KMI) = CEXP//'.7.'//CSEG
+ IF ( NDAD(KMI) == 8) CDAD_NAME(KMI) = CEXP//'.8.'//CSEG
+ END IF
+ELSE
+ ALLOCATE(XUM(0,0,0))
+ ALLOCATE(XVM(0,0,0))
+ ALLOCATE(XWM(0,0,0))
+ ALLOCATE(XDUM(0,0,0))
+ ALLOCATE(XDVM(0,0,0))
+ ALLOCATE(XDWM(0,0,0))
+END IF
+!
+!-------------------------------------------------------------------------------
+!
+!* 7. INITIALIZE GRIDS AND METRIC COEFFICIENTS
+! ----------------------------------------
+!
+CALL SET_GRID(KMI,TPINIFILE,IKU,NIMAX_ll,NJMAX_ll, &
+ XTSTEP,XSEGLEN, &
+ XLONORI,XLATORI,XLON,XLAT, &
+ XXHAT,XYHAT,XDXHAT,XDYHAT, XMAP, &
+ XZS,XZZ,XZHAT,XZTOP,LSLEVE,XLEN1,XLEN2,XZSMT, &
+ ZJ, &
+ TDTMOD,TDTCUR,NSTOP,NBAK_NUMB,NOUT_NUMB,TBACKUPN,TOUTPUTN)
+!
+CALL METRICS(XMAP,XDXHAT,XDYHAT,XZZ,XDXX,XDYY,XDZX,XDZY,XDZZ)
+!
+!* update halos of metric coefficients
+!
+!
+CALL UPDATE_METRICS(CLBCX,CLBCY,XDXX,XDYY,XDZX,XDZY,XDZZ)
+!
+!
+CALL SET_DIRCOS(CLBCX,CLBCY,XDXX,XDYY,XDZX,XDZY,TZINITHALO2D_ll, &
+ XDIRCOSXW,XDIRCOSYW,XDIRCOSZW,XCOSSLOPE,XSINSLOPE )
+!
+! grid nesting initializations
+IF ( KMI == 1 ) THEN
+ XTSTEP_MODEL1=XTSTEP
+END IF
+!
+NDT_2_WAY(KMI)=4
+!
+!-------------------------------------------------------------------------------
+!
+!* 8. INITIALIZE DATA FOR JVALUES AND AEROSOLS
+!
+IF ( LUSECHEM .OR. LCHEMDIAG ) THEN
+ IF ((KMI==1).AND.(CPROGRAM == "MESONH".OR.CPROGRAM == "DIAG ")) &
+ CALL CH_INIT_JVALUES(TDTCUR%TDATE%DAY, TDTCUR%TDATE%MONTH, &
+ TDTCUR%TDATE%YEAR, ILUOUT, XCH_TUV_DOBNEW)
+!
+ IF (LORILAM) THEN
+ CALL CH_AER_MOD_INIT
+ ENDIF
+END IF
+IF (.NOT.(ASSOCIATED(XMI))) ALLOCATE(XMI(0,0,0,0))
+IF (.NOT.(ASSOCIATED(XSOLORG))) ALLOCATE(XSOLORG(0,0,0,0))
+!
+IF (CCLOUD=='LIMA') CALL INIT_AEROSOL_PROPERTIES
+!
+!-------------------------------------------------------------------------------
+!
+!* 9. INITIALIZE THE PROGNOSTIC FIELDS
+! --------------------------------
+!
+CALL MPPDB_CHECK3D(XUT,"INI_MODEL_N-before read_field::XUT",PRECISION)
+CALL READ_FIELD(TPINIFILE,IIU,IJU,IKU, &
+ CGETTKET,CGETRVT,CGETRCT,CGETRRT,CGETRIT,CGETCIT,CGETZWS, &
+ CGETRST,CGETRGT,CGETRHT,CGETSVT,CGETSRCT,CGETSIGS,CGETCLDFR, &
+ CGETBL_DEPTH,CGETSBL_DEPTH,CGETPHC,CGETPHR,CUVW_ADV_SCHEME, &
+ CTEMP_SCHEME,NSIZELBX_ll,NSIZELBXU_ll,NSIZELBY_ll,NSIZELBYV_ll,&
+ NSIZELBXTKE_ll,NSIZELBYTKE_ll, &
+ NSIZELBXR_ll,NSIZELBYR_ll,NSIZELBXSV_ll,NSIZELBYSV_ll, &
+ XUM,XVM,XWM,XDUM,XDVM,XDWM, &
+ XUT,XVT,XWT,XTHT,XPABST,XTKET,XRTKEMS, &
+ XRT,XSVT,XZWS,XCIT,XDRYMASST, &
+ XSIGS,XSRCT,XCLDFR,XBL_DEPTH,XSBL_DEPTH,XWTHVMF,XPHC,XPHR, &
+ XLSUM,XLSVM,XLSWM,XLSTHM,XLSRVM,XLSZWSM, &
+ XLBXUM,XLBXVM,XLBXWM,XLBXTHM,XLBXTKEM, &
+ XLBXRM,XLBXSVM, &
+ XLBYUM,XLBYVM,XLBYWM,XLBYTHM,XLBYTKEM, &
+ XLBYRM,XLBYSVM, &
+ NFRC,TDTFRC,XUFRC,XVFRC,XWFRC,XTHFRC,XRVFRC, &
+ XTENDTHFRC,XTENDRVFRC,XGXTHFRC,XGYTHFRC, &
+ XPGROUNDFRC, XATC, &
+ XTENDUFRC, XTENDVFRC, &
+ NADVFRC,TDTADVFRC,XDTHFRC,XDRVFRC, &
+ NRELFRC,TDTRELFRC,XTHREL,XRVREL, &
+ XVTH_FLUX_M,XWTH_FLUX_M,XVU_FLUX_M, &
+ XRUS_PRES,XRVS_PRES,XRWS_PRES,XRTHS_CLD,XRRS_CLD,XRSVS_CLD )
+!
+!-------------------------------------------------------------------------------
+!
+!
+!* 10. INITIALIZE REFERENCE STATE
+! ---------------------------
+!
+!
+CALL SET_REF(KMI,TPINIFILE, &
+ XZZ,XZHAT,ZJ,XDXX,XDYY,CLBCX,CLBCY, &
+ XREFMASS,XMASS_O_PHI0,XLINMASS, &
+ XRHODREF,XTHVREF,XRVREF,XEXNREF,XRHODJ )
+!
+!-------------------------------------------------------------------------------
+!
+!* 10.1 INITIALIZE THE TURBULENCE VARIABLES
+! -----------------------------------
+!
+IF ((CTURB == 'TKEL').AND.(CCONF=='START')) THEN
+ CALL MPPDB_CHECK3D(XUT,"INI_MODEL_N-before ini_tke_eps::XUT",PRECISION)
+ CALL INI_TKE_EPS(CGETTKET,XTHVREF,XZZ, &
+ XUT,XVT,XTHT, &
+ XTKET,TZINITHALO3D_ll )
+ CALL MPPDB_CHECK3D(XUT,"INI_MODEL_N-after ini_tke_eps::XUT",PRECISION)
+END IF
+!
+!
+!* 10.2 INITIALIZE THE LES VARIABLES
+! ----------------------------
+!
+CALL INI_LES_n
+!
+!-------------------------------------------------------------------------------
+!
+!* 11. INITIALIZE THE SOURCE OF TOTAL DRY MASS Md
+! ------------------------------------------
+!
+IF((KMI==1).AND.LSTEADYLS) THEN
+ XDRYMASSS = 0.
+END IF
+!
+!-------------------------------------------------------------------------------
+!
+!* 12. INITIALIZE THE MICROPHYSICS
+! ----------------------------
+!
+IF (CELEC == 'NONE') THEN
+ CALL INI_MICRO_n(TPINIFILE,ILUOUT)
+!
+!-------------------------------------------------------------------------------
+!
+!* 13. INITIALIZE THE ATMOSPHERIC ELECTRICITY
+! --------------------------------------
+!
+ELSE
+ CALL INI_ELEC_n(ILUOUT, CELEC, CCLOUD, TPINIFILE, &
+ XTSTEP, XZZ, &
+ XDXX, XDYY, XDZZ, XDZX, XDZY )
+!
+ WRITE (UNIT=ILUOUT,&
+ FMT='(/,"ELECTRIC VARIABLES ARE BETWEEN INDEX",I2," AND ",I2)')&
+ NSV_ELECBEG, NSV_ELECEND
+!
+ IF( CGETSVT(NSV_ELECBEG)=='INIT' ) THEN
+ XSVT(:,:,:,NSV_ELECBEG) = XCION_POS_FW(:,:,:) ! Nb/kg
+ XSVT(:,:,:,NSV_ELECEND) = XCION_NEG_FW(:,:,:)
+!
+ XSVT(:,:,:,NSV_ELECBEG+1:NSV_ELECEND-1) = 0.0
+ ELSE ! Convert elec_variables per m3 into elec_variables per kg of air
+ DO JSV = NSV_ELECBEG, NSV_ELECEND
+ XSVT(:,:,:,JSV) = XSVT(:,:,:,JSV) / XRHODREF(:,:,:)
+ ENDDO
+ END IF
+END IF
+!
+!-------------------------------------------------------------------------------
+!
+!* 14. INITIALIZE THE LARGE SCALE SOURCES
+! ----------------------------------
+!
+IF ((KMI==1).AND.(.NOT. LSTEADYLS)) THEN
+ CALL MPPDB_CHECK3D(XUT,"INI_MODEL_N-before ini_cpl::XUT",PRECISION)
+ CALL INI_CPL(NSTOP,XTSTEP,LSTEADYLS,CCONF, &
+ CGETTKET, &
+ CGETRVT,CGETRCT,CGETRRT,CGETRIT, &
+ CGETRST,CGETRGT,CGETRHT,CGETSVT,LCH_INIT_FIELD, &
+ NSV,NIMAX_ll,NJMAX_ll, &
+ NSIZELBX_ll,NSIZELBXU_ll,NSIZELBY_ll,NSIZELBYV_ll, &
+ NSIZELBXTKE_ll,NSIZELBYTKE_ll, &
+ NSIZELBXR_ll,NSIZELBYR_ll,NSIZELBXSV_ll,NSIZELBYSV_ll, &
+ XLSUM,XLSVM,XLSWM,XLSTHM,XLSRVM,XLSZWSM,XDRYMASST, &
+ XLBXUM,XLBXVM,XLBXWM,XLBXTHM,XLBXTKEM,XLBXRM,XLBXSVM, &
+ XLBYUM,XLBYVM,XLBYWM,XLBYTHM,XLBYTKEM,XLBYRM,XLBYSVM, &
+ XLSUS,XLSVS,XLSWS,XLSTHS,XLSRVS,XLSZWSS,XDRYMASSS, &
+ XLBXUS,XLBXVS,XLBXWS,XLBXTHS,XLBXTKES,XLBXRS,XLBXSVS, &
+ XLBYUS,XLBYVS,XLBYWS,XLBYTHS,XLBYTKES,XLBYRS,XLBYSVS )
+ CALL MPPDB_CHECK3D(XUT,"INI_MODEL_N-after ini_cpl::XUT",PRECISION)
+!
+ DO JSV=NSV_CHEMBEG,NSV_CHEMEND
+ XLBXSVS(:,:,:,JSV)=MAX(XLBXSVS(:,:,:,JSV),0.)
+ XLBYSVS(:,:,:,JSV)=MAX(XLBYSVS(:,:,:,JSV),0.)
+ ENDDO
+ !
+ DO JSV=NSV_LNOXBEG,NSV_LNOXEND
+ XLBXSVS(:,:,:,JSV)=MAX(XLBXSVS(:,:,:,JSV),0.)
+ XLBYSVS(:,:,:,JSV)=MAX(XLBYSVS(:,:,:,JSV),0.)
+ ENDDO
+ !
+ DO JSV=NSV_AERBEG,NSV_AEREND
+ XLBXSVS(:,:,:,JSV)=MAX(XLBXSVS(:,:,:,JSV),0.)
+ XLBYSVS(:,:,:,JSV)=MAX(XLBYSVS(:,:,:,JSV),0.)
+ ENDDO
+ !
+ DO JSV=NSV_DSTBEG,NSV_DSTEND
+ XLBXSVS(:,:,:,JSV)=MAX(XLBXSVS(:,:,:,JSV),0.)
+ XLBYSVS(:,:,:,JSV)=MAX(XLBYSVS(:,:,:,JSV),0.)
+ ENDDO
+ !
+ DO JSV=NSV_DSTDEPBEG,NSV_DSTDEPEND
+ XLBXSVS(:,:,:,JSV)=MAX(XLBXSVS(:,:,:,JSV),0.)
+ XLBYSVS(:,:,:,JSV)=MAX(XLBYSVS(:,:,:,JSV),0.)
+ ENDDO
+ !
+ DO JSV=NSV_SLTBEG,NSV_SLTEND
+ XLBXSVS(:,:,:,JSV)=MAX(XLBXSVS(:,:,:,JSV),0.)
+ XLBYSVS(:,:,:,JSV)=MAX(XLBYSVS(:,:,:,JSV),0.)
+ ENDDO
+ !
+ DO JSV=NSV_SLTDEPBEG,NSV_SLTDEPEND
+ XLBXSVS(:,:,:,JSV)=MAX(XLBXSVS(:,:,:,JSV),0.)
+ XLBYSVS(:,:,:,JSV)=MAX(XLBYSVS(:,:,:,JSV),0.)
+ ENDDO
+ !
+ DO JSV=NSV_PPBEG,NSV_PPEND
+ XLBXSVS(:,:,:,JSV)=MAX(XLBXSVS(:,:,:,JSV),0.)
+ XLBYSVS(:,:,:,JSV)=MAX(XLBYSVS(:,:,:,JSV),0.)
+ ENDDO
+ !
+#ifdef MNH_FOREFIRE
+ DO JSV=NSV_FFBEG,NSV_FFEND
+ XLBXSVS(:,:,:,JSV)=MAX(XLBXSVS(:,:,:,JSV),0.)
+ XLBYSVS(:,:,:,JSV)=MAX(XLBYSVS(:,:,:,JSV),0.)
+ ENDDO
+ !
+#endif
+ DO JSV=NSV_CSBEG,NSV_CSEND
+ XLBXSVS(:,:,:,JSV)=MAX(XLBXSVS(:,:,:,JSV),0.)
+ XLBYSVS(:,:,:,JSV)=MAX(XLBYSVS(:,:,:,JSV),0.)
+ ENDDO
+!
+END IF
+ALLOCATE(XLSZWSM(IIU,IJU)) ; XLSZWSM = -1.
+!
+IF ( KMI > 1) THEN
+ ! Use dummy pointers to correct an ifort BUG
+ DPTR_XBMX1=>XBMX1
+ DPTR_XBMX2=>XBMX2
+ DPTR_XBMX3=>XBMX3
+ DPTR_XBMX4=>XBMX4
+ DPTR_XBMY1=>XBMY1
+ DPTR_XBMY2=>XBMY2
+ DPTR_XBMY3=>XBMY3
+ DPTR_XBMY4=>XBMY4
+ DPTR_XBFX1=>XBFX1
+ DPTR_XBFX2=>XBFX2
+ DPTR_XBFX3=>XBFX3
+ DPTR_XBFX4=>XBFX4
+ DPTR_XBFY1=>XBFY1
+ DPTR_XBFY2=>XBFY2
+ DPTR_XBFY3=>XBFY3
+ DPTR_XBFY4=>XBFY4
+ DPTR_CLBCX=>CLBCX
+ DPTR_CLBCY=>CLBCY
+ !
+ DPTR_XZZ=>XZZ
+ DPTR_XZHAT=>XZHAT
+ DPTR_XLSUM=>XLSUM
+ DPTR_XLSVM=>XLSVM
+ DPTR_XLSWM=>XLSWM
+ DPTR_XLSTHM=>XLSTHM
+ DPTR_XLSRVM=>XLSRVM
+ DPTR_XLSZWSM=>XLSZWSM
+ DPTR_XLSUS=>XLSUS
+ DPTR_XLSVS=>XLSVS
+ DPTR_XLSWS=>XLSWS
+ DPTR_XLSTHS=>XLSTHS
+ DPTR_XLSRVS=>XLSRVS
+ DPTR_XLSZWSS=>XLSZWSS
+ !
+ DPTR_NKLIN_LBXU=>NKLIN_LBXU
+ DPTR_XCOEFLIN_LBXU=>XCOEFLIN_LBXU
+ DPTR_NKLIN_LBYU=>NKLIN_LBYU
+ DPTR_XCOEFLIN_LBYU=>XCOEFLIN_LBYU
+ DPTR_NKLIN_LBXV=>NKLIN_LBXV
+ DPTR_XCOEFLIN_LBXV=>XCOEFLIN_LBXV
+ DPTR_NKLIN_LBYV=>NKLIN_LBYV
+ DPTR_XCOEFLIN_LBYV=>XCOEFLIN_LBYV
+ DPTR_NKLIN_LBXW=>NKLIN_LBXW
+ DPTR_XCOEFLIN_LBXW=>XCOEFLIN_LBXW
+ DPTR_NKLIN_LBYW=>NKLIN_LBYW
+ DPTR_XCOEFLIN_LBYW=>XCOEFLIN_LBYW
+ DPTR_NKLIN_LBXM=>NKLIN_LBXM
+ DPTR_XCOEFLIN_LBXM=>XCOEFLIN_LBXM
+ DPTR_NKLIN_LBYM=>NKLIN_LBYM
+ DPTR_XCOEFLIN_LBYM=>XCOEFLIN_LBYM
+ !
+ CALL INI_SPAWN_LS_n(NDAD(KMI),XTSTEP,KMI, &
+ DPTR_XBMX1,DPTR_XBMX2,DPTR_XBMX3,DPTR_XBMX4,DPTR_XBMY1,DPTR_XBMY2,DPTR_XBMY3,DPTR_XBMY4, &
+ DPTR_XBFX1,DPTR_XBFX2,DPTR_XBFX3,DPTR_XBFX4,DPTR_XBFY1,DPTR_XBFY2,DPTR_XBFY3,DPTR_XBFY4, &
+ NDXRATIO_ALL(KMI),NDYRATIO_ALL(KMI), &
+ DPTR_CLBCX,DPTR_CLBCY,DPTR_XZZ,DPTR_XZHAT, &
+ LSLEVE,XLEN1,XLEN2, &
+ DPTR_XLSUM,DPTR_XLSVM,DPTR_XLSWM,DPTR_XLSTHM,DPTR_XLSRVM,DPTR_XLSZWSM, &
+ DPTR_XLSUS,DPTR_XLSVS,DPTR_XLSWS,DPTR_XLSTHS,DPTR_XLSRVS,DPTR_XLSZWSS, &
+ DPTR_NKLIN_LBXU,DPTR_XCOEFLIN_LBXU,DPTR_NKLIN_LBYU,DPTR_XCOEFLIN_LBYU, &
+ DPTR_NKLIN_LBXV,DPTR_XCOEFLIN_LBXV,DPTR_NKLIN_LBYV,DPTR_XCOEFLIN_LBYV, &
+ DPTR_NKLIN_LBXW,DPTR_XCOEFLIN_LBXW,DPTR_NKLIN_LBYW,DPTR_XCOEFLIN_LBYW, &
+ DPTR_NKLIN_LBXM,DPTR_XCOEFLIN_LBXM,DPTR_NKLIN_LBYM,DPTR_XCOEFLIN_LBYM )
+ !
+ DPTR_XLBXUM=>XLBXUM
+ DPTR_XLBYUM=>XLBYUM
+ DPTR_XLBXVM=>XLBXVM
+ DPTR_XLBYVM=>XLBYVM
+ DPTR_XLBXWM=>XLBXWM
+ DPTR_XLBYWM=>XLBYWM
+ DPTR_XLBXTHM=>XLBXTHM
+ DPTR_XLBYTHM=>XLBYTHM
+ DPTR_XLBXTKEM=>XLBXTKEM
+ DPTR_XLBYTKEM=>XLBYTKEM
+ DPTR_XLBXRM=>XLBXRM
+ DPTR_XLBYRM=>XLBYRM
+ DPTR_XLBXSVM=>XLBXSVM
+ DPTR_XLBYSVM=>XLBYSVM
+ CALL INI_ONE_WAY_n(NDAD(KMI),KMI, &
+ DPTR_XBMX1,DPTR_XBMX2,DPTR_XBMX3,DPTR_XBMX4,DPTR_XBMY1,DPTR_XBMY2,DPTR_XBMY3,DPTR_XBMY4, &
+ DPTR_XBFX1,DPTR_XBFX2,DPTR_XBFX3,DPTR_XBFX4,DPTR_XBFY1,DPTR_XBFY2,DPTR_XBFY3,DPTR_XBFY4, &
+ NDXRATIO_ALL(KMI),NDYRATIO_ALL(KMI), &
+ DPTR_CLBCX,DPTR_CLBCY,NRIMX,NRIMY, &
+ DPTR_NKLIN_LBXU,DPTR_XCOEFLIN_LBXU,DPTR_NKLIN_LBYU,DPTR_XCOEFLIN_LBYU, &
+ DPTR_NKLIN_LBXV,DPTR_XCOEFLIN_LBXV,DPTR_NKLIN_LBYV,DPTR_XCOEFLIN_LBYV, &
+ DPTR_NKLIN_LBXW,DPTR_XCOEFLIN_LBXW,DPTR_NKLIN_LBYW,DPTR_XCOEFLIN_LBYW, &
+ DPTR_NKLIN_LBXM,DPTR_XCOEFLIN_LBXM,DPTR_NKLIN_LBYM,DPTR_XCOEFLIN_LBYM, &
+ CCLOUD, LUSECHAQ, LUSECHIC, &
+ DPTR_XLBXUM,DPTR_XLBYUM,DPTR_XLBXVM,DPTR_XLBYVM,DPTR_XLBXWM,DPTR_XLBYWM, &
+ DPTR_XLBXTHM,DPTR_XLBYTHM, &
+ DPTR_XLBXTKEM,DPTR_XLBYTKEM, &
+ DPTR_XLBXRM,DPTR_XLBYRM,DPTR_XLBXSVM,DPTR_XLBYSVM )
+END IF
+!
+!
+!-------------------------------------------------------------------------------
+!
+!* 15. INITIALIZE THE SCALAR VARIABLES
+! -------------------------------
+!
+IF (LLG .AND. LINIT_LG .AND. CPROGRAM=='MESONH') &
+ CALL INI_LG(XXHAT,XYHAT,XZZ,XSVT,XLBXSVM,XLBYSVM)
+
+!
+!-------------------------------------------------------------------------------
+!
+!* 16. INITIALIZE THE PARAMETERS FOR THE DYNAMICS
+! ------------------------------------------
+!
+CALL INI_DYNAMICS(XLON,XLAT,XRHODJ,XTHVREF,XMAP,XZZ,XDXHAT,XDYHAT, &
+ XZHAT,CLBCX,CLBCY,XTSTEP,CPRESOPT, &
+ LVE_RELAX,LVE_RELAX_GRD,LHORELAX_UVWTH,LHORELAX_RV, &
+ LHORELAX_RC,LHORELAX_RR,LHORELAX_RI,LHORELAX_RS,LHORELAX_RG, &
+ LHORELAX_RH,LHORELAX_TKE,LHORELAX_SV, &
+ LHORELAX_SVC2R2,LHORELAX_SVC1R3,LHORELAX_SVELEC,LHORELAX_SVLG, &
+ LHORELAX_SVCHEM,LHORELAX_SVAER,LHORELAX_SVDST,LHORELAX_SVSLT, &
+ LHORELAX_SVPP,LHORELAX_SVCS,LHORELAX_SVCHIC,LHORELAX_SVSNW, &
+#ifdef MNH_FOREFIRE
+ LHORELAX_SVFF, &
+#endif
+ XRIMKMAX,NRIMX,NRIMY, &
+ XALKTOP,XALKGRD,XALZBOT,XALZBAS, &
+ XT4DIFU,XT4DIFTH,XT4DIFSV, &
+ XCORIOX,XCORIOY,XCORIOZ,XCURVX,XCURVY, &
+ XDXHATM,XDYHATM,XRHOM,XAF,XBFY,XCF,XTRIGSX,XTRIGSY,NIFAXX,NIFAXY,&
+ XALK,XALKW,NALBOT,XALKBAS,XALKWBAS,NALBAS, &
+ LMASK_RELAX,XKURELAX,XKVRELAX,XKWRELAX, &
+ XDK2U,XDK4U,XDK2TH,XDK4TH,XDK2SV,XDK4SV, &
+ LZDIFFU,XZDIFFU_HALO2, &
+ XBFB,XBF_SXP2_YP1_Z, &
+ XAF_ZS,XBF_ZS,XCF_ZS, &
+ XDXATH_ZS,XDYATH_ZS,XRHO_ZS, &
+ XA_K,XB_K,XC_K,XD_K )
+!
+!
+!* 16.1 Initialize the XDRAG array
+! -------------
+IF (LDRAG) THEN
+ CALL INI_DRAG(LMOUNT,XZS,XHSTART,NSTART,XDRAG)
+ENDIF
+!-------------------------------------------------------------------------------
+!
+!* 17. SURFACE FIELDS
+! --------------
+!
+!* 17.1 Radiative setup
+! ---------------
+!
+IF (CRAD /= 'NONE') THEN
+ IF (CGETRAD =='INIT') THEN
+ GINIRAD =.TRUE.
+ ELSE
+ GINIRAD =.FALSE.
+ END IF
+ CALL INI_RADIATIONS(TPINIFILE,GINIRAD,TDTCUR,TDTEXP,XZZ, &
+ XDXX, XDYY, &
+ XSINDEL,XCOSDEL,XTSIDER,XCORSOL, &
+ XSLOPANG,XSLOPAZI, &
+ XDTHRAD,XDIRFLASWD,XSCAFLASWD, &
+ XFLALWD,XDIRSRFSWD,NCLEARCOL_TM1, &
+ XZENITH,XAZIM, &
+ TDTRAD_FULL,TDTRAD_CLONLY, &
+ TZINITHALO2D_ll, &
+ XRADEFF,XSWU,XSWD,XLWU, &
+ XLWD,XDTHRADSW,XDTHRADLW )
+ !
+ IF (GINIRAD) CALL SUNPOS_n(XZENITH,PAZIMSOL=XAZIM)
+ CALL SURF_SOLAR_GEOM (XZS, XZS_XY)
+ !
+ ALLOCATE(XXHAT_ll (IIU_ll))
+ ALLOCATE(XYHAT_ll (IJU_ll))
+ ALLOCATE(XZS_ll (IIU_ll,IJU_ll))
+ ALLOCATE(XZS_XY_ll (IIU_ll,IJU_ll))
+ !
+ CALL GATHERALL_FIELD_ll('XY',XZS,XZS_ll,IRESP)
+ CALL GATHERALL_FIELD_ll('XY',XZS_XY,XZS_XY_ll,IRESP)
+ CALL GATHERALL_FIELD_ll('XX',XXHAT,XXHAT_ll,IRESP)
+ CALL GATHERALL_FIELD_ll('YY',XYHAT,XYHAT_ll,IRESP)
+ XZS_MAX_ll=MAXVAL(XZS_ll)
+ELSE
+ XAZIM = XPI
+ XZENITH = XPI/2.
+ XDIRSRFSWD = 0.
+ XSCAFLASWD = 0.
+ XFLALWD = 300. ! W/m2
+ XTSIDER = 0.
+END IF
+!
+!
+CALL INI_SW_SETUP (CRAD,NSWB_MNH,XSW_BANDS)
+CALL INI_LW_SETUP (CRAD,NLWB_MNH,XLW_BANDS)
+!
+!
+! 17.1.1 Special initialisation for CO2 content
+! CO2 (molar mass=44) horizontally and vertically homogeneous at 360 ppm
+!
+XCCO2 = 360.0E-06 * 44.0E-03 / XMD
+#ifdef MNH_ECRAD
+RCCO2 = 360.0E-06 * 44.0E-03 / XMD
+#endif
+!
+!
+!* 17.2 Externalized surface fields
+! ---------------------------
+!
+ALLOCATE(ZCO2(IIU,IJU))
+ZCO2(:,:) = XCCO2
+!
+
+ALLOCATE(ZDIR_ALB(IIU,IJU,NSWB_MNH))
+ALLOCATE(ZSCA_ALB(IIU,IJU,NSWB_MNH))
+ALLOCATE(ZEMIS (IIU,IJU,NLWB_MNH))
+ALLOCATE(ZTSRAD (IIU,IJU))
+!
+IF ((TPINIFILE%NMNHVERSION(1)==4 .AND. TPINIFILE%NMNHVERSION(2)>=6) .OR. TPINIFILE%NMNHVERSION(1)>4) THEN
+ CALL IO_Field_read(TPINIFILE,'SURF',CSURF)
+ELSE
+ CSURF = "EXTE"
+END IF
+!
+!
+IF (CSURF=='EXTE' .AND. (CPROGRAM=='MESONH' .OR. CPROGRAM=='DIAG ')) THEN
+ ! ouverture du fichier PGD
+ IF ( LEN_TRIM(CINIFILEPGD) > 0 ) THEN
+ CALL IO_File_add2list(TINIFILEPGD,TRIM(CINIFILEPGD),'PGD','READ',KLFITYPE=2,KLFIVERB=NVERB)
+ CALL IO_File_open(TINIFILEPGD,KRESP=IRESP)
+ LUNIT_MODEL(KMI)%TINIFILEPGD => TINIFILEPGD
+ IF (IRESP/=0) THEN
+ WRITE(ILUOUT,FMT=*) "INI_MODEL_n ERROR TO OPEN THE FILE CINIFILEPGD=",CINIFILEPGD
+ WRITE(ILUOUT,FMT=*) "CHECK YOUR NAMELIST NAM_LUNITn"
+ !callabortstop
+ CALL PRINT_MSG(NVERB_FATAL,'GEN','INI_MODEL_n','')
+ ENDIF
+ ELSE
+ ! case after a spawning
+ CINIFILEPGD = TPINIFILE%CNAME
+ END IF
+ !
+ CALL GOTO_SURFEX(KMI)
+#ifdef CPLOASIS
+ CALL SFX_OASIS_READ_NAM(CPROGRAM,XTSTEP)
+ WRITE(*,*) 'SFX-OASIS: READ NAM_SFX_SEA_CPL OK'
+#endif
+ !* initialization of surface
+ CALL INIT_GROUND_PARAM_n ('ALL',SIZE(CSV),CSV,ZCO2, &
+ XZENITH,XAZIM,XSW_BANDS,XLW_BANDS,ZDIR_ALB,ZSCA_ALB, &
+ ZEMIS,ZTSRAD )
+ !
+ IF (SIZE(XEMIS)>0) THEN
+ XDIR_ALB = ZDIR_ALB
+ XSCA_ALB = ZSCA_ALB
+ XEMIS = ZEMIS
+ XTSRAD = ZTSRAD
+ CALL MNHGET_SURF_PARAM_n (PSEA=XSEA)
+ END IF
+ELSE
+ !* fields not physically necessary, but must be initialized
+ IF (SIZE(XEMIS)>0) THEN
+ XDIR_ALB = 0.
+ XSCA_ALB = 0.
+ XEMIS = 1.
+ XTSRAD = XTT
+ XSEA = 1.
+ END IF
+
+END IF
+IF (CSURF=='EXTE' .AND. (CPROGRAM=='SPAWN ')) THEN
+ ! ouverture du fichier PGD
+ CALL IO_File_add2list(TINIFILEPGD,TRIM(CINIFILEPGD),'PGD','READ',KLFITYPE=2,KLFIVERB=NVERB)
+ CALL IO_File_open(TINIFILEPGD,KRESP=IRESP)
+ LUNIT_MODEL(KMI)%TINIFILEPGD => TINIFILEPGD
+ IF (IRESP/=0) THEN
+ WRITE(ILUOUT,FMT=*) "INI_MODEL_n ERROR TO OPEN THE FILE CINIFILEPGD=",CINIFILEPGD
+ WRITE(ILUOUT,FMT=*) "CHECK YOUR NAMELIST NAM_LUNIT2_SPA"
+ !callabortstop
+ CALL PRINT_MSG(NVERB_FATAL,'GEN','INI_MODEL_n','')
+ ENDIF
+ENDIF
+!
+IF (.NOT.ASSOCIATED(TINIFILEPGD)) TINIFILEPGD => TFILE_DUMMY
+!
+ !* special case after spawning in prep_real_case
+IF (CSURF=='EXRM' .AND. CPROGRAM=='REAL ') CSURF = 'EXTE'
+!
+DEALLOCATE(ZDIR_ALB)
+DEALLOCATE(ZSCA_ALB)
+DEALLOCATE(ZEMIS )
+DEALLOCATE(ZTSRAD )
+!
+DEALLOCATE(ZCO2)
+!
+!
+!* in a RESTART case, reads surface radiative quantities in the MESONH file
+!
+IF ((CRAD == 'ECMW' .OR. CRAD == 'ECRA') .AND. CGETRAD=='READ') THEN
+ CALL INI_SURF_RAD(TPINIFILE, XDIR_ALB, XSCA_ALB, XEMIS, XTSRAD)
+END IF
+!
+!
+!* 17.3 Mesonh fields
+! -------------
+!
+IF (CPROGRAM/='REAL ') CALL MNHREAD_ZS_DUMMY_n(TINIFILEPGD)
+!
+!-------------------------------------------------------------------------------
+!
+!* 18. INITIALIZE THE PARAMETERS FOR THE PHYSICS
+! -----------------------------------------
+!
+IF (CRAD == 'ECMW') THEN
+!
+!* get cover mask for aerosols
+!
+ IF (CPROGRAM=='MESONH' .OR. CPROGRAM=='DIAG ') THEN
+ ALLOCATE(ZSEA(IIU,IJU))
+ ALLOCATE(ZTOWN(IIU,IJU))
+ ALLOCATE(ZBARE(IIU,IJU))
+ IF (CSURF=='EXTE') THEN
+ CALL GOTO_SURFEX(KMI)
+ CALL MNHGET_SURF_PARAM_n(PSEA=ZSEA,PTOWN=ZTOWN,PBARE=ZBARE)
+ ELSE
+ ZSEA (:,:) = 1.
+ ZTOWN(:,:) = 0.
+ ZBARE(:,:) = 0.
+ END IF
+!
+ IF ( CAOP=='EXPL' .AND. LDUST ) THEN
+ ALLOCATE( XEXT_COEFF_WVL_LKT_DUST( NMAX_RADIUS_LKT_DUST, NMAX_SIGMA_LKT_DUST, NMAX_WVL_SW_DUST ) )
+ ALLOCATE( XEXT_COEFF_550_LKT_DUST( NMAX_RADIUS_LKT_DUST, NMAX_SIGMA_LKT_DUST ) )
+ ALLOCATE( XPIZA_LKT_DUST ( NMAX_RADIUS_LKT_DUST, NMAX_SIGMA_LKT_DUST, NMAX_WVL_SW_DUST ) )
+ ALLOCATE( XCGA_LKT_DUST ( NMAX_RADIUS_LKT_DUST, NMAX_SIGMA_LKT_DUST, NMAX_WVL_SW_DUST ) )
+ END IF
+!
+ IF ( CAOP=='EXPL' .AND. LSALT ) THEN
+ ALLOCATE( XEXT_COEFF_WVL_LKT_SALT( NMAX_RADIUS_LKT_SALT, NMAX_SIGMA_LKT_SALT, NMAX_WVL_SW_SALT ) )
+ ALLOCATE( XEXT_COEFF_550_LKT_SALT( NMAX_RADIUS_LKT_SALT, NMAX_SIGMA_LKT_SALT ) )
+ ALLOCATE( XPIZA_LKT_SALT ( NMAX_RADIUS_LKT_SALT, NMAX_SIGMA_LKT_SALT, NMAX_WVL_SW_SALT ) )
+ ALLOCATE( XCGA_LKT_SALT ( NMAX_RADIUS_LKT_SALT, NMAX_SIGMA_LKT_SALT, NMAX_WVL_SW_SALT ) )
+ END IF
+!
+ CALL INI_RADIATIONS_ECMWF (XZHAT,XPABST,XTHT,XTSRAD,XLAT,XLON,TDTCUR,TDTEXP, &
+ CLW,NDLON,NFLEV,NFLUX,NRAD,NSWB_OLD,CAER,NAER,NSTATM, &
+ XSTATM,ZSEA,ZTOWN,ZBARE,XOZON, XAER,XDST_WL, LSUBG_COND )
+!
+ DEALLOCATE(ZSEA,ZTOWN,ZBARE)
+ ALLOCATE (XAER_CLIM(SIZE(XAER,1),SIZE(XAER,2),SIZE(XAER,3),SIZE(XAER,4)))
+ XAER_CLIM(:,:,:,:) =XAER(:,:,:,:)
+!
+ END IF
+
+ELSE IF (CRAD == 'ECRA') THEN
+#ifdef MNH_ECRAD
+!* get cover mask for aerosols
+!
+ IF (CPROGRAM=='MESONH' .OR. CPROGRAM=='DIAG ') THEN
+ ALLOCATE(ZSEA(IIU,IJU))
+ ALLOCATE(ZTOWN(IIU,IJU))
+ ALLOCATE(ZBARE(IIU,IJU))
+ IF (CSURF=='EXTE') THEN
+ CALL GOTO_SURFEX(KMI)
+ CALL MNHGET_SURF_PARAM_n(PSEA=ZSEA,PTOWN=ZTOWN,PBARE=ZBARE)
+ ELSE
+ ZSEA (:,:) = 1.
+ ZTOWN(:,:) = 0.
+ ZBARE(:,:) = 0.
+ END IF
+!
+ CALL INI_RADIATIONS_ECRAD (XZHAT,XPABST,XTHT,XTSRAD,XLAT,XLON,TDTCUR,TDTEXP, &
+ CLW,NDLON,NFLEV,NFLUX,NRAD,NSWB_OLD,CAER,NAER,NSTATM, &
+ XSTATM,ZSEA,ZTOWN,ZBARE,XOZON, XAER,XDST_WL, LSUBG_COND )
+
+ DEALLOCATE(ZSEA,ZTOWN,ZBARE)
+ ALLOCATE (XAER_CLIM(SIZE(XAER,1),SIZE(XAER,2),SIZE(XAER,3),SIZE(XAER,4)))
+ XAER_CLIM(:,:,:,:) = XAER(:,:,:,:)
+!
+ END IF
+#endif
+ELSE
+ ALLOCATE (XOZON(0,0,0))
+ ALLOCATE (XAER(0,0,0,0))
+ ALLOCATE (XDST_WL(0,0,0,0))
+ ALLOCATE (XAER_CLIM(0,0,0,0))
+END IF
+!
+!
+!
+IF (CDCONV /= 'NONE' .OR. CSCONV == 'KAFR') THEN
+ IF (CGETCONV=='INIT') THEN
+ GINIDCONV=.TRUE.
+ ELSE
+ GINIDCONV=.FALSE.
+ END IF
+!
+! commensurability between convection calling time and time step
+!
+ XDTCONV=XTSTEP*REAL( INT( (MIN(XDTCONV,1800.)+1.E-10)/XTSTEP ) )
+ XDTCONV=MAX( XDTCONV, XTSTEP )
+ IF (NVERB>=10) THEN
+ WRITE(ILUOUT,*) 'XDTCONV has been set to : ',XDTCONV
+ END IF
+ CALL INI_DEEP_CONVECTION (TPINIFILE,GINIDCONV,TDTCUR, &
+ NCOUNTCONV,XDTHCONV,XDRVCONV,XDRCCONV, &
+ XDRICONV,XPRCONV,XPRSCONV,XPACCONV, &
+ XUMFCONV,XDMFCONV,XMFCONV,XPRLFLXCONV,XPRSFLXCONV,&
+ XCAPE,NCLTOPCONV,NCLBASCONV, &
+ TDTDCONV, CGETSVCONV, XDSVCONV, &
+ LCH_CONV_LINOX, XIC_RATE, XCG_RATE, &
+ XIC_TOTAL_NUMBER, XCG_TOTAL_NUMBER )
+
+END IF
+!
+!-------------------------------------------------------------------------------
+!
+!
+!* 19. ALLOCATION OF THE TEMPORAL SERIES
+! ---------------------------------
+!
+IF (LSERIES .AND. CPROGRAM/='DIAG ') CALL INI_SERIES_n
+!
+!-------------------------------------------------------------------------------
+!
+!
+!* 20. (re)initialize scalar variables
+! -------------------------------
+!
+!
+IF ( LUSECHEM .OR. LCHEMDIAG ) THEN
+ IF (CPROGRAM=='MESONH'.AND.CCONF=='RESTA') LCH_INIT_FIELD =.FALSE.
+ IF (CPROGRAM=='MESONH'.OR. CPROGRAM=='DIAG ' .OR. CPROGRAM=='IDEAL ') &
+ CALL CH_INIT_FIELD_n(KMI, ILUOUT, NVERB)
+END IF
+!
+!-------------------------------------------------------------------------------
+!
+!* 21. UPDATE HALO
+! -----------
+!
+!
+CALL UPDATE_HALO_ll(TZINITHALO3D_ll,IINFO_ll)
+CALL UPDATE_HALO_ll(TZINITHALO2D_ll,IINFO_ll)
+CALL CLEANLIST_ll(TZINITHALO3D_ll)
+CALL CLEANLIST_ll(TZINITHALO2D_ll)
+!
+!
+!-------------------------------------------------------------------------------
+!
+!* 22. DEALLOCATION
+! -------------
+!
+DEALLOCATE(ZJ)
+!
+DEALLOCATE(XSTROATM)
+DEALLOCATE(XSMLSATM)
+DEALLOCATE(XSMLWATM)
+DEALLOCATE(XSPOSATM)
+DEALLOCATE(XSPOWATM)
+!
+!-------------------------------------------------------------------------------
+!
+!* 23. BALLOON and AIRCRAFT initializations
+! ------------------------------------
+!
+CALL INI_AIRCRAFT_BALLOON(TPINIFILE,XTSTEP, TDTSEG, XSEGLEN, NRR, NSV, &
+ IKU,CTURB=="TKEL" , &
+ XLATORI, XLONORI )
+!
+!-------------------------------------------------------------------------------
+!
+!* 24. STATION initializations
+! -----------------------
+!
+CALL INI_SURFSTATION_n(XTSTEP, TDTSEG, XSEGLEN, NRR, NSV, &
+ CTURB=="TKEL" , &
+ XLATORI, XLONORI )
+!
+!-------------------------------------------------------------------------------
+!
+!* 25. PROFILER initializations
+! ------------------------
+!
+CALL INI_POSPROFILER_n(XTSTEP, TDTSEG, XSEGLEN, NRR, NSV, &
+ CTURB=="TKEL", &
+ XLATORI, XLONORI )
+!
+!-------------------------------------------------------------------------------
+!
+!* 26. Prognostic aerosols
+! ------------------------
+!
+IF ( ( CRAD=='ECMW' .OR. CRAD=='ECRA' ) .AND. CAOP=='EXPL' .AND. LORILAM ) THEN
+ ALLOCATE(POLYTAU(6,10,8,6,13))
+ ALLOCATE(POLYSSA(6,10,8,6,13))
+ ALLOCATE(POLYG (6,10,8,6,13))
+ CALL INI_AEROSET1
+ CALL INI_AEROSET2
+ CALL INI_AEROSET3
+ CALL INI_AEROSET4
+ CALL INI_AEROSET5
+ CALL INI_AEROSET6
+END IF
+#ifdef MNH_FOREFIRE
+!
+!-------------------------------------------------------------------------------
+!
+!* 27. FOREFIRE initializations
+! ------------------------
+!
+
+! Coupling with ForeFire if resolution is low enough
+!---------------------------------------------------
+IF ( LFOREFIRE .AND. 0.5*(XXHAT(2)-XXHAT(1)+XYHAT(2)-XYHAT(1)) < COUPLINGRES ) THEN
+ FFCOUPLING = .TRUE.
+ELSE
+ FFCOUPLING = .FALSE.
+ENDIF
+
+! Initializing the ForeFire variables
+!------------------------------------
+IF ( LFOREFIRE ) THEN
+ CALL INIT_FOREFIRE_n(KMI, ILUOUT, IP &
+ , TDTCUR%TDATE%YEAR, TDTCUR%TDATE%MONTH, TDTCUR%TDATE%DAY, TDTCUR%TIME, XTSTEP)
+END IF
+#endif
+
+!-------------------------------------------------------------------------------
+!
+!* 30. Total production/Loss for chemical species
+!
+IF (LCHEMDIAG) THEN
+ CALL CH_INIT_PRODLOSSTOT_n(ILUOUT)
+ IF (NEQ_PLT>0) THEN
+ ALLOCATE(XPROD(IIU,IJU,IKU,NEQ_PLT))
+ ALLOCATE(XLOSS(IIU,IJU,IKU,NEQ_PLT))
+ XPROD=0.0
+ XLOSS=0.0
+ ELSE
+ ALLOCATE(XPROD(0,0,0,0))
+ ALLOCATE(XLOSS(0,0,0,0))
+ END IF
+ELSE
+ ALLOCATE(XPROD(0,0,0,0))
+ ALLOCATE(XLOSS(0,0,0,0))
+END IF
+!
+!-------------------------------------------------------------------------------
+!
+!* 31. Extended production/loss terms for chemical species
+!
+IF (LCHEMDIAG) THEN
+ CALL CH_INIT_BUDGET_n(ILUOUT)
+ IF (NEQ_BUDGET>0) THEN
+ ALLOCATE(IINDEX(2,NNONZEROTERMS))
+ ALLOCATE(IIND(NEQ_BUDGET))
+ CALL CH_NONZEROTERMS(KMI,IINDEX,NNONZEROTERMS)
+ ALLOCATE(XTCHEM(NEQ_BUDGET))
+ DO JM=1,NEQ_BUDGET
+ IIND(JM)=COUNT((IINDEX(1,:))==NSPEC_BUDGET(JM))
+ ALLOCATE(XTCHEM(JM)%NB_REAC(IIND(JM)))
+ ALLOCATE(XTCHEM(JM)%XB_REAC(IIU,IJU,IKU,IIND(JM)))
+ END DO
+ DEALLOCATE(IIND)
+ DEALLOCATE(IINDEX)
+ ELSE
+ ALLOCATE(XTCHEM(0))
+ END IF
+ELSE
+ ALLOCATE(XTCHEM(0))
+END IF
+
+END SUBROUTINE INI_MODEL_n
+
diff --git a/src/ZSOLVER/ini_spectren.f90 b/src/ZSOLVER/ini_spectren.f90
new file mode 100644
index 0000000000000000000000000000000000000000..4783443207ecf52aa183b97da09c2f4014f94b58
--- /dev/null
+++ b/src/ZSOLVER/ini_spectren.f90
@@ -0,0 +1,941 @@
+!MNH_LIC Copyright 2015-2019 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.
+!-----------------------------------------------------------------
+! #######################
+ MODULE MODI_INI_SPECTRE_n
+! #######################
+!
+INTERFACE
+!
+ SUBROUTINE INI_SPECTRE_n(KMI,TPINIFILE)
+!
+ USE MODD_IO, ONLY: TFILEDATA
+!
+ INTEGER, INTENT(IN) :: KMI ! Model index
+ TYPE(TFILEDATA), INTENT(IN) :: TPINIFILE ! Initial file
+!
+END SUBROUTINE INI_SPECTRE_n
+!
+END INTERFACE
+!
+END MODULE MODI_INI_SPECTRE_n
+! #######################################
+ SUBROUTINE INI_SPECTRE_n(KMI,TPINIFILE)
+! #######################################
+!
+!!**** *INI_SPECTRE_n* - routine to initialize SPECTRE (based on ini_modeln.f90)
+!!
+!!
+!! AUTHOR
+!! ------
+!! J.P Chaboureau * L.A*
+!! 10/2016 (C.Lac) Cleaning of the modules
+!! Philippe Wautelet: 05/2016-04/2018: new data structures and calls for I/O
+! P. Wautelet 08/02/2019: allocate to zero-size non associated pointers
+! P. Wautelet 14/02/2019: remove CLUOUT/CLUOUT0 and associated variables
+! S. Bielli 02/2019: sea salt: significant sea wave height influences salt emission; 5 salt modes
+! P. Wautelet 10/04/2019: replace ABORT and STOP calls by Print_msg
+! P. Wautelet 19/04/2019: removed unused dummy arguments and variables
+!
+!---------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_ADV_n
+USE MODD_ARGSLIST_ll, ONLY: LIST_ll
+USE MODD_BIKHARDT_n
+USE MODD_BUDGET
+USE MODD_CH_MNHC_n, ONLY: LUSECHAQ, LUSECHIC, LCH_INIT_FIELD
+USE MODD_CH_PH_n
+USE MODD_CLOUD_MF_n
+USE MODD_CST
+USE MODD_CONF
+USE MODD_CONF_n
+USE MODD_CTURB
+USE MODD_CURVCOR_n
+USE MODD_DEEP_CONVECTION_n
+USE MODD_DIM_n
+USE MODD_DRAGTREE
+USE MODD_DUST
+USE MODD_DYN
+USE MODD_DYN_n
+USE MODD_DYNZD
+USE MODD_DYNZD_n
+USE MODD_FIELD_n
+USE MODD_FRC
+USE MODD_FRC_n
+USE MODD_GET_n
+USE MODD_GRID, ONLY: XLONORI,XLATORI
+USE MODD_GRID_n
+USE MODD_IO, ONLY: TFILEDATA
+USE MODD_LBC_n, only: CLBCX, CLBCY
+USE MODD_LSFIELD_n
+USE MODD_LUNIT_n, ONLY: COUTFILE, TLUOUT
+USE MODD_MEAN_FIELD
+USE MODD_MEAN_FIELD_n
+USE MODD_METRICS_n
+USE MODD_NESTING, only: NDAD, NDT_2_WAY, NDXRATIO_ALL, NDYRATIO_ALL
+USE MODD_NSV
+USE MODD_OUT_n
+USE MODD_PARAMETERS
+USE MODD_PARAM_KAFR_n
+USE MODD_PARAM_MFSHALL_n
+USE MODD_PARAM_n
+USE MODD_PASPOL
+USE MODD_PASPOL_n
+USE MODD_BLOWSNOW
+USE MODD_BLOWSNOW_n
+USE MODD_PAST_FIELD_n
+USE MODD_RADIATIONS_n
+USE MODD_REF
+USE MODD_REF_n
+USE MODD_SHADOWS_n
+USE MODD_SPECTRE
+USE MODD_TIME
+USE MODD_TIME_n
+USE MODD_TURB_n
+USE MODD_VAR_ll, ONLY: IP
+!
+USE MODE_GATHER_ll
+USE MODE_INI_ONE_WAY_n
+USE MODE_IO_FIELD_READ, only: IO_Field_read
+USE MODE_ll
+USE MODE_MODELN_HANDLER
+USE MODE_MSG
+USE MODE_SPLITTINGZ_ll, ONLY: GET_DIM_EXTZ_ll
+USE MODE_TYPE_ZDIFFU
+!
+USE MODI_INI_BIKHARDT_n
+USE MODI_INI_CPL
+USE MODI_INI_DYNAMICS
+USE MODI_INI_SPAWN_LS_n
+USE MODI_GET_SIZEX_LB
+USE MODI_GET_SIZEY_LB
+USE MODI_SET_GRID
+USE MODI_METRICS
+USE MODI_SET_REF
+USE MODI_UPDATE_METRICS
+USE MODI_UPDATE_NSV
+!
+IMPLICIT NONE
+!
+!* 0.1 declarations of arguments
+!
+!
+INTEGER, INTENT(IN) :: KMI ! Model index
+TYPE(TFILEDATA), INTENT(IN) :: TPINIFILE ! Initial file
+!
+!* 0.2 declarations of local variables
+!
+INTEGER :: ILUOUT ! Logical unit number of output-listing
+INTEGER :: IIU ! Upper dimension in x direction (local)
+INTEGER :: IJU ! Upper dimension in y direction (local)
+INTEGER :: IIU_ll ! Upper dimension in x direction (global)
+INTEGER :: IJU_ll ! Upper dimension in y direction (global)
+INTEGER :: IKU ! Upper dimension in z direction
+REAL, DIMENSION(:,:,:), ALLOCATABLE :: ZJ ! Jacobian
+!
+!
+TYPE(LIST_ll), POINTER :: TZINITHALO2D_ll ! pointer for the list of 2D fields
+ ! which must be communicated in INIT
+TYPE(LIST_ll), POINTER :: TZINITHALO3D_ll ! pointer for the list of 3D fields
+ ! which must be communicated in INIT
+!
+INTEGER :: IISIZEXF,IJSIZEXF,IISIZEXFU,IJSIZEXFU ! dimensions of the
+INTEGER :: IISIZEX4,IJSIZEX4,IISIZEX2,IJSIZEX2 ! West-east LB arrays
+INTEGER :: IISIZEYF,IJSIZEYF,IISIZEYFV,IJSIZEYFV ! dimensions of the
+INTEGER :: IISIZEY4,IJSIZEY4,IISIZEY2,IJSIZEY2 ! North-south LB arrays
+INTEGER :: IINFO_ll ! Return code of //routines
+INTEGER :: IIY,IJY
+INTEGER :: IIU_B,IJU_B
+INTEGER :: IIU_SXP2_YP1_Z_ll,IJU_SXP2_YP1_Z_ll,IKU_SXP2_YP1_Z_ll
+!
+!------------------------------------------
+! Dummy pointers needed to correct an ifort Bug
+REAL, DIMENSION(:), POINTER :: DPTR_XZHAT
+REAL, DIMENSION(:), POINTER :: DPTR_XBMX1,DPTR_XBMX2,DPTR_XBMX3,DPTR_XBMX4
+REAL, DIMENSION(:), POINTER :: DPTR_XBMY1,DPTR_XBMY2,DPTR_XBMY3,DPTR_XBMY4
+REAL, DIMENSION(:), POINTER :: DPTR_XBFX1,DPTR_XBFX2,DPTR_XBFX3,DPTR_XBFX4
+REAL, DIMENSION(:), POINTER :: DPTR_XBFY1,DPTR_XBFY2,DPTR_XBFY3,DPTR_XBFY4
+CHARACTER(LEN=4), DIMENSION(:), POINTER :: DPTR_CLBCX,DPTR_CLBCY
+INTEGER, DIMENSION(:,:,:), POINTER :: DPTR_NKLIN_LBXU,DPTR_NKLIN_LBYU,DPTR_NKLIN_LBXV,DPTR_NKLIN_LBYV
+INTEGER, DIMENSION(:,:,:), POINTER :: DPTR_NKLIN_LBXW,DPTR_NKLIN_LBYW,DPTR_NKLIN_LBXM,DPTR_NKLIN_LBYM
+REAL, DIMENSION(:,:,:), POINTER :: DPTR_XCOEFLIN_LBXU,DPTR_XCOEFLIN_LBYU
+REAL, DIMENSION(:,:,:), POINTER :: DPTR_XCOEFLIN_LBXV,DPTR_XCOEFLIN_LBYV
+REAL, DIMENSION(:,:,:), POINTER :: DPTR_XCOEFLIN_LBXW,DPTR_XCOEFLIN_LBYW
+REAL, DIMENSION(:,:,:), POINTER :: DPTR_XCOEFLIN_LBXM,DPTR_XCOEFLIN_LBYM
+REAL, DIMENSION(:,:,:), POINTER :: DPTR_XLBXUM,DPTR_XLBYUM,DPTR_XLBXVM,DPTR_XLBYVM
+REAL, DIMENSION(:,:,:), POINTER :: DPTR_XLBXWM,DPTR_XLBYWM,DPTR_XLBXTHM,DPTR_XLBYTHM
+REAL, DIMENSION(:,:,:), POINTER :: DPTR_XLBXTKEM,DPTR_XLBYTKEM
+REAL, DIMENSION(:,:,:,:), POINTER :: DPTR_XLBXSVM,DPTR_XLBYSVM
+REAL, DIMENSION(:,:,:,:), POINTER :: DPTR_XLBXRM,DPTR_XLBYRM
+REAL, DIMENSION(:,:,:), POINTER :: DPTR_XZZ
+REAL, DIMENSION(:,:,:), POINTER :: DPTR_XLSUM,DPTR_XLSVM,DPTR_XLSWM,DPTR_XLSTHM,DPTR_XLSRVM
+REAL, DIMENSION(:,:,:), POINTER :: DPTR_XLSUS,DPTR_XLSVS,DPTR_XLSWS,DPTR_XLSTHS,DPTR_XLSRVS
+REAL, DIMENSION(:,:), POINTER :: DPTR_XLSZWSS,DPTR_XLSZWSM
+!
+!-------------------------------------------------------------------------------
+!
+!* 0. PROLOGUE
+! --------
+!
+NULLIFY(TZINITHALO2D_ll)
+NULLIFY(TZINITHALO3D_ll)
+!
+!* 1. RETRIEVE LOGICAL UNIT NUMBER
+! ----------------------------
+!
+ILUOUT = TLUOUT%NLU
+!
+!-------------------------------------------------------------------------------
+!
+!* 2. END OF READING
+! --------------
+!* 2.1 Read number of forcing fields
+!
+!* 2.2 Checks the position of vertical absorbing layer
+!
+IKU=NKMAX+2*JPVEXT
+!
+ALLOCATE(XZHAT(IKU))
+CALL IO_Field_read(TPINIFILE,'ZHAT',XZHAT)
+CALL IO_Field_read(TPINIFILE,'ZTOP',XZTOP)
+IF (XALZBOT>=XZHAT(IKU) .AND. LVE_RELAX) THEN
+ WRITE(ILUOUT,FMT=*) "INI_SPECTRE_n ERROR: you want to use vertical relaxation"
+ WRITE(ILUOUT,FMT=*) " but bottom of layer XALZBOT(",XALZBOT,")"
+ WRITE(ILUOUT,FMT=*) " is upper than model top (",XZHAT(IKU),")"
+!callabortstop
+ CALL PRINT_MSG(NVERB_FATAL,'GEN','INI_SPECTRE_n','')
+END IF
+IF (LVE_RELAX) THEN
+ IF (XALZBOT>=XZHAT(IKU-4) ) THEN
+ WRITE(ILUOUT,FMT=*) "INI_SPECTRE_n WARNING: you want to use vertical relaxation"
+ WRITE(ILUOUT,FMT=*) " but the layer defined by XALZBOT(",XALZBOT,")"
+ WRITE(ILUOUT,FMT=*) " contains less than 5 model levels"
+ END IF
+END IF
+DEALLOCATE(XZHAT)
+!
+!* 2.3 Compute sizes of arrays of the extended sub-domain
+!
+CALL GET_DIM_EXT_ll('B',IIU,IJU)
+IIU_ll=NIMAX_ll + 2 * JPHEXT
+IJU_ll=NJMAX_ll + 2 * JPHEXT
+! initialize NIMAX and NJMAX for not updated versions regarding the parallelism
+! spawning,...
+CALL GET_DIM_PHYS_ll('B',NIMAX,NJMAX)
+!
+NRR=1
+NRRL=0
+NRRI=0
+IF (NVERB >= 5) THEN
+ WRITE (UNIT=ILUOUT,FMT='("THERE ARE ",I2," WATER VARIABLES")') NRR
+ WRITE (UNIT=ILUOUT,FMT='("THERE ARE ",I2," LIQUID VARIABLES")') NRRL
+ WRITE (UNIT=ILUOUT,FMT='("THERE ARE ",I2," SOLID VARIABLES")') NRRI
+END IF
+!
+!* 2.3 Update NSV and floating indices for the current model
+!
+!
+CALL UPDATE_NSV(KMI)
+!
+!-------------------------------------------------------------------------------
+!
+!* 3. ALLOCATE MEMORY
+! -----------------
+!
+!* 3.2 Module MODD_GRID_n and MODD_METRICS_n
+!
+IF (LCARTESIAN) THEN
+ ALLOCATE(XLON(0,0))
+ ALLOCATE(XLAT(0,0))
+ ALLOCATE(XMAP(0,0))
+ELSE
+ ALLOCATE(XLON(IIU,IJU))
+ ALLOCATE(XLAT(IIU,IJU))
+ ALLOCATE(XMAP(IIU,IJU))
+END IF
+ALLOCATE(XXHAT(IIU))
+ALLOCATE(XDXHAT(IIU))
+ALLOCATE(XYHAT(IJU))
+ALLOCATE(XDYHAT(IJU))
+ALLOCATE(XZS(IIU,IJU))
+ALLOCATE(XZSMT(IIU,IJU))
+ALLOCATE(XZZ(IIU,IJU,IKU))
+ALLOCATE(XZHAT(IKU))
+!
+ALLOCATE(XDXX(IIU,IJU,IKU))
+ALLOCATE(XDYY(IIU,IJU,IKU))
+ALLOCATE(XDZX(IIU,IJU,IKU))
+ALLOCATE(XDZY(IIU,IJU,IKU))
+ALLOCATE(XDZZ(IIU,IJU,IKU))
+!
+!* 3.3 Modules MODD_REF and MODD_REF_n
+!
+IF (KMI == 1) THEN
+ ALLOCATE(XRHODREFZ(IKU),XTHVREFZ(IKU))
+END IF
+ALLOCATE(XRHODREF(IIU,IJU,IKU))
+ALLOCATE(XTHVREF(IIU,IJU,IKU))
+ALLOCATE(XEXNREF(IIU,IJU,IKU))
+ALLOCATE(XRHODJ(IIU,IJU,IKU))
+IF (CEQNSYS=='DUR' .AND. LUSERV) THEN
+ ALLOCATE(XRVREF(IIU,IJU,IKU))
+ELSE
+ ALLOCATE(XRVREF(0,0,0))
+END IF
+!
+!* 3.4 Module MODD_CURVCOR_n
+!
+IF (LTHINSHELL) THEN
+ ALLOCATE(XCORIOX(0,0))
+ ALLOCATE(XCORIOY(0,0))
+ELSE
+ ALLOCATE(XCORIOX(IIU,IJU))
+ ALLOCATE(XCORIOY(IIU,IJU))
+END IF
+ ALLOCATE(XCORIOZ(IIU,IJU))
+IF (LCARTESIAN) THEN
+ ALLOCATE(XCURVX(0,0))
+ ALLOCATE(XCURVY(0,0))
+ELSE
+ ALLOCATE(XCURVX(IIU,IJU))
+ ALLOCATE(XCURVY(IIU,IJU))
+END IF
+!
+!* 3.5 Module MODD_DYN_n
+!
+CALL GET_DIM_EXT_ll('Y',IIY,IJY)
+IF (L2D) THEN
+ ALLOCATE(XBFY(IIY,IJY,IKU))
+ELSE
+ ALLOCATE(XBFY(IJY,IIY,IKU)) ! transposition needed by the optimisition of the
+ ! FFT solver
+END IF
+CALL GET_DIM_EXT_ll('B',IIU_B,IJU_B)
+ALLOCATE(XBFB(IIU_B,IJU_B,IKU))
+CALL GET_DIM_EXTZ_ll('SXP2_YP1_Z',IIU_SXP2_YP1_Z_ll,IJU_SXP2_YP1_Z_ll,IKU_SXP2_YP1_Z_ll)
+ALLOCATE(XBF_SXP2_YP1_Z(IIU_SXP2_YP1_Z_ll,IJU_SXP2_YP1_Z_ll,IKU_SXP2_YP1_Z_ll))
+ALLOCATE(XAF(IKU),XCF(IKU))
+ALLOCATE(XTRIGSX(3*IIU_ll))
+ALLOCATE(XTRIGSY(3*IJU_ll))
+ALLOCATE(XRHOM(IKU))
+ALLOCATE(XALK(IKU))
+ALLOCATE(XALKW(IKU))
+!
+IF ( LHORELAX_UVWTH .OR. LHORELAX_RV .OR. &
+ LHORELAX_RC .OR. LHORELAX_RR .OR. LHORELAX_RI .OR. LHORELAX_RS .OR. &
+ LHORELAX_RG .OR. LHORELAX_RH .OR. LHORELAX_TKE .OR. &
+ ANY(LHORELAX_SV) ) THEN
+ ALLOCATE(XKURELAX(IIU,IJU))
+ ALLOCATE(XKVRELAX(IIU,IJU))
+ ALLOCATE(XKWRELAX(IIU,IJU))
+ ALLOCATE(LMASK_RELAX(IIU,IJU))
+ELSE
+ ALLOCATE(XKURELAX(0,0))
+ ALLOCATE(XKVRELAX(0,0))
+ ALLOCATE(XKWRELAX(0,0))
+ ALLOCATE(LMASK_RELAX(0,0))
+END IF
+!
+! Additional fields for truly horizontal diffusion (Module MODD_DYNZD$n)
+IF (LZDIFFU) THEN
+ CALL INIT_TYPE_ZDIFFU_HALO2(XZDIFFU_HALO2)
+ELSE
+ CALL INIT_TYPE_ZDIFFU_HALO2(XZDIFFU_HALO2,0)
+ENDIF
+!
+!* 3.6 Larger Scale variables (Module MODD_LSFIELD$n)
+!
+!
+! upper relaxation part
+!
+ALLOCATE(XLSUM(IIU,IJU,IKU)) ; XLSUM = 0.0
+ALLOCATE(XLSVM(IIU,IJU,IKU)) ; XLSVM = 0.0
+ALLOCATE(XLSWM(IIU,IJU,IKU)) ; XLSWM = 0.0
+ALLOCATE(XLSTHM(IIU,IJU,IKU)) ; XLSTHM = 0.0
+IF ( NRR > 0 ) THEN
+ ALLOCATE(XLSRVM(IIU,IJU,IKU)) ; XLSRVM = 0.0
+ELSE
+ ALLOCATE(XLSRVM(0,0,0))
+END IF
+!
+! lbc part
+!
+IF ( L1D) THEN ! 1D case
+!
+ NSIZELBX_ll=0
+ NSIZELBXU_ll=0
+ NSIZELBY_ll=0
+ NSIZELBYV_ll=0
+ NSIZELBXTKE_ll=0
+ NSIZELBXR_ll=0
+ NSIZELBXSV_ll=0
+ NSIZELBYTKE_ll=0
+ NSIZELBYR_ll=0
+ NSIZELBYSV_ll=0
+ ALLOCATE(XLBXUM(0,0,0))
+ ALLOCATE(XLBYUM(0,0,0))
+ ALLOCATE(XLBXVM(0,0,0))
+ ALLOCATE(XLBYVM(0,0,0))
+ ALLOCATE(XLBXWM(0,0,0))
+ ALLOCATE(XLBYWM(0,0,0))
+ ALLOCATE(XLBXTHM(0,0,0))
+ ALLOCATE(XLBYTHM(0,0,0))
+ ALLOCATE(XLBXTKEM(0,0,0))
+ ALLOCATE(XLBYTKEM(0,0,0))
+ ALLOCATE(XLBXRM(0,0,0,0))
+ ALLOCATE(XLBYRM(0,0,0,0))
+ ALLOCATE(XLBXSVM(0,0,0,0))
+ ALLOCATE(XLBYSVM(0,0,0,0))
+!
+ELSEIF( L2D ) THEN ! 2D case
+!
+ NSIZELBY_ll=0
+ NSIZELBYV_ll=0
+ NSIZELBYTKE_ll=0
+ NSIZELBYR_ll=0
+ NSIZELBYSV_ll=0
+ ALLOCATE(XLBYUM(0,0,0))
+ ALLOCATE(XLBYVM(0,0,0))
+ ALLOCATE(XLBYWM(0,0,0))
+ ALLOCATE(XLBYTHM(0,0,0))
+ ALLOCATE(XLBYTKEM(0,0,0))
+ ALLOCATE(XLBYRM(0,0,0,0))
+ ALLOCATE(XLBYSVM(0,0,0,0))
+!
+ CALL GET_SIZEX_LB(NIMAX_ll,NJMAX_ll,NRIMX, &
+ IISIZEXF,IJSIZEXF,IISIZEXFU,IJSIZEXFU, &
+ IISIZEX4,IJSIZEX4,IISIZEX2,IJSIZEX2)
+!
+ IF ( LHORELAX_UVWTH ) THEN
+ NSIZELBX_ll=2*NRIMX+2
+ NSIZELBXU_ll=2*NRIMX+2
+ ALLOCATE(XLBXUM(IISIZEXFU,IJSIZEXFU,IKU))
+ ALLOCATE(XLBXVM(IISIZEXF,IJSIZEXF,IKU))
+ ALLOCATE(XLBXWM(IISIZEXF,IJSIZEXF,IKU))
+ ALLOCATE(XLBXTHM(IISIZEXF,IJSIZEXF,IKU))
+ ELSE
+ NSIZELBX_ll=2
+ NSIZELBXU_ll=4
+ ALLOCATE(XLBXUM(IISIZEX4,IJSIZEX4,IKU))
+ ALLOCATE(XLBXVM(IISIZEX2,IJSIZEX2,IKU))
+ ALLOCATE(XLBXWM(IISIZEX2,IJSIZEX2,IKU))
+ ALLOCATE(XLBXTHM(IISIZEX2,IJSIZEX2,IKU))
+ END IF
+!
+ IF (CTURB /= 'NONE') THEN
+ IF ( LHORELAX_TKE) THEN
+ NSIZELBXTKE_ll=2* NRIMX+2
+ ALLOCATE(XLBXTKEM(IISIZEXF,IJSIZEXF,IKU))
+ ELSE
+ NSIZELBXTKE_ll=2
+ ALLOCATE(XLBXTKEM(IISIZEX2,IJSIZEX2,IKU))
+ END IF
+ ELSE
+ NSIZELBXTKE_ll=0
+ ALLOCATE(XLBXTKEM(0,0,0))
+ END IF
+ !
+ IF ( NRR > 0 ) THEN
+ IF (LHORELAX_RV .OR. LHORELAX_RC .OR. LHORELAX_RR .OR. LHORELAX_RI &
+ .OR. LHORELAX_RS .OR. LHORELAX_RG .OR. LHORELAX_RH &
+ ) THEN
+ NSIZELBXR_ll=2* NRIMX+2
+ ALLOCATE(XLBXRM(IISIZEXF,IJSIZEXF,IKU,NRR))
+ ELSE
+ NSIZELBXR_ll=2
+ ALLOCATE(XLBXRM(IISIZEX2,IJSIZEX2,IKU,NRR))
+ ENDIF
+ ELSE
+ NSIZELBXR_ll=0
+ ALLOCATE(XLBXRM(0,0,0,0))
+ END IF
+ !
+ IF ( NSV > 0 ) THEN
+ IF ( ANY( LHORELAX_SV(:)) ) THEN
+ NSIZELBXSV_ll=2* NRIMX+2
+ ALLOCATE(XLBXSVM(IISIZEXF,IJSIZEXF,IKU,NSV))
+ ELSE
+ NSIZELBXSV_ll=2
+ ALLOCATE(XLBXSVM(IISIZEX2,IJSIZEX2,IKU,NSV))
+ END IF
+ ELSE
+ NSIZELBXSV_ll=0
+ ALLOCATE(XLBXSVM(0,0,0,0))
+ END IF
+!
+ELSE ! 3D case
+!
+!
+ CALL GET_SIZEX_LB(NIMAX_ll,NJMAX_ll,NRIMX, &
+ IISIZEXF,IJSIZEXF,IISIZEXFU,IJSIZEXFU, &
+ IISIZEX4,IJSIZEX4,IISIZEX2,IJSIZEX2)
+ CALL GET_SIZEY_LB(NIMAX_ll,NJMAX_ll,NRIMY, &
+ IISIZEYF,IJSIZEYF,IISIZEYFV,IJSIZEYFV, &
+ IISIZEY4,IJSIZEY4,IISIZEY2,IJSIZEY2)
+!
+! check if local domain not to small for NRIMX NRIMY
+!
+ IF ( CLBCX(1) /= 'CYCL' ) THEN
+ IF ( NRIMX+2*JPHEXT .GE. IIU ) THEN
+ WRITE(*,'(A,I8,A/A,2I8,/A)') "Processor=", IP-1, &
+ " :: INI_SPECTRE_n ERROR: ( NRIMX+2*JPHEXT >= IIU ) ", &
+ " Local domain to small for relaxation NRIMX+2*JPHEXT,IIU ", &
+ NRIMX+2*JPHEXT,IIU ,&
+ " change relaxation parameters or number of processors "
+ call Print_msg(NVERB_FATAL,'GEN','INI_SPECTRE_n','')
+ END IF
+ END IF
+ IF ( CLBCY(1) /= 'CYCL' ) THEN
+ IF ( NRIMY+2*JPHEXT .GE. IJU ) THEN
+ WRITE(*,'(A,I8,A/A,2I8,/A)') "Processor=", IP-1, &
+ " :: INI_SPECTRE_n ERROR: ( NRIMY+2*JPHEXT >= IJU ) ", &
+ " Local domain to small for relaxation NRIMY+2*JPHEXT,IJU ", &
+ NRIMY+2*JPHEXT,IJU ,&
+ " change relaxation parameters or number of processors "
+ call Print_msg(NVERB_FATAL,'GEN','INI_SPECTRE_n','')
+ END IF
+ END IF
+IF ( LHORELAX_UVWTH ) THEN
+ NSIZELBX_ll=2*NRIMX+2
+ NSIZELBXU_ll=2*NRIMX+2
+ NSIZELBY_ll=2*NRIMY+2
+ NSIZELBYV_ll=2*NRIMY+2
+ ALLOCATE(XLBXUM(IISIZEXFU,IJSIZEXFU,IKU))
+ ALLOCATE(XLBYUM(IISIZEYF,IJSIZEYF,IKU))
+ ALLOCATE(XLBXVM(IISIZEXF,IJSIZEXF,IKU))
+ ALLOCATE(XLBYVM(IISIZEYFV,IJSIZEYFV,IKU))
+ ALLOCATE(XLBXWM(IISIZEXF,IJSIZEXF,IKU))
+ ALLOCATE(XLBYWM(IISIZEYF,IJSIZEYF,IKU))
+ ALLOCATE(XLBXTHM(IISIZEXF,IJSIZEXF,IKU))
+ ALLOCATE(XLBYTHM(IISIZEYF,IJSIZEYF,IKU))
+ ELSE
+ NSIZELBX_ll=2
+ NSIZELBXU_ll=4
+ NSIZELBY_ll=2
+ NSIZELBYV_ll=4
+ ALLOCATE(XLBXUM(IISIZEX4,IJSIZEX4,IKU))
+ ALLOCATE(XLBYUM(IISIZEY2,IJSIZEY2,IKU))
+ ALLOCATE(XLBXVM(IISIZEX2,IJSIZEX2,IKU))
+ ALLOCATE(XLBYVM(IISIZEY4,IJSIZEY4,IKU))
+ ALLOCATE(XLBXWM(IISIZEX2,IJSIZEX2,IKU))
+ ALLOCATE(XLBYWM(IISIZEY2,IJSIZEY2,IKU))
+ ALLOCATE(XLBXTHM(IISIZEX2,IJSIZEX2,IKU))
+ ALLOCATE(XLBYTHM(IISIZEY2,IJSIZEY2,IKU))
+ END IF
+ !
+ IF (CTURB /= 'NONE') THEN
+ IF ( LHORELAX_TKE) THEN
+ NSIZELBXTKE_ll=2*NRIMX+2
+ NSIZELBYTKE_ll=2*NRIMY+2
+ ALLOCATE(XLBXTKEM(IISIZEXF,IJSIZEXF,IKU))
+ ALLOCATE(XLBYTKEM(IISIZEYF,IJSIZEYF,IKU))
+ ELSE
+ NSIZELBXTKE_ll=2
+ NSIZELBYTKE_ll=2
+ ALLOCATE(XLBXTKEM(IISIZEX2,IJSIZEX2,IKU))
+ ALLOCATE(XLBYTKEM(IISIZEY2,IJSIZEY2,IKU))
+ END IF
+ ELSE
+ NSIZELBXTKE_ll=0
+ NSIZELBYTKE_ll=0
+ ALLOCATE(XLBXTKEM(0,0,0))
+ ALLOCATE(XLBYTKEM(0,0,0))
+ END IF
+ !
+ IF ( NRR > 0 ) THEN
+ IF (LHORELAX_RV .OR. LHORELAX_RC .OR. LHORELAX_RR .OR. LHORELAX_RI &
+ .OR. LHORELAX_RS .OR. LHORELAX_RG .OR. LHORELAX_RH &
+ ) THEN
+ NSIZELBXR_ll=2*NRIMX+2
+ NSIZELBYR_ll=2*NRIMY+2
+ ALLOCATE(XLBXRM(IISIZEXF,IJSIZEXF,IKU,NRR))
+ ALLOCATE(XLBYRM(IISIZEYF,IJSIZEYF,IKU,NRR))
+ ELSE
+ NSIZELBXR_ll=2
+ NSIZELBYR_ll=2
+ ALLOCATE(XLBXRM(IISIZEX2,IJSIZEX2,IKU,NRR))
+ ALLOCATE(XLBYRM(IISIZEY2,IJSIZEY2,IKU,NRR))
+ ENDIF
+ ELSE
+ NSIZELBXR_ll=0
+ NSIZELBYR_ll=0
+ ALLOCATE(XLBXRM(0,0,0,0))
+ ALLOCATE(XLBYRM(0,0,0,0))
+ END IF
+ !
+ IF ( NSV > 0 ) THEN
+ IF ( ANY( LHORELAX_SV(:)) ) THEN
+ NSIZELBXSV_ll=2*NRIMX+2
+ NSIZELBYSV_ll=2*NRIMY+2
+ ALLOCATE(XLBXSVM(IISIZEXF,IJSIZEXF,IKU,NSV))
+ ALLOCATE(XLBYSVM(IISIZEYF,IJSIZEYF,IKU,NSV))
+ ELSE
+ NSIZELBXSV_ll=2
+ NSIZELBYSV_ll=2
+ ALLOCATE(XLBXSVM(IISIZEX2,IJSIZEX2,IKU,NSV))
+ ALLOCATE(XLBYSVM(IISIZEY2,IJSIZEY2,IKU,NSV))
+ END IF
+ ELSE
+ NSIZELBXSV_ll=0
+ NSIZELBYSV_ll=0
+ ALLOCATE(XLBXSVM(0,0,0,0))
+ ALLOCATE(XLBYSVM(0,0,0,0))
+ END IF
+END IF ! END OF THE IF STRUCTURE ON THE MODEL DIMENSION
+!
+!
+IF ( KMI > 1 ) THEN
+ ! it has been assumed that the THeta field used the largest rim area compared
+ ! to the others prognostic variables, if it is not the case, you must change
+ ! these lines
+ ALLOCATE(XCOEFLIN_LBXM(SIZE(XLBXTHM,1),SIZE(XLBXTHM,2),SIZE(XLBXTHM,3)))
+ ALLOCATE( NKLIN_LBXM(SIZE(XLBXTHM,1),SIZE(XLBXTHM,2),SIZE(XLBXTHM,3)))
+ ALLOCATE(XCOEFLIN_LBYM(SIZE(XLBYTHM,1),SIZE(XLBYTHM,2),SIZE(XLBYTHM,3)))
+ ALLOCATE( NKLIN_LBYM(SIZE(XLBYTHM,1),SIZE(XLBYTHM,2),SIZE(XLBYTHM,3)))
+ ALLOCATE(XCOEFLIN_LBXU(SIZE(XLBXUM,1),SIZE(XLBXUM,2),SIZE(XLBXUM,3)))
+ ALLOCATE( NKLIN_LBXU(SIZE(XLBXUM,1),SIZE(XLBXUM,2),SIZE(XLBXUM,3)))
+ ALLOCATE(XCOEFLIN_LBYU(SIZE(XLBYUM,1),SIZE(XLBYUM,2),SIZE(XLBYUM,3)))
+ ALLOCATE( NKLIN_LBYU(SIZE(XLBYUM,1),SIZE(XLBYUM,2),SIZE(XLBYUM,3)))
+ ALLOCATE(XCOEFLIN_LBXV(SIZE(XLBXVM,1),SIZE(XLBXVM,2),SIZE(XLBXVM,3)))
+ ALLOCATE( NKLIN_LBXV(SIZE(XLBXVM,1),SIZE(XLBXVM,2),SIZE(XLBXVM,3)))
+ ALLOCATE(XCOEFLIN_LBYV(SIZE(XLBYVM,1),SIZE(XLBYVM,2),SIZE(XLBYVM,3)))
+ ALLOCATE( NKLIN_LBYV(SIZE(XLBYVM,1),SIZE(XLBYVM,2),SIZE(XLBYVM,3)))
+ ALLOCATE(XCOEFLIN_LBXW(SIZE(XLBXWM,1),SIZE(XLBXWM,2),SIZE(XLBXWM,3)))
+ ALLOCATE( NKLIN_LBXW(SIZE(XLBXWM,1),SIZE(XLBXWM,2),SIZE(XLBXWM,3)))
+ ALLOCATE(XCOEFLIN_LBYW(SIZE(XLBYWM,1),SIZE(XLBYWM,2),SIZE(XLBYWM,3)))
+ ALLOCATE( NKLIN_LBYW(SIZE(XLBYWM,1),SIZE(XLBYWM,2),SIZE(XLBYWM,3)))
+END IF
+!
+! allocation of the LS fields for vertical relaxation and numerical diffusion
+IF( .NOT. LSTEADYLS ) THEN
+!
+ ALLOCATE(XLSUS(SIZE(XLSUM,1),SIZE(XLSUM,2),SIZE(XLSUM,3)))
+ ALLOCATE(XLSVS(SIZE(XLSVM,1),SIZE(XLSVM,2),SIZE(XLSVM,3)))
+ ALLOCATE(XLSWS(SIZE(XLSWM,1),SIZE(XLSWM,2),SIZE(XLSWM,3)))
+ ALLOCATE(XLSTHS(SIZE(XLSTHM,1),SIZE(XLSTHM,2),SIZE(XLSTHM,3)))
+ ALLOCATE(XLSRVS(SIZE(XLSRVM,1),SIZE(XLSRVM,2),SIZE(XLSRVM,3)))
+!
+ELSE
+!
+ ALLOCATE(XLSUS(0,0,0))
+ ALLOCATE(XLSVS(0,0,0))
+ ALLOCATE(XLSWS(0,0,0))
+ ALLOCATE(XLSTHS(0,0,0))
+ ALLOCATE(XLSRVS(0,0,0))
+!
+END IF
+! allocation of the LB fields for horizontal relaxation and Lateral Boundaries
+IF( .NOT. ( LSTEADYLS .AND. KMI==1 ) ) THEN
+!
+ ALLOCATE(XLBXTKES(SIZE(XLBXTKEM,1),SIZE(XLBXTKEM,2),SIZE(XLBXTKEM,3)))
+ ALLOCATE(XLBYTKES(SIZE(XLBYTKEM,1),SIZE(XLBYTKEM,2),SIZE(XLBYTKEM,3)))
+ ALLOCATE(XLBXUS(SIZE(XLBXUM,1),SIZE(XLBXUM,2),SIZE(XLBXUM,3)))
+ ALLOCATE(XLBYUS(SIZE(XLBYUM,1),SIZE(XLBYUM,2),SIZE(XLBYUM,3)))
+ ALLOCATE(XLBXVS(SIZE(XLBXVM,1),SIZE(XLBXVM,2),SIZE(XLBXVM,3)))
+ ALLOCATE(XLBYVS(SIZE(XLBYVM,1),SIZE(XLBYVM,2),SIZE(XLBYVM,3)))
+ ALLOCATE(XLBXWS(SIZE(XLBXWM,1),SIZE(XLBXWM,2),SIZE(XLBXWM,3)))
+ ALLOCATE(XLBYWS(SIZE(XLBYWM,1),SIZE(XLBYWM,2),SIZE(XLBYWM,3)))
+ ALLOCATE(XLBXTHS(SIZE(XLBXTHM,1),SIZE(XLBXTHM,2),SIZE(XLBXTHM,3)))
+ ALLOCATE(XLBYTHS(SIZE(XLBYTHM,1),SIZE(XLBYTHM,2),SIZE(XLBYTHM,3)))
+ ALLOCATE(XLBXRS(SIZE(XLBXRM,1),SIZE(XLBXRM,2),SIZE(XLBXRM,3),SIZE(XLBXRM,4)))
+ ALLOCATE(XLBYRS(SIZE(XLBYRM,1),SIZE(XLBYRM,2),SIZE(XLBYRM,3),SIZE(XLBYRM,4)))
+ ALLOCATE(XLBXSVS(SIZE(XLBXSVM,1),SIZE(XLBXSVM,2),SIZE(XLBXSVM,3),SIZE(XLBXSVM,4)))
+ ALLOCATE(XLBYSVS(SIZE(XLBYSVM,1),SIZE(XLBYSVM,2),SIZE(XLBYSVM,3),SIZE(XLBYSVM,4)))
+!
+ELSE
+!
+ ALLOCATE(XLBXTKES(0,0,0))
+ ALLOCATE(XLBYTKES(0,0,0))
+ ALLOCATE(XLBXUS(0,0,0))
+ ALLOCATE(XLBYUS(0,0,0))
+ ALLOCATE(XLBXVS(0,0,0))
+ ALLOCATE(XLBYVS(0,0,0))
+ ALLOCATE(XLBXWS(0,0,0))
+ ALLOCATE(XLBYWS(0,0,0))
+ ALLOCATE(XLBXTHS(0,0,0))
+ ALLOCATE(XLBYTHS(0,0,0))
+ ALLOCATE(XLBXRS(0,0,0,0))
+ ALLOCATE(XLBYRS(0,0,0,0))
+ ALLOCATE(XLBXSVS(0,0,0,0))
+ ALLOCATE(XLBYSVS(0,0,0,0))
+!
+END IF
+!
+!* 3.9 Local variables
+!
+ALLOCATE(ZJ(IIU,IJU,IKU))
+!
+!-------------------------------------------------------------------------------
+!
+!
+!* 5. INITIALIZE INTERPOLATION COEFFICIENTS
+!
+CALL INI_BIKHARDT_n (NDXRATIO_ALL(KMI),NDYRATIO_ALL(KMI),KMI)
+!
+!-------------------------------------------------------------------------------
+!
+!* 6. INITIALIZE GRIDS AND METRIC COEFFICIENTS
+! ----------------------------------------
+!
+CALL SET_GRID(KMI,TPINIFILE,IKU,NIMAX_ll,NJMAX_ll, &
+ XTSTEP,XSEGLEN, &
+ XLONORI,XLATORI,XLON,XLAT, &
+ XXHAT,XYHAT,XDXHAT,XDYHAT, XMAP, &
+ XZS,XZZ,XZHAT,XZTOP,LSLEVE,XLEN1,XLEN2,XZSMT, &
+ ZJ, &
+ TDTMOD,TDTCUR,NSTOP,NBAK_NUMB,NOUT_NUMB,TBACKUPN,TOUTPUTN)
+!
+CALL METRICS(XMAP,XDXHAT,XDYHAT,XZZ,XDXX,XDYY,XDZX,XDZY,XDZZ)
+!
+!* update halos of metric coefficients
+!
+!
+CALL UPDATE_METRICS(CLBCX,CLBCY,XDXX,XDYY,XDZX,XDZY,XDZZ)
+!
+!
+! grid nesting initializations
+IF ( KMI == 1 ) THEN
+ XTSTEP_MODEL1=XTSTEP
+END IF
+!
+NDT_2_WAY(KMI)=4
+!
+!-------------------------------------------------------------------------------
+!
+!* 8. INITIALIZE THE PROGNOSTIC FIELDS
+! --------------------------------
+!
+
+IF (LSPECTRE_U) THEN
+ ALLOCATE(XUT(IIU,IJU,IKU)) ; XUT = 0.0
+ CALL IO_Field_read(TPINIFILE,'UT',XUT)
+END IF
+!
+IF (LSPECTRE_V) THEN
+ ALLOCATE(XVT(IIU,IJU,IKU)) ; XVT = 0.0
+ CALL IO_Field_read(TPINIFILE,'VT',XVT)
+END IF
+!
+IF (LSPECTRE_W) THEN
+ ALLOCATE(XWT(IIU,IJU,IKU)) ; XWT = 0.0
+ CALL IO_Field_read(TPINIFILE,'WT',XWT)
+END IF
+!
+IF (LSPECTRE_TH) THEN
+ ALLOCATE(XTHT(IIU,IJU,IKU)) ; XTHT = 0.0
+ CALL IO_Field_read(TPINIFILE,'THT',XTHT)
+END IF
+!
+IF (LSPECTRE_RV) THEN
+ ALLOCATE(XRT(IIU,IJU,IKU,NRR))
+ CALL IO_Field_read(TPINIFILE,'RVT',XRT(:,:,:,1))
+END IF
+!
+!-------------------------------------------------------------------------------
+!
+!
+!* 9. INITIALIZE REFERENCE STATE
+! ---------------------------
+!
+!
+CALL SET_REF(KMI,TPINIFILE, &
+ XZZ,XZHAT,ZJ,XDXX,XDYY,CLBCX,CLBCY, &
+ XREFMASS,XMASS_O_PHI0,XLINMASS, &
+ XRHODREF,XTHVREF,XRVREF,XEXNREF,XRHODJ)
+!-------------------------------------------------------------------------------
+!
+!* 11. INITIALIZE THE SOURCE OF TOTAL DRY MASS Md
+! ------------------------------------------
+!
+IF((KMI==1).AND.LSTEADYLS) THEN
+ XDRYMASSS = 0.
+END IF
+!
+!
+!-------------------------------------------------------------------------------
+!
+!* 14. INITIALIZE THE LARGE SCALE SOURCES
+! ----------------------------------
+!
+IF ((KMI==1).AND.(.NOT. LSTEADYLS)) THEN
+ IF (LSPECTRE_LSU.OR.LSPECTRE_LSV.OR.LSPECTRE_LSW.OR. &
+ LSPECTRE_LSRV.OR.LSPECTRE_LSTH) THEN
+ CALL INI_CPL(NSTOP,XTSTEP,LSTEADYLS,CCONF, &
+ CGETTKET, &
+ CGETRVT,CGETRCT,CGETRRT,CGETRIT, &
+ CGETRST,CGETRGT,CGETRHT,CGETSVT,LCH_INIT_FIELD, &
+ NSV,NIMAX_ll,NJMAX_ll, &
+ NSIZELBX_ll,NSIZELBXU_ll,NSIZELBY_ll,NSIZELBYV_ll, &
+ NSIZELBXTKE_ll,NSIZELBYTKE_ll, &
+ NSIZELBXR_ll,NSIZELBYR_ll,NSIZELBXSV_ll,NSIZELBYSV_ll, &
+ XLSUM,XLSVM,XLSWM,XLSTHM,XLSRVM,XLSZWSM,XDRYMASST, &
+ XLBXUM,XLBXVM,XLBXWM,XLBXTHM,XLBXTKEM,XLBXRM,XLBXSVM, &
+ XLBYUM,XLBYVM,XLBYWM,XLBYTHM,XLBYTKEM,XLBYRM,XLBYSVM, &
+ XLSUS,XLSVS,XLSWS,XLSTHS,XLSRVS,XLSZWSS,XDRYMASSS, &
+ XLBXUS,XLBXVS,XLBXWS,XLBXTHS,XLBXTKES,XLBXRS,XLBXSVS, &
+ XLBYUS,XLBYVS,XLBYWS,XLBYTHS,XLBYTKES,XLBYRS,XLBYSVS )
+ END IF
+END IF
+!
+IF ( KMI > 1) THEN
+ ! Use dummy pointers to correct an ifort BUG
+ DPTR_XBMX1=>XBMX1
+ DPTR_XBMX2=>XBMX2
+ DPTR_XBMX3=>XBMX3
+ DPTR_XBMX4=>XBMX4
+ DPTR_XBMY1=>XBMY1
+ DPTR_XBMY2=>XBMY2
+ DPTR_XBMY3=>XBMY3
+ DPTR_XBMY4=>XBMY4
+ DPTR_XBFX1=>XBFX1
+ DPTR_XBFX2=>XBFX2
+ DPTR_XBFX3=>XBFX3
+ DPTR_XBFX4=>XBFX4
+ DPTR_XBFY1=>XBFY1
+ DPTR_XBFY2=>XBFY2
+ DPTR_XBFY3=>XBFY3
+ DPTR_XBFY4=>XBFY4
+ DPTR_CLBCX=>CLBCX
+ DPTR_CLBCY=>CLBCY
+ !
+ DPTR_XZZ=>XZZ
+ DPTR_XZHAT=>XZHAT
+ DPTR_XLSUM=>XLSUM
+ DPTR_XLSVM=>XLSVM
+ DPTR_XLSWM=>XLSWM
+ DPTR_XLSTHM=>XLSTHM
+ DPTR_XLSRVM=>XLSRVM
+ DPTR_XLSZWSM=>XLSZWSM
+ DPTR_XLSUS=>XLSUS
+ DPTR_XLSVS=>XLSVS
+ DPTR_XLSWS=>XLSWS
+ DPTR_XLSTHS=>XLSTHS
+ DPTR_XLSRVS=>XLSRVS
+ DPTR_XLSZWSS=>XLSZWSS
+ !
+ DPTR_NKLIN_LBXU=>NKLIN_LBXU
+ DPTR_XCOEFLIN_LBXU=>XCOEFLIN_LBXU
+ DPTR_NKLIN_LBYU=>NKLIN_LBYU
+ DPTR_XCOEFLIN_LBYU=>XCOEFLIN_LBYU
+ DPTR_NKLIN_LBXV=>NKLIN_LBXV
+ DPTR_XCOEFLIN_LBXV=>XCOEFLIN_LBXV
+ DPTR_NKLIN_LBYV=>NKLIN_LBYV
+ DPTR_XCOEFLIN_LBYV=>XCOEFLIN_LBYV
+ DPTR_NKLIN_LBXW=>NKLIN_LBXW
+ DPTR_XCOEFLIN_LBXW=>XCOEFLIN_LBXW
+ DPTR_NKLIN_LBYW=>NKLIN_LBYW
+ DPTR_XCOEFLIN_LBYW=>XCOEFLIN_LBYW
+ DPTR_NKLIN_LBXM=>NKLIN_LBXM
+ DPTR_XCOEFLIN_LBXM=>XCOEFLIN_LBXM
+ DPTR_NKLIN_LBYM=>NKLIN_LBYM
+ DPTR_XCOEFLIN_LBYM=>XCOEFLIN_LBYM
+ !
+ CALL INI_SPAWN_LS_n(NDAD(KMI),XTSTEP,KMI, &
+ DPTR_XBMX1,DPTR_XBMX2,DPTR_XBMX3,DPTR_XBMX4,DPTR_XBMY1,DPTR_XBMY2,DPTR_XBMY3,DPTR_XBMY4, &
+ DPTR_XBFX1,DPTR_XBFX2,DPTR_XBFX3,DPTR_XBFX4,DPTR_XBFY1,DPTR_XBFY2,DPTR_XBFY3,DPTR_XBFY4, &
+ NDXRATIO_ALL(KMI),NDYRATIO_ALL(KMI), &
+ DPTR_CLBCX,DPTR_CLBCY,DPTR_XZZ,DPTR_XZHAT, &
+ LSLEVE,XLEN1,XLEN2, &
+ DPTR_XLSUM,DPTR_XLSVM,DPTR_XLSWM,DPTR_XLSTHM,DPTR_XLSRVM,DPTR_XLSZWSM, &
+ DPTR_XLSUS,DPTR_XLSVS,DPTR_XLSWS,DPTR_XLSTHS,DPTR_XLSRVS,DPTR_XLSZWSS, &
+ DPTR_NKLIN_LBXU,DPTR_XCOEFLIN_LBXU,DPTR_NKLIN_LBYU,DPTR_XCOEFLIN_LBYU, &
+ DPTR_NKLIN_LBXV,DPTR_XCOEFLIN_LBXV,DPTR_NKLIN_LBYV,DPTR_XCOEFLIN_LBYV, &
+ DPTR_NKLIN_LBXW,DPTR_XCOEFLIN_LBXW,DPTR_NKLIN_LBYW,DPTR_XCOEFLIN_LBYW, &
+ DPTR_NKLIN_LBXM,DPTR_XCOEFLIN_LBXM,DPTR_NKLIN_LBYM,DPTR_XCOEFLIN_LBYM )
+ !
+ DPTR_XLBXUM=>XLBXUM
+ DPTR_XLBYUM=>XLBYUM
+ DPTR_XLBXVM=>XLBXVM
+ DPTR_XLBYVM=>XLBYVM
+ DPTR_XLBXWM=>XLBXWM
+ DPTR_XLBYWM=>XLBYWM
+ DPTR_XLBXTHM=>XLBXTHM
+ DPTR_XLBYTHM=>XLBYTHM
+ DPTR_XLBXTKEM=>XLBXTKEM
+ DPTR_XLBYTKEM=>XLBYTKEM
+ DPTR_XLBXRM=>XLBXRM
+ DPTR_XLBYRM=>XLBYRM
+ DPTR_XLBXSVM=>XLBXSVM
+ DPTR_XLBYSVM=>XLBYSVM
+ CALL INI_ONE_WAY_n(NDAD(KMI),KMI, &
+ DPTR_XBMX1,DPTR_XBMX2,DPTR_XBMX3,DPTR_XBMX4,DPTR_XBMY1,DPTR_XBMY2,DPTR_XBMY3,DPTR_XBMY4, &
+ DPTR_XBFX1,DPTR_XBFX2,DPTR_XBFX3,DPTR_XBFX4,DPTR_XBFY1,DPTR_XBFY2,DPTR_XBFY3,DPTR_XBFY4, &
+ NDXRATIO_ALL(KMI),NDYRATIO_ALL(KMI), &
+ DPTR_CLBCX,DPTR_CLBCY,NRIMX,NRIMY, &
+ DPTR_NKLIN_LBXU,DPTR_XCOEFLIN_LBXU,DPTR_NKLIN_LBYU,DPTR_XCOEFLIN_LBYU, &
+ DPTR_NKLIN_LBXV,DPTR_XCOEFLIN_LBXV,DPTR_NKLIN_LBYV,DPTR_XCOEFLIN_LBYV, &
+ DPTR_NKLIN_LBXW,DPTR_XCOEFLIN_LBXW,DPTR_NKLIN_LBYW,DPTR_XCOEFLIN_LBYW, &
+ DPTR_NKLIN_LBXM,DPTR_XCOEFLIN_LBXM,DPTR_NKLIN_LBYM,DPTR_XCOEFLIN_LBYM, &
+ CCLOUD, LUSECHAQ, LUSECHIC, &
+ DPTR_XLBXUM,DPTR_XLBYUM,DPTR_XLBXVM,DPTR_XLBYVM,DPTR_XLBXWM,DPTR_XLBYWM, &
+ DPTR_XLBXTHM,DPTR_XLBYTHM, &
+ DPTR_XLBXTKEM,DPTR_XLBYTKEM, &
+ DPTR_XLBXRM,DPTR_XLBYRM,DPTR_XLBXSVM,DPTR_XLBYSVM )
+END IF
+!
+!
+!* 16. BUILT THE GENERIC OUTPUT NAME
+! ----------------------------
+!
+WRITE(COUTFILE,'(A,".",I1,".",A)') CEXP,KMI,TRIM(ADJUSTL(CSEG))
+
+!-------------------------------------------------------------------------------
+!
+!* 17. INITIALIZE THE PARAMETERS FOR THE DYNAMICS
+! ------------------------------------------
+!
+!Allocate to zero size to not pass unallocated pointers
+ALLOCATE(XALKBAS(0))
+ALLOCATE(XALKWBAS(0))
+!
+CALL INI_DYNAMICS(XLON,XLAT,XRHODJ,XTHVREF,XMAP,XZZ,XDXHAT,XDYHAT, &
+ XZHAT,CLBCX,CLBCY,XTSTEP,CPRESOPT, &
+ LVE_RELAX,LVE_RELAX_GRD,LHORELAX_UVWTH,LHORELAX_RV, &
+ LHORELAX_RC,LHORELAX_RR,LHORELAX_RI,LHORELAX_RS,LHORELAX_RG, &
+ LHORELAX_RH,LHORELAX_TKE,LHORELAX_SV, &
+ LHORELAX_SVC2R2,LHORELAX_SVC1R3,LHORELAX_SVELEC,LHORELAX_SVLG, &
+ LHORELAX_SVCHEM,LHORELAX_SVAER,LHORELAX_SVDST,LHORELAX_SVSLT, &
+ LHORELAX_SVPP,LHORELAX_SVCS,LHORELAX_SVCHIC,LHORELAX_SVSNW, &
+#ifdef MNH_FOREFIRE
+ LHORELAX_SVFF, &
+#endif
+ XRIMKMAX,NRIMX,NRIMY, &
+ XALKTOP,XALKGRD,XALZBOT,XALZBAS, &
+ XT4DIFU,XT4DIFTH,XT4DIFSV, &
+ XCORIOX,XCORIOY,XCORIOZ,XCURVX,XCURVY, &
+ XDXHATM,XDYHATM,XRHOM,XAF,XBFY,XCF,XTRIGSX,XTRIGSY,NIFAXX,NIFAXY,&
+ XALK,XALKW,NALBOT,XALKBAS,XALKWBAS,NALBAS, &
+ LMASK_RELAX,XKURELAX,XKVRELAX,XKWRELAX, &
+ XDK2U,XDK4U,XDK2TH,XDK4TH,XDK2SV,XDK4SV, &
+ LZDIFFU,XZDIFFU_HALO2, &
+ XBFB,XBF_SXP2_YP1_Z, &
+ XAF_ZS,XBF_ZS,XCF_ZS, &
+ XDXATH_ZS,XDYATH_ZS,XRHO_ZS, &
+ XA_K,XB_K,XC_K,XD_K)
+!
+!-------------------------------------------------------------------------------
+!
+!* 22. UPDATE HALO
+! -----------
+!
+!
+CALL UPDATE_HALO_ll(TZINITHALO3D_ll,IINFO_ll)
+CALL UPDATE_HALO_ll(TZINITHALO2D_ll,IINFO_ll)
+CALL CLEANLIST_ll(TZINITHALO3D_ll)
+CALL CLEANLIST_ll(TZINITHALO2D_ll)
+!
+!
+!-------------------------------------------------------------------------------
+!
+!* 23. DEALLOCATION
+! -------------
+!
+DEALLOCATE(ZJ)
+!
+
+END SUBROUTINE INI_SPECTRE_n
diff --git a/src/ZSOLVER/mass_leak.f90 b/src/ZSOLVER/mass_leak.f90
new file mode 100644
index 0000000000000000000000000000000000000000..9ffe52c67bd2b3bceed6459854309e30d6eb4468
--- /dev/null
+++ b/src/ZSOLVER/mass_leak.f90
@@ -0,0 +1,289 @@
+!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 solver 2006/05/18 14:41:09
+!-----------------------------------------------------------------
+!####################
+MODULE MODI_MASS_LEAK
+!####################
+!
+INTERFACE
+!
+ SUBROUTINE MASS_LEAK (PDXX,PDYY,HLBCX,HLBCY,PLINMASS,PRHODJ,PRUS,PRVS)
+!
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDXX ! metric coefficient dxx
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDYY ! metric coefficient dyy
+CHARACTER(LEN=4), DIMENSION(2), INTENT(IN) :: HLBCX ! type of lateral boundary
+! ! condition (i=IB, i=IE+1)
+CHARACTER(LEN=4), DIMENSION(2), INTENT(IN) :: HLBCY ! type of lateral boundary
+! ! condition (j=JB, j=JE+1)
+REAL, INTENT(IN) :: PLINMASS ! lineic mass through open
+! ! boundaries
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODJ ! rhodref*J
+REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PRUS ! Horizontal
+REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PRVS ! momentum tendencies
+!
+END SUBROUTINE MASS_LEAK
+!
+END INTERFACE
+!
+END MODULE MODI_MASS_LEAK
+!
+! #####################################################################
+ SUBROUTINE MASS_LEAK(PDXX,PDYY,HLBCX,HLBCY,PLINMASS,PRHODJ,PRUS,PRVS)
+! #####################################################################
+!
+!!*** *MASS_LEAK* - assures global non-divergence condition
+!!
+!! PURPOSE
+!! -------
+!!
+!! This routine changes the horizontal reference dry mass fluxes through
+!! the open boundary condition faces to set the global divergence in the
+!! model domain to zero.
+!!
+!!** METHOD
+!! ------
+!!
+!! 1) The leak term is computed as:
+!!
+!! -- -- IE+1 -- -- JE+1
+!! | JE KE | | IE KE |
+!! | _ _ | | _ _ |
+!! | \ \ 1 _ _ | | \ \ 1 _ _ |
+!! ZLEAK= | / / --- PRUS dydz | + | / / --- PRVS dxdz |
+!! | - - dxx | | - - dyy |
+!! | JB KB | | IB KB |
+!! -- -- i=IB -- -- j=JB
+!!
+!! 2) Then the correction wind value ZRUSTOP is found as
+!! ZLEAK
+!! ZRUSTOP= ----------
+!! PLINMASS
+!!
+!! where PLINMASS is the lineic mass through the open lateral boundaries.
+!!
+!! 3) This horizontal wind correction is applied on the normal wind of
+!! open lateral boundaries only.
+!!
+!!
+!! EXTERNAL
+!! --------
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!! Module MODD_PARAMETERS : contains declaration of parameter variables
+!!
+!! JPHEXT : Horizontal external points number
+!! JPVEXT : Vertical external points number
+!!
+!! REFERENCE
+!! ---------
+!!
+!! book2
+!!
+!! AUTHOR
+!! ------
+!!
+!! V. Masson Meteo-France
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 09/02/95
+!! Modification 20/10/97 (J.P.Lafore) introduction of 'DAVI' type of lbc
+!! 15/06/98 (D.Lugato, R.Guivarch) Parallelisation
+!! 05/06 Suppression of Davies type of lbc
+!!
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_PARAMETERS
+!
+USE MODE_ll
+!JUAN
+USE MODE_REPRO_SUM
+!JUAN
+!
+IMPLICIT NONE
+!
+!* 0.1 declarations of dummy arguments
+!
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDXX ! metric coefficient dxx
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDYY ! metric coefficient dyy
+CHARACTER(LEN=4), DIMENSION(2),INTENT(IN) :: HLBCX ! type of lateral boundary
+! ! condition (i=IB, i=IE+1)
+CHARACTER(LEN=4), DIMENSION(2),INTENT(IN) :: HLBCY ! type of lateral boundary
+! ! condition (j=JB, j=JE+1)
+REAL, INTENT(IN) :: PLINMASS! lineic mass through open
+! ! boundaries
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODJ ! rhodref*J
+REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PRUS ! Horizontal
+REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PRVS ! momentum tendencies
+!
+!* 0.2 declarations of local variables
+!
+!JUAN16
+REAL :: ZLEAK ! total leak of mass
+REAL, ALLOCATABLE, DIMENSION (:,:) :: ZLEAK_W_2D , ZLEAK_E_2D , ZLEAK_S_2D , ZLEAK_N_2D
+!JUAN16
+
+REAL :: ZUSTOP ! wind correction!
+INTEGER :: IIB ! indice I Beginning in x direction
+INTEGER :: IJB ! indice J Beginning in y direction
+INTEGER :: IKB ! indice K Beginning in z direction
+INTEGER :: IIE ! indice I End in x direction
+INTEGER :: IJE ! indice J End in y direction
+INTEGER :: IKE ! indice K End in z direction
+INTEGER :: JI ! Loop index in x direction
+INTEGER :: JJ ! Loop index in y direction
+INTEGER :: JK ! Loop index in z direction
+!
+INTEGER :: IINFO_ll ! return code of parallel routine
+!
+LOGICAL :: GWEST,GEAST,GSOUTH,GNORTH
+REAL :: ZLEAK_W,ZLEAK_E,ZLEAK_S,ZLEAK_N
+!
+!-------------------------------------------------------------------------------
+!
+!* 1. COMPUTE DIMENSIONS OF ARRAYS AND OTHER INDICES:
+! ----------------------------------------------
+!
+CALL GET_INDICE_ll(IIB,IJB,IIE,IJE)
+!
+IKB = 1 + JPVEXT
+IKE = SIZE(PRUS,3) - JPVEXT
+!
+GWEST = ( HLBCX(1) /= 'CYCL' .AND. LWEST_ll() )
+GEAST = ( HLBCX(2) /= 'CYCL' .AND. LEAST_ll() )
+GSOUTH = ( HLBCY(1) /= 'CYCL' .AND. LSOUTH_ll() )
+GNORTH = ( HLBCY(2) /= 'CYCL' .AND. LNORTH_ll() )
+!
+!-------------------------------------------------------------------------------
+!
+!* 2. COMPUTATION OF LEAK
+! -------------------
+!
+ZLEAK=0.
+ZLEAK_E=0.
+ZLEAK_W=0.
+ZLEAK_S=0.
+ZLEAK_N=0.
+!
+IF( HLBCY(1) /= 'CYCL' ) THEN
+ ALLOCATE( ZLEAK_W_2D(IIB:IIB,IJB:IJE))
+ ALLOCATE( ZLEAK_E_2D(IIE+1:IIE+1,IJB:IJE))
+ !$acc kernels async
+ ZLEAK_W_2D = 0.0
+ IF( GWEST ) THEN
+ DO JK=IKB,IKE
+ DO JJ=IJB,IJE
+ ZLEAK_W_2D(IIB,JJ) = ZLEAK_W_2D(IIB,JJ) - 1./PDXX(IIB,JJ,JK) *PRUS(IIB,JJ,JK)
+ END DO
+ END DO
+ END IF
+ !$acc end kernels
+ !
+ !$acc kernels async
+ ZLEAK_E_2D = 0.0
+ IF( GEAST ) THEN
+ DO JK=IKB,IKE
+ DO JJ=IJB,IJE
+ ZLEAK_E_2D(IIE+1,JJ) = ZLEAK_E_2D(IIE+1,JJ) + 1./PDXX(IIE+1,JJ,JK)*PRUS(IIE+1,JJ,JK)
+ END DO
+ END DO
+ END IF
+ !$acc end kernels
+ !
+ !$acc wait
+ !
+ ZLEAK_W = SUM_DD_R2_ll(ZLEAK_W_2D)
+ ZLEAK_E = SUM_DD_R2_ll(ZLEAK_E_2D)
+END IF
+!
+IF( HLBCY(1) /= 'CYCL' ) THEN
+ ALLOCATE( ZLEAK_S_2D(IIB:IIE,IJB:IJB))
+ ALLOCATE( ZLEAK_N_2D(IIB:IIE,IJE+1:IJE+1))
+ !
+ !$acc kernels async
+ ZLEAK_S_2D = 0.0
+ IF( GSOUTH ) THEN
+ DO JI=IIB,IIE
+ DO JK=IKB,IKE
+ ZLEAK_S_2D(JI,IJB) = ZLEAK_S_2D(JI,IJB) - 1./PDYY(JI,IJB,JK) *PRVS(JI,IJB,JK)
+ END DO
+ END DO
+ END IF
+ !$acc end kernels
+ !
+ !$acc kernels async
+ ZLEAK_N_2D = 0.0
+ IF ( GNORTH ) THEN
+ DO JI=IIB,IIE
+ DO JK=IKB,IKE
+ ZLEAK_N_2D(JI,IJE+1) = ZLEAK_N_2D(JI,IJE+1) + 1./PDYY(JI,IJE+1,JK)*PRVS(JI,IJE+1,JK)
+ END DO
+ END DO
+ END IF
+ !$acc end kernels
+ !
+ !$acc wait
+ !
+ ZLEAK_S = SUM_DD_R2_ll(ZLEAK_S_2D)
+ ZLEAK_N = SUM_DD_R2_ll(ZLEAK_N_2D)
+!
+END IF
+!
+ZLEAK = ZLEAK_E + ZLEAK_W + ZLEAK_S + ZLEAK_N
+!!$ZLEAK = ZLEAK_E
+!!$ZLEAK = ZLEAK + ZLEAK_W
+!!$ZLEAK = ZLEAK + ZLEAK_S
+!!$ZLEAK = ZLEAK + ZLEAK_N
+!
+!CALL REDUCESUM_ll(ZLEAK,IINFO_ll) ! we do the reducesum_ll in SUM_DD_R2_ll so we do not do it here
+!
+!-------------------------------------------------------------------------------
+!
+!* 3. CORRECTION OF WIND ON OPEN BOUNDARIES
+! -------------------------------------
+!
+ZUSTOP=ZLEAK
+ZUSTOP=ZUSTOP/PLINMASS
+!
+IF (HLBCX(1)=='OPEN' .AND. LWEST_ll() ) THEN
+ !$acc kernels async
+ PRUS(IIB,:,:)=PRUS(IIB,:,:)+ZUSTOP*0.5*(PRHODJ(IIB,:,:)+PRHODJ(IIB-1,:,:))
+ !$acc end kernels
+END IF
+!
+IF (HLBCX(2)=='OPEN' .AND. LEAST_ll() ) THEN
+ !$acc kernels async
+ PRUS(IIE+1,:,:)=PRUS(IIE+1,:,:)-ZUSTOP*0.5*(PRHODJ(IIE+1,:,:)+PRHODJ(IIE,:,:))
+ !$acc end kernels
+END IF
+!
+IF (HLBCY(1)=='OPEN' .AND. LSOUTH_ll() ) THEN
+ !$acc kernels async
+ PRVS(:,IJB,:)=PRVS(:,IJB,:)+ZUSTOP*0.5*(PRHODJ(:,IJB,:)+PRHODJ(:,IJB-1,:))
+ !$acc end kernels
+END IF
+!
+IF (HLBCY(2)=='OPEN' .AND. LNORTH_ll() ) THEN
+ !$acc kernels async
+ PRVS(:,IJE+1,:)=PRVS(:,IJE+1,:)-ZUSTOP*0.5*(PRHODJ(:,IJE+1,:)+PRHODJ(:,IJE,:))
+ !$acc end kernels
+END IF
+!
+!$acc wait
+!
+!
+!-------------------------------------------------------------------------------
+!
+END SUBROUTINE MASS_LEAK
diff --git a/src/ZSOLVER/modd_dynn.f90 b/src/ZSOLVER/modd_dynn.f90
new file mode 100644
index 0000000000000000000000000000000000000000..445105291501c6f96285c0eb1654124d801036a5
--- /dev/null
+++ b/src/ZSOLVER/modd_dynn.f90
@@ -0,0 +1,402 @@
+!MNH_LIC Copyright 1994-2018 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.
+!-----------------------------------------------------------------
+! #################
+ MODULE MODD_DYN_n
+! #################
+!
+!!**** *MODD_DYN$n* - declaration of dynamic control variables
+!!
+!! PURPOSE
+!! -------
+! The purpose of this declarative module is to declare the dynamic
+! control variables.
+!
+!!
+!!** IMPLICIT ARGUMENTS
+!! ------------------
+!! None
+!!
+!! REFERENCE
+!! ---------
+!! Book2 of documentation of Meso-NH (module MODD_DYNn)
+!! Technical Specifications Report of the Meso-NH (chapters 2 and 3)
+!!
+!! AUTHOR
+!! ------
+!! V. Ducrocq *Meteo France*
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 18/05/94
+!! Modifications 16/11/94 (Lafore+Pinty) For NUM_DIFF
+!! Modifications 06/01/95 (Lafore) For LSTEADY_DMASS
+!! Modifications 28/07/96 (Masson) Supress LSTEADY_DMASS
+!! Modifications 15/03/98 (Stein) Add LHO_RELAX for each variables
+!! Modifications 22/01/01 (Gazen) Add LHORELAX_SVC2R2, _SVCHEM, _SVLG
+!! Modifications 29/11/02 (Pinty) Add LHORELAX_SVC1R3, _SVELEC
+!! Modifications 07/05 (P.Tulet) Add relaxation for dust and aerosol
+!! Modifications 05/07 (C.Lac) Separation of num diffusion
+!! Modifications 07/10 (M.Leriche) Add relaxation for ice phase chemical
+!! Modification 01/2016 (JP Pinty) Add LIMA
+!! Philippe Wautelet: 05/2016-04/2018: new data structures and calls for I/O
+!! Modification 07/2017 (V. Vionnet) Add blowing snow variable
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_PARAMETERS, ONLY: JPMODELMAX, JPSVMAX
+IMPLICIT NONE
+
+TYPE DYN_t
+!
+ INTEGER :: NSTOP ! Number of time step
+ REAL :: XTSTEP ! Time step
+!
+!++++++++++++++++++++++++++++++++++
+!PART USED BY THE PRESSURE SOLVER
+!++++++++++++++++++++++++++++++++++
+!
+ REAL, DIMENSION(:,:,:), POINTER :: XBFY=>NULL() ! Vectors giving the non
+ REAL, DIMENSION(:,:,:), POINTER :: XBFB=>NULL() ! Vectors giving the non
+ REAL, DIMENSION(:,:,:), POINTER :: XBF_SXP2_YP1_Z=>NULL() ! Vectors giving the non
+ REAL, DIMENSION(:,:,:), POINTER :: XBF=>NULL() ! vanishing elements of the
+ REAL, DIMENSION(:), POINTER :: XAF=>NULL(),XCF=>NULL() ! tri-diag matrix in the pressure equation
+ REAL, DIMENSION(:,:,:), POINTER :: XAF_ZS=>NULL(),XBF_ZS=>NULL(),XCF_ZS=>NULL() ! coef for Zsolver
+ REAL, DIMENSION(:,:) , POINTER :: XDXATH_ZS=>NULL(),XDYATH_ZS=>NULL()
+ REAL, DIMENSION(:,:,:), POINTER :: XRHO_ZS=>NULL()
+ REAL, DIMENSION(:), POINTER :: XA_K=>NULL(),XB_K=>NULL(),XC_K=>NULL(),XD_K=>NULL()
+!
+ ! Arrays of sinus or cosinus
+ ! values for the FFT
+ REAL, DIMENSION(:), POINTER :: XTRIGSX=>NULL() ! in x-direction
+ REAL, DIMENSION(:), POINTER :: XTRIGSY=>NULL() ! in y-direction
+ INTEGER, DIMENSION(:),POINTER :: NIFAXX =>NULL() ! Decomposition in prime numbers
+ INTEGER, DIMENSION(:),POINTER :: NIFAXY =>NULL() ! for the FFT in x and y directions
+ CHARACTER(LEN=5) :: CPRESOPT ! Choice of the pressure solver
+ INTEGER :: NITR ! Number of iterations for the
+ ! pressure solver
+ LOGICAL :: LITRADJ ! Choice to adjust the number of
+ !solver iterations during
+ !the simulation
+ LOGICAL :: LRES ! Choice of a different residual
+ ! divergence limit
+ REAL :: XRES ! Value of residual divergence limit
+ REAL :: XRELAX ! relaxation coefficient for the
+ ! Richardson's method
+!
+ REAL :: XDXHATM ! mean grid increment in the
+ REAL :: XDYHATM ! x and y directions
+
+ REAL, DIMENSION (:), POINTER :: XRHOM=>NULL() ! mean of XRHODJ on the plane x y
+ ! localized at a mass level
+!
+!++++++++++++++++++++++++++++++++++
+!PART USED BY THE ABSORBING LAYERS
+!++++++++++++++++++++++++++++++++++
+!
+ INTEGER :: NALBOT ! Vertical index corresponding to the
+ ! absorbing layer base
+!
+ INTEGER :: NALBAS ! Vertical index corresponding to the
+ ! absorbing layer base
+!
+ REAL, DIMENSION(:), POINTER :: XALK=>NULL() ! Function of the absorbing
+ ! layer damping coefficient defined for
+ ! u,v,and theta
+ REAL, DIMENSION(:), POINTER :: XALKW=>NULL() ! Idem but defined for w
+!
+ REAL, DIMENSION(:), POINTER :: XALKBAS=>NULL() ! Function of the absorbing
+ ! layer damping coefficient defined for
+ ! u,v,and theta
+ REAL, DIMENSION(:), POINTER :: XALKWBAS=>NULL() ! Idem but defined for w
+!
+ LOGICAL :: LVE_RELAX ! switch to activate the VErtical RELAXation
+ LOGICAL :: LVE_RELAX_GRD ! switch to activate the VErtical RELAXation
+!
+! switch to activate the HOrizontal RELAXation
+! LOGICAL :: LHORELAX_UVWTH
+!
+ LOGICAL :: LHORELAX_RV, LHORELAX_RC, LHORELAX_RR, LHORELAX_RI
+ LOGICAL :: LHORELAX_RS, LHORELAX_RG, LHORELAX_RH
+!
+! LOGICAL :: LHORELAX_TKE
+!
+ LOGICAL :: LHORELAX_SVC2R2
+ LOGICAL :: LHORELAX_SVC1R3
+ LOGICAL :: LHORELAX_SVLIMA
+ LOGICAL :: LHORELAX_SVELEC
+ LOGICAL :: LHORELAX_SVCHEM
+ LOGICAL :: LHORELAX_SVCHIC
+ LOGICAL :: LHORELAX_SVLG
+ LOGICAL :: LHORELAX_SVDST
+ LOGICAL :: LHORELAX_SVSLT
+ LOGICAL :: LHORELAX_SVAER
+ LOGICAL :: LHORELAX_SVPP
+#ifdef MNH_FOREFIRE
+ LOGICAL :: LHORELAX_SVFF
+#endif
+ LOGICAL :: LHORELAX_SVCS
+ LOGICAL :: LHORELAX_SVSNW
+ LOGICAL, DIMENSION(:),POINTER :: LHORELAX_SV =>NULL()
+!
+ REAL :: XRIMKMAX ! Max. value of the horiz. relaxation coeff.
+! INTEGER :: NRIMX,NRIMY! Number of points in the lateral absorbing
+ ! layer in the x and y directions
+! sizes of the West-east total LB area
+ INTEGER :: NSIZELBX_ll,NSIZELBXU_ll ! for T,V,W and u
+ INTEGER :: NSIZELBXTKE_ll ! for TKE
+ INTEGER :: NSIZELBXR_ll,NSIZELBXSV_ll ! for Rx and SV
+! sizes of the North-south total LB area
+ INTEGER :: NSIZELBY_ll,NSIZELBYV_ll ! for T,U,W and v
+ INTEGER :: NSIZELBYTKE_ll ! for TKE
+ INTEGER :: NSIZELBYR_ll,NSIZELBYSV_ll ! for Rx and SV
+ LOGICAL, DIMENSION(:,:), POINTER :: LMASK_RELAX=>NULL() ! Mask for lateral
+ ! relaxation: True where it has to be performed
+ REAL, DIMENSION(:,:), POINTER :: XKURELAX=>NULL() ! Horizontal relaxation
+ REAL, DIMENSION(:,:), POINTER :: XKVRELAX=>NULL() ! coefficients for the
+ REAL, DIMENSION(:,:), POINTER :: XKWRELAX=>NULL() ! u, v and mass locations
+!
+!++++++++++++++++++++++++++++++++++++
+!PART USED BY THE NUMERICAL DIFFUSION
+!++++++++++++++++++++++++++++++++++++
+!
+ REAL :: XT4DIFU ! Damping time scale for 2*dx wavelength
+ ! specified for the 4nd order num. diffusion
+ ! for momentum
+ REAL :: XT4DIFTH! for theta and mixing ratios
+ REAL :: XT4DIFSV! for scalar variables
+ REAL :: XDK2U ! 2nd order num. diffusion coef. /dx2
+ ! for momentum
+ REAL :: XDK4U ! 4nd order num. diffusion coef. /dx4
+ ! for momentum
+ REAL :: XDK2TH ! for theta and mixing ratios
+ REAL :: XDK4TH ! for theta and mixing ratios
+ REAL :: XDK2SV ! for scalar variables
+ REAL :: XDK4SV ! for scalar variables
+!
+END TYPE DYN_t
+
+TYPE(DYN_t), DIMENSION(JPMODELMAX), TARGET, SAVE :: DYN_MODEL
+LOGICAL , DIMENSION(JPMODELMAX), SAVE :: DYN_FIRST_CALL = .TRUE.
+
+INTEGER, POINTER :: NSTOP=>NULL()
+REAL, POINTER :: XTSTEP=>NULL()
+REAL, DIMENSION(:,:,:), POINTER :: XBFY=>NULL()
+REAL, DIMENSION(:,:,:), POINTER :: XBFB=>NULL()
+REAL, DIMENSION(:,:,:), POINTER :: XBF_SXP2_YP1_Z=>NULL()
+REAL, DIMENSION(:,:,:), POINTER :: XBF=>NULL()
+REAL, DIMENSION(:), POINTER :: XAF=>NULL(),XCF=>NULL()
+REAL, DIMENSION(:,:,:), POINTER :: XAF_ZS=>NULL(),XBF_ZS=>NULL(),XCF_ZS=>NULL()
+REAL, DIMENSION(:,:) , POINTER :: XDXATH_ZS=>NULL(),XDYATH_ZS=>NULL()
+REAL, DIMENSION(:,:,:), POINTER :: XRHO_ZS=>NULL()
+REAL, DIMENSION(:), POINTER :: XA_K=>NULL(),XB_K=>NULL(),XC_K=>NULL(),XD_K=>NULL()
+REAL, DIMENSION(:), POINTER :: XTRIGSX=>NULL()
+REAL, DIMENSION(:), POINTER :: XTRIGSY=>NULL()
+INTEGER, DIMENSION(:), POINTER :: NIFAXX=>NULL()
+INTEGER, DIMENSION(:), POINTER :: NIFAXY=>NULL()
+CHARACTER(LEN=5), POINTER :: CPRESOPT=>NULL()
+INTEGER, POINTER :: NITR=>NULL()
+LOGICAL, POINTER :: LITRADJ=>NULL()
+LOGICAL, POINTER :: LRES=>NULL()
+REAL, POINTER :: XRES=>NULL()
+REAL, POINTER :: XRELAX=>NULL()
+REAL, POINTER :: XDXHATM=>NULL()
+REAL, POINTER :: XDYHATM=>NULL()
+REAL, DIMENSION (:), POINTER :: XRHOM=>NULL()
+INTEGER, POINTER :: NALBOT=>NULL()
+REAL, DIMENSION(:), POINTER :: XALK=>NULL()
+REAL, DIMENSION(:), POINTER :: XALKW=>NULL()
+INTEGER, POINTER :: NALBAS=>NULL()
+REAL, DIMENSION(:), POINTER :: XALKBAS=>NULL()
+REAL, DIMENSION(:), POINTER :: XALKWBAS=>NULL()
+LOGICAL, POINTER :: LVE_RELAX=>NULL()
+LOGICAL, POINTER :: LVE_RELAX_GRD=>NULL()
+LOGICAL, POINTER :: LHORELAX_UVWTH=>NULL()
+LOGICAL, POINTER :: LHORELAX_RV=>NULL(), LHORELAX_RC=>NULL(), LHORELAX_RR=>NULL(), LHORELAX_RI=>NULL()
+LOGICAL, POINTER :: LHORELAX_RS=>NULL(), LHORELAX_RG=>NULL(), LHORELAX_RH=>NULL()
+LOGICAL, POINTER :: LHORELAX_TKE=>NULL()
+LOGICAL, POINTER :: LHORELAX_SVC2R2=>NULL()
+LOGICAL, POINTER :: LHORELAX_SVC1R3=>NULL()
+LOGICAL, POINTER :: LHORELAX_SVLIMA=>NULL()
+LOGICAL, POINTER :: LHORELAX_SVELEC=>NULL()
+LOGICAL, POINTER :: LHORELAX_SVCHEM=>NULL()
+LOGICAL, POINTER :: LHORELAX_SVCHIC=>NULL()
+LOGICAL, POINTER :: LHORELAX_SVLG=>NULL()
+LOGICAL, POINTER :: LHORELAX_SVDST=>NULL()
+LOGICAL, POINTER :: LHORELAX_SVSLT=>NULL()
+LOGICAL, POINTER :: LHORELAX_SVAER=>NULL()
+LOGICAL, POINTER :: LHORELAX_SVPP=>NULL()
+#ifdef MNH_FOREFIRE
+LOGICAL, POINTER :: LHORELAX_SVFF=>NULL()
+#endif
+LOGICAL, POINTER :: LHORELAX_SVCS=>NULL()
+LOGICAL, POINTER :: LHORELAX_SVSNW=>NULL()
+LOGICAL, DIMENSION(:), POINTER :: LHORELAX_SV=>NULL()
+REAL, POINTER :: XRIMKMAX=>NULL()
+INTEGER, POINTER :: NRIMX=>NULL(),NRIMY=>NULL()
+INTEGER, POINTER :: NSIZELBX_ll=>NULL(),NSIZELBXU_ll=>NULL()
+INTEGER, POINTER :: NSIZELBXTKE_ll=>NULL()
+INTEGER, POINTER :: NSIZELBXR_ll=>NULL(),NSIZELBXSV_ll=>NULL()
+INTEGER, POINTER :: NSIZELBY_ll=>NULL(),NSIZELBYV_ll=>NULL()
+INTEGER, POINTER :: NSIZELBYTKE_ll=>NULL()
+INTEGER, POINTER :: NSIZELBYR_ll=>NULL(),NSIZELBYSV_ll=>NULL()
+LOGICAL, DIMENSION(:,:), POINTER :: LMASK_RELAX=>NULL()
+REAL, DIMENSION(:,:), POINTER :: XKURELAX=>NULL()
+REAL, DIMENSION(:,:), POINTER :: XKVRELAX=>NULL()
+REAL, DIMENSION(:,:), POINTER :: XKWRELAX=>NULL()
+REAL, POINTER :: XT4DIFU=>NULL()
+REAL, POINTER :: XDK2U=>NULL()
+REAL, POINTER :: XDK4U=>NULL()
+REAL, POINTER :: XT4DIFTH=>NULL()
+REAL, POINTER :: XDK2TH=>NULL()
+REAL, POINTER :: XDK4TH=>NULL()
+REAL, POINTER :: XT4DIFSV=>NULL()
+REAL, POINTER :: XDK2SV=>NULL()
+REAL, POINTER :: XDK4SV=>NULL()
+
+CONTAINS
+
+SUBROUTINE DYN_GOTO_MODEL(KFROM, KTO)
+INTEGER, INTENT(IN) :: KFROM, KTO
+!
+IF (DYN_FIRST_CALL(KTO)) THEN
+ALLOCATE (DYN_MODEL(KTO)%NIFAXX(19))
+ALLOCATE (DYN_MODEL(KTO)%NIFAXY(19))
+ALLOCATE (DYN_MODEL(KTO)%LHORELAX_SV(JPSVMAX))
+DYN_FIRST_CALL(KTO) = .FALSE.
+ENDIF
+! Save current state for allocated arrays
+DYN_MODEL(KFROM)%XBFY=>XBFY
+DYN_MODEL(KFROM)%XBFB=>XBFB
+DYN_MODEL(KFROM)%XBF_SXP2_YP1_Z=>XBF_SXP2_YP1_Z
+DYN_MODEL(KFROM)%XBF=>XBF
+DYN_MODEL(KFROM)%XAF=>XAF
+DYN_MODEL(KFROM)%XCF=>XCF
+
+DYN_MODEL(KFROM)%XAF_ZS=>XAF_ZS
+DYN_MODEL(KFROM)%XBF_ZS=>XBF_ZS
+DYN_MODEL(KFROM)%XCF_ZS=>XCF_ZS
+
+DYN_MODEL(KFROM)%XDXATH_ZS=>XDXATH_ZS
+DYN_MODEL(KFROM)%XDYATH_ZS=>XDYATH_ZS
+DYN_MODEL(KFROM)%XRHO_ZS=>XRHO_ZS
+DYN_MODEL(KFROM)%XA_K=>XA_K
+DYN_MODEL(KFROM)%XB_K=>XB_K
+DYN_MODEL(KFROM)%XC_K=>XC_K
+DYN_MODEL(KFROM)%XD_K=>XD_K
+
+DYN_MODEL(KFROM)%XTRIGSX=>XTRIGSX
+DYN_MODEL(KFROM)%XTRIGSY=>XTRIGSY
+DYN_MODEL(KFROM)%XRHOM=>XRHOM
+DYN_MODEL(KFROM)%XALK=>XALK
+DYN_MODEL(KFROM)%XALKW=>XALKW
+DYN_MODEL(KFROM)%XALKBAS=>XALKBAS
+DYN_MODEL(KFROM)%XALKWBAS=>XALKWBAS
+DYN_MODEL(KFROM)%LMASK_RELAX=>LMASK_RELAX
+DYN_MODEL(KFROM)%XKURELAX=>XKURELAX
+DYN_MODEL(KFROM)%XKVRELAX=>XKVRELAX
+DYN_MODEL(KFROM)%XKWRELAX=>XKWRELAX
+!
+! Current model is set to model KTO
+NSTOP=>DYN_MODEL(KTO)%NSTOP
+XTSTEP=>DYN_MODEL(KTO)%XTSTEP
+XBFY=>DYN_MODEL(KTO)%XBFY
+XBFB=>DYN_MODEL(KTO)%XBFB
+XBF_SXP2_YP1_Z=>DYN_MODEL(KTO)%XBF_SXP2_YP1_Z
+XBF=>DYN_MODEL(KTO)%XBF
+XAF=>DYN_MODEL(KTO)%XAF
+XCF=>DYN_MODEL(KTO)%XCF
+
+XAF_ZS=>DYN_MODEL(KTO)%XAF_ZS
+XBF_ZS=>DYN_MODEL(KTO)%XBF_ZS
+XCF_ZS=>DYN_MODEL(KTO)%XCF_ZS
+
+XDXATH_ZS=>DYN_MODEL(KFROM)%XDXATH_ZS
+XDYATH_ZS=>DYN_MODEL(KFROM)%XDYATH_ZS
+XRHO_ZS=>DYN_MODEL(KFROM)%XRHO_ZS
+XA_K=>DYN_MODEL(KFROM)%XA_K
+XB_K=>DYN_MODEL(KFROM)%XB_K
+XC_K=>DYN_MODEL(KFROM)%XC_K
+XD_K=>DYN_MODEL(KFROM)%XD_K
+
+XTRIGSX=>DYN_MODEL(KTO)%XTRIGSX
+XTRIGSY=>DYN_MODEL(KTO)%XTRIGSY
+NIFAXX=>DYN_MODEL(KTO)%NIFAXX
+NIFAXY=>DYN_MODEL(KTO)%NIFAXY
+CPRESOPT=>DYN_MODEL(KTO)%CPRESOPT
+NITR=>DYN_MODEL(KTO)%NITR
+LITRADJ=>DYN_MODEL(KTO)%LITRADJ
+LRES=>DYN_MODEL(KTO)%LRES
+XRES=>DYN_MODEL(KTO)%XRES
+XRELAX=>DYN_MODEL(KTO)%XRELAX
+XDXHATM=>DYN_MODEL(KTO)%XDXHATM
+XDYHATM=>DYN_MODEL(KTO)%XDYHATM
+XRHOM=>DYN_MODEL(KTO)%XRHOM
+NALBOT=>DYN_MODEL(KTO)%NALBOT
+XALK=>DYN_MODEL(KTO)%XALK
+XALKW=>DYN_MODEL(KTO)%XALKW
+NALBAS=>DYN_MODEL(KTO)%NALBAS
+XALKBAS=>DYN_MODEL(KTO)%XALKBAS
+XALKWBAS=>DYN_MODEL(KTO)%XALKWBAS
+LVE_RELAX=>DYN_MODEL(KTO)%LVE_RELAX
+LVE_RELAX_GRD=>DYN_MODEL(KTO)%LVE_RELAX_GRD
+!LHORELAX_UVWTH=>DYN_MODEL(KTO)%LHORELAX_UVWTH !Done in FIELDLIST_GOTO_MODEL
+LHORELAX_RV=>DYN_MODEL(KTO)%LHORELAX_RV
+LHORELAX_RC=>DYN_MODEL(KTO)%LHORELAX_RC
+LHORELAX_RR=>DYN_MODEL(KTO)%LHORELAX_RR
+LHORELAX_RI=>DYN_MODEL(KTO)%LHORELAX_RI
+LHORELAX_RS=>DYN_MODEL(KTO)%LHORELAX_RS
+LHORELAX_RG=>DYN_MODEL(KTO)%LHORELAX_RG
+LHORELAX_RH=>DYN_MODEL(KTO)%LHORELAX_RH
+!LHORELAX_TKE=>DYN_MODEL(KTO)%LHORELAX_TKE !Done in FIELDLIST_GOTO_MODEL
+LHORELAX_SVC2R2=>DYN_MODEL(KTO)%LHORELAX_SVC2R2
+LHORELAX_SVC1R3=>DYN_MODEL(KTO)%LHORELAX_SVC1R3
+LHORELAX_SVLIMA=>DYN_MODEL(KTO)%LHORELAX_SVLIMA
+LHORELAX_SVELEC=>DYN_MODEL(KTO)%LHORELAX_SVELEC
+LHORELAX_SVCHEM=>DYN_MODEL(KTO)%LHORELAX_SVCHEM
+LHORELAX_SVCHIC=>DYN_MODEL(KTO)%LHORELAX_SVCHIC
+LHORELAX_SVLG=>DYN_MODEL(KTO)%LHORELAX_SVLG
+LHORELAX_SVDST=>DYN_MODEL(KTO)%LHORELAX_SVDST
+LHORELAX_SVSLT=>DYN_MODEL(KTO)%LHORELAX_SVSLT
+LHORELAX_SVAER=>DYN_MODEL(KTO)%LHORELAX_SVAER
+LHORELAX_SVPP=>DYN_MODEL(KTO)%LHORELAX_SVPP
+#ifdef MNH_FOREFIRE
+LHORELAX_SVFF=>DYN_MODEL(KTO)%LHORELAX_SVFF
+#endif
+LHORELAX_SVCS=>DYN_MODEL(KTO)%LHORELAX_SVCS
+LHORELAX_SVSNW=>DYN_MODEL(KTO)%LHORELAX_SVSNW
+LHORELAX_SV=>DYN_MODEL(KTO)%LHORELAX_SV
+XRIMKMAX=>DYN_MODEL(KTO)%XRIMKMAX
+!NRIMX=>DYN_MODEL(KTO)%NRIMX !Done in FIELDLIST_GOTO_MODEL
+!NRIMY=>DYN_MODEL(KTO)%NRIMY !Done in FIELDLIST_GOTO_MODEL
+NSIZELBX_ll=>DYN_MODEL(KTO)%NSIZELBX_ll
+NSIZELBXU_ll=>DYN_MODEL(KTO)%NSIZELBXU_ll
+NSIZELBXTKE_ll=>DYN_MODEL(KTO)%NSIZELBXTKE_ll
+NSIZELBXR_ll=>DYN_MODEL(KTO)%NSIZELBXR_ll
+NSIZELBXSV_ll=>DYN_MODEL(KTO)%NSIZELBXSV_ll
+NSIZELBY_ll=>DYN_MODEL(KTO)%NSIZELBY_ll
+NSIZELBYV_ll=>DYN_MODEL(KTO)%NSIZELBYV_ll
+NSIZELBYTKE_ll=>DYN_MODEL(KTO)%NSIZELBYTKE_ll
+NSIZELBYR_ll=>DYN_MODEL(KTO)%NSIZELBYR_ll
+NSIZELBYSV_ll=>DYN_MODEL(KTO)%NSIZELBYSV_ll
+LMASK_RELAX=>DYN_MODEL(KTO)%LMASK_RELAX
+XKURELAX=>DYN_MODEL(KTO)%XKURELAX
+XKVRELAX=>DYN_MODEL(KTO)%XKVRELAX
+XKWRELAX=>DYN_MODEL(KTO)%XKWRELAX
+XT4DIFU=>DYN_MODEL(KTO)%XT4DIFU
+XDK2U=>DYN_MODEL(KTO)%XDK2U
+XDK4U=>DYN_MODEL(KTO)%XDK4U
+XT4DIFTH=>DYN_MODEL(KTO)%XT4DIFTH
+XDK2TH=>DYN_MODEL(KTO)%XDK2TH
+XDK4TH=>DYN_MODEL(KTO)%XDK4TH
+XT4DIFSV=>DYN_MODEL(KTO)%XT4DIFSV
+XDK2SV=>DYN_MODEL(KTO)%XDK2SV
+XDK4SV=>DYN_MODEL(KTO)%XDK4SV
+
+END SUBROUTINE DYN_GOTO_MODEL
+
+END MODULE MODD_DYN_n
diff --git a/src/ZSOLVER/modeln.f90 b/src/ZSOLVER/modeln.f90
new file mode 100644
index 0000000000000000000000000000000000000000..a65e4e58abd7369dc942b9d7956f844df1cfa6dc
--- /dev/null
+++ b/src/ZSOLVER/modeln.f90
@@ -0,0 +1,2257 @@
+!MNH_LIC Copyright 1994-2020 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.
+!-----------------------------------------------------------------
+! ###################
+ MODULE MODI_MODEL_n
+! ###################
+!
+INTERFACE
+!
+ SUBROUTINE MODEL_n(KTCOUNT,OEXIT)
+!
+INTEGER, INTENT(IN) :: KTCOUNT ! temporal loop index of model KMODEL
+LOGICAL, INTENT(INOUT):: OEXIT ! switch for the end of the temporal loop
+!
+END SUBROUTINE MODEL_n
+!
+END INTERFACE
+!
+END MODULE MODI_MODEL_n
+
+! ###################################
+ SUBROUTINE MODEL_n(KTCOUNT, OEXIT)
+! ###################################
+!
+!!**** *MODEL_n * -monitor of the model version _n
+!!
+!! PURPOSE
+!! -------
+! The purpose of this routine is to build up a typical model version
+! by sequentially calling the specialized routines.
+!
+!!** METHOD
+!! ------
+!! Some preliminary initializations are performed in the first section.
+!! Then, specialized routines are called to update the guess of the future
+!! instant XRxxS of the variable xx by adding the effects of all the
+!! different sources of evolution.
+!!
+!! (guess of xx at t+dt) * Rhod_ref * Jacobian
+!! XRxxS = -------------------------------------------
+!! 2 dt
+!!
+!! At this level, the informations are transferred with a USE association
+!! from the INIT step, where the modules have been previously filled. The
+!! transfer to the subroutines computing each source term is performed by
+!! argument in order to avoid repeated compilations of these subroutines.
+!! This monitor model_n, must therefore be duplicated for each model,
+!! model1 corresponds in this case to the outermost model, model2 is used
+!! for the first level of gridnesting,....
+!! The effect of all parameterizations is computed in PHYS_PARAM_n, which
+!! is itself a monitor. This is due to a possible large number of
+!! parameterizations, which can be activated and therefore, will require a
+!! very large list of arguments. To circumvent this problem, we transfer by
+!! a USE association, the necessary informations in this monitor, which will
+!! dispatch the pertinent information to every parametrization.
+!! Some elaborated diagnostics, LES tools, budget storages are also called
+!! at this level because they require informations about the fields at every
+!! timestep.
+!!
+!!
+!! EXTERNAL
+!! --------
+!! Subroutine IO_File_open: to open a file
+!! Subroutine WRITE_DESFM: to write the descriptive part of a FMfile
+!! Subroutine WRITE_LFIFM: to write the binary part of a FMfile
+!! Subroutine SET_MASK : to compute all the masks selected for budget
+!! computations
+!! Subroutine BOUNDARIES : set the fields at the marginal points in every
+!! directions according the selected boundary conditions
+!! Subroutine INITIAL_GUESS: initializes the guess of the future instant
+!! Subroutine LES_FLX_SPECTRA: computes the resolved fluxes and the
+!! spectra of some quantities when running in LES mode.
+!! Subroutine ADVECTION: computes the advection terms.
+!! Subroutine DYN_SOURCES: computes the curvature, Coriolis, gravity terms.
+!! Subroutine NUM_DIFF: applies the fourth order numerical diffusion.
+!! Subroutine RELAXATION: performs the relaxation to Larger Scale fields
+!! in the upper levels and outermost vertical planes
+!! Subroutine PHYS_PARAM_n : computes the parameterized physical terms
+!! Subroutine RAD_BOUND: prepares the velocity normal components for the bc.
+!! Subroutine RESOLVED_CLOUD : computes the sources terms for water in any
+!! form
+!! Subroutine PRESSURE : computes the pressure gradient term and the
+!! absolute pressure
+!! Subroutine EXCHANGE : updates the halo of each subdomains
+!! Subroutine ENDSTEP : advances in time the fields.
+!! Subroutines UVW_LS_COUPLING and SCALAR_LS_COUPLING:
+!! compute the large scale fields, used to
+!! couple Model_n with outer informations.
+!! Subroutine ENDSTEP_BUDGET: writes the budget informations.
+!! Subroutine IO_File_close: closes a file
+!! Subroutine DATETIME_CORRECTDATE: transform the current time in GMT
+!! Subroutine FORCING : computes forcing terms
+!! Subroutine ADD3DFIELD_ll : add a field to 3D-list
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! MODD_DYN
+!! MODD_CONF
+!! MODD_NESTING
+!! MODD_BUDGET
+!! MODD_PARAMETERS
+!! MODD_CONF_n
+!! MODD_CURVCOR_n
+!! MODD_DYN_n
+!! MODD_DIM_n
+!! MODD_ADV_n
+!! MODD_FIELD_n
+!! MODD_LSFIELD_n
+!! MODD_GRID_n
+!! MODD_METRICS_n
+!! MODD_LBC_n
+!! MODD_PARAM_n
+!! MODD_REF_n
+!! MODD_LUNIT_n
+!! MODD_OUT_n
+!! MODD_TIME_n
+!! MODD_TURB_n
+!! MODD_CLOUDPAR_n
+!! MODD_TIME
+!!
+!! REFERENCE
+!! ---------
+!!
+!! AUTHOR
+!! ------
+!! J.-P. Pinty * LA *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 15/09/94
+!! Modification 20/10/94 (J.Stein) for the outputs and abs_layers routines
+!! Modification 10/11/94 (J.Stein) change ABS_LAYER_FIELDS call
+!! Modification 16/11/94 (J.Stein) add call to the renormalization
+!! Modification 17/11/94 (J.-P. Lafore and J.-P. Pinty) call NUM_DIFF
+!! Modification 08/12/94 (J.Stein) cleaning + remove (RENORM + ABS_LAYER..
+!! ..) + add RELAXATION + LS fiels in the arguments
+!! Modification 19/12/94 (J.Stein) switch for the num diff
+!! Modification 22/12/94 (J.Stein) update tdtcur + change dyn_source call
+!! Modification 05/01/95 (J.Stein) add the parameterization monitor
+!! Modification 09/01/95 (J.Stein) add the 1D switch
+!! Modification 10/01/95 (J.Stein) displace the TDTCUR computation
+!! Modification 03/01/95 (J.-P. Lafore) Absolute pressure diagnosis
+!! Modification Jan 19, 1995 (J. Cuxart) Shunt the DYN_SOURCES in 1D cases.
+!! Modification Jan 24, 1995 (J. Stein) Interchange Boundaries and
+!! Initial_guess to correct a bug in 2D configuration
+!! Modification Feb 02, 1995 (I.Mallet) update BOUNDARIES and RAD_BOUND
+!! calls
+!! Modification Mar 10, 1995 (I.Mallet) add call to SET_COUPLING
+!! March,21, 1995 (J. Stein) remove R from the historical var.
+!! March,26, 1995 (J. Stein) add the EPS variable
+!! April 18, 1995 (J. Cuxart) add the LES call
+!! Sept 20,1995 (Lafore) coupling for the dry mass Md
+!! Nov 2,1995 (Stein) displace the temporal counter increase
+!! Jan 2,1996 (Stein) rm the test on the temporal counter
+!! Modification Feb 5,1996 (J. Vila) implementation new advection
+!! schemes for scalars
+!! Modification Feb 20,1996 (J.Stein) doctor norm
+!! Dec95 - Jul96 (Georgelin, Pinty, Mari, Suhre) FORCING
+!! June 17,1996 (Vincent, Lafore, Jabouille)
+!! statistics of computing time
+!! Aug 8, 1996 (K. Suhre) add chemistry
+!! October 12, 1996 (J. Stein) save the PSRC value
+!! Sept 05,1996 (V.Masson) print of loop index for debugging
+!! purposes
+!! July 22,1996 (Lafore) improve write of computing time statistics
+!! July 29,1996 (Lafore) nesting introduction
+!! Aug. 1,1996 (Lafore) synchronization between models
+!! Sept. 4,1996 (Lafore) modification of call to routine SET_COUPLING
+!! now splitted in 2 routines
+!! (UVW_LS_COUPLING and SCALAR_LS_COUPLING)
+!! Sept 5,1996 (V.Masson) print of loop index for debugging
+!! purposes
+!! Sept 25,1996 (V.Masson) test for coupling performed here
+!! Oct. 29,1996 (Lafore) one-way nesting implementation
+!! Oct. 12,1996 (J. Stein) save the PSRC value
+!! Dec. 12,1996 (Lafore) change call to RAD_BOUND
+!! Dec. 21,1996 (Lafore) two-way nesting implementation
+!! Mar. 12,1997 (Lafore) introduction of "surfacic" LS fields
+!! Nov 18, 1996 (J.-P. Pinty) FORCING revisited (translation)
+!! Dec 04, 1996 (J.-P. Pinty) include mixed-phase clouds
+!! Dec 20, 1996 (J.-P. Pinty) update the budgets
+!! Dec 23, 1996 (J.-P. Pinty) add the diachronic file control
+!! Jan 11, 1997 (J.-P. Pinty) add the deep convection control
+!! Dec 20,1996 (V.Masson) call boundaries before the writing
+!! Fev 25, 1997 (P.Jabouille) modify the LES tools
+!! April 3,1997 (Lafore) merging of the nesting
+!! developments on MASTER3
+!! Jul. 8,1997 (Lafore) print control for nesting (NVERB>=7)
+!! Jul. 28,1997 (Masson) supress LSTEADY_DMASS
+!! Aug. 19,1997 (Lafore) full Clark's formulation introduction
+!! Sept 26,1997 (Lafore) LS source calculation at restart
+!! (temporarily test to have LS at instant t)
+!! Jan. 28,1998 (Bechtold) add SST forcing
+!! fev. 10,1998 (Lafore) RHODJ computation and storage for budget
+!! Jul. 10,1998 (Stein ) sequentiel loop for nesting
+!! Apr. 07,1999 (Stein ) cleaning of the nesting subroutines
+!! oct. 20,1998 (Jabouille) //
+!! oct. 20,2000 (J.-P. Pinty) add the C2R2 scheme
+!! fev. 01,2001 (D.Gazen) add module MODD_NSV for NSV variables
+!! mar, 4,2002 (V.Ducrocq) call to temporal series
+!! mar, 8, 2001 (V. Masson) advection of perturbation of theta in neutral cases.
+!! Nov, 6, 2002 (V. Masson) time counters for budgets & LES
+!! mars 20,2001 (Pinty) add ICE4 and C3R5 options
+!! jan. 2004 (Masson) surface externalization
+!! sept 2004 (M. Tomasini) Cloud mixing length modification
+!! june 2005 (P. Tulet) add aerosols / dusts
+!! Jul. 2005 (N. Asencio) two_way and phys_param calls:
+!! Add the surface parameters : precipitating
+!! hydrometeors, Short and Long Wave , MASKkids array
+!! Fev. 2006 (M. Leriche) add aqueous phase chemistry
+!! april 2006 (T.Maric) Add halo related to 4th order advection scheme
+!! May 2006 Remove KEPS
+!! Oct 2008 (C.Lac) FIT for variables advected with PPM
+!! July 2009 : Displacement of surface diagnostics call to be
+!! coherent with surface diagnostics obtained with DIAG
+!! 10/11/2009 (P. Aumond) Add mean moments
+!! Nov, 12, 2009 (C. Barthe) add cloud electrification and lightning flashes
+!! July 2010 (M. Leriche) add ice phase chemical species
+!! April 2011 (C.Lac) : Remove instant M
+!! April 2011 (C.Lac, V.Masson) : Time splitting for advection
+!! J.Escobar 21/03/2013: for HALOK comment all NHALO=1 test
+!! P. Tulet Nov 2014 accumulated moles of aqueous species that fall at the surface
+!! Dec 2014 (C.Lac) : For reproducibility START/RESTA
+!! J.Escobar 20/04/2015: missing UPDATE_HALO before UPDATE_HALO2
+!! July, 2015 (O.Nuissier/F.Duffourg) Add microphysics diagnostic for
+!! aircraft, ballon and profiler
+!! C.Lac 11/09/2015: correction of the budget due to FIT temporal scheme
+!! J.Escobar : 15/09/2015 : WENO5 & JPHEXT <> 1
+!! Sep 2015 (S. Bielli) : Remove YDADFILE from argument call
+! of write_phys_param
+!! J.Escobar : 19/04/2016 : Pb IOZ/NETCDF , missing OPARALLELIO=.FALSE. for PGD files
+!! M.Mazoyer : 04/2016 DTHRAD used for radiative cooling when LACTIT
+!!! Modification 01/2016 (JP Pinty) Add LIMA
+!! 06/2016 (G.Delautier) phasage surfex 8
+!! M.Leriche : 03/2016 Move computation of accumulated chem. in rain to ch_monitor
+!! 09/2016 Add filter on negative values on AERDEP SV before relaxation
+!! 10/2016 (C.Lac) _ Correction on the flag for Strang splitting
+!! to insure reproducibility between START and RESTA
+!! _ Add OSPLIT_WENO
+!! _ Add droplet deposition
+!! 10/2016 (M.Mazoyer) New KHKO output fields
+!! P.Wautelet : 11/07/2016 : removed MNH_NCWRIT define
+!! 09/2017 Q.Rodier add LTEND_UV_FRC
+!! 10/2017 (C.Lac) Necessity to have chemistry processes as
+!! the las process modifying XRSVS
+!! 01/2018 (G.Delautier) SURFEX 8.1
+!! 03/2018 (P.Wautelet) replace ADD_FORECAST_TO_DATE by DATETIME_CORRECTDATE
+!! Philippe Wautelet: 05/2016-04/2018: new data structures and calls for I/O
+!! 07/2017 (V. Vionnet) : Add blowing snow scheme
+!! S. Riette : 11/2016 Add ZPABST to keep pressure constant during timestep
+!! 01/2018 (C.Lac) Add VISCOSITY
+!! Philippe Wautelet: 21/01/2019: add LIO_ALLOW_NO_BACKUP and LIO_NO_WRITE to modd_io_ll
+! to allow to disable writes (for bench purposes)
+! P. Wautelet 07/02/2019: remove OPARALLELIO argument from open and close files subroutines
+! (nsubfiles_ioz is now determined in IO_File_add2list)
+!! 02/2019 C.Lac add rain fraction as an output field
+!! Bielli S. 02/2019 Sea salt : significant sea wave height influences salt emission; 5 salt modes
+! P. Wautelet 28/03/2019: use MNHTIME for time measurement variables
+! P. Wautelet 28/03/2019: use TFILE instead of unit number for set_iluout_timing
+! P. Wautelet 19/04/2019: removed unused dummy arguments and variables
+! P. Wautelet 26/04/2019: replace non-standard FLOAT function by REAL function
+! P. Wautelet 20/05/2019: add name argument to ADDnFIELD_ll + new ADD4DFIELD_ll subroutine
+! J. Escobar 09/07/2019: norme Doctor -> Rename Module Type variable TZ -> T
+! J. Escobar 09/07/2019: for bug in management of XLSZWSM variable, add/use specific 2D TLSFIELD2D_ll pointer
+! P. Wautelet 23/07/2019: OpenACC: move data creations from resolved_cloud to modeln and optimize updates
+! J. Escobar 27/09/2019: add missing report timing of RESOLVED_ELEC
+!!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_2D_FRC
+USE MODD_ADV_n
+USE MODD_AIRCRAFT_BALLOON
+USE MODD_BAKOUT
+USE MODD_BIKHARDT_n
+USE MODD_BLANK
+USE MODD_BUDGET
+USE MODD_CH_AERO_n, ONLY: XSOLORG, XMI
+USE MODD_CH_MNHC_n, ONLY: LUSECHEM,LCH_CONV_LINOX,LUSECHAQ,LUSECHIC, &
+ LCH_INIT_FIELD
+USE MODD_CLOUD_MF_n
+USE MODD_VISCOSITY
+USE MODD_DRAG_n
+USE MODD_CLOUDPAR_n
+USE MODD_CONF
+USE MODD_CONF_n
+USE MODD_CURVCOR_n
+USE MODD_DEEP_CONVECTION_n
+USE MODD_DIM_n
+USE MODD_DUST, ONLY: LDUST
+USE MODD_DYN
+USE MODD_DYN_n
+USE MODD_DYNZD
+USE MODD_DYNZD_n
+USE MODD_ELEC_DESCR
+USE MODD_FIELD_n
+USE MODD_FRC
+USE MODD_FRC_n
+USE MODD_GET_n
+USE MODD_GRID, ONLY: XLONORI,XLATORI
+USE MODD_GRID_n
+USE MODD_ICE_C1R3_DESCR, ONLY: XRTMIN_C1R3=>XRTMIN
+USE MODD_IO, ONLY: LIO_NO_WRITE, TFILEDATA, TFILE_SURFEX, TFILE_DUMMY
+USE MODD_LBC_n
+USE MODD_LES
+USE MODD_LES_BUDGET
+USE MODD_LIMA_PRECIP_SCAVENGING_n
+USE MODD_LSFIELD_n
+USE MODD_LUNIT, ONLY: TLUOUT0,TOUTDATAFILE
+USE MODD_LUNIT_n, ONLY: TDIAFILE,TINIFILE,TINIFILEPGD,TLUOUT
+USE MODD_MEAN_FIELD
+USE MODD_MEAN_FIELD_n
+USE MODD_METRICS_n
+USE MODD_MNH_SURFEX_n
+USE MODD_NESTING
+USE MODD_NSV
+USE MODD_NUDGING_n
+USE MODD_OUT_n
+USE MODD_PARAM_C1R3, ONLY: NSEDI => LSEDI, NHHONI => LHHONI
+USE MODD_PARAM_C2R2, ONLY: NSEDC => LSEDC, NRAIN => LRAIN, NACTIT => LACTIT,LACTTKE,LDEPOC
+USE MODD_PARAMETERS
+USE MODD_PARAM_ICE, ONLY: LWARM,LSEDIC,LCONVHG,LDEPOSC
+USE MODD_PARAM_LIMA, ONLY: MSEDC => LSEDC, MWARM => LWARM, MRAIN => LRAIN, &
+ MACTIT => LACTIT, LSCAV, LCOLD, &
+ MSEDI => LSEDI, MHHONI => LHHONI, LHAIL, &
+ XRTMIN_LIMA=>XRTMIN, MACTTKE=>LACTTKE
+USE MODD_BLOWSNOW_n
+USE MODD_BLOWSNOW
+USE MODD_PARAM_MFSHALL_n
+USE MODD_PARAM_n
+USE MODD_PAST_FIELD_n
+USE MODD_PRECIP_n
+use modd_precision, only: MNHTIME
+USE MODD_PROFILER_n
+USE MODD_RADIATIONS_n, ONLY: XTSRAD,XSCAFLASWD,XDIRFLASWD,XDIRSRFSWD, XAER, XDTHRAD
+USE MODD_RAIN_ICE_DESCR, ONLY: XRTMIN
+USE MODD_REF_n
+USE MODD_SALT, ONLY: LSALT
+USE MODD_SERIES, ONLY: LSERIES
+USE MODD_SERIES_n, ONLY: NFREQSERIES
+USE MODD_STATION_n
+USE MODD_SUB_MODEL_n
+USE MODD_TIME
+USE MODD_TIME_n
+USE MODD_TIMEZ
+USE MODD_TURB_CLOUD, ONLY: NMODEL_CLOUD,CTURBLEN_CLOUD,XCEI
+USE MODD_TURB_n
+!
+USE MODE_DATETIME
+USE MODE_ELEC_ll
+USE MODE_GRIDCART
+USE MODE_GRIDPROJ
+USE MODE_IO_FIELD_WRITE, only: IO_Field_user_write, IO_Fieldlist_write, IO_Header_write
+USE MODE_IO_FILE, only: IO_File_close, IO_File_open
+USE MODE_IO_MANAGE_STRUCT, only: IO_File_add2list
+USE MODE_ll
+USE MODE_MNH_TIMING
+USE MODE_MODELN_HANDLER
+USE MODE_MPPDB
+USE MODE_ONE_WAY_n
+!
+USE MODI_ADVECTION_METSV
+USE MODI_ADVECTION_UVW
+USE MODI_ADVECTION_UVW_CEN
+USE MODI_ADV_FORCING_n
+USE MODI_AER_MONITOR_n
+USE MODI_AIRCRAFT_BALLOON
+USE MODI_BLOWSNOW
+USE MODI_BOUNDARIES
+USE MODI_BUDGET_FLAGS
+USE MODI_CART_COMPRESS
+USE MODI_CH_MONITOR_n
+USE MODI_DIAG_SURF_ATM_N
+USE MODI_DYN_SOURCES
+USE MODI_END_DIAG_IN_RUN
+USE MODI_ENDSTEP
+USE MODI_ENDSTEP_BUDGET
+USE MODI_EXCHANGE
+USE MODI_FORCING
+USE MODI_FORC_SQUALL_LINE
+USE MODI_FORC_WIND
+USE MODI_GET_HALO
+USE MODI_GRAVITY_IMPL
+USE MODI_INI_DIAG_IN_RUN
+USE MODI_INI_LG
+USE MODI_INI_MEAN_FIELD
+USE MODI_INITIAL_GUESS
+USE MODI_LES_INI_TIMESTEP_n
+USE MODI_LES_N
+USE MODI_VISCOSITY
+USE MODI_LIMA_PRECIP_SCAVENGING
+USE MODI_LS_COUPLING
+USE MODI_MASK_COMPRESS
+USE MODI_MEAN_FIELD
+USE MODI_MENU_DIACHRO
+USE MODI_MNHGET_SURF_PARAM_n
+USE MODI_MNHWRITE_ZS_DUMMY_n
+USE MODI_NUDGING
+USE MODI_NUM_DIFF
+USE MODI_PHYS_PARAM_n
+USE MODI_PRESSUREZ
+USE MODI_PROFILER_n
+USE MODI_RAD_BOUND
+USE MODI_RELAX2FW_ION
+USE MODI_RELAXATION
+USE MODI_REL_FORCING_n
+USE MODI_RESOLVED_CLOUD
+USE MODI_RESOLVED_ELEC_n
+USE MODI_SERIES_N
+USE MODI_SETLB_LG
+USE MODI_SET_MASK
+USE MODI_SHUMAN
+USE MODI_SPAWN_LS_n
+USE MODI_STATION_n
+USE MODI_TURB_CLOUD_INDEX
+USE MODI_TWO_WAY
+USE MODI_UPDATE_NSV
+USE MODI_WRITE_AIRCRAFT_BALLOON
+USE MODI_WRITE_DESFM_n
+USE MODI_WRITE_DIAG_SURF_ATM_N
+USE MODI_WRITE_LES_n
+USE MODI_WRITE_LFIFM_n
+USE MODI_WRITE_LFIFMN_FORDIACHRO_n
+USE MODI_WRITE_PROFILER_n
+USE MODI_WRITE_SERIES_n
+USE MODI_WRITE_STATION_n
+USE MODI_WRITE_SURF_ATM_N
+!
+IMPLICIT NONE
+!
+!* 0.1 declarations of arguments
+!
+!
+!
+INTEGER, INTENT(IN) :: KTCOUNT
+LOGICAL, INTENT(INOUT):: OEXIT
+!
+!* 0.2 declarations of local variables
+!
+INTEGER :: ILUOUT ! Logical unit number for the output listing
+INTEGER :: IIU,IJU,IKU ! array size in first, second and third dimensions
+INTEGER :: IIB,IIE,IJB,IJE ! index values for the physical subdomain
+INTEGER :: JSV,JRR ! Loop index for scalar and moist variables
+INTEGER :: INBVAR ! number of HALO2_lls to allocate
+INTEGER :: IINFO_ll ! return code of parallel routine
+INTEGER :: IVERB ! LFI verbosity level
+LOGICAL :: GSTEADY_DMASS ! conditional call to mass computation
+!
+ ! for computing time analysis
+REAL(kind=MNHTIME), DIMENSION(2) :: ZTIME, ZTIME1, ZTIME2, ZEND, ZTOT, ZALL, ZTOT_PT
+REAL(kind=MNHTIME), DIMENSION(2) :: ZTIME_STEP,ZTIME_STEP_PTS
+CHARACTER :: YMI
+INTEGER :: IPOINTS
+CHARACTER(len=16) :: YTCOUNT,YPOINTS
+!
+INTEGER :: ISYNCHRO ! model synchronic index relative to its father
+ ! = 1 for the first time step in phase with DAD
+ ! = 0 for the last time step (out of phase)
+INTEGER :: IMI ! Current model index
+REAL, DIMENSION(:,:),ALLOCATABLE :: ZSEA
+REAL, DIMENSION(:,:),ALLOCATABLE :: ZTOWN
+! Dummy pointers needed to correct an ifort Bug
+REAL, DIMENSION(:), POINTER :: DPTR_XZHAT
+REAL, DIMENSION(:), POINTER :: DPTR_XBMX1,DPTR_XBMX2,DPTR_XBMX3,DPTR_XBMX4
+REAL, DIMENSION(:), POINTER :: DPTR_XBMY1,DPTR_XBMY2,DPTR_XBMY3,DPTR_XBMY4
+REAL, DIMENSION(:), POINTER :: DPTR_XBFX1,DPTR_XBFX2,DPTR_XBFX3,DPTR_XBFX4
+REAL, DIMENSION(:), POINTER :: DPTR_XBFY1,DPTR_XBFY2,DPTR_XBFY3,DPTR_XBFY4
+CHARACTER(LEN=4), DIMENSION(:), POINTER :: DPTR_CLBCX,DPTR_CLBCY
+INTEGER, DIMENSION(:,:,:), POINTER :: DPTR_NKLIN_LBXU,DPTR_NKLIN_LBYU,DPTR_NKLIN_LBXV,DPTR_NKLIN_LBYV
+INTEGER, DIMENSION(:,:,:), POINTER :: DPTR_NKLIN_LBXW,DPTR_NKLIN_LBYW,DPTR_NKLIN_LBXM,DPTR_NKLIN_LBYM
+REAL, DIMENSION(:,:,:), POINTER :: DPTR_XCOEFLIN_LBXU,DPTR_XCOEFLIN_LBYU
+REAL, DIMENSION(:,:,:), POINTER :: DPTR_XCOEFLIN_LBXV,DPTR_XCOEFLIN_LBYV
+REAL, DIMENSION(:,:,:), POINTER :: DPTR_XCOEFLIN_LBXW,DPTR_XCOEFLIN_LBYW
+REAL, DIMENSION(:,:,:), POINTER :: DPTR_XCOEFLIN_LBXM,DPTR_XCOEFLIN_LBYM
+REAL, DIMENSION(:,:,:), POINTER :: DPTR_XLBXUM,DPTR_XLBYUM,DPTR_XLBXVM,DPTR_XLBYVM
+REAL, DIMENSION(:,:,:), POINTER :: DPTR_XLBXWM,DPTR_XLBYWM,DPTR_XLBXTHM,DPTR_XLBYTHM
+REAL, DIMENSION(:,:,:), POINTER :: DPTR_XLBXTKEM,DPTR_XLBYTKEM
+REAL, DIMENSION(:,:,:,:), POINTER :: DPTR_XLBXSVM,DPTR_XLBYSVM
+REAL, DIMENSION(:,:,:,:), POINTER :: DPTR_XLBXRM,DPTR_XLBYRM
+REAL, DIMENSION(:,:,:), POINTER :: DPTR_XZZ
+REAL, DIMENSION(:,:,:), POINTER :: DPTR_XLSUM,DPTR_XLSVM,DPTR_XLSWM,DPTR_XLSTHM,DPTR_XLSRVM
+REAL, DIMENSION(:,:,:), POINTER :: DPTR_XLSUS,DPTR_XLSVS,DPTR_XLSWS,DPTR_XLSTHS,DPTR_XLSRVS
+REAL, DIMENSION(:,:), POINTER :: DPTR_XLSZWSM,DPTR_XLSZWSS
+REAL, DIMENSION(:,:,:), POINTER :: DPTR_XLBXUS,DPTR_XLBYUS,DPTR_XLBXVS,DPTR_XLBYVS
+REAL, DIMENSION(:,:,:), POINTER :: DPTR_XLBXWS,DPTR_XLBYWS,DPTR_XLBXTHS,DPTR_XLBYTHS
+REAL, DIMENSION(:,:,:), POINTER :: DPTR_XLBXTKES,DPTR_XLBYTKES
+REAL, DIMENSION(:,:,:,:), POINTER :: DPTR_XLBXRS,DPTR_XLBYRS,DPTR_XLBXSVS,DPTR_XLBYSVS
+!
+REAL, DIMENSION(:,:,:), POINTER :: DPTR_XRHODJ,DPTR_XUM,DPTR_XVM,DPTR_XWM,DPTR_XTHM
+REAL, DIMENSION(:,:,:), POINTER :: DPTR_XTKEM,DPTR_XRUS,DPTR_XRVS,DPTR_XRWS,DPTR_XRTHS
+REAL, DIMENSION(:,:,:), POINTER :: DPTR_XRTKES,DPTR_XDIRFLASWD,DPTR_XSCAFLASWD,DPTR_XDIRSRFSWD
+REAL, DIMENSION(:,:,:,:), POINTER :: DPTR_XRM,DPTR_XSVM,DPTR_XRRS,DPTR_XRSVS
+REAL, DIMENSION(:,:), POINTER :: DPTR_XINPRC,DPTR_XINPRR,DPTR_XINPRS,DPTR_XINPRG
+REAL, DIMENSION(:,:), POINTER :: DPTR_XINPRH,DPTR_XPRCONV,DPTR_XPRSCONV
+LOGICAL, DIMENSION(:,:),POINTER :: DPTR_GMASKkids
+!
+! REAL, DIMENSION(SIZE(XTHT,1),SIZE(XTHT,2),SIZE(XTHT,3)) :: ZSPEEDC
+! REAL, DIMENSION(SIZE(XTHT,1),SIZE(XTHT,2),SIZE(XTHT,3)) :: ZSPEEDR
+! REAL, DIMENSION(SIZE(XTHT,1),SIZE(XTHT,2),SIZE(XTHT,3)) :: ZSPEEDS
+! REAL, DIMENSION(SIZE(XTHT,1),SIZE(XTHT,2),SIZE(XTHT,3)) :: ZSPEEDG
+! REAL, DIMENSION(SIZE(XTHT,1),SIZE(XTHT,2),SIZE(XTHT,3)) :: ZSPEEDH
+! REAL, DIMENSION(SIZE(XTHT,1),SIZE(XTHT,2),SIZE(XTHT,3)) :: ZINPRC3D
+! REAL, DIMENSION(SIZE(XTHT,1),SIZE(XTHT,2),SIZE(XTHT,3)) :: ZINPRS3D
+! REAL, DIMENSION(SIZE(XTHT,1),SIZE(XTHT,2),SIZE(XTHT,3)) :: ZINPRG3D
+! REAL, DIMENSION(SIZE(XTHT,1),SIZE(XTHT,2),SIZE(XTHT,3)) :: ZINPRH3D
+!
+LOGICAL :: KWARM
+LOGICAL :: KRAIN
+LOGICAL :: KSEDC
+LOGICAL :: KACTIT
+LOGICAL :: KSEDI
+LOGICAL :: KHHONI
+!
+REAL, DIMENSION(:,:,:), ALLOCATABLE :: ZRUS,ZRVS,ZRWS
+REAL, DIMENSION(:,:,:), ALLOCATABLE :: ZPABST !To give pressure at t
+ ! (and not t+1) to resolved_cloud
+REAL, DIMENSION(:,:,:), ALLOCATABLE :: ZJ
+!
+TYPE(LIST_ll), POINTER :: TZFIELDC_ll ! list of fields to exchange
+TYPE(HALO2LIST_ll), POINTER :: TZHALO2C_ll ! list of fields to exchange
+LOGICAL :: GCLD ! conditionnal call for dust wet deposition
+LOGICAL :: GCLOUD_ONLY ! conditionnal radiation computations for
+ ! the only cloudy columns
+REAL, DIMENSION(:,:,:,:), ALLOCATABLE :: ZWETDEPAER
+
+
+!
+TYPE(TFILEDATA),POINTER :: TZBAKFILE, TZOUTFILE
+! TYPE(TFILEDATA),SAVE :: TZDIACFILE
+!-------------------------------------------------------------------------------
+!
+TZBAKFILE=> NULL()
+TZOUTFILE=> NULL()
+
+allocate( ZRUS (SIZE(XTHT,1),SIZE(XTHT,2),SIZE(XTHT,3)) )
+allocate( ZRVS (SIZE(XTHT,1),SIZE(XTHT,2),SIZE(XTHT,3)) )
+allocate( ZRWS (SIZE(XTHT,1),SIZE(XTHT,2),SIZE(XTHT,3)) )
+allocate( ZPABST(SIZE(XTHT,1),SIZE(XTHT,2),SIZE(XTHT,3)) )
+allocate( ZJ (SIZE(XTHT,1),SIZE(XTHT,2),SIZE(XTHT,3)) )
+allocate( ZWETDEPAER(SIZE(XRSVS,1), SIZE(XRSVS,2), SIZE(XRSVS,3), NSV_AER) )
+
+!$acc data create( zrws )
+
+!
+!* 0. MICROPHYSICAL SCHEME
+! -------------------
+SELECT CASE(CCLOUD)
+CASE('C2R2','KHKO','C3R5')
+ KWARM = .TRUE.
+ KRAIN = NRAIN
+ KSEDC = NSEDC
+ KACTIT = NACTIT
+!
+ KSEDI = NSEDI
+ KHHONI = NHHONI
+CASE('LIMA')
+ KWARM = MWARM
+ KRAIN = MRAIN
+ KSEDC = MSEDC
+ KACTIT = MACTIT
+!
+ KSEDI = MSEDI
+ KHHONI = MHHONI
+CASE('ICE3','ICE4') !default values
+ KWARM = LWARM
+ KRAIN = .TRUE.
+ KSEDC = .TRUE.
+ KACTIT = .FALSE.
+!
+ KSEDI = .TRUE.
+ KHHONI = .FALSE.
+END SELECT
+!
+!
+!* 1 PRELIMINARY
+! ------------
+IMI = GET_CURRENT_MODEL_INDEX()
+!
+!* 1.0 update NSV_* variables for current model
+! ----------------------------------------
+!
+CALL UPDATE_NSV(IMI)
+!
+!* 1.1 RECOVER THE LOGICAL UNIT NUMBER FOR THE OUTPUT PRINTS
+!
+ILUOUT = TLUOUT%NLU
+!
+!* 1.2 SET ARRAY SIZE
+!
+CALL GET_DIM_EXT_ll('B',IIU,IJU)
+IKU=NKMAX+2*JPVEXT
+CALL GET_INDICE_ll (IIB,IJB,IIE,IJE)
+!
+IF (IMI==1) THEN
+ GSTEADY_DMASS=LSTEADYLS
+ELSE
+ GSTEADY_DMASS=.FALSE.
+END IF
+!
+!* 1.3 OPEN THE DIACHRONIC FILE
+!
+IF (KTCOUNT == 1) THEN
+!
+ NULLIFY(TFIELDS_ll,TLSFIELD_ll,TFIELDT_ll)
+ NULLIFY(TLSFIELD2D_ll)
+ NULLIFY(THALO2T_ll)
+ NULLIFY(TLSHALO2_ll)
+ NULLIFY(TFIELDSC_ll)
+!
+ ALLOCATE(XWT_ACT_NUC(SIZE(XWT,1),SIZE(XWT,2),SIZE(XWT,3)))
+ ALLOCATE(GMASKkids(SIZE(XWT,1),SIZE(XWT,2)))
+!
+! initialization of the FM file backup/output number
+ IBAK=0
+ IOUT=0
+!
+ IF ( .NOT. LIO_NO_WRITE ) THEN
+ CALL IO_File_open(TDIAFILE)
+!
+ CALL IO_Header_write(TDIAFILE)
+ CALL WRITE_DESFM_n(IMI,TDIAFILE)
+ CALL WRITE_LFIFMN_FORDIACHRO_n(TDIAFILE)
+ END IF
+!
+!* 1.4 Initialization of the list of fields for the halo updates
+!
+! a) Sources terms
+!
+ CALL ADD3DFIELD_ll( TFIELDS_ll, XRUS, 'MODEL_n::XRUS' )
+ CALL ADD3DFIELD_ll( TFIELDS_ll, XRVS, 'MODEL_n::XRVS' )
+ CALL ADD3DFIELD_ll( TFIELDS_ll, XRWS, 'MODEL_n::XRWS' )
+ CALL ADD3DFIELD_ll( TFIELDS_ll, XRTHS, 'MODEL_n::XRTHS' )
+ CALL ADD3DFIELD_ll( TFIELDS_ll, XRUS_PRES, 'MODEL_n::XRUS_PRES' )
+ CALL ADD3DFIELD_ll( TFIELDS_ll, XRVS_PRES, 'MODEL_n::XRVS_PRES' )
+ CALL ADD3DFIELD_ll( TFIELDS_ll, XRWS_PRES, 'MODEL_n::XRWS_PRES' )
+ CALL ADD3DFIELD_ll( TFIELDS_ll, XRTHS_CLD, 'MODEL_n::XRTHS_CLD' )
+ IF (SIZE(XRTKES,1) /= 0) CALL ADD3DFIELD_ll( TFIELDS_ll, XRTKES, 'MODEL_n::XRTKES' )
+ CALL ADD4DFIELD_ll( TFIELDS_ll, XRRS (:,:,:,1:NRR), 'MODEL_n::XRRS' )
+ CALL ADD4DFIELD_ll( TFIELDS_ll, XRRS_CLD (:,:,:,1:NRR), 'MODEL_n::XRRS_CLD' )
+ CALL ADD4DFIELD_ll( TFIELDS_ll, XRSVS (:,:,:,1:NSV), 'MODEL_n::XRSVS')
+ CALL ADD4DFIELD_ll( TFIELDS_ll, XRSVS_CLD(:,:,:,1:NSV), 'MODEL_n::XRSVS_CLD')
+ IF (SIZE(XSRCT,1) /= 0) CALL ADD3DFIELD_ll( TFIELDS_ll, XSRCT, 'MODEL_n::XSRCT' )
+ !
+ IF ((LNUMDIFU .OR. LNUMDIFTH .OR. LNUMDIFSV) ) THEN
+ !
+ ! b) LS fields
+ !
+ CALL ADD3DFIELD_ll( TLSFIELD_ll, XLSUM, 'MODEL_n::XLSUM' )
+ CALL ADD3DFIELD_ll( TLSFIELD_ll, XLSVM, 'MODEL_n::XLSVM' )
+ CALL ADD3DFIELD_ll( TLSFIELD_ll, XLSWM, 'MODEL_n::XLSWM' )
+ CALL ADD3DFIELD_ll( TLSFIELD_ll, XLSTHM, 'MODEL_n::XLSTHM' )
+ CALL ADD2DFIELD_ll( TLSFIELD2D_ll, XLSZWSM, 'MODEL_n::XLSZWSM' )
+ IF (NRR >= 1) THEN
+ CALL ADD3DFIELD_ll( TLSFIELD_ll, XLSRVM, 'MODEL_n::XLSRVM' )
+ ENDIF
+ !
+ ! c) Fields at t
+ !
+ CALL ADD3DFIELD_ll( TFIELDT_ll, XUT, 'MODEL_n::XUT' )
+ CALL ADD3DFIELD_ll( TFIELDT_ll, XVT, 'MODEL_n::XVT' )
+ CALL ADD3DFIELD_ll( TFIELDT_ll, XWT, 'MODEL_n::XWT' )
+ CALL ADD3DFIELD_ll( TFIELDT_ll, XTHT, 'MODEL_n::XTHT' )
+ IF (SIZE(XRTKES,1) /= 0) CALL ADD3DFIELD_ll( TFIELDT_ll, XTKET, 'MODEL_n::XTKET' )
+ CALL ADD4DFIELD_ll(TFIELDT_ll, XRT (:,:,:,1:NRR), 'MODEL_n::XSV' )
+ CALL ADD4DFIELD_ll(TFIELDT_ll, XSVT(:,:,:,1:NSV), 'MODEL_n::XSVT' )
+ !
+ !* 1.5 Initialize the list of fields for the halo updates (2nd layer)
+ !
+ INBVAR = 4+NRR+NSV
+ IF (SIZE(XRTKES,1) /= 0) INBVAR=INBVAR+1
+ CALL INIT_HALO2_ll(THALO2T_ll,INBVAR,IIU,IJU,IKU)
+ CALL INIT_HALO2_ll(TLSHALO2_ll,4+MIN(1,NRR),IIU,IJU,IKU)
+ !
+ !* 1.6 Initialise the 2nd layer of the halo of the LS fields
+ !
+ IF ( LSTEADYLS ) THEN
+ CALL UPDATE_HALO_ll(TLSFIELD_ll, IINFO_ll)
+ CALL UPDATE_HALO_ll(TLSFIELD2D_ll,IINFO_ll)
+ CALL UPDATE_HALO2_ll(TLSFIELD_ll, TLSHALO2_ll, IINFO_ll)
+ END IF
+ END IF
+ !
+!
+ !
+ XT_START = 0.0_MNHTIME
+ !
+ XT_STORE = 0.0_MNHTIME
+ XT_BOUND = 0.0_MNHTIME
+ XT_GUESS = 0.0_MNHTIME
+ XT_FORCING = 0.0_MNHTIME
+ XT_NUDGING = 0.0_MNHTIME
+ XT_ADV = 0.0_MNHTIME
+ XT_ADVUVW = 0.0_MNHTIME
+ XT_GRAV = 0.0_MNHTIME
+ XT_SOURCES = 0.0_MNHTIME
+ !
+ XT_DIFF = 0.0_MNHTIME
+ XT_RELAX = 0.0_MNHTIME
+ XT_PARAM = 0.0_MNHTIME
+ XT_SPECTRA = 0.0_MNHTIME
+ XT_HALO = 0.0_MNHTIME
+ XT_VISC = 0.0_MNHTIME
+ XT_RAD_BOUND = 0.0_MNHTIME
+ XT_PRESS = 0.0_MNHTIME
+ !
+ XT_CLOUD = 0.0_MNHTIME
+ XT_STEP_SWA = 0.0_MNHTIME
+ XT_STEP_MISC = 0.0_MNHTIME
+ XT_COUPL = 0.0_MNHTIME
+ XT_1WAY = 0.0_MNHTIME
+ XT_STEP_BUD = 0.0_MNHTIME
+ !
+ XT_RAD = 0.0_MNHTIME
+ XT_DCONV = 0.0_MNHTIME
+ XT_GROUND = 0.0_MNHTIME
+ XT_TURB = 0.0_MNHTIME
+ XT_MAFL = 0.0_MNHTIME
+ XT_DRAG = 0.0_MNHTIME
+ XT_TRACER = 0.0_MNHTIME
+ XT_SHADOWS = 0.0_MNHTIME
+ XT_ELEC = 0.0_MNHTIME
+ XT_CHEM = 0.0_MNHTIME
+ XT_2WAY = 0.0_MNHTIME
+ !
+END IF
+!
+!* 1.7 Allocation of arrays for observation diagnostics
+!
+CALL INI_DIAG_IN_RUN(IIU,IJU,IKU,LFLYER,LSTATION,LPROFILER)
+!
+!
+CALL SECOND_MNH2(ZEND)
+!
+!-------------------------------------------------------------------------------
+!
+!* 2. ONE-WAY NESTING AND LARGE SCALE FIELD REFRESH
+! ---------------------------------------------
+!
+!
+CALL SECOND_MNH2(ZTIME1)
+!
+ISYNCHRO = MODULO (KTCOUNT, NDTRATIO(IMI) ) ! test of synchronisation
+!
+
+
+IF (IMI/=1 .AND. NDAD(IMI)/=IMI .AND. (ISYNCHRO==1 .OR. NDTRATIO(IMI) == 1) ) THEN
+!
+ ! Use dummy pointers to correct an ifort BUG
+ DPTR_XBMX1=>XBMX1
+ DPTR_XBMX2=>XBMX2
+ DPTR_XBMX3=>XBMX3
+ DPTR_XBMX4=>XBMX4
+ DPTR_XBMY1=>XBMY1
+ DPTR_XBMY2=>XBMY2
+ DPTR_XBMY3=>XBMY3
+ DPTR_XBMY4=>XBMY4
+ DPTR_XBFX1=>XBFX1
+ DPTR_XBFX2=>XBFX2
+ DPTR_XBFX3=>XBFX3
+ DPTR_XBFX4=>XBFX4
+ DPTR_XBFY1=>XBFY1
+ DPTR_XBFY2=>XBFY2
+ DPTR_XBFY3=>XBFY3
+ DPTR_XBFY4=>XBFY4
+ DPTR_CLBCX=>CLBCX
+ DPTR_CLBCY=>CLBCY
+ !
+ DPTR_XZZ=>XZZ
+ DPTR_XZHAT=>XZHAT
+ DPTR_XCOEFLIN_LBXM=>XCOEFLIN_LBXM
+ DPTR_XLSTHM=>XLSTHM
+ DPTR_XLSRVM=>XLSRVM
+ DPTR_XLSUM=>XLSUM
+ DPTR_XLSVM=>XLSVM
+ DPTR_XLSWM=>XLSWM
+ DPTR_XLSZWSM=>XLSZWSM
+ DPTR_XLSTHS=>XLSTHS
+ DPTR_XLSRVS=>XLSRVS
+ DPTR_XLSUS=>XLSUS
+ DPTR_XLSVS=>XLSVS
+ DPTR_XLSWS=>XLSWS
+ DPTR_XLSZWSS=>XLSZWSS
+ !
+ IF ( LSTEADYLS ) THEN
+ NCPL_CUR=0
+ ELSE
+ IF (NCPL_CUR/=1) THEN
+ IF ( KTCOUNT+1 == NCPL_TIMES(NCPL_CUR-1,IMI) ) THEN
+ !
+ ! LS sources are interpolated from the LS field
+ ! values of model DAD(IMI)
+ CALL SPAWN_LS_n(NDAD(IMI),XTSTEP,IMI, &
+ DPTR_XBMX1,DPTR_XBMX2,DPTR_XBMX3,DPTR_XBMX4,DPTR_XBMY1,DPTR_XBMY2,DPTR_XBMY3,DPTR_XBMY4, &
+ DPTR_XBFX1,DPTR_XBFX2,DPTR_XBFX3,DPTR_XBFX4,DPTR_XBFY1,DPTR_XBFY2,DPTR_XBFY3,DPTR_XBFY4, &
+ NDXRATIO_ALL(IMI),NDYRATIO_ALL(IMI), &
+ DPTR_CLBCX,DPTR_CLBCY,DPTR_XZZ,DPTR_XZHAT,LSLEVE,XLEN1,XLEN2,DPTR_XCOEFLIN_LBXM, &
+ DPTR_XLSTHM,DPTR_XLSRVM,DPTR_XLSUM,DPTR_XLSVM,DPTR_XLSWM,DPTR_XLSZWSM, &
+ DPTR_XLSTHS,DPTR_XLSRVS,DPTR_XLSUS,DPTR_XLSVS,DPTR_XLSWS, DPTR_XLSZWSS )
+ END IF
+ END IF
+ !
+ END IF
+ !
+ DPTR_NKLIN_LBXU=>NKLIN_LBXU
+ DPTR_XCOEFLIN_LBXU=>XCOEFLIN_LBXU
+ DPTR_NKLIN_LBYU=>NKLIN_LBYU
+ DPTR_XCOEFLIN_LBYU=>XCOEFLIN_LBYU
+ DPTR_NKLIN_LBXV=>NKLIN_LBXV
+ DPTR_XCOEFLIN_LBXV=>XCOEFLIN_LBXV
+ DPTR_NKLIN_LBYV=>NKLIN_LBYV
+ DPTR_XCOEFLIN_LBYV=>XCOEFLIN_LBYV
+ DPTR_NKLIN_LBXW=>NKLIN_LBXW
+ DPTR_XCOEFLIN_LBXW=>XCOEFLIN_LBXW
+ DPTR_NKLIN_LBYW=>NKLIN_LBYW
+ DPTR_XCOEFLIN_LBYW=>XCOEFLIN_LBYW
+ !
+ DPTR_NKLIN_LBXM=>NKLIN_LBXM
+ DPTR_XCOEFLIN_LBXM=>XCOEFLIN_LBXM
+ DPTR_NKLIN_LBYM=>NKLIN_LBYM
+ DPTR_XCOEFLIN_LBYM=>XCOEFLIN_LBYM
+ !
+ DPTR_XLBXUM=>XLBXUM
+ DPTR_XLBYUM=>XLBYUM
+ DPTR_XLBXVM=>XLBXVM
+ DPTR_XLBYVM=>XLBYVM
+ DPTR_XLBXWM=>XLBXWM
+ DPTR_XLBYWM=>XLBYWM
+ DPTR_XLBXTHM=>XLBXTHM
+ DPTR_XLBYTHM=>XLBYTHM
+ DPTR_XLBXTKEM=>XLBXTKEM
+ DPTR_XLBYTKEM=>XLBYTKEM
+ DPTR_XLBXRM=>XLBXRM
+ DPTR_XLBYRM=>XLBYRM
+ DPTR_XLBXSVM=>XLBXSVM
+ DPTR_XLBYSVM=>XLBYSVM
+ !
+ DPTR_XLBXUS=>XLBXUS
+ DPTR_XLBYUS=>XLBYUS
+ DPTR_XLBXVS=>XLBXVS
+ DPTR_XLBYVS=>XLBYVS
+ DPTR_XLBXWS=>XLBXWS
+ DPTR_XLBYWS=>XLBYWS
+ DPTR_XLBXTHS=>XLBXTHS
+ DPTR_XLBYTHS=>XLBYTHS
+ DPTR_XLBXTKES=>XLBXTKES
+ DPTR_XLBYTKES=>XLBYTKES
+ DPTR_XLBXRS=>XLBXRS
+ DPTR_XLBYRS=>XLBYRS
+ DPTR_XLBXSVS=>XLBXSVS
+ DPTR_XLBYSVS=>XLBYSVS
+ !
+ CALL ONE_WAY_n(NDAD(IMI),XTSTEP,IMI,KTCOUNT, &
+ DPTR_XBMX1,DPTR_XBMX2,DPTR_XBMX3,DPTR_XBMX4,DPTR_XBMY1,DPTR_XBMY2,DPTR_XBMY3,DPTR_XBMY4, &
+ DPTR_XBFX1,DPTR_XBFX2,DPTR_XBFX3,DPTR_XBFX4,DPTR_XBFY1,DPTR_XBFY2,DPTR_XBFY3,DPTR_XBFY4, &
+ NDXRATIO_ALL(IMI),NDYRATIO_ALL(IMI),NDTRATIO(IMI), &
+ DPTR_CLBCX,DPTR_CLBCY,NRIMX,NRIMY, &
+ DPTR_NKLIN_LBXU,DPTR_XCOEFLIN_LBXU,DPTR_NKLIN_LBYU,DPTR_XCOEFLIN_LBYU, &
+ DPTR_NKLIN_LBXV,DPTR_XCOEFLIN_LBXV,DPTR_NKLIN_LBYV,DPTR_XCOEFLIN_LBYV, &
+ DPTR_NKLIN_LBXW,DPTR_XCOEFLIN_LBXW,DPTR_NKLIN_LBYW,DPTR_XCOEFLIN_LBYW, &
+ DPTR_NKLIN_LBXM,DPTR_XCOEFLIN_LBXM,DPTR_NKLIN_LBYM,DPTR_XCOEFLIN_LBYM, &
+ GSTEADY_DMASS,CCLOUD,LUSECHAQ,LUSECHIC, &
+ DPTR_XLBXUM,DPTR_XLBYUM,DPTR_XLBXVM,DPTR_XLBYVM,DPTR_XLBXWM,DPTR_XLBYWM, &
+ DPTR_XLBXTHM,DPTR_XLBYTHM, &
+ DPTR_XLBXTKEM,DPTR_XLBYTKEM, &
+ DPTR_XLBXRM,DPTR_XLBYRM,DPTR_XLBXSVM,DPTR_XLBYSVM, &
+ XDRYMASST,XDRYMASSS, &
+ DPTR_XLBXUS,DPTR_XLBYUS,DPTR_XLBXVS,DPTR_XLBYVS,DPTR_XLBXWS,DPTR_XLBYWS, &
+ DPTR_XLBXTHS,DPTR_XLBYTHS, &
+ DPTR_XLBXTKES,DPTR_XLBYTKES, &
+ DPTR_XLBXRS,DPTR_XLBYRS,DPTR_XLBXSVS,DPTR_XLBYSVS )
+ !
+END IF
+!
+CALL SECOND_MNH2(ZTIME2)
+XT_1WAY = XT_1WAY + ZTIME2 - ZTIME1
+!
+!-------------------------------------------------------------------------------
+!
+!* 3. LATERAL BOUNDARY CONDITIONS EXCEPT FOR NORMAL VELOCITY
+! ------------------------------------------------------
+!
+ZTIME1=ZTIME2
+!
+!* 3.1 Set the lagragian variables values at the LB
+!
+IF( LLG .AND. IMI==1 ) CALL SETLB_LG
+!
+IF (CCONF == "START" .OR. (CCONF == "RESTA" .AND. KTCOUNT /= 1 )) THEN
+CALL BOUNDARIES ( &
+ XTSTEP,CLBCX,CLBCY,NRR,NSV,KTCOUNT, &
+ XLBXUM,XLBXVM,XLBXWM,XLBXTHM,XLBXTKEM,XLBXRM,XLBXSVM, &
+ XLBYUM,XLBYVM,XLBYWM,XLBYTHM,XLBYTKEM,XLBYRM,XLBYSVM, &
+ XLBXUS,XLBXVS,XLBXWS,XLBXTHS,XLBXTKES,XLBXRS,XLBXSVS, &
+ XLBYUS,XLBYVS,XLBYWS,XLBYTHS,XLBYTKES,XLBYRS,XLBYSVS, &
+ XRHODJ, &
+ XUT, XVT, XWT, XTHT, XTKET, XRT, XSVT, XSRCT )
+END IF
+!
+CALL SECOND_MNH2(ZTIME2)
+!
+XT_BOUND = XT_BOUND + ZTIME2 - ZTIME1
+!
+!-------------------------------------------------------------------------------
+!* initializes surface number
+IF (CSURF=='EXTE') CALL GOTO_SURFEX(IMI)
+!-------------------------------------------------------------------------------
+!
+!* 4. STORAGE IN A SYNCHRONOUS FILE
+! -----------------------------
+!
+ZTIME1 = ZTIME2
+!
+IF (IBAK < NBAK_NUMB ) THEN
+ IF (KTCOUNT == TBACKUPN(IBAK+1)%NSTEP) THEN
+ IBAK=IBAK+1
+ GCLOSE_OUT=.TRUE.
+ !
+ TZBAKFILE => TBACKUPN(IBAK)%TFILE
+ IVERB = TZBAKFILE%NLFIVERB
+ !
+ CALL IO_File_open(TZBAKFILE)
+ !
+ CALL WRITE_DESFM_n(IMI,TZBAKFILE)
+ CALL IO_Header_write(TBACKUPN(IBAK)%TFILE)
+ CALL WRITE_LFIFM_n(TBACKUPN(IBAK)%TFILE,TBACKUPN(IBAK)%TFILE%TDADFILE%CNAME)
+ TOUTDATAFILE => TZBAKFILE
+ CALL MNHWRITE_ZS_DUMMY_n(TZBAKFILE)
+ IF (CSURF=='EXTE') THEN
+ TFILE_SURFEX => TZBAKFILE
+ CALL GOTO_SURFEX(IMI)
+ CALL WRITE_SURF_ATM_n(YSURF_CUR,'MESONH','ALL',.FALSE.)
+ NULLIFY(TFILE_SURFEX)
+ END IF
+ !
+ ! Reinitialize Lagragian variables at every model backup
+ IF (LLG .AND. LINIT_LG .AND. CINIT_LG=='FMOUT') THEN
+ CALL INI_LG(XXHAT,XYHAT,XZZ,XSVT,XLBXSVM,XLBYSVM)
+ IF (IVERB>=5) THEN
+ WRITE(UNIT=ILUOUT,FMT=*) '************************************'
+ WRITE(UNIT=ILUOUT,FMT=*) '*** Lagrangian variables refreshed after ',TRIM(TZBAKFILE%CNAME),' backup'
+ WRITE(UNIT=ILUOUT,FMT=*) '************************************'
+ END IF
+ END IF
+ ! Reinitialise mean variables
+ IF (LMEAN_FIELD) THEN
+ CALL INI_MEAN_FIELD
+ END IF
+!
+ ELSE
+ !Necessary to have a 'valid' CNAME when calling some subroutines
+ TZBAKFILE => TFILE_DUMMY
+ END IF
+ELSE
+ !Necessary to have a 'valid' CNAME when calling some subroutines
+ TZBAKFILE => TFILE_DUMMY
+END IF
+!
+IF (IOUT < NOUT_NUMB ) THEN
+ IF (KTCOUNT == TOUTPUTN(IOUT+1)%NSTEP) THEN
+ IOUT=IOUT+1
+ !
+ TZOUTFILE => TOUTPUTN(IOUT)%TFILE
+ !
+ CALL IO_File_open(TZOUTFILE)
+ !
+ CALL IO_Header_write(TZOUTFILE)
+ CALL IO_Fieldlist_write(TOUTPUTN(IOUT))
+ CALL IO_Field_user_write(TOUTPUTN(IOUT))
+ !
+ CALL IO_File_close(TZOUTFILE)
+ !
+ END IF
+END IF
+!
+CALL SECOND_MNH2(ZTIME2)
+!
+XT_STORE = XT_STORE + ZTIME2 - ZTIME1
+!
+!-------------------------------------------------------------------------------
+!
+!* 5. INITIALIZATION OF THE BUDGET VARIABLES
+! --------------------------------------
+!
+IF (NBUMOD==IMI) THEN
+ LBU_ENABLE = CBUTYPE /='NONE'.AND. CBUTYPE /='SKIP'
+ELSE
+ LBU_ENABLE = .FALSE.
+END IF
+!
+IF (NBUMOD==IMI .AND. CBUTYPE=='MASK' ) THEN
+ CALL SET_MASK
+ IF (LBU_RU) XBURHODJU(:,NBUTIME,:) = XBURHODJU(:,NBUTIME,:) &
+ + MASK_COMPRESS(MXM(XRHODJ))
+ IF (LBU_RV) XBURHODJV(:,NBUTIME,:) = XBURHODJV(:,NBUTIME,:) &
+ + MASK_COMPRESS(MYM(XRHODJ))
+ IF (LBU_RW) XBURHODJW(:,NBUTIME,:) = XBURHODJW(:,NBUTIME,:) &
+ + MASK_COMPRESS(MZM(XRHODJ))
+ IF (ALLOCATED(XBURHODJ)) &
+ XBURHODJ (:,NBUTIME,:) = XBURHODJ (:,NBUTIME,:) &
+ + MASK_COMPRESS(XRHODJ)
+END IF
+!
+IF (NBUMOD==IMI .AND. CBUTYPE=='CART' ) THEN
+ IF (LBU_RU) XBURHODJU(:,:,:) = XBURHODJU(:,:,:) &
+ + CART_COMPRESS(MXM(XRHODJ))
+ IF (LBU_RV) XBURHODJV(:,:,:) = XBURHODJV(:,:,:) &
+ + CART_COMPRESS(MYM(XRHODJ))
+ IF (LBU_RW) XBURHODJW(:,:,:) = XBURHODJW(:,:,:) &
+ + CART_COMPRESS(MZM(XRHODJ))
+ IF (ALLOCATED(XBURHODJ)) &
+ XBURHODJ (:,:,:) = XBURHODJ (:,:,:) &
+ + CART_COMPRESS(XRHODJ)
+END IF
+!
+CALL BUDGET_FLAGS(LUSERV, LUSERC, LUSERR, &
+ LUSERI, LUSERS, LUSERG, LUSERH )
+!
+XTIME_BU = 0.0
+!
+!-------------------------------------------------------------------------------
+!
+!* 6. INITIALIZATION OF THE FIELD TENDENCIES
+! --------------------------------------
+!
+ZTIME1 = ZTIME2
+XTIME_BU_PROCESS = 0.
+!
+CALL INITIAL_GUESS ( NRR, NSV, KTCOUNT, XRHODJ,IMI, XTSTEP, &
+ XRUS, XRVS, XRWS, XRTHS, XRRS, XRTKES, XRSVS, &
+ XUT, XVT, XWT, XTHT, XRT, XTKET, XSVT )
+!
+CALL SECOND_MNH2(ZTIME2)
+!
+XT_GUESS = XT_GUESS + ZTIME2 - ZTIME1 - XTIME_BU_PROCESS
+!
+!-------------------------------------------------------------------------------
+!
+!* 7. INITIALIZATION OF THE LES FOR CURRENT TIME-STEP
+! -----------------------------------------------
+!
+XTIME_LES_BU = 0.0
+XTIME_LES = 0.0
+IF (LLES) CALL LES_INI_TIMESTEP_n(KTCOUNT)
+!
+!-------------------------------------------------------------------------------
+!
+!* 8. TWO-WAY INTERACTIVE GRID-NESTING
+! --------------------------------
+!
+!
+CALL SECOND_MNH2(ZTIME1)
+XTIME_BU_PROCESS = 0.
+XTIME_LES_BU_PROCESS = 0.
+!
+GMASKkids(:,:)=.FALSE.
+!
+IF (NMODEL>1) THEN
+ ! correct an ifort bug
+ DPTR_XRHODJ=>XRHODJ
+ DPTR_XUM=>XUT
+ DPTR_XVM=>XVT
+ DPTR_XWM=>XWT
+ DPTR_XTHM=>XTHT
+ DPTR_XRM=>XRT
+ DPTR_XTKEM=>XTKET
+ DPTR_XSVM=>XSVT
+ DPTR_XRUS=>XRUS
+ DPTR_XRVS=>XRVS
+ DPTR_XRWS=>XRWS
+ DPTR_XRTHS=>XRTHS
+ DPTR_XRRS=>XRRS
+ DPTR_XRTKES=>XRTKES
+ DPTR_XRSVS=>XRSVS
+ DPTR_XINPRC=>XINPRC
+ DPTR_XINPRR=>XINPRR
+ DPTR_XINPRS=>XINPRS
+ DPTR_XINPRG=>XINPRG
+ DPTR_XINPRH=>XINPRH
+ DPTR_XPRCONV=>XPRCONV
+ DPTR_XPRSCONV=>XPRSCONV
+ DPTR_XDIRFLASWD=>XDIRFLASWD
+ DPTR_XSCAFLASWD=>XSCAFLASWD
+ DPTR_XDIRSRFSWD=>XDIRSRFSWD
+ DPTR_GMASKkids=>GMASKkids
+ !
+ CALL TWO_WAY( NRR,NSV,KTCOUNT,DPTR_XRHODJ,IMI,XTSTEP, &
+ DPTR_XUM ,DPTR_XVM ,DPTR_XWM , DPTR_XTHM, DPTR_XRM,DPTR_XSVM, &
+ DPTR_XRUS,DPTR_XRVS,DPTR_XRWS,DPTR_XRTHS,DPTR_XRRS,DPTR_XRSVS, &
+ DPTR_XINPRC,DPTR_XINPRR,DPTR_XINPRS,DPTR_XINPRG,DPTR_XINPRH,DPTR_XPRCONV,DPTR_XPRSCONV, &
+ DPTR_XDIRFLASWD,DPTR_XSCAFLASWD,DPTR_XDIRSRFSWD,DPTR_GMASKkids )
+END IF
+!
+CALL SECOND_MNH2(ZTIME2)
+XT_2WAY = XT_2WAY + ZTIME2 - ZTIME1 - XTIME_LES_BU_PROCESS - XTIME_BU_PROCESS
+!
+!-------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------
+!
+!* 10. FORCING
+! -------
+!
+!
+ZTIME1 = ZTIME2
+XTIME_BU_PROCESS = 0.
+XTIME_LES_BU_PROCESS = 0.
+IF (LCARTESIAN) THEN
+ CALL SM_GRIDCART(XXHAT,XYHAT,XZHAT,XZS,LSLEVE,XLEN1,XLEN2,XZSMT,XDXHAT,XDYHAT,XZZ,ZJ)
+ XMAP=1.
+ELSE
+ CALL SM_GRIDPROJ(XXHAT,XYHAT,XZHAT,XZS,LSLEVE,XLEN1,XLEN2,XZSMT,XLATORI,XLONORI, &
+ XMAP,XLAT,XLON,XDXHAT,XDYHAT,XZZ,ZJ)
+END IF
+!
+IF ( LFORCING ) THEN
+ CALL FORCING(XTSTEP,LUSERV,XRHODJ,XCORIOZ,XZHAT,XZZ,TDTCUR,&
+ XUFRC_PAST, XVFRC_PAST, &
+ XUT,XVT,XWT,XTHT,XTKET,XRT,XSVT, &
+ XRUS,XRVS,XRWS,XRTHS,XRTKES,XRRS,XRSVS,IMI,ZJ)
+END IF
+!
+IF ( L2D_ADV_FRC ) THEN
+ CALL ADV_FORCING_n(XRHODJ,TDTCUR,XTHT,XRT,XZZ,XRTHS,XRRS)
+END IF
+IF ( L2D_REL_FRC ) THEN
+ CALL REL_FORCING_n(XRHODJ,TDTCUR,XTHT,XRT,XZZ,XRTHS,XRRS)
+END IF
+!
+CALL SECOND_MNH2(ZTIME2)
+!
+XT_FORCING = XT_FORCING + ZTIME2 - ZTIME1 &
+ - XTIME_LES_BU_PROCESS - XTIME_BU_PROCESS
+!
+!-------------------------------------------------------------------------------
+!
+!* 11. NUDGING
+! -------
+!
+!
+ZTIME1 = ZTIME2
+XTIME_BU_PROCESS = 0.
+XTIME_LES_BU_PROCESS = 0.
+!
+IF ( LNUDGING ) THEN
+ CALL NUDGING(LUSERV,XRHODJ,XTNUDGING, &
+ XUT,XVT,XWT,XTHT,XRT, &
+ XLSUM,XLSVM,XLSWM,XLSTHM,XLSRVM, &
+ XRUS,XRVS,XRWS,XRTHS,XRRS)
+
+END IF
+!
+CALL SECOND_MNH2(ZTIME2)
+!
+XT_NUDGING = XT_NUDGING + ZTIME2 - ZTIME1 &
+ - XTIME_LES_BU_PROCESS - XTIME_BU_PROCESS
+!
+!-------------------------------------------------------------------------------
+!
+!* 12. DYNAMICAL SOURCES
+! -----------------
+!
+ZTIME1 = ZTIME2
+XTIME_BU_PROCESS = 0.
+XTIME_LES_BU_PROCESS = 0.
+!
+IF( LTRANS ) THEN
+ XUT(:,:,:) = XUT(:,:,:) + XUTRANS
+ XVT(:,:,:) = XVT(:,:,:) + XVTRANS
+END IF
+!
+CALL DYN_SOURCES( NRR,NRRL, NRRI, &
+ XUT, XVT, XWT, XTHT, XRT, &
+ XCORIOX, XCORIOY, XCORIOZ, XCURVX, XCURVY, &
+ XRHODJ, XZZ, XTHVREF, XEXNREF, &
+ XRUS, XRVS, XRWS, XRTHS )
+!
+IF( LTRANS ) THEN
+ XUT(:,:,:) = XUT(:,:,:) - XUTRANS
+ XVT(:,:,:) = XVT(:,:,:) - XVTRANS
+END IF
+!
+CALL SECOND_MNH2(ZTIME2)
+!
+XT_SOURCES = XT_SOURCES + ZTIME2 - ZTIME1 &
+ - XTIME_LES_BU_PROCESS - XTIME_BU_PROCESS
+!
+!-------------------------------------------------------------------------------
+!
+!* 13. NUMERICAL DIFFUSION
+! -------------------
+!
+ZTIME1 = ZTIME2
+XTIME_BU_PROCESS = 0.
+XTIME_LES_BU_PROCESS = 0.
+!
+IF ( LNUMDIFU .OR. LNUMDIFTH .OR. LNUMDIFSV ) THEN
+!
+ CALL UPDATE_HALO_ll(TFIELDT_ll, IINFO_ll)
+ CALL UPDATE_HALO2_ll(TFIELDT_ll, THALO2T_ll, IINFO_ll)
+ IF ( .NOT. LSTEADYLS ) THEN
+ CALL UPDATE_HALO_ll(TLSFIELD_ll, IINFO_ll)
+ CALL UPDATE_HALO_ll(TLSFIELD2D_ll,IINFO_ll)
+ CALL UPDATE_HALO2_ll(TLSFIELD_ll, TLSHALO2_ll, IINFO_ll)
+ END IF
+ CALL NUM_DIFF ( CLBCX, CLBCY, NRR, NSV, &
+ XDK2U, XDK4U, XDK2TH, XDK4TH, XDK2SV, XDK4SV, IMI, &
+ XUT, XVT, XWT, XTHT, XTKET, XRT, XSVT, &
+ XLSUM,XLSVM,XLSWM,XLSTHM,XLSRVM,XRHODJ, &
+ XRUS, XRVS, XRWS, XRTHS, XRTKES, XRRS, XRSVS, &
+ LZDIFFU,LNUMDIFU, LNUMDIFTH, LNUMDIFSV, &
+ THALO2T_ll, TLSHALO2_ll,XZDIFFU_HALO2 )
+END IF
+!
+DO JSV = NSV_CHEMBEG,NSV_CHEMEND
+ XRSVS(:,:,:,JSV) = MAX(XRSVS(:,:,:,JSV),0.)
+END DO
+DO JSV = NSV_CHICBEG,NSV_CHICEND
+ XRSVS(:,:,:,JSV) = MAX(XRSVS(:,:,:,JSV),0.)
+END DO
+DO JSV = NSV_AERBEG,NSV_AEREND
+ XRSVS(:,:,:,JSV) = MAX(XRSVS(:,:,:,JSV),0.)
+END DO
+DO JSV = NSV_LNOXBEG,NSV_LNOXEND
+ XRSVS(:,:,:,JSV) = MAX(XRSVS(:,:,:,JSV),0.)
+END DO
+DO JSV = NSV_DSTBEG,NSV_DSTEND
+ XRSVS(:,:,:,JSV) = MAX(XRSVS(:,:,:,JSV),0.)
+END DO
+DO JSV = NSV_SLTBEG,NSV_SLTEND
+ XRSVS(:,:,:,JSV) = MAX(XRSVS(:,:,:,JSV),0.)
+END DO
+DO JSV = NSV_PPBEG,NSV_PPEND
+ XRSVS(:,:,:,JSV) = MAX(XRSVS(:,:,:,JSV),0.)
+END DO
+#ifdef MNH_FOREFIRE
+DO JSV = NSV_FFBEG,NSV_FFEND
+ XRSVS(:,:,:,JSV) = MAX(XRSVS(:,:,:,JSV),0.)
+END DO
+#endif
+DO JSV = NSV_CSBEG,NSV_CSEND
+ XRSVS(:,:,:,JSV) = MAX(XRSVS(:,:,:,JSV),0.)
+END DO
+DO JSV = NSV_DSTDEPBEG,NSV_DSTDEPEND
+ XRSVS(:,:,:,JSV) = MAX(XRSVS(:,:,:,JSV),0.)
+END DO
+DO JSV = NSV_SLTDEPBEG,NSV_SLTDEPEND
+ XRSVS(:,:,:,JSV) = MAX(XRSVS(:,:,:,JSV),0.)
+END DO
+DO JSV = NSV_AERDEPBEG,NSV_AERDEPEND
+ XRSVS(:,:,:,JSV) = MAX(XRSVS(:,:,:,JSV),0.)
+END DO
+DO JSV = NSV_SNWBEG,NSV_SNWEND
+ XRSVS(:,:,:,JSV) = MAX(XRSVS(:,:,:,JSV),0.)
+END DO
+IF (CELEC .NE. 'NONE') THEN
+ XRSVS(:,:,:,NSV_ELECBEG) = MAX(XRSVS(:,:,:,NSV_ELECBEG),0.)
+ XRSVS(:,:,:,NSV_ELECEND) = MAX(XRSVS(:,:,:,NSV_ELECEND),0.)
+END IF
+!
+CALL SECOND_MNH2(ZTIME2)
+!
+XT_DIFF = XT_DIFF + ZTIME2 - ZTIME1 &
+ - XTIME_LES_BU_PROCESS - XTIME_BU_PROCESS
+!
+!-------------------------------------------------------------------------------
+!
+!* 14. UPPER AND LATERAL RELAXATION
+! ----------------------------
+!
+ZTIME1 = ZTIME2
+XTIME_BU_PROCESS = 0.
+XTIME_LES_BU_PROCESS = 0.
+!
+IF(LVE_RELAX .OR. LVE_RELAX_GRD .OR. LHORELAX_UVWTH .OR. LHORELAX_RV .OR.&
+ LHORELAX_RC .OR. LHORELAX_RR .OR. LHORELAX_RI .OR. LHORELAX_RS .OR. &
+ LHORELAX_RG .OR. LHORELAX_RH .OR. LHORELAX_TKE .OR. &
+ ANY(LHORELAX_SV)) THEN
+ CALL RELAXATION (LVE_RELAX,LVE_RELAX_GRD,LHORELAX_UVWTH,LHORELAX_RV,LHORELAX_RC, &
+ LHORELAX_RR,LHORELAX_RI,LHORELAX_RS,LHORELAX_RG, &
+ LHORELAX_RH,LHORELAX_TKE,LHORELAX_SV, &
+ LHORELAX_SVC2R2,LHORELAX_SVC1R3, &
+ LHORELAX_SVELEC,LHORELAX_SVLG, &
+ LHORELAX_SVCHEM,LHORELAX_SVCHIC,LHORELAX_SVAER, &
+ LHORELAX_SVDST,LHORELAX_SVSLT,LHORELAX_SVPP, &
+ LHORELAX_SVCS,LHORELAX_SVSNW, &
+#ifdef MNH_FOREFIRE
+ LHORELAX_SVFF, &
+#endif
+ KTCOUNT,NRR,NSV,XTSTEP,XRHODJ, &
+ XUT, XVT, XWT, XTHT, XRT, XSVT, XTKET, &
+ XLSUM, XLSVM, XLSWM, XLSTHM, &
+ XLBXUM, XLBXVM, XLBXWM, XLBXTHM, &
+ XLBXRM, XLBXSVM, XLBXTKEM, &
+ XLBYUM, XLBYVM, XLBYWM, XLBYTHM, &
+ XLBYRM, XLBYSVM, XLBYTKEM, &
+ NALBOT, XALK, XALKW, &
+ NALBAS, XALKBAS, XALKWBAS, &
+ LMASK_RELAX,XKURELAX, XKVRELAX, XKWRELAX, &
+ NRIMX,NRIMY, &
+ XRUS, XRVS, XRWS, XRTHS, XRRS, XRSVS, XRTKES )
+END IF
+
+IF (CELEC.NE.'NONE' .AND. LRELAX2FW_ION) THEN
+ CALL RELAX2FW_ION (KTCOUNT, IMI, XTSTEP, XRHODJ, XSVT, NALBOT, &
+ XALK, LMASK_RELAX, XKWRELAX, XRSVS )
+END IF
+!
+CALL SECOND_MNH2(ZTIME2)
+!
+XT_RELAX = XT_RELAX + ZTIME2 - ZTIME1 &
+ - XTIME_LES_BU_PROCESS - XTIME_BU_PROCESS
+!
+!-------------------------------------------------------------------------------
+!
+!* 15. PARAMETRIZATIONS' MONITOR
+! -------------------------
+!
+ZTIME1 = ZTIME2
+!
+CALL PHYS_PARAM_n(KTCOUNT,TZBAKFILE, GCLOSE_OUT, &
+ XT_RAD,XT_SHADOWS,XT_DCONV,XT_GROUND,XT_MAFL, &
+ XT_DRAG,XT_TURB,XT_TRACER, &
+ ZTIME,ZWETDEPAER,GMASKkids,GCLOUD_ONLY)
+!
+IF (CDCONV/='NONE') THEN
+ XPACCONV = XPACCONV + XPRCONV * XTSTEP
+ IF (LCH_CONV_LINOX) THEN
+ XIC_TOTAL_NUMBER = XIC_TOTAL_NUMBER + XIC_RATE * XTSTEP
+ XCG_TOTAL_NUMBER = XCG_TOTAL_NUMBER + XCG_RATE * XTSTEP
+ END IF
+END IF
+!
+IF (IBAK>0 .AND. IBAK <= NBAK_NUMB ) THEN
+ IF (KTCOUNT == TBACKUPN(IBAK)%NSTEP) THEN
+ IF (CSURF=='EXTE') THEN
+ CALL GOTO_SURFEX(IMI)
+ CALL DIAG_SURF_ATM_n(YSURF_CUR,'MESONH')
+ TFILE_SURFEX => TZBAKFILE
+ CALL WRITE_DIAG_SURF_ATM_n(YSURF_CUR,'MESONH','ALL')
+ NULLIFY(TFILE_SURFEX)
+ END IF
+ END IF
+END IF
+!
+CALL SECOND_MNH2(ZTIME2)
+!
+XT_PARAM = XT_PARAM + ZTIME2 - ZTIME1 - XTIME_LES - ZTIME
+!
+!-------------------------------------------------------------------------------
+!
+!* 16. TEMPORAL SERIES
+! ---------------
+!
+ZTIME1 = ZTIME2
+!
+IF (LSERIES) THEN
+ IF ( MOD (KTCOUNT-1,NFREQSERIES) == 0 ) CALL SERIES_n
+END IF
+!
+CALL SECOND_MNH2(ZTIME2)
+!
+XT_STEP_MISC = XT_STEP_MISC + ZTIME2 - ZTIME1
+!
+!-------------------------------------------------------------------------------
+!
+!* 17. LARGE SCALE FIELD REFRESH
+! -------------------------
+!
+ZTIME1 = ZTIME2
+!
+IF (.NOT. LSTEADYLS) THEN
+ IF ( IMI==1 .AND. &
+ NCPL_CUR < NCPL_NBR ) THEN
+ IF (KTCOUNT+1 == NCPL_TIMES(NCPL_CUR,1) ) THEN
+ ! The next current time reachs a
+ NCPL_CUR=NCPL_CUR+1 ! coupling one, LS sources are refreshed
+ !
+ CALL LS_COUPLING(XTSTEP,GSTEADY_DMASS,CCONF, &
+ CGETTKET, &
+ CGETRVT,CGETRCT,CGETRRT,CGETRIT, &
+ CGETRST,CGETRGT,CGETRHT,CGETSVT,LCH_INIT_FIELD, NSV, &
+ NIMAX_ll,NJMAX_ll, &
+ NSIZELBX_ll,NSIZELBXU_ll,NSIZELBY_ll,NSIZELBYV_ll, &
+ NSIZELBXTKE_ll,NSIZELBYTKE_ll, &
+ NSIZELBXR_ll,NSIZELBYR_ll,NSIZELBXSV_ll,NSIZELBYSV_ll, &
+ XLSUM,XLSVM,XLSWM,XLSTHM,XLSRVM,XLSZWSM,XDRYMASST, &
+ XLBXUM,XLBXVM,XLBXWM,XLBXTHM,XLBXTKEM,XLBXRM,XLBXSVM, &
+ XLBYUM,XLBYVM,XLBYWM,XLBYTHM,XLBYTKEM,XLBYRM,XLBYSVM, &
+ XLSUS,XLSVS,XLSWS,XLSTHS,XLSRVS,XLSZWSS,XDRYMASSS, &
+ XLBXUS,XLBXVS,XLBXWS,XLBXTHS,XLBXTKES,XLBXRS,XLBXSVS, &
+ XLBYUS,XLBYVS,XLBYWS,XLBYTHS,XLBYTKES,XLBYRS,XLBYSVS )
+ !
+ DO JSV=NSV_CHEMBEG,NSV_CHEMEND
+ XLBXSVS(:,:,:,JSV)=MAX(XLBXSVS(:,:,:,JSV),0.)
+ XLBYSVS(:,:,:,JSV)=MAX(XLBYSVS(:,:,:,JSV),0.)
+ ENDDO
+ !
+ DO JSV=NSV_LNOXBEG,NSV_LNOXEND
+ XLBXSVS(:,:,:,JSV)=MAX(XLBXSVS(:,:,:,JSV),0.)
+ XLBYSVS(:,:,:,JSV)=MAX(XLBYSVS(:,:,:,JSV),0.)
+ ENDDO
+ !
+ DO JSV=NSV_AERBEG,NSV_AEREND
+ XLBXSVS(:,:,:,JSV)=MAX(XLBXSVS(:,:,:,JSV),0.)
+ XLBYSVS(:,:,:,JSV)=MAX(XLBYSVS(:,:,:,JSV),0.)
+ ENDDO
+ !
+ DO JSV=NSV_DSTBEG,NSV_DSTEND
+ XLBXSVS(:,:,:,JSV)=MAX(XLBXSVS(:,:,:,JSV),0.)
+ XLBYSVS(:,:,:,JSV)=MAX(XLBYSVS(:,:,:,JSV),0.)
+ ENDDO
+ !
+ DO JSV=NSV_DSTDEPBEG,NSV_DSTDEPEND
+ XLBXSVS(:,:,:,JSV)=MAX(XLBXSVS(:,:,:,JSV),0.)
+ XLBYSVS(:,:,:,JSV)=MAX(XLBYSVS(:,:,:,JSV),0.)
+ ENDDO
+ !
+ DO JSV=NSV_SLTBEG,NSV_SLTEND
+ XLBXSVS(:,:,:,JSV)=MAX(XLBXSVS(:,:,:,JSV),0.)
+ XLBYSVS(:,:,:,JSV)=MAX(XLBYSVS(:,:,:,JSV),0.)
+ ENDDO
+ !
+ DO JSV=NSV_SLTDEPBEG,NSV_SLTDEPEND
+ XLBXSVS(:,:,:,JSV)=MAX(XLBXSVS(:,:,:,JSV),0.)
+ XLBYSVS(:,:,:,JSV)=MAX(XLBYSVS(:,:,:,JSV),0.)
+ ENDDO
+ !
+ DO JSV=NSV_PPBEG,NSV_PPEND
+ XLBXSVS(:,:,:,JSV)=MAX(XLBXSVS(:,:,:,JSV),0.)
+ XLBYSVS(:,:,:,JSV)=MAX(XLBYSVS(:,:,:,JSV),0.)
+ ENDDO
+ !
+#ifdef MNH_FOREFIRE
+ DO JSV=NSV_FFBEG,NSV_FFEND
+ XLBXSVS(:,:,:,JSV)=MAX(XLBXSVS(:,:,:,JSV),0.)
+ XLBYSVS(:,:,:,JSV)=MAX(XLBYSVS(:,:,:,JSV),0.)
+ ENDDO
+ !
+#endif
+ DO JSV=NSV_CSBEG,NSV_CSEND
+ XLBXSVS(:,:,:,JSV)=MAX(XLBXSVS(:,:,:,JSV),0.)
+ XLBYSVS(:,:,:,JSV)=MAX(XLBYSVS(:,:,:,JSV),0.)
+ ENDDO
+ !
+ DO JSV=NSV_SNWBEG,NSV_SNWEND
+ XLBXSVS(:,:,:,JSV)=MAX(XLBXSVS(:,:,:,JSV),0.)
+ XLBYSVS(:,:,:,JSV)=MAX(XLBYSVS(:,:,:,JSV),0.)
+ ENDDO
+ !
+ END IF
+ END IF
+END IF
+!
+CALL SECOND_MNH2(ZTIME2)
+!
+XT_COUPL = XT_COUPL + ZTIME2 - ZTIME1
+!
+!-------------------------------------------------------------------------------
+!
+!
+!
+!* 8 Bis . Blowing snow scheme
+! ---------
+!
+IF(LBLOWSNOW) THEN
+ CALL BLOWSNOW(CLBCX,CLBCY,XTSTEP,NRR,XPABST,XTHT,XRT,XZZ,XRHODREF, &
+ XRHODJ,XEXNREF,XRRS,XRTHS,XSVT,XRSVS,XSNWSUBL3D )
+ENDIF
+!
+!-----------------------------------------------------------------------
+!
+!* 8 Ter VISCOSITY (no-slip condition inside)
+! ---------
+!
+!
+IF ( LVISC ) THEN
+!
+ZTIME1 = ZTIME2
+!
+ CALL VISCOSITY(CLBCX, CLBCY, NRR, NSV, XMU_V,XPRANDTL, &
+ LVISC_UVW,LVISC_TH,LVISC_SV,LVISC_R, &
+ LDRAG, &
+ XUT, XVT, XWT, XTHT, XRT, XSVT, &
+ XRHODJ, XDXX, XDYY, XDZZ, XDZX, XDZY, &
+ XRUS, XRVS, XRWS, XRTHS, XRRS, XRSVS,XDRAG )
+!
+ENDIF
+!
+CALL SECOND_MNH2(ZTIME2)
+!
+XT_VISC = XT_VISC + ZTIME2 - ZTIME1
+!!
+!-------------------------------------------------------------------------------
+!
+!* 9. ADVECTION
+! ---------
+!
+ZTIME1 = ZTIME2
+XTIME_BU_PROCESS = 0.
+XTIME_LES_BU_PROCESS = 0.
+!
+!$acc update device(XRTHS)
+!
+!$acc data create (XUT, XVT, XWT) &
+!$acc & copyin (XTHT, XPABST, XRT, XSVT, XRTHS_CLD, XRRS_CLD, XTHVREF) &
+!$acc & copy (XRRS, XRUS, XRVS, XRWS) &
+!$acc & copy (XRWS_PRES) & !XRWS_PRES copy and not copyout (hidden in UPDATE_HALO)
+!$acc & present(XDXX, XDYY, XDZZ, XDZX, XDZY, XRHODJ)
+!
+!$acc update device(XUT, XVT, XWT, XRHODJ)
+
+!
+!
+!$acc data copyin (XTKET, XRSVS_CLD) &
+!$acc & copy (XRTKES, XRSVS) &
+!$acc & copyout(XRTKEMS)
+CALL ADVECTION_METSV ( TZBAKFILE, GCLOSE_OUT,CUVW_ADV_SCHEME, &
+ CMET_ADV_SCHEME, CSV_ADV_SCHEME, CCLOUD, NSPLIT, &
+ LSPLIT_CFL, XSPLIT_CFL, LCFL_WRIT, &
+ CLBCX, CLBCY, NRR, NSV, TDTCUR, XTSTEP, &
+ XUT, XVT, XWT, XTHT, XRT, XTKET, XSVT, XPABST, &
+ XTHVREF, XRHODJ, XDXX, XDYY, XDZZ, XDZX, XDZY, &
+ XRTHS, XRRS, XRTKES, XRSVS, &
+ XRTHS_CLD, XRRS_CLD, XRSVS_CLD, XRTKEMS )
+!$acc end data
+!
+!$acc update host(XRTHS)
+!
+CALL SECOND_MNH2(ZTIME2)
+!
+XT_ADV = XT_ADV + ZTIME2 - ZTIME1 - XTIME_LES_BU_PROCESS - XTIME_BU_PROCESS
+!
+!-------------------------------------------------------------------------------
+ZTIME1 = ZTIME2
+XTIME_BU_PROCESS = 0.
+XTIME_LES_BU_PROCESS = 0.
+!
+!$acc kernels
+ZRWS(:,:,:) = XRWS(:,:,:)
+!$acc end kernels
+!
+CALL GRAVITY_IMPL ( CLBCX, CLBCY, NRR, NRRL, NRRI,XTSTEP, &
+ XTHT, XRT, XTHVREF, XRHODJ, XRWS, XRTHS, XRRS, &
+ XRTHS_CLD, XRRS_CLD )
+!
+! At the initial instant the difference with the ref state creates a
+! vertical velocity production that must not be advected as it is
+! compensated by the pressure gradient
+!
+IF (KTCOUNT == 1 .AND. CCONF=='START') THEN
+!$acc kernels
+ XRWS_PRES(:,:,:) = ZRWS(:,:,:) - XRWS(:,:,:)
+!$acc end kernels
+END IF
+!
+CALL SECOND_MNH2(ZTIME2)
+!
+XT_GRAV = XT_GRAV + ZTIME2 - ZTIME1 - XTIME_LES_BU_PROCESS - XTIME_BU_PROCESS
+!
+ZTIME1 = ZTIME2
+XTIME_BU_PROCESS = 0.
+XTIME_LES_BU_PROCESS = 0.
+!
+IF ((CUVW_ADV_SCHEME(1:3)=='CEN') .AND. (CTEMP_SCHEME == 'LEFR')) THEN
+ IF (CUVW_ADV_SCHEME=='CEN4TH') THEN
+ NULLIFY(TZFIELDC_ll)
+ NULLIFY(TZHALO2C_ll)
+ CALL ADD3DFIELD_ll( TZFIELDC_ll, XUT, 'MODEL_n::XUT' )
+ CALL ADD3DFIELD_ll( TZFIELDC_ll, XVT, 'MODEL_n::XVT' )
+ CALL ADD3DFIELD_ll( TZFIELDC_ll, XWT, 'MODEL_n::XWT' )
+ CALL INIT_HALO2_ll(TZHALO2C_ll,3,IIU,IJU,IKU)
+ CALL UPDATE_HALO_ll(TZFIELDC_ll,IINFO_ll)
+ CALL UPDATE_HALO2_ll(TZFIELDC_ll, TZHALO2C_ll, IINFO_ll)
+!$acc update device(XUT, XVT, XWT)
+ END IF
+!$acc data copyin(XUM, XVM, XWM) &
+!$acc & copy (XDUM, XDVM, XDWM)
+ CALL ADVECTION_UVW_CEN(CUVW_ADV_SCHEME, &
+ CLBCX, CLBCY, &
+ XTSTEP, KTCOUNT, &
+ XUM, XVM, XWM, XDUM, XDVM, XDWM, &
+ XUT, XVT, XWT, &
+ XRHODJ, XDXX, XDYY, XDZZ, XDZX, XDZY, &
+ XRUS,XRVS, XRWS, &
+ TZHALO2C_ll )
+!$acc end data
+ IF (CUVW_ADV_SCHEME=='CEN4TH') THEN
+ CALL CLEANLIST_ll(TZFIELDC_ll)
+ NULLIFY(TZFIELDC_ll)
+ CALL DEL_HALO2_ll(TZHALO2C_ll)
+ NULLIFY(TZHALO2C_ll)
+ END IF
+ELSE
+
+!$acc data copyin(XRUS_PRES, XRVS_PRES)
+ CALL ADVECTION_UVW(CUVW_ADV_SCHEME, CTEMP_SCHEME, &
+ NWENO_ORDER, LSPLIT_WENO, &
+ CLBCX, CLBCY, XTSTEP, &
+ XUT, XVT, XWT, &
+ XRHODJ, XDXX, XDYY, XDZZ, XDZX, XDZY, &
+ XRUS, XRVS, XRWS, &
+ XRUS_PRES, XRVS_PRES, XRWS_PRES )
+!$acc end data
+END IF
+!
+!$acc end data
+!
+CALL SECOND_MNH2(ZTIME2)
+!
+XT_ADVUVW = XT_ADVUVW + ZTIME2 - ZTIME1 - XTIME_LES_BU_PROCESS - XTIME_BU_PROCESS
+!
+!-------------------------------------------------------------------------------
+!
+IF (NMODEL_CLOUD==IMI .AND. CTURBLEN_CLOUD/='NONE') THEN
+ CALL TURB_CLOUD_INDEX(XTSTEP,TZBAKFILE, &
+ LTURB_DIAG,GCLOSE_OUT,NRRI, &
+ XRRS,XRT,XRHODJ,XDXX,XDYY,XDZZ,XDZX,XDZY, &
+ XCEI )
+END IF
+!
+!-------------------------------------------------------------------------------
+!
+!* 18. LATERAL BOUNDARY CONDITION FOR THE NORMAL VELOCITY
+! --------------------------------------------------
+!
+ZTIME1 = ZTIME2
+!
+ZRUS=XRUS
+ZRVS=XRVS
+ZRWS=XRWS
+!
+ CALL RAD_BOUND (CLBCX,CLBCY,CTURB,XCARPKMAX, &
+ XTSTEP, &
+ XDXHAT, XDYHAT, XZHAT, &
+ XUT, XVT, &
+ XLBXUM, XLBYVM, XLBXUS, XLBYVS, &
+ XCPHASE, XCPHASE_PBL, XRHODJ, &
+ XTKET,XRUS, XRVS, XRWS )
+ZRUS=XRUS-ZRUS
+ZRVS=XRVS-ZRVS
+ZRWS=XRWS-ZRWS
+!
+CALL SECOND_MNH2(ZTIME2)
+!
+XT_RAD_BOUND = XT_RAD_BOUND + ZTIME2 - ZTIME1
+!
+!-------------------------------------------------------------------------------
+!
+!* 19. PRESSURE COMPUTATION
+! --------------------
+!
+ZTIME1 = ZTIME2
+XTIME_BU_PROCESS = 0.
+XTIME_LES_BU_PROCESS = 0.
+!
+ZPABST = XPABST
+!
+IF(.NOT. L1D) THEN
+!
+ XRUS_PRES = XRUS
+ XRVS_PRES = XRVS
+ XRWS_PRES = XRWS
+!
+ CALL PRESSUREZ( CLBCX,CLBCY,CPRESOPT,NITR,LITRADJ,KTCOUNT, XRELAX,IMI, &
+ XRHODJ,XDXX,XDYY,XDZZ,XDZX,XDZY,XDXHATM,XDYHATM,XRHOM, &
+ XAF,XBFY,XCF,XTRIGSX,XTRIGSY,NIFAXX,NIFAXY, &
+ NRR,NRRL,NRRI,XDRYMASST,XREFMASS,XMASS_O_PHI0, &
+ XTHT,XRT,XRHODREF,XTHVREF,XRVREF,XEXNREF, XLINMASS, &
+ XRUS, XRVS, XRWS, XPABST, &
+ XBFB, &
+ XBF_SXP2_YP1_Z, &
+ XAF_ZS,XBF_ZS,XCF_ZS, &
+ XDXATH_ZS,XDYATH_ZS,XRHO_ZS, &
+ XA_K,XB_K,XC_K,XD_K) !JUAN FULL ZSOLVER
+!
+ XRUS_PRES = XRUS - XRUS_PRES + ZRUS
+ XRVS_PRES = XRVS - XRVS_PRES + ZRVS
+ XRWS_PRES = XRWS - XRWS_PRES + ZRWS
+!
+END IF
+!
+CALL SECOND_MNH2(ZTIME2)
+!
+XT_PRESS = XT_PRESS + ZTIME2 - ZTIME1 &
+ - XTIME_LES_BU_PROCESS - XTIME_BU_PROCESS
+!
+!-------------------------------------------------------------------------------
+!
+!* 20. CHEMISTRY/AEROSOLS
+! ------------------
+!
+ZTIME1 = ZTIME2
+XTIME_BU_PROCESS = 0.
+XTIME_LES_BU_PROCESS = 0.
+!
+IF (LUSECHEM) THEN
+ CALL CH_MONITOR_n(ZWETDEPAER,KTCOUNT,XTSTEP, ILUOUT, NVERB)
+END IF
+!
+! For inert aerosol (dust and sea salt) => aer_monitor_n
+IF ((LDUST).OR.(LSALT)) THEN
+!
+! tests to see if any cloud exists
+!
+ GCLD=.TRUE.
+ IF (GCLD .AND. NRR.LE.3 ) THEN
+ IF( MAXVAL(XCLDFR(:,:,:)).LE. 1.E-10 .AND. GCLOUD_ONLY ) THEN
+ GCLD = .FALSE. ! only the cloudy verticals would be
+ ! refreshed but there is no clouds
+ END IF
+ END IF
+!
+ IF (GCLD .AND. NRR.GE.4 ) THEN
+ IF( CCLOUD(1:3)=='ICE' )THEN
+ IF( MAXVAL(XRT(:,:,:,2)).LE.XRTMIN(2) .AND. &
+ MAXVAL(XRT(:,:,:,4)).LE.XRTMIN(4) .AND. GCLOUD_ONLY ) THEN
+ GCLD = .FALSE. ! only the cloudy verticals would be
+ ! refreshed but there is no cloudwater and ice
+ END IF
+ END IF
+ IF( CCLOUD=='C3R5' )THEN
+ IF( MAXVAL(XRT(:,:,:,2)).LE.XRTMIN_C1R3(2) .AND. &
+ MAXVAL(XRT(:,:,:,4)).LE.XRTMIN_C1R3(4) .AND. GCLOUD_ONLY ) THEN
+ GCLD = .FALSE. ! only the cloudy verticals would be
+ ! refreshed but there is no cloudwater and ice
+ END IF
+ END IF
+ IF( CCLOUD=='LIMA' )THEN
+ IF( MAXVAL(XRT(:,:,:,2)).LE.XRTMIN_LIMA(2) .AND. &
+ MAXVAL(XRT(:,:,:,4)).LE.XRTMIN_LIMA(4) .AND. GCLOUD_ONLY ) THEN
+ GCLD = .FALSE. ! only the cloudy verticals would be
+ ! refreshed but there is no cloudwater and ice
+ END IF
+ END IF
+ END IF
+
+!
+ CALL AER_MONITOR_n(KTCOUNT,XTSTEP, ILUOUT, NVERB, GCLD)
+END IF
+!
+!
+CALL SECOND_MNH2(ZTIME2)
+!
+XT_CHEM = XT_CHEM + ZTIME2 - ZTIME1 &
+ - XTIME_LES_BU_PROCESS - XTIME_BU_PROCESS
+!
+ZTIME = ZTIME + XTIME_LES_BU_PROCESS + XTIME_BU_PROCESS
+
+!-------------------------------------------------------------------------------
+!
+!* 20. WATER MICROPHYSICS
+! ------------------
+!
+ZTIME1 = ZTIME2
+XTIME_BU_PROCESS = 0.
+XTIME_LES_BU_PROCESS = 0.
+!
+IF (CCLOUD /= 'NONE' .AND. CELEC == 'NONE') THEN
+!
+ IF (CCLOUD == 'C2R2' .OR. CCLOUD == 'KHKO' .OR. CCLOUD == 'C3R5' &
+ .OR. CCLOUD == "LIMA" ) THEN
+ IF ( LFORCING ) THEN
+ XWT_ACT_NUC(:,:,:) = XWT(:,:,:) + XWTFRC(:,:,:)
+ ELSE
+ XWT_ACT_NUC(:,:,:) = XWT(:,:,:)
+ END IF
+ IF (CTURB /= 'NONE' ) THEN
+ IF ( ((CCLOUD=='C2R2'.OR.CCLOUD=='KHKO').AND.LACTTKE) .OR. (CCLOUD=='LIMA'.AND.MACTTKE) ) THEN
+ XWT_ACT_NUC(:,:,:) = XWT_ACT_NUC(:,:,:) + (2./3. * XTKET(:,:,:))**0.5
+ ELSE
+ XWT_ACT_NUC(:,:,:) = XWT_ACT_NUC(:,:,:)
+ ENDIF
+ ENDIF
+ ELSE
+ XWT_ACT_NUC(:,:,:) = 0.
+ END IF
+!
+ XRTHS_CLD(:, :, : ) = XRTHS(:, :, : )
+ XRRS_CLD (:, :, :, : ) = XRRS(:, :, :, : )
+ XRSVS_CLD(:, :, :, : ) = XRSVS(:, :, :, : )
+!$acc data present(XRHODJ) &
+!$acc & copyin (XZZ, XRHODREF, XEXNREF, ZPABST, XTHT, XSIGS, VSIGQSAT, XMFCONV, XTHM, XPABSM, &
+!$acc & XRCM, XWT_ACT_NUC, XDTHRAD, XCF_MF, XRC_MF, XRI_MF, &
+!$acc & XSOLORG, XMI) &
+!$acc & copy (XSUPSAT, XNACT, XNPRO, XSSPRO, &
+!$acc & XRT, XRRS, XSVT, XRSVS, XCLDFR, XCIT, XINPRR3D, XEVAP3D, &
+!$acc & XINPRC, XINPRR, XINPRS, XINPRG, XINPRH, XINDEP) &
+!$acc & copyout(XSRCT, XRAINFR)
+
+!$acc update device ( XRTHS )
+
+ IF (CSURF=='EXTE') THEN
+ ALLOCATE (ZSEA(SIZE(XRHODJ,1),SIZE(XRHODJ,2)))
+ ALLOCATE (ZTOWN(SIZE(XRHODJ,1),SIZE(XRHODJ,2)))
+ ZSEA(:,:) = 0.
+ ZTOWN(:,:)= 0.
+ CALL MNHGET_SURF_PARAM_n (PSEA=ZSEA(:,:),PTOWN=ZTOWN(:,:))
+!$acc data copyin(ZSEA, ZTOWN )
+ CALL RESOLVED_CLOUD ( CCLOUD, CACTCCN, CSCONV, CMF_CLOUD, NRR, NSPLITR, &
+ NSPLITG, IMI, KTCOUNT, &
+ CLBCX,CLBCY,TZBAKFILE, CRAD, CTURBDIM, &
+ GCLOSE_OUT, LSUBG_COND,LSIGMAS,CSUBG_AUCV,XTSTEP, &
+ XZZ, XRHODJ, XRHODREF, XEXNREF, &
+ ZPABST, XTHT,XRT,XSIGS,VSIGQSAT,XMFCONV,XTHM,XRCM, &
+ XPABSM, XWT_ACT_NUC,XDTHRAD, XRTHS, XRRS, &
+ XSVT, XRSVS, &
+ XSRCT, XCLDFR,XCIT, &
+ LSEDIC,KACTIT, KSEDC, KSEDI, KRAIN, KWARM, KHHONI, &
+ LCONVHG, XCF_MF,XRC_MF, XRI_MF, &
+! XINPRC,ZINPRC3D,XINPRR, XINPRR3D, XEVAP3D, &
+! XINPRS,ZINPRS3D, XINPRG,ZINPRG3D, XINPRH,ZINPRH3D, &
+ XINPRC,XINPRR, XINPRR3D, XEVAP3D, &
+ XINPRS, XINPRG,XINPRH, &
+! XSOLORG, XMI,ZSPEEDC, ZSPEEDR, ZSPEEDS, ZSPEEDG, ZSPEEDH, &
+ XSOLORG, XMI, &
+ XINDEP, XSUPSAT, XNACT, XNPRO,XSSPRO, XRAINFR, &
+ ZSEA, ZTOWN )
+!$acc end data
+ DEALLOCATE(ZTOWN)
+ ELSE
+ CALL RESOLVED_CLOUD ( CCLOUD, CACTCCN, CSCONV, CMF_CLOUD, NRR, NSPLITR, &
+ NSPLITG, IMI, KTCOUNT, &
+ CLBCX,CLBCY,TZBAKFILE, CRAD, CTURBDIM, &
+ GCLOSE_OUT, LSUBG_COND,LSIGMAS,CSUBG_AUCV, &
+ XTSTEP,XZZ, XRHODJ, XRHODREF, XEXNREF, &
+ ZPABST, XTHT,XRT,XSIGS,VSIGQSAT,XMFCONV,XTHM,XRCM, &
+ XPABSM, XWT_ACT_NUC,XDTHRAD, XRTHS, XRRS, &
+ XSVT, XRSVS, &
+ XSRCT, XCLDFR,XCIT, &
+ LSEDIC,KACTIT, KSEDC, KSEDI, KRAIN, KWARM, KHHONI, &
+ LCONVHG, XCF_MF,XRC_MF, XRI_MF, &
+! XINPRC,ZINPRC3D,XINPRR, XINPRR3D, XEVAP3D, &
+! XINPRS,ZINPRS3D, XINPRG,ZINPRG3D, XINPRH,ZINPRH3D, &
+ XINPRC,XINPRR, XINPRR3D, XEVAP3D, &
+ XINPRS, XINPRG,XINPRH, &
+! XSOLORG, XMI,ZSPEEDC, ZSPEEDR, ZSPEEDS, ZSPEEDG, ZSPEEDH, &
+ XSOLORG, XMI, &
+ XINDEP, XSUPSAT, XNACT, XNPRO,XSSPRO, XRAINFR )
+ END IF
+!$acc end data
+
+!$acc update host(XRTHS)
+
+ XRTHS_CLD(:, :, : ) = XRTHS(:, :, : ) - XRTHS_CLD(:, :, : )
+ XRRS_CLD (:, :, :, : ) = XRRS (:, :, :, : ) - XRRS_CLD (:, :, :, : )
+ XRSVS_CLD(:, :, :, : ) = XRSVS(:, :, :, : ) - XRSVS_CLD(:, :, :, : )
+!
+ IF (CCLOUD /= 'REVE' ) THEN
+ XACPRR = XACPRR + XINPRR * XTSTEP
+ IF ( (CCLOUD(1:3) == 'ICE' .AND. LSEDIC ) .OR. &
+ ((CCLOUD == 'C2R2' .OR. CCLOUD == 'C3R5' .OR. CCLOUD == 'KHKO' &
+ .OR. CCLOUD == 'LIMA' ) .AND. KSEDC ) ) THEN
+ XACPRC = XACPRC + XINPRC * XTSTEP
+ IF (LDEPOSC .OR. LDEPOC) XACDEP = XACDEP + XINDEP * XTSTEP
+ END IF
+ IF (CCLOUD(1:3) == 'ICE' .OR. CCLOUD == 'C3R5' .OR. &
+ (CCLOUD == 'LIMA' .AND. LCOLD ) ) THEN
+ XACPRS = XACPRS + XINPRS * XTSTEP
+ XACPRG = XACPRG + XINPRG * XTSTEP
+ IF (CCLOUD == 'ICE4' .OR. (CCLOUD == 'LIMA' .AND. LHAIL)) XACPRH = XACPRH + XINPRH * XTSTEP
+ END IF
+!
+! Lessivage des CCN et IFN nucléables par Slinn
+!
+ IF (LSCAV .AND. (CCLOUD == 'LIMA')) THEN
+ CALL LIMA_PRECIP_SCAVENGING(CCLOUD, ILUOUT, KTCOUNT,XTSTEP,XRT(:,:,:,3), &
+ XRHODREF, XRHODJ, XZZ, XPABST, XTHT, &
+ XSVT(:,:,:,NSV_LIMA_BEG:NSV_LIMA_END), &
+ XRSVS(:,:,:,NSV_LIMA_BEG:NSV_LIMA_END), XINPAP )
+!
+ XACPAP(:,:) = XACPAP(:,:) + XINPAP(:,:) * XTSTEP
+ END IF
+ END IF
+!
+! It is necessary that SV_C2R2 and SV_C1R3 are contiguous in the preceeding CALL
+!
+END IF
+!
+CALL SECOND_MNH2(ZTIME2)
+!
+XT_CLOUD = XT_CLOUD + ZTIME2 - ZTIME1 &
+ - XTIME_LES_BU_PROCESS - XTIME_BU_PROCESS
+!
+!-------------------------------------------------------------------------------
+!
+!* 21. CLOUD ELECTRIFICATION AND LIGHTNING FLASHES
+! -------------------------------------------
+!
+ZTIME1 = ZTIME2
+XTIME_BU_PROCESS = 0.
+XTIME_LES_BU_PROCESS = 0.
+!
+IF (CELEC /= 'NONE' .AND. (CCLOUD(1:3) == 'ICE')) THEN
+ XWT_ACT_NUC(:,:,:) = 0.
+!
+ XRTHS_CLD = XRTHS
+ XRRS_CLD = XRRS
+ XRSVS_CLD = XRSVS
+ IF (CSURF=='EXTE') THEN
+ ALLOCATE (ZSEA(SIZE(XRHODJ,1),SIZE(XRHODJ,2)))
+ ALLOCATE (ZTOWN(SIZE(XRHODJ,1),SIZE(XRHODJ,2)))
+ ZSEA(:,:) = 0.
+ ZTOWN(:,:)= 0.
+ CALL MNHGET_SURF_PARAM_n (PSEA=ZSEA(:,:),PTOWN=ZTOWN(:,:))
+ CALL RESOLVED_ELEC_n (CCLOUD, CSCONV, CMF_CLOUD, &
+ NRR, NSPLITR, IMI, KTCOUNT, OEXIT, &
+ CLBCX, CLBCY, CRAD, CTURBDIM, &
+ LSUBG_COND, LSIGMAS,VSIGQSAT,CSUBG_AUCV, &
+ XTSTEP, XZZ, XRHODJ, XRHODREF, XEXNREF, &
+ ZPABST, XTHT, XRTHS, XWT, XRT, XRRS, &
+ XSVT, XRSVS, XCIT, &
+ XSIGS, XSRCT, XCLDFR, XMFCONV, XCF_MF, XRC_MF, &
+ XRI_MF, LSEDIC, LWARM, &
+ XINPRC, XINPRR, XINPRR3D, XEVAP3D, &
+ XINPRS, XINPRG, XINPRH, &
+ ZSEA, ZTOWN )
+ DEALLOCATE(ZTOWN)
+ ELSE
+ CALL RESOLVED_ELEC_n (CCLOUD, CSCONV, CMF_CLOUD, &
+ NRR, NSPLITR, IMI, KTCOUNT, OEXIT, &
+ CLBCX, CLBCY, CRAD, CTURBDIM, &
+ LSUBG_COND, LSIGMAS,VSIGQSAT, CSUBG_AUCV, &
+ XTSTEP, XZZ, XRHODJ, XRHODREF, XEXNREF, &
+ ZPABST, XTHT, XRTHS, XWT, &
+ XRT, XRRS, XSVT, XRSVS, XCIT, &
+ XSIGS, XSRCT, XCLDFR, XMFCONV, XCF_MF, XRC_MF, &
+ XRI_MF, LSEDIC, LWARM, &
+ XINPRC, XINPRR, XINPRR3D, XEVAP3D, &
+ XINPRS, XINPRG, XINPRH )
+ END IF
+ XRTHS_CLD = XRTHS - XRTHS_CLD
+ XRRS_CLD = XRRS - XRRS_CLD
+ XRSVS_CLD = XRSVS - XRSVS_CLD
+!
+ XACPRR = XACPRR + XINPRR * XTSTEP
+ IF ((CCLOUD(1:3) == 'ICE' .AND. LSEDIC)) &
+ XACPRC = XACPRC + XINPRC * XTSTEP
+ IF (CCLOUD(1:3) == 'ICE') THEN
+ XACPRS = XACPRS + XINPRS * XTSTEP
+ XACPRG = XACPRG + XINPRG * XTSTEP
+ IF (CCLOUD == 'ICE4') XACPRH = XACPRH + XINPRH * XTSTEP
+ END IF
+END IF
+!
+CALL SECOND_MNH2(ZTIME2)
+!
+XT_ELEC = XT_ELEC + ZTIME2 - ZTIME1 &
+ - XTIME_LES_BU_PROCESS - XTIME_BU_PROCESS
+!
+!-------------------------------------------------------------------------------
+!
+!* 21. L.E.S. COMPUTATIONS
+! -------------------
+!
+ZTIME1 = ZTIME2
+!
+CALL LES_n
+!
+CALL SECOND_MNH2(ZTIME2)
+!
+XT_SPECTRA = XT_SPECTRA + ZTIME2 - ZTIME1 + XTIME_LES_BU + XTIME_LES
+!
+!-------------------------------------------------------------------------------
+!
+!* 21. bis MEAN_UM
+! --------------------
+!
+IF (LMEAN_FIELD) THEN
+ CALL MEAN_FIELD(XUT, XVT, XWT, XTHT, XTKET, XPABST)
+END IF
+!
+!-------------------------------------------------------------------------------
+!
+!* 22. UPDATE HALO OF EACH SUBDOMAINS FOR TIME T+DT
+! --------------------------------------------
+!
+ZTIME1 = ZTIME2
+!
+CALL EXCHANGE (XTSTEP,NRR,NSV,XRHODJ,TFIELDS_ll, &
+ XRUS, XRVS,XRWS,XRTHS,XRRS,XRTKES,XRSVS)
+!
+CALL SECOND_MNH2(ZTIME2)
+!
+XT_HALO = XT_HALO + ZTIME2 - ZTIME1
+!
+!-------------------------------------------------------------------------------
+!
+!* 23. TEMPORAL SWAPPING
+! -----------------
+!
+ZTIME1 = ZTIME2
+XTIME_BU_PROCESS = 0.
+!
+CALL ENDSTEP ( XTSTEP,NRR,NSV,KTCOUNT,IMI, &
+ CUVW_ADV_SCHEME,CTEMP_SCHEME,XRHODJ, &
+ XRUS,XRVS,XRWS,XDRYMASSS, &
+ XRTHS,XRRS,XRTKES,XRSVS, &
+ XLSUS,XLSVS,XLSWS, &
+ XLSTHS,XLSRVS,XLSZWSS, &
+ XLBXUS,XLBXVS,XLBXWS, &
+ XLBXTHS,XLBXRS,XLBXTKES,XLBXSVS, &
+ XLBYUS,XLBYVS,XLBYWS, &
+ XLBYTHS,XLBYRS,XLBYTKES,XLBYSVS, &
+ XUM,XVM,XWM,XZWS, &
+ XUT,XVT,XWT,XPABST,XDRYMASST, &
+ XTHT, XRT, XTHM, XRCM, XPABSM,XTKET, XSVT,&
+ XLSUM,XLSVM,XLSWM, &
+ XLSTHM,XLSRVM,XLSZWSM, &
+ XLBXUM,XLBXVM,XLBXWM, &
+ XLBXTHM,XLBXRM,XLBXTKEM,XLBXSVM, &
+ XLBYUM,XLBYVM,XLBYWM, &
+ XLBYTHM,XLBYRM,XLBYTKEM,XLBYSVM )
+!
+CALL SECOND_MNH2(ZTIME2)
+!
+XT_STEP_SWA = XT_STEP_SWA + ZTIME2 - ZTIME1 - XTIME_BU_PROCESS
+!
+!-------------------------------------------------------------------------------
+!
+!* 24.1 BALLOON and AIRCRAFT
+! --------------------
+!
+ZTIME1 = ZTIME2
+!
+IF (LFLYER) &
+ CALL AIRCRAFT_BALLOON(XTSTEP, &
+ TDTEXP, TDTMOD, TDTSEG, TDTCUR, &
+ XXHAT, XYHAT, XZZ, XMAP, XLONORI, XLATORI, &
+ XUT, XVT, XWT, XPABST, XTHT, XRT, XSVT, XTKET, XTSRAD, &
+ XRHODREF,XCIT,PSEA=ZSEA(:,:))
+
+
+!-------------------------------------------------------------------------------
+!
+!* 24.2 STATION (observation diagnostic)
+! --------------------------------
+!
+IF (LSTATION) &
+ CALL STATION_n(XTSTEP, &
+ TDTEXP, TDTMOD, TDTSEG, TDTCUR, &
+ XXHAT, XYHAT, XZZ, &
+ XUT, XVT, XWT, XTHT, XRT, XSVT, XTKET, XTSRAD, XPABST )
+!
+!---------------------------------------------------------
+!
+!* 24.3 PROFILER (observation diagnostic)
+! ---------------------------------
+!
+IF (LPROFILER) &
+ CALL PROFILER_n(XTSTEP, &
+ TDTEXP, TDTMOD, TDTSEG, TDTCUR, &
+ XXHAT, XYHAT, XZZ,XRHODREF, &
+ XUT, XVT, XWT, XTHT, XRT, XSVT, XTKET, XTSRAD, XPABST, &
+ XAER, XCLDFR, XCIT)
+!
+!
+CALL SECOND_MNH2(ZTIME2)
+!
+XT_STEP_MISC = XT_STEP_MISC + ZTIME2 - ZTIME1
+!
+!-------------------------------------------------------------------------------
+!
+!* 24.4 deallocation of observation diagnostics
+! ---------------------------------------
+!
+CALL END_DIAG_IN_RUN
+!
+!-------------------------------------------------------------------------------
+!
+!
+!* 25. STORAGE OF BUDGET FIELDS
+! ------------------------
+!
+ZTIME1 = ZTIME2
+!
+IF ( .NOT. LIO_NO_WRITE ) THEN
+ IF (NBUMOD==IMI .AND. CBUTYPE/='NONE') THEN
+ CALL ENDSTEP_BUDGET(TDIAFILE,KTCOUNT,TDTCUR,TDTMOD,XTSTEP,NSV)
+ END IF
+END IF
+!
+CALL SECOND_MNH2(ZTIME2)
+!
+XT_STEP_BUD = XT_STEP_BUD + ZTIME2 - ZTIME1 + XTIME_BU
+!
+!-------------------------------------------------------------------------------
+!
+!* 26. FM FILE CLOSURE
+! ---------------
+!
+IF (GCLOSE_OUT) THEN
+ GCLOSE_OUT=.FALSE.
+ CALL IO_File_close(TZBAKFILE)
+END IF
+!
+!-------------------------------------------------------------------------------
+!
+!* 27. CURRENT TIME REFRESH
+! --------------------
+!
+TDTCUR%TIME=TDTCUR%TIME + XTSTEP
+CALL DATETIME_CORRECTDATE(TDTCUR)
+!
+!-------------------------------------------------------------------------------
+!
+!* 28. CPU ANALYSIS
+! ------------
+!
+CALL SECOND_MNH2(ZTIME2)
+XT_START=XT_START+ZTIME2-ZEND
+!
+!
+IF ( KTCOUNT == NSTOP .AND. IMI==1) THEN
+ OEXIT=.TRUE.
+END IF
+!
+IF (OEXIT) THEN
+!
+ IF ( .NOT. LIO_NO_WRITE ) THEN
+ IF (LSERIES) CALL WRITE_SERIES_n(TDIAFILE)
+ CALL WRITE_AIRCRAFT_BALLOON(TDIAFILE)
+ CALL WRITE_STATION_n(TDIAFILE)
+ CALL WRITE_PROFILER_n(TDIAFILE)
+ CALL WRITE_LES_n(TDIAFILE,' ')
+ CALL WRITE_LES_n(TDIAFILE,'A')
+ CALL WRITE_LES_n(TDIAFILE,'E')
+ CALL WRITE_LES_n(TDIAFILE,'H')
+ CALL MENU_DIACHRO(TDIAFILE,'END')
+ CALL IO_File_close(TDIAFILE)
+ END IF
+ !
+ CALL IO_File_close(TINIFILE)
+ IF (CSURF=="EXTE") CALL IO_File_close(TINIFILEPGD)
+!
+!* 28.1 print statistics!
+!
+ ! Set File Timing OUTPUT
+ !
+ CALL SET_ILUOUT_TIMING(TLUOUT)
+ !
+ ! Compute global time
+ !
+ CALL TIME_STAT_ll(XT_START,ZTOT)
+ !
+ CALL TIME_HEADER_ll(IMI)
+ !
+ CALL TIME_STAT_ll(XT_1WAY,ZTOT, ' ONE WAY','=')
+ CALL TIME_STAT_ll(XT_BOUND,ZTOT, ' BOUNDARIES','=')
+ CALL TIME_STAT_ll(XT_STORE,ZTOT, ' STORE-FIELDS','=')
+ CALL TIME_STAT_ll(TIMEZ%T_WRIT3D_SEND,ZTOT, ' W3D_SEND ','-')
+ CALL TIME_STAT_ll(TIMEZ%T_WRIT3D_RECV,ZTOT, ' W3D_RECV ','-')
+ CALL TIME_STAT_ll(TIMEZ%T_WRIT3D_WRIT,ZTOT, ' W3D_WRIT ','-')
+ CALL TIME_STAT_ll(TIMEZ%T_WRIT3D_WAIT,ZTOT, ' W3D_WAIT ','-')
+ CALL TIME_STAT_ll(TIMEZ%T_WRIT3D_ALL ,ZTOT, ' W3D_ALL ','-')
+ CALL TIME_STAT_ll(TIMEZ%T_WRIT2D_GATH,ZTOT, ' W2D_GATH ','-')
+ CALL TIME_STAT_ll(TIMEZ%T_WRIT2D_WRIT,ZTOT, ' W2D_WRIT ','-')
+ CALL TIME_STAT_ll(TIMEZ%T_WRIT2D_ALL ,ZTOT, ' W2D_ALL ','-')
+ CALL TIME_STAT_ll(XT_GUESS,ZTOT, ' INITIAL_GUESS','=')
+ CALL TIME_STAT_ll(XT_2WAY,ZTOT, ' TWO WAY','=')
+ CALL TIME_STAT_ll(XT_ADV,ZTOT, ' ADVECTION MET','=')
+ CALL TIME_STAT_ll(XT_ADVUVW,ZTOT, ' ADVECTION UVW','=')
+ CALL TIME_STAT_ll(XT_GRAV,ZTOT, ' GRAVITY','=')
+ CALL TIME_STAT_ll(XT_FORCING,ZTOT, ' FORCING','=')
+ CALL TIME_STAT_ll(XT_NUDGING,ZTOT, ' NUDGING','=')
+ CALL TIME_STAT_ll(XT_SOURCES,ZTOT, ' DYN_SOURCES','=')
+ CALL TIME_STAT_ll(XT_DIFF,ZTOT, ' NUM_DIFF','=')
+ CALL TIME_STAT_ll(XT_RELAX,ZTOT, ' RELAXATION','=')
+ !
+ CALL TIMING_LEGEND()
+ !
+ CALL TIME_STAT_ll(XT_PARAM,ZTOT, ' PHYS_PARAM','=')
+ CALL TIME_STAT_ll(XT_RAD,ZTOT, ' RAD = '//CRAD ,'-')
+ CALL TIME_STAT_ll(XT_SHADOWS,ZTOT, ' SHADOWS' ,'-')
+ CALL TIME_STAT_ll(XT_DCONV,ZTOT, ' DEEP CONV = '//CDCONV,'-')
+ CALL TIME_STAT_ll(XT_GROUND,ZTOT, ' GROUND' ,'-')
+ CALL TIME_STAT_ll(XT_TURB,ZTOT, ' TURB = '//CTURB ,'-')
+ CALL TIME_STAT_ll(XT_MAFL,ZTOT, ' MAFL = '//CSCONV,'-')
+ CALL TIME_STAT_ll(XT_CHEM,ZTOT, ' CHIMIE' ,'-')
+ CALL TIMING_LEGEND()
+ CALL TIME_STAT_ll(XT_COUPL,ZTOT, ' SET_COUPLING','=')
+ CALL TIME_STAT_ll(XT_RAD_BOUND,ZTOT, ' RAD_BOUND','=')
+ !
+ CALL TIMING_LEGEND()
+ !
+ CALL TIME_STAT_ll(XT_PRESS,ZTOT, ' PRESSURE ','=','F')
+ !JUAN Z_SPLITTING
+ CALL TIME_STAT_ll(TIMEZ%T_MAP_B_SX_YP2_ZP1,ZTOT, ' REMAP B=>FFTXZ' ,'-','F')
+ CALL TIME_STAT_ll(TIMEZ%T_MAP_SX_YP2_ZP1_SXP2_Y_ZP1,ZTOT, ' REMAP FFTXZ=>FFTYZ' ,'-','F')
+ CALL TIME_STAT_ll(TIMEZ%T_MAP_SXP2_Y_ZP1_B,ZTOT, ' REMAP FTTYZ=>B' ,'-','F')
+ CALL TIME_STAT_ll(TIMEZ%T_MAP_SXP2_Y_ZP1_SXP2_YP1_Z,ZTOT, ' REMAP FFTYZ=>SUBZ' ,'-','F')
+ CALL TIME_STAT_ll(TIMEZ%T_MAP_B_SXP2_Y_ZP1,ZTOT, ' REMAP B=>FFTYZ-1','-','F')
+ CALL TIME_STAT_ll(TIMEZ%T_MAP_SXP2_YP1_Z_SXP2_Y_ZP1,ZTOT, ' REMAP SUBZ=>FFTYZ-1','-','F')
+ CALL TIME_STAT_ll(TIMEZ%T_MAP_SXP2_Y_ZP1_SX_YP2_ZP1,ZTOT, ' REMAP FFTYZ-1=>FFTXZ-1','-','F')
+ CALL TIME_STAT_ll(TIMEZ%T_MAP_SX_YP2_ZP1_B,ZTOT, ' REMAP FFTXZ-1=>B ' ,'-','F')
+ ! JUAN P1/P2
+ CALL TIME_STAT_ll(XT_CLOUD,ZTOT, ' RESOLVED_CLOUD','=')
+ CALL TIME_STAT_ll(XT_ELEC,ZTOT, ' RESOLVED_ELEC','=')
+ CALL TIME_STAT_ll(XT_HALO,ZTOT, ' EXCHANGE_HALO','=')
+ CALL TIME_STAT_ll(XT_STEP_SWA,ZTOT, ' ENDSTEP','=')
+ CALL TIME_STAT_ll(XT_STEP_BUD,ZTOT, ' BUDGETS','=')
+ CALL TIME_STAT_ll(XT_SPECTRA,ZTOT, ' LES','=')
+ CALL TIME_STAT_ll(XT_STEP_MISC,ZTOT, ' MISCELLANEOUS','=')
+ !
+ ! sum of call subroutine
+ !
+ ZALL = XT_1WAY + XT_BOUND + XT_STORE + XT_GUESS + XT_2WAY + &
+ XT_ADV + XT_FORCING + XT_NUDGING + XT_SOURCES + XT_DIFF + &
+ XT_ADVUVW + XT_GRAV + &
+ XT_RELAX+ XT_PARAM + XT_COUPL + XT_RAD_BOUND+XT_PRESS + &
+ XT_CLOUD+ XT_ELEC + XT_HALO + XT_SPECTRA + XT_STEP_SWA + &
+ XT_STEP_MISC+ XT_STEP_BUD
+ CALL TIME_STAT_ll(ZALL,ZTOT, ' SUM(CALL)','=')
+ CALL TIMING_SEPARATOR('=')
+ !
+ ! Gobale Stat
+ !
+ WRITE(ILUOUT,FMT=*)
+ WRITE(ILUOUT,FMT=*)
+ CALL TIMING_LEGEND()
+ !
+ ! MODELN all included
+ !
+ CALL TIMING_SEPARATOR('+')
+ CALL TIMING_SEPARATOR('+')
+ WRITE(YMI,FMT="(I0)") IMI
+ CALL TIME_STAT_ll(XT_START,ZTOT, ' MODEL'//YMI,'+')
+ CALL TIMING_SEPARATOR('+')
+ CALL TIMING_SEPARATOR('+')
+ CALL TIMING_SEPARATOR('+')
+ !
+ ! Timing/ Steps
+ !
+ ZTIME_STEP = XT_START / REAL(KTCOUNT)
+ WRITE(YTCOUNT,FMT="(I0)") KTCOUNT
+ CALL TIME_STAT_ll(ZTIME_STEP,ZTOT, ' SECOND/STEP='//YTCOUNT,'=')
+ !
+ ! Timing/Step/Points
+ !
+ IPOINTS = NIMAX_ll*NJMAX_ll*NKMAX
+ WRITE(YPOINTS,FMT="(I0)") IPOINTS
+ ZTIME_STEP_PTS = ZTIME_STEP / REAL(IPOINTS) * 1e6
+ CALL TIME_STAT_ll(ZTIME_STEP_PTS,ZTOT_PT)
+ CALL TIME_STAT_ll(ZTIME_STEP_PTS,ZTOT_PT, ' MICROSEC/STP/PT='//YPOINTS,'-')
+ !
+ CALL TIMING_SEPARATOR('=')
+ !
+ !
+ !
+ CALL IO_File_close(TLUOUT)
+ IF (IMI==NMODEL) CALL IO_File_close(TLUOUT0)
+END IF
+
+!$acc end data
+
+END SUBROUTINE MODEL_n
diff --git a/src/ZSOLVER/pressurez.f90 b/src/ZSOLVER/pressurez.f90
new file mode 100644
index 0000000000000000000000000000000000000000..a637645ae4e9cd3df13f6ec93fbff5a551d4338b
--- /dev/null
+++ b/src/ZSOLVER/pressurez.f90
@@ -0,0 +1,928 @@
+!MNH_LIC Copyright 1994-2020 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.
+!-----------------------------------------------------------------
+!###################
+MODULE MODI_PRESSUREZ
+!###################
+!
+INTERFACE
+!
+ SUBROUTINE PRESSUREZ( &
+ HLBCX,HLBCY,HPRESOPT,KITR,OITRADJ,KTCOUNT,PRELAX,KMI, &
+ PRHODJ,PDXX,PDYY,PDZZ,PDZX,PDZY,PDXHATM,PDYHATM,PRHOT, &
+ PAF,PBF,PCF,PTRIGSX,PTRIGSY,KIFAXX,KIFAXY, &
+ KRR,KRRL,KRRI,PDRYMASST,PREFMASS,PMASS_O_PHI0, &
+ PTHT,PRT,PRHODREF,PTHVREF,PRVREF,PEXNREF,PLINMASS, &
+ PRUS,PRVS,PRWS,PPABST, &
+ PBFB, &
+ PBF_SXP2_YP1_Z, &
+ PAF_ZS,PBF_ZS,PCF_ZS, &
+ PDXATH_ZS,PDYATH_ZS,PRHO_ZS, &
+ A_K,B_K,C_K,D_K, &
+ PRESIDUAL) !JUAN FULL ZSOLVER
+!
+IMPLICIT NONE
+!
+CHARACTER (LEN=*), DIMENSION(:), INTENT(IN) :: HLBCX ! x-direction LBC type
+CHARACTER (LEN=*), DIMENSION(:), INTENT(IN) :: HLBCY ! y-direction LBC type
+!
+CHARACTER (LEN=5), INTENT(IN) :: HPRESOPT ! choice of the pressure solver
+!
+INTEGER, INTENT(INOUT) :: KITR ! number of iterations for the
+ ! pressure solver
+LOGICAL, INTENT(IN) :: OITRADJ ! switch to adjust or not KITR
+INTEGER, INTENT(IN) :: KTCOUNT ! counter value of the
+ ! model temporal loop
+INTEGER, INTENT(IN) :: KMI ! Model index
+REAL, INTENT(IN) :: PRELAX ! relaxation coefficient for
+ ! the Richardson's method
+!
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODJ ! density of reference state
+ ! * J
+!
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDXX,PDYY,PDZZ,PDZX,PDZY ! metric coefficients
+!
+REAL, INTENT(IN) :: PDXHATM ! mean grid increment in the x
+ ! direction
+REAL, INTENT(IN) :: PDYHATM ! mean grid increment in the y
+ ! direction
+!
+REAL, DIMENSION (:), INTENT(IN) :: PRHOT ! mean of XRHODJ on the plane x y
+ ! localized at a mass level
+!
+REAL, DIMENSION(:), INTENT(IN) :: PAF,PCF ! vectors giving the nonvanishing
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PBF ! elements of the tri-diag. y-slide
+ ! matrix in the pressure eq.
+!
+ ! arrays of sin or cos values
+ ! for the FFT :
+REAL, DIMENSION(:), INTENT(IN) :: PTRIGSX ! - along x
+REAL, DIMENSION(:), INTENT(IN) :: PTRIGSY ! - along y
+!
+ ! decomposition in prime
+ ! numbers for the FFT:
+INTEGER, DIMENSION(19), INTENT(IN) :: KIFAXX ! - along x
+INTEGER, DIMENSION(19), INTENT(IN) :: KIFAXY ! - along y
+!
+!
+INTEGER, INTENT(IN) :: KRR ! Total number of water var.
+INTEGER, INTENT(IN) :: KRRL ! Number of liquid water var.
+INTEGER, INTENT(IN) :: KRRI ! Number of ice water var.
+!
+REAL, INTENT(IN) :: PDRYMASST ! Mass of dry air and of
+REAL, INTENT(IN) :: PREFMASS ! the ref. atmosphere
+REAL, INTENT(IN) :: PMASS_O_PHI0 ! Mass / Phi0
+!
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PTHT ! Temperature and water
+REAL, DIMENSION(:,:,:,:), INTENT(IN) :: PRT ! variables at time t
+!
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODREF ! dry Density
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PTHVREF ! Virtual Temperature
+ ! of the reference state
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRVREF ! mixing ratio of the
+ ! reference state
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PEXNREF ! Exner function
+ ! of the reference state
+REAL, INTENT(IN) :: PLINMASS ! lineic mass through
+ ! open boundaries
+!
+REAL, INTENT(INOUT) :: PRUS(:,:,:) ! source term along x
+REAL, INTENT(INOUT) :: PRVS(:,:,:) ! source term along y
+REAL, INTENT(INOUT) :: PRWS(:,:,:) ! source term along z
+!
+REAL, INTENT(INOUT) :: PPABST(:,:,:) ! pressure(t)
+!
+!JUAN Z_SPLITING
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PBFB ! elements of the tri-diag b-slide .
+ ! matrix in the pressure eq.
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PBF_SXP2_YP1_Z ! elements of the tri-diag. SXP2_YP1_Z-slide
+ ! matrix in the pressure eq.
+
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PAF_ZS,PBF_ZS,PCF_ZS
+REAL, DIMENSION(:,:) , INTENT(IN) :: PDXATH_ZS,PDYATH_ZS
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHO_ZS
+REAL, DIMENSION(:) , INTENT(IN) :: A_K,B_K,C_K,D_K
+
+REAL, OPTIONAL :: PRESIDUAL
+!JUAN Z_SPLITING
+END SUBROUTINE PRESSUREZ
+!
+END INTERFACE
+!
+END MODULE MODI_PRESSUREZ
+! ######################################################################
+ SUBROUTINE PRESSUREZ( &
+ HLBCX,HLBCY,HPRESOPT,KITR,OITRADJ,KTCOUNT,PRELAX,KMI, &
+ PRHODJ,PDXX,PDYY,PDZZ,PDZX,PDZY,PDXHATM,PDYHATM,PRHOT, &
+ PAF,PBF,PCF,PTRIGSX,PTRIGSY,KIFAXX,KIFAXY, &
+ KRR,KRRL,KRRI,PDRYMASST,PREFMASS,PMASS_O_PHI0, &
+ PTHT,PRT,PRHODREF,PTHVREF,PRVREF,PEXNREF,PLINMASS, &
+ PRUS,PRVS,PRWS,PPABST, &
+ PBFB, &
+ PBF_SXP2_YP1_Z, &
+ PAF_ZS,PBF_ZS,PCF_ZS, &
+ PDXATH_ZS,PDYATH_ZS,PRHO_ZS, &
+ A_K,B_K,C_K,D_K, &
+ PRESIDUAL) !JUAN FULL ZSOLVER
+! ######################################################################
+!
+!!**** *PRESSUREZ * - solve the pressure equation and add the pressure term
+!! to the sources
+!!
+!! PURPOSE
+!! -------
+! The purpose of this routine is to solve the pressure equation:
+! with either the conjugate gradient method or the Richardson's method.
+! The pressure gradient is added to the sources in order
+! to nullify the divergence of the momentum* Thetavref*(1+Rvref)
+! at the time t+dt.
+!
+!!** METHOD
+!! ------
+!! The divergence of the sources ( RHS of the pressure equation ) is
+!! computed. The pressure equation is then solved by either CG method,
+!! either Richardson's method, or an exact method. Finally, the pressure
+!! gradient is added to the sources RUS, RVS, RWS.
+!! Finally, the absolute pressure is diagnozed from the total mass
+!! included in the simulation domain.
+!!
+!! EXTERNAL
+!! --------
+!! Subroutine MASS_LEAK : assures global non-divergence condition in the
+!! case of open boundaries
+!! Subroutine FLAT_INV : solve the pressure equation for the case
+!! without orography
+!! Subroutine RICHARDSON: solve the pressure equation with the
+!! Richardson's method
+!! Subroutine CONJGRAD : solve the pressure equation with the Conjugate
+!! Gradient algorithm
+!! Function GX_M_U : compute the gradient along x
+!! Function GY_M_V : compute the gradient along y
+!! Function GZ_M_W : compute the gradient along z
+!! Subroutine GDIV : compute J times the divergence of 1/J times a vector
+!! Function MXM: compute an average in the x direction for a variable
+!! at a mass localization
+!! Function MYM: compute an average in the y direction for a variable
+!! at a mass localization
+!! Function MZM: compute an average in the z direction for a variable
+!! at a mass localization
+!! Subroutine P_ABS : compute the constant for PABS and therefore, the
+!! absolute pressure function
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module MODD_CONF: model configuration
+!! LFLAT: logical switch for zero orography
+!! L2D : logical switch for two-dimensional configuration
+!! LCARTESIAN : logical switch for cartesian geometry
+!! Module MODD_PARAMETERS: declaration of parameter variables
+!! JPHEXT, JPVEXT: define the number of marginal points out of the
+!! physical domain along horizontal and vertical directions respectively
+!! Module MODD_CST: physical constants
+!! XCPD
+!!
+!! REFERENCE
+!! ---------
+!! Book2 of documentation (subroutine PRESSURE) + Book1 ( )
+!!
+!! AUTHOR
+!! ------
+!! P. Hereil and J. Stein * Meteo France *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 05/07/94
+!! Modification 03/01/95 (Lafore) To add the absolute pressure diagnosis
+!! Modification 31/01/95 (Stein) Copy of the pressure function in the
+!! 2D case in the two outermost planes
+!! Modification 16/02/95 (Mallet) Add the call to MASS_LEAK
+!! Modification 16/03/95 (Stein) change the argument list of the
+!! gradient and remove R from the historical var.
+!! Modification 30/06/95 (Stein) Add a test not to compute the absolute
+!! pressure in the Boussinesq case
+!! 16/10/95 (J. Stein) change the budget calls
+!! 29/01/96 (J. Stein) call iterative resolution for
+!! non-cartessian geometry
+!! 19/12/96 (J.-P. Pinty) update the budget calls
+!! 14/01/97 (Stein,Lafore) New anelastic equations
+!! 17/12/97 ( Stein )include the case of non-vanishing
+!! orography at the lbc
+!! 26/03/98 (Stein,Jabouille) fix the value of the corner point
+!! 15/06/98 (D.Lugato, R.Guivarch) Parallelisation
+!! 25/08/99 (J.-P. Pinty) add CRESI option to CPRESOPT
+!! 06/11/02 (V. Masson) update the budget calls
+!! 24/08/2005 (J. escobar) BUG : remove IIE+1, IJE+1 out of bound
+!! references in parallel run
+!! 08/2010 (V.Masson, C.Lac) Add UPDATE_HALO
+!! 11/2010 (V.Masson, C.Lac) PPABST, must not be cyclic => add temp array
+!! to save it before UPDATE_HALO
+!! 07/2011 (J.escobar ) Bypass Bug with ifort11/12 on HLBCX,HLBCY
+!! 09/2001 (J.escobar ) reintroduce correctly the GMAXLOC_ll call
+!! 11/2010 (V.Masson, C.Lac) PPABST must not be cyclic => add temp array
+!! to save it before UPDATE_HALO
+!! 02/2013 (J.Escobar ) add a test on abs(err) > 100.O for BG without controle of NAN
+!! 2012 (V.Masson) Modif update_halo due to CONTRAV
+!! 2014 (C.Lac) correction for 3D run with LBOUSS=.TRUE.
+!! J.Escobar : 15/09/2015 : WENO5 & JPHEXT <> 1
+!! J.escobar : check nb proc versus ZRESI & min(DIMX,DIMY)
+!! Philippe Wautelet: 05/2016-04/2018: new data structures and calls for I/O
+!! Philippe Wautelet: 22/01/2019: use standard FLUSH statement instead of non standard intrinsics
+! P. Wautelet 10/04/2019: replace ABORT and STOP calls by Print_msg
+! P. Wautelet 20/05/2019: add name argument to ADDnFIELD_ll + new ADD4DFIELD_ll subroutine
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_ARGSLIST_ll, ONLY: LIST_ll
+USE MODD_BUDGET
+USE MODD_CST
+USE MODD_CONF
+USE MODD_DYN_n, ONLY: LRES, XRES
+USE MODD_LUNIT_n, ONLY: TLUOUT
+USE MODD_MPIF
+USE MODD_PARAMETERS
+use modd_precision, only: MNHREAL_MPI
+USE MODD_REF, ONLY: LBOUSS
+USE MODD_VAR_ll, ONLY: NMNH_COMM_WORLD , NPROC
+!
+USE MODE_ll
+USE MODE_MPPDB
+USE MODE_MSG
+USE MODE_SUM2_ll, ONLY: GMAXLOC_ll
+!
+USE MODI_BUDGET
+USE MODI_CONJGRAD
+USE MODI_ZCONJGRAD
+USE MODI_CONRESOL
+USE MODI_CONRESOLZ
+USE MODI_FLAT_INV
+USE MODI_ZSOLVER
+USE MODI_FLAT_INVZ
+USE MODI_GDIV
+USE MODI_GRADIENT_M
+USE MODI_MASS_LEAK
+USE MODI_P_ABS
+USE MODI_RICHARDSON
+USE MODI_SHUMAN
+#ifdef MNH_OPENACC
+USE MODI_SHUMAN_DEVICE
+USE MODI_GET_HALO
+#endif
+!
+#ifdef MNH_BITREP
+USE MODI_BITREP
+USE MODE_MNH_ZWORK , ONLY : MNH_ALLOCATE_ZT3D , MNH_REL_ZT3D
+#endif
+!
+IMPLICIT NONE
+!
+!* 0.1 declarations of arguments
+!
+ CHARACTER (LEN=*), DIMENSION(:), INTENT(IN) :: HLBCX ! x-direction LBC type
+ CHARACTER (LEN=*), DIMENSION(:), INTENT(IN) :: HLBCY ! y-direction LBC type
+!
+CHARACTER (LEN=5), INTENT(IN) :: HPRESOPT ! choice of the pressure solver
+!
+INTEGER, INTENT(INOUT) :: KITR ! number of iterations for the
+ ! pressure solver
+LOGICAL, INTENT(IN) :: OITRADJ ! switch to adjust or not KITR
+INTEGER, INTENT(IN) :: KTCOUNT ! counter value of the
+ ! model temporal loop
+INTEGER, INTENT(IN) :: KMI ! Model index
+REAL, INTENT(IN) :: PRELAX ! relaxation coefficient for
+ ! the Richardson's method
+!
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODJ ! density of reference state
+ ! * J
+!
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDXX,PDYY,PDZZ,PDZX,PDZY ! metric coefficients
+!
+REAL, INTENT(IN) :: PDXHATM ! mean grid increment in the x
+ ! direction
+REAL, INTENT(IN) :: PDYHATM ! mean grid increment in the y
+ ! direction
+!
+REAL, DIMENSION (:), INTENT(IN) :: PRHOT ! mean of XRHODJ on the plane x y
+ ! localized at a mass level
+!
+REAL, DIMENSION(:), INTENT(IN) :: PAF,PCF ! vectors giving the nonvanishing
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PBF ! elements of the tri-diag y-slide .
+ ! matrix in the pressure eq.
+!
+ ! arrays of sin or cos values
+ ! for the FFT :
+REAL, DIMENSION(:), INTENT(IN) :: PTRIGSX ! - along x
+REAL, DIMENSION(:), INTENT(IN) :: PTRIGSY ! - along y
+!
+ ! decomposition in prime
+ ! numbers for the FFT:
+INTEGER, DIMENSION(19), INTENT(IN) :: KIFAXX ! - along x
+INTEGER, DIMENSION(19), INTENT(IN) :: KIFAXY ! - along y
+!
+INTEGER, INTENT(IN) :: KRR ! Total number of water var.
+INTEGER, INTENT(IN) :: KRRL ! Number of liquid water var.
+INTEGER, INTENT(IN) :: KRRI ! Number of ice water var.
+!
+REAL, INTENT(IN) :: PDRYMASST ! Mass of dry air and of
+REAL, INTENT(IN) :: PREFMASS ! the ref. atmosphere
+REAL, INTENT(IN) :: PMASS_O_PHI0 ! Mass / Phi0
+!
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PTHT ! Temperature and water
+REAL, DIMENSION(:,:,:,:), INTENT(IN) :: PRT ! variables at time t
+!
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODREF ! dry Density
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PTHVREF ! Virtual Temperature
+ ! of the reference state
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRVREF ! mixing ratio of the
+ ! reference state
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PEXNREF ! Exner function
+ ! of the reference state
+REAL, INTENT(IN) :: PLINMASS ! lineic mass through
+ ! open boundaries
+!
+REAL, INTENT(INOUT) :: PRUS(:,:,:) ! source term along x
+REAL, INTENT(INOUT) :: PRVS(:,:,:) ! source term along y
+REAL, INTENT(INOUT) :: PRWS(:,:,:) ! source term along z
+!
+REAL, INTENT(INOUT) :: PPABST(:,:,:) ! pressure(t)
+!
+!JUAN Z_SPLITING
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PBFB ! elements of the tri-diag b-slide .
+ ! matrix in the pressure eq.
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PBF_SXP2_YP1_Z ! elements of the tri-diag. SXP2_YP1_Z-slide
+ ! matrix in the pressure eq.
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PAF_ZS,PBF_ZS,PCF_ZS
+REAL, DIMENSION(:,:) , INTENT(IN) :: PDXATH_ZS,PDYATH_ZS
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHO_ZS
+REAL, DIMENSION(:) , INTENT(IN) :: A_K,B_K,C_K,D_K
+
+REAL, OPTIONAL :: PRESIDUAL
+!JUAN Z_SPLITING
+!
+!* 0.2 declarations of local variables
+!
+! Metric coefficients:
+!
+REAL, DIMENSION(SIZE(PPABST,1),SIZE(PPABST,2),SIZE(PPABST,3)) :: ZDV_SOURCE
+! ! divergence of the sources
+!
+INTEGER :: IIB ! indice I for the first inner mass point along x
+INTEGER :: IIE ! indice I for the last inner mass point along x
+INTEGER :: IJB ! indice J for the first inner mass point along y
+INTEGER :: IJE ! indice J for the last inner mass point along y
+INTEGER :: IKB ! indice K for the first inner mass point along z
+INTEGER :: IKE ! indice K for the last inner mass point along z
+INTEGER :: ILUOUT ! Logical unit of output listing
+INTEGER :: IRESP ! Return code of FM routines
+!
+REAL, DIMENSION(SIZE(PPABST,1),SIZE(PPABST,2),SIZE(PPABST,3)) :: ZTHETAV, &
+ ! virtual potential temperature
+ ZPHIT
+ ! MAE + DUR => Exner function perturbation
+ ! LHE => Exner function perturbation * CPD * THVREF
+!
+REAL :: ZRV_OV_RD ! XRV / XRD
+REAL :: ZMAXVAL, ZMAXRES, ZMAX,ZMAX_ll ! for print
+INTEGER, DIMENSION(3) :: IMAXLOC ! purpose
+INTEGER :: JWATER ! loop index on water species
+INTEGER :: IIU,IJU,IKU ! array sizes in I,J,K
+INTEGER :: JK ! loop index on the vertical levels
+INTEGER :: JI,JJ
+!
+REAL, DIMENSION(SIZE(PDXX,1),SIZE(PDXX,3)) :: ZPABS_S ! local pressure on southern side
+REAL, DIMENSION(SIZE(PDXX,1),SIZE(PDXX,3)) :: ZPABS_N ! local pressure on northern side
+REAL, DIMENSION(SIZE(PDYY,2),SIZE(PDXX,3)) :: ZPABS_E ! local pressure on eastern side
+REAL, DIMENSION(SIZE(PDYY,2),SIZE(PDXX,3)) :: ZPABS_W ! local pressure on western side
+INTEGER :: IINFO_ll,KINFO
+TYPE(LIST_ll), POINTER :: TZFIELDS_ll, TZFIELDS2_ll ! list of fields to exchange
+!
+INTEGER :: IIB_I,IIE_I,IJB_I,IJE_I
+INTEGER :: IIMAX_ll,IJMAX_ll
+!
+REAL, DIMENSION(:,:,:) , POINTER , CONTIGUOUS :: ZPRHODJ,ZMXM_PRHODJ,ZMZM_PRHODJ,ZGZ_M_W
+INTEGER :: IZPRHODJ,IZMXM_PRHODJ,IZMZM_PRHODJ,IZGZ_M_W
+REAL, DIMENSION(:,:,:) , POINTER , CONTIGUOUS :: ZMYM_PRHODJ
+INTEGER :: IZMYM_PRHODJ
+!
+!
+LOGICAL :: GWEST,GEAST,GSOUTH,GNORTH
+LOGICAL :: GSOUTH2D,GNORTH2D,GPRVREF0
+!
+!------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------
+!
+!* 1. PRELIMINARIES
+! -------------
+!
+ILUOUT = TLUOUT%NLU
+!
+CALL GET_GLOBALDIMS_ll (IIMAX_ll,IJMAX_ll)
+IF ( ( MIN(IIMAX_ll,IJMAX_ll) < NPROC ) .AND. ( HPRESOPT /= 'ZRESI' ) .AND. ( HPRESOPT /= 'ZSOLV' )) THEN
+ WRITE(UNIT=ILUOUT,FMT=*) 'ERROR IN PRESSUREZ:: YOU WANT TO USE TO MANY PROCESSOR WITHOUT CPRESOPT="ZRESI/ZSOLV" '
+ WRITE(UNIT=ILUOUT,FMT=*) 'MIN(IIMAX_ll,IJMAX_ll)=',MIN(IIMAX_ll,IJMAX_ll),' < NPROC =', NPROC
+ WRITE(UNIT=ILUOUT,FMT=*) 'YOU HAVE TO SET CPRESOPT="ZRESI => JOB ABORTED '
+ CALL PRINT_MSG(NVERB_FATAL,'GEN','PRESSUREZ','')
+ENDIF
+CALL GET_PHYSICAL_ll(IIB,IJB,IIE,IJE)
+CALL GET_DIM_EXT_ll('B',IIU,IJU)
+!
+IKB= 1+JPVEXT
+IKU= SIZE(PPABST,3)
+IKE= IKU - JPVEXT
+!
+GWEST = ( HLBCX(1) /= 'CYCL' .AND. LWEST_ll() )
+GEAST = ( HLBCX(2) /= 'CYCL' .AND. LEAST_ll() )
+GSOUTH = ( .NOT. L2D .AND. HLBCY(1) /= 'CYCL' .AND. LSOUTH_ll() )
+GNORTH = ( .NOT. L2D .AND. HLBCY(2) /= 'CYCL' .AND. LNORTH_ll() )
+GSOUTH2D = ( L2D .AND. LSOUTH_ll() )
+GNORTH2D = ( L2D .AND. LNORTH_ll() )
+!
+GPRVREF0 = ( SIZE(PRVREF,1) == 0 )
+!
+IZPRHODJ = MNH_ALLOCATE_ZT3D( ZPRHODJ,IIU,IJU,IKU )
+IZMXM_PRHODJ = MNH_ALLOCATE_ZT3D( ZMXM_PRHODJ,IIU,IJU,IKU )
+IZMZM_PRHODJ = MNH_ALLOCATE_ZT3D( ZMZM_PRHODJ,IIU,IJU,IKU )
+IZGZ_M_W = MNH_ALLOCATE_ZT3D( ZGZ_M_W,IIU,IJU,IKU )
+IZMYM_PRHODJ = MNH_ALLOCATE_ZT3D( ZMYM_PRHODJ,IIU,IJU,IKU )
+!
+!$acc kernels
+ZPABS_S(:,:) = 0.
+ZPABS_N(:,:) = 0.
+ZPABS_E(:,:) = 0.
+ZPABS_W(:,:) = 0.
+!$acc end kernels
+!
+!
+!-------------------------------------------------------------------------------
+!
+!* 3. COMPUTE THE LINEIC MASS
+! -----------------------
+!
+IF ( ANY(HLBCX(:)=='OPEN') .OR. ANY(HLBCY(:)=='OPEN') ) THEN
+ CALL MASS_LEAK(PDXX,PDYY,HLBCX,HLBCY,PLINMASS,PRHODJ,PRUS,PRVS)
+END IF
+!
+!-------------------------------------------------------------------------------
+!
+!* 4. COMPUTE THE FORCING TERM FOR THE PRESSURE EQUATION
+! --------------------------------------------------
+!
+!
+CALL MPPDB_CHECK3D(PRUS,"pressurez 4-before update_halo_ll::PRUS",PRECISION)
+CALL MPPDB_CHECK3D(PRVS,"pressurez 4-before update_halo_ll::PRVS",PRECISION)
+CALL MPPDB_CHECK3D(PRWS,"pressurez 4-before update_halo_ll::PRWS",PRECISION)
+#ifndef MNH_OPENACC
+NULLIFY(TZFIELDS_ll)
+CALL ADD3DFIELD_ll( TZFIELDS_ll, PRUS, 'PRESSUREZ::PRUS' )
+CALL ADD3DFIELD_ll( TZFIELDS_ll, PRVS, 'PRESSUREZ::PRVS' )
+CALL ADD3DFIELD_ll( TZFIELDS_ll, PRWS, 'PRESSUREZ::PRWS' )
+CALL UPDATE_HALO_ll(TZFIELDS_ll,IINFO_ll)
+CALL CLEANLIST_ll(TZFIELDS_ll)
+#else
+CALL GET_HALO_D(PRUS,HNAME='PRESSUREZ::PRUS' )
+CALL GET_HALO_D(PRVS,HNAME='PRESSUREZ::PRVS' )
+CALL GET_HALO_D(PRWS,HNAME='PRESSUREZ::PRWS' )
+#endif
+CALL MPPDB_CHECK3D(PRUS,"pressurez 4-after update_halo_ll::PRUS",PRECISION)
+CALL MPPDB_CHECK3D(PRVS,"pressurez 4-after update_halo_ll::PRVS",PRECISION)
+CALL MPPDB_CHECK3D(PRWS,"pressurez 4-after update_halo_ll::PRWS",PRECISION)
+!
+CALL GDIV(HLBCX,HLBCY,PDXX,PDYY,PDZX,PDZY,PDZZ,PRUS,PRVS,PRWS,ZDV_SOURCE)
+!
+! The non-homogenous Neuman problem is transformed in an homogenous Neuman
+! problem in the non-periodic cases
+IF ( GWEST ) THEN
+ !$acc kernels async
+ ZDV_SOURCE(IIB-1,:,:) = 0.
+ !$acc end kernels
+END IF
+IF ( GEAST ) THEN
+ !$acc kernels async
+ ZDV_SOURCE(IIE+1,:,:) = 0.
+ !$acc end kernels
+END IF
+IF ( GSOUTH ) THEN
+ !$acc kernels async
+ ZDV_SOURCE(:,IJB-1,:) = 0.
+ !$acc end kernels
+END IF
+IF ( GNORTH ) THEN
+ !$acc kernels async
+ ZDV_SOURCE(:,IJE+1,:) = 0.
+ !$acc end kernels
+END IF
+!$acc wait
+!
+!-------------------------------------------------------------------------------
+!
+!* 5. SOLVE THE PRESSURE EQUATION
+! ---------------------------
+!
+!
+!* 5.1 Compute the virtual theta and the pressure perturbation
+! -------------------------------------------------------
+!
+IF(CEQNSYS=='MAE' .OR. CEQNSYS=='DUR') THEN
+ !$acc kernels
+ IF(KRR > 0) THEN
+ !
+ ! compute the ratio : 1 + total water mass / dry air mass
+ ZRV_OV_RD = XRV / XRD
+ ZTHETAV(:,:,:) = 1. + PRT(:,:,:,1)
+ DO JWATER = 2 , 1+KRRL+KRRI
+ ZTHETAV(:,:,:) = ZTHETAV(:,:,:) + PRT(:,:,:,JWATER)
+ END DO
+ ! compute the virtual potential temperature when water is present in any
+ ! form
+ ZTHETAV(:,:,:) = PTHT(:,:,:) * (1. + PRT(:,:,:,1) * ZRV_OV_RD) / ZTHETAV(:,:,:)
+ ELSE
+ ! compute the virtual potential temperature when water is absent
+ ZTHETAV(:,:,:) = PTHT(:,:,:)
+ END IF
+ !$acc end kernels
+ !
+#ifndef MNH_OPENACC
+ ZPHIT(:,:,:)=(PPABST(:,:,:)/XP00)**(XRD/XCPD)-PEXNREF(:,:,:)
+#else
+ !$acc kernels
+ ZPHIT(:,:,:)=BR_POW((PPABST(:,:,:)/XP00),(XRD/XCPD))-PEXNREF(:,:,:)
+ !$acc end kernels
+#endif
+ !
+ELSEIF(CEQNSYS=='LHE') THEN
+ ZPHIT(:,:,:)= ((PPABST(:,:,:)/XP00)**(XRD/XCPD)-PEXNREF(:,:,:)) &
+ * XCPD * PTHVREF(:,:,:)
+ !
+END IF
+!
+IF(CEQNSYS=='LHE'.AND. LFLAT .AND. LCARTESIAN) THEN
+ ! flat cartesian LHE case -> exact solution
+ IF ( HPRESOPT /= "ZRESI" ) THEN
+ CALL FLAT_INV(HLBCX,HLBCY,PDXHATM,PDYHATM,PRHOT,PAF,PBF,PCF, &
+ PTRIGSX,PTRIGSY,KIFAXX,KIFAXY,ZDV_SOURCE,ZPHIT)
+ ELSE
+ CALL FLAT_INVZ(HLBCX,HLBCY,PDXHATM,PDYHATM,PRHOT,PAF,PBF,PCF, &
+ PTRIGSX,PTRIGSY,KIFAXX,KIFAXY,ZDV_SOURCE,ZPHIT,&
+ PBFB,&
+ PBF_SXP2_YP1_Z)
+ ENDIF
+ELSE
+ SELECT CASE(HPRESOPT)
+ CASE('RICHA') ! Richardson's method
+!
+ CALL RICHARDSON(HLBCX,HLBCY,PDXX,PDYY,PDZX,PDZY,PDZZ,PRHODJ,ZTHETAV, &
+ PDXHATM,PDYHATM,PRHOT,PAF,PBF,PCF,PTRIGSX,PTRIGSY, &
+ KIFAXX,KIFAXY,KITR,KTCOUNT,PRELAX,ZDV_SOURCE,ZPHIT)
+!
+ CASE('CGRAD') ! Conjugate Gradient method
+ CALL CONJGRAD(HLBCX,HLBCY,PDXX,PDYY,PDZX,PDZY,PDZZ,PRHODJ,ZTHETAV, &
+ PDXHATM,PDYHATM,PRHOT,PAF,PBF,PCF,PTRIGSX,PTRIGSY, &
+ KIFAXX,KIFAXY,KITR,ZDV_SOURCE,ZPHIT)
+ CASE('ZGRAD') ! Conjugate Gradient method
+ CALL ZCONJGRAD(HLBCX,HLBCY,PDXX,PDYY,PDZX,PDZY,PDZZ,PRHODJ,ZTHETAV, &
+ PDXHATM,PDYHATM,PRHOT,PAF,PBF,PCF,PTRIGSX,PTRIGSY, &
+ KIFAXX,KIFAXY,KITR,ZDV_SOURCE,ZPHIT)
+!
+ CASE('CRESI') ! Conjugate Residual method
+ CALL CONRESOL(HLBCX,HLBCY,PDXX,PDYY,PDZX,PDZY,PDZZ,PRHODJ,ZTHETAV, &
+ PDXHATM,PDYHATM,PRHOT,PAF,PBF,PCF,PTRIGSX,PTRIGSY, &
+ KIFAXX,KIFAXY,KITR,ZDV_SOURCE,ZPHIT)
+!
+ CASE('ZSOLV') ! Conjugate Residual method
+ CALL ZSOLVER(HLBCX,HLBCY,PDXX,PDYY,PDZX,PDZY,PDZZ,PRHODJ,ZTHETAV, &
+ PDXHATM,PDYHATM,PRHOT,PAF,PBF,PCF,PTRIGSX,PTRIGSY, &
+ KIFAXX,KIFAXY,KITR,ZDV_SOURCE,ZPHIT, &
+ PAF_ZS,PBF_ZS,PCF_ZS, &
+ PDXATH_ZS,PDYATH_ZS,PRHO_ZS,PBFB, &
+ A_K,B_K,C_K,D_K)
+!
+ CASE('ZRESI') ! Conjugate Residual method
+ CALL CONRESOLZ(HLBCX,HLBCY,PDXX,PDYY,PDZX,PDZY,PDZZ,PRHODJ,ZTHETAV, &
+ PDXHATM,PDYHATM,PRHOT,PAF,PBF,PCF,PTRIGSX,PTRIGSY, &
+ KIFAXX,KIFAXY,KITR,ZDV_SOURCE,ZPHIT, &
+ PBFB,&
+ PBF_SXP2_YP1_Z) !JUAN Z_SPLITING
+ END SELECT
+END IF
+!
+!-------------------------------------------------------------------------------
+!
+!* 6. ADD THE PRESSURE GRADIENT TO THE SOURCES
+! ----------------------------------------
+!
+IF ( GWEST ) THEN
+ !$acc kernels async
+ ZPHIT(IIB-1,:,IKB-1) = ZPHIT(IIB,:,IKB-1)
+ !$acc end kernels
+END IF
+IF ( GEAST ) THEN
+ !$acc kernels async
+ ZPHIT(IIE+1,:,IKB-1) = ZPHIT(IIE,:,IKB-1)
+ !$acc end kernels
+END IF
+IF ( GSOUTH ) THEN
+ !$acc kernels async
+ ZPHIT(:,IJB-1,IKB-1) = ZPHIT(:,IJB,IKB-1)
+ !$acc end kernels
+END IF
+IF ( GNORTH ) THEN
+ !$acc kernels async
+ ZPHIT(:,IJE+1,IKB-1) = ZPHIT(:,IJE,IKB-1)
+ !$acc end kernels
+END IF
+IF ( GSOUTH2D ) THEN
+ !$acc kernels async
+ ZPHIT(:,IJB-1,:) = ZPHIT(:,IJB,:)
+ !$acc end kernels
+END IF
+IF ( GNORTH2D ) THEN
+ !$acc kernels async
+ ZPHIT(:,IJE+1,:) = ZPHIT(:,IJB,:)
+ !$acc end kernels
+END IF
+!$acc wait
+!
+#ifndef MNH_OPENACC
+ZDV_SOURCE = GX_M_U(1,IKU,1,ZPHIT,PDXX,PDZZ,PDZX)
+#else
+CALL GX_M_U_DEVICE(1,IKU,1,ZPHIT,PDXX,PDZZ,PDZX,ZDV_SOURCE)
+#endif
+!
+IF ( GWEST ) THEN
+!!!!!!!!!!!!!!!! FUJI compiler directive !!!!!!!!!!
+!!!!!!!!!!!!!!!! FUJI compiler directive !!!!!!!!!!
+ !$acc kernels
+ DO JK=2,IKU-1
+ ZDV_SOURCE(IIB,:,JK)= &
+ (ZPHIT(IIB,:,JK) - ZPHIT(IIB-1,:,JK) - 0.5 * ( &
+ PDZX(IIB,:,JK) * (ZPHIT(IIB,:,JK)-ZPHIT(IIB,:,JK-1)) / PDZZ(IIB,:,JK) &
+ +PDZX(IIB,:,JK+1) * (ZPHIT(IIB,:,JK+1)-ZPHIT(IIB,:,JK)) / PDZZ(IIB,:,JK+1) &
+ ) &
+ ) / PDXX(IIB,:,JK)
+ END DO
+ !$acc end kernels
+ENDIF
+ !
+IF( GEAST ) THEN
+ !$acc kernels
+ DO JK=2,IKU-1
+ ZDV_SOURCE(IIE+1,:,JK)= &
+ (ZPHIT(IIE+1,:,JK) - ZPHIT(IIE+1-1,:,JK) - 0.5 * ( &
+ PDZX(IIE+1,:,JK) * (ZPHIT(IIE+1-1,:,JK)-ZPHIT(IIE+1-1,:,JK-1)) &
+ / PDZZ(IIE+1-1,:,JK) &
+ +PDZX(IIE+1,:,JK+1) * (ZPHIT(IIE+1-1,:,JK+1)-ZPHIT(IIE+1-1,:,JK)) &
+ / PDZZ(IIE+1-1,:,JK+1) &
+ ) &
+ ) / PDXX(IIE+1,:,JK)
+ END DO
+ !$acc end kernels
+END IF
+!
+CALL MPPDB_CHECK3DM("before MXM PRESSUREZ :PRU/V/WS",PRECISION,PRUS,PRVS,PRWS)
+IF(CEQNSYS=='MAE' .OR. CEQNSYS=='DUR') THEN
+!!$ PRUS = PRUS - MXM(PRHODJ * XCPD * ZTHETAV) * ZDV_SOURCE
+!!$ PRWS = PRWS - MZM(PRHODJ * XCPD * ZTHETAV) * GZ_M_W(1,IKU,1,ZPHIT,PDZZ)
+ !$acc kernels
+ ZPRHODJ = PRHODJ * XCPD * ZTHETAV
+ !$acc end kernels
+ CALL MXM_DEVICE(ZPRHODJ, ZMXM_PRHODJ)
+ CALL MZM_DEVICE(ZPRHODJ, ZMZM_PRHODJ)
+ CALL GZ_M_W_DEVICE(1,IKU,1,ZPHIT,PDZZ,ZGZ_M_W)
+ !$acc kernels
+ PRUS = PRUS - ZMXM_PRHODJ * ZDV_SOURCE
+ PRWS = PRWS - ZMZM_PRHODJ * ZGZ_M_W
+ !$acc end kernels
+ELSEIF(CEQNSYS=='LHE') THEN
+ PRUS = PRUS - MXM(PRHODJ) * ZDV_SOURCE
+ PRWS = PRWS - MZM(PRHODJ) * GZ_M_W(1,IKU,1,ZPHIT,PDZZ)
+END IF
+!
+IF(.NOT. L2D) THEN
+ !
+#ifndef MNH_OPENACC
+ ZDV_SOURCE = GY_M_V(1,IKU,1,ZPHIT,PDYY,PDZZ,PDZY)
+#else
+ CALL GY_M_V_DEVICE(1,IKU,1,ZPHIT,PDYY,PDZZ,PDZY,ZDV_SOURCE)
+#endif
+!
+ IF ( GSOUTH ) THEN
+!!!!!!!!!!!!!!!! FUJI compiler directive !!!!!!!!!!
+!!!!!!!!!!!!!!!! FUJI compiler directive !!!!!!!!!!
+ !$acc kernels async
+ DO JK=2,IKU-1
+ ZDV_SOURCE(:,IJB,JK)= &
+ (ZPHIT(:,IJB,JK) - ZPHIT(:,IJB-1,JK) - 0.5 * ( &
+ PDZY(:,IJB,JK) * (ZPHIT(:,IJB,JK)-ZPHIT(:,IJB,JK-1)) / PDZZ(:,IJB,JK) &
+ +PDZY(:,IJB,JK+1) * (ZPHIT(:,IJB,JK+1)-ZPHIT(:,IJB,JK)) / PDZZ(:,IJB,JK+1) &
+ ) &
+ ) / PDYY(:,IJB,JK)
+ END DO
+ !$acc end kernels
+ END IF
+ !
+ IF ( GNORTH ) THEN
+ !$acc kernels async
+ DO JK=2,IKU-1
+ ZDV_SOURCE(:,IJE+1,JK)= &
+ (ZPHIT(:,IJE+1,JK) - ZPHIT(:,IJE+1-1,JK) - 0.5 * ( &
+ PDZY(:,IJE+1,JK) * (ZPHIT(:,IJE+1-1,JK)-ZPHIT(:,IJE+1-1,JK-1)) &
+ / PDZZ(:,IJE+1-1,JK) &
+ +PDZY(:,IJE+1,JK+1) * (ZPHIT(:,IJE+1-1,JK+1)-ZPHIT(:,IJE+1-1,JK)) &
+ / PDZZ(:,IJE+1-1,JK+1) &
+ ) &
+ ) / PDYY(:,IJE+1,JK)
+ END DO
+ !$acc end kernels
+ END IF
+!$acc wait
+!
+ CALL MPPDB_CHECK3DM("before MYM PRESSUREZ :PRU/V/WS",PRECISION,PRUS,PRVS,PRWS)
+ IF(CEQNSYS=='MAE' .OR. CEQNSYS=='DUR') THEN
+!!$ PRVS = PRVS - MYM(PRHODJ * XCPD * ZTHETAV) * ZDV_SOURCE
+ CALL MYM_DEVICE(ZPRHODJ,ZMYM_PRHODJ)
+ !$acc kernels
+ PRVS = PRVS - ZMYM_PRHODJ * ZDV_SOURCE
+ !$acc end kernels
+ ELSEIF(CEQNSYS=='LHE') THEN
+ PRVS = PRVS - MYM(PRHODJ) * ZDV_SOURCE
+ END IF
+END IF
+!
+!! same boundary conditions as in gdiv ... !! (provisory coding)
+!! (necessary when NVERB=1)
+!!
+ !$acc kernels
+ PRUS(:,:,IKB-1)=PRUS(:,:,IKB)
+ PRUS(:,:,IKE+1)=PRUS(:,:,IKE)
+ PRVS(:,:,IKB-1)=PRVS(:,:,IKB)
+ PRVS(:,:,IKE+1)=PRVS(:,:,IKE)
+ !$acc end kernels
+!
+#ifndef MNH_OPENACC
+NULLIFY(TZFIELDS2_ll)
+CALL ADD3DFIELD_ll( TZFIELDS2_ll, PRUS, 'PRESSUREZ::PRUS' )
+CALL ADD3DFIELD_ll( TZFIELDS2_ll, PRVS, 'PRESSUREZ::PRVS' )
+CALL ADD3DFIELD_ll( TZFIELDS2_ll, PRWS, 'PRESSUREZ::PRWS' )
+CALL UPDATE_HALO_ll(TZFIELDS2_ll,IINFO_ll)
+CALL CLEANLIST_ll(TZFIELDS2_ll)
+#else
+CALL GET_HALO_D(PRUS,HNAME='PRESSUREZ::PRUS' )
+CALL GET_HALO_D(PRVS,HNAME='PRESSUREZ::PRVS' )
+CALL GET_HALO_D(PRWS,HNAME='PRESSUREZ::PRWS' )
+#endif
+!
+! compute the residual divergence
+CALL GDIV(HLBCX,HLBCY,PDXX,PDYY,PDZX,PDZY,PDZZ,PRUS,PRVS,PRWS,ZDV_SOURCE)
+!
+IF ( CEQNSYS=='DUR' ) THEN
+ IF ( GPRVREF0 ) THEN
+ !$acc kernels
+ ZDV_SOURCE=ZDV_SOURCE/PRHODJ/XTH00*PRHODREF*PTHVREF
+ !$acc end kernels
+ ELSE
+ !$acc kernels
+ ZDV_SOURCE=ZDV_SOURCE/PRHODJ/XTH00*PRHODREF*PTHVREF*(1.+PRVREF)
+ !$acc end kernels
+ END IF
+ELSEIF( CEQNSYS=='MAE' .OR. CEQNSYS=='LHE' ) THEN
+ ZDV_SOURCE=ZDV_SOURCE/PRHODJ*PRHODREF
+END IF
+!
+ZMAXVAL=MAX_ll(ABS(ZDV_SOURCE),IINFO_ll)
+!JUANZ
+IF (PRESENT(PRESIDUAL)) PRESIDUAL = ZMAXVAL
+!JUANZ
+IMAXLOC=GMAXLOC_ll( ABS(ZDV_SOURCE) )
+!
+WRITE(ILUOUT,*) 'residual divergence / 2 DT', ZMAXVAL, &
+ ' located at ', IMAXLOC
+FLUSH(unit=ILUOUT)
+IF (ABS(ZMAXVAL) .GT. 100.0 ) THEN
+ call Print_msg( NVERB_FATAL, 'GEN', 'PRESSUREZ', 'something wrong with pressure: abs(residual) > 100.0' )
+END IF
+! number of iterations adjusted
+IF (LRES) THEN
+ ZMAXRES = XRES
+ELSEIF (LFLAT .AND. LCARTESIAN) THEN
+ ZMAXRES = XRES_FLAT_CART
+ELSE
+ ZMAXRES = XRES_OTHER
+END IF
+!
+IF (OITRADJ) THEN
+ IF (ZMAXVAL>10.*ZMAXRES) THEN
+ KITR=KITR+2
+ WRITE(ILUOUT,*) 'NITR adjusted to ', KITR
+ ELSE IF (ZMAXVAL<ZMAXRES) THEN
+ KITR=MAX(KITR-1,1)
+ WRITE(ILUOUT,*) 'NITR adjusted to ', KITR
+ ENDIF
+ENDIF
+!
+!* 7. STORAGE OF THE FIELDS IN BUDGET ARRAYS
+! --------------------------------------
+!
+IF (LBUDGET_U) CALL BUDGET (PRUS,1,'PRES_BU_RU')
+IF (LBUDGET_V) CALL BUDGET (PRVS,2,'PRES_BU_RV')
+IF (LBUDGET_W) CALL BUDGET (PRWS,3,'PRES_BU_RW')
+!
+!-------------------------------------------------------------------------------
+!
+!* 8. ABSOLUTE PRESSURE COMPUTATION
+! -----------------------------
+!
+ZMAX = MAXVAL(ABS ( PRHODREF(:,:,IKB)-PRHODREF(:,:,IKE)) )
+CALL MPI_ALLREDUCE(ZMAX, ZMAX_ll, 1, MNHREAL_MPI, MPI_MAX, &
+ NMNH_COMM_WORLD, KINFO)
+!IF ( ABS(PRHODREF(IIB,IJB,IKB)-PRHODREF(IIB,IJB,IKE)) > 1.E-12 &
+! .AND. KTCOUNT >0 ) THEN
+IF ((ZMAX_ll > 1.E-12) .AND. KTCOUNT >0 ) THEN
+!IF ( KTCOUNT >0 .AND. .NOT.LBOUSS ) THEN
+ CALL P_ABS ( KRR, KRRL, KRRI, PDRYMASST, PREFMASS, PMASS_O_PHI0, &
+ PTHT, PRT, PRHODJ, PRHODREF, ZTHETAV, PTHVREF, &
+ PRVREF, PEXNREF, ZPHIT )
+!
+ IF(CEQNSYS=='MAE' .OR. CEQNSYS=='DUR') THEN
+#ifndef MNH_OPENACC
+ PPABST(:,:,:)=XP00*(ZPHIT+PEXNREF)**(XCPD/XRD)
+#else
+ !$acc kernels
+ PPABST(:,:,:)=XP00*BR_POW((ZPHIT+PEXNREF),(XCPD/XRD))
+ !$acc end kernels
+#endif
+ ELSEIF(CEQNSYS=='LHE') THEN
+ PPABST(:,:,:)=XP00*(ZPHIT/(XCPD*PTHVREF)+PEXNREF)**(XCPD/XRD)
+ ENDIF
+!
+ IF( GWEST ) THEN
+ !$acc kernels async
+ ZPABS_W(:,:)= PPABST(IIB,:,:)
+ !$acc end kernels
+ END IF
+!
+ IF ( GEAST ) THEN
+ !$acc kernels async
+ ZPABS_E(:,:)= PPABST(IIE+1,:,:)
+ !$acc end kernels
+ END IF
+!
+ IF( GSOUTH ) THEN
+ !$acc kernels async
+ ZPABS_S(:,:)= PPABST(:,IJB,:)
+ !$acc end kernels
+ END IF
+!
+ IF ( GNORTH ) THEN
+ !$acc kernels async
+ ZPABS_N(:,:)= PPABST(:,IJE+1,:)
+ !$acc end kernels
+ END IF
+ !
+ !$acc wait
+ !
+#ifndef MNH_OPENACC
+ CALL ADD3DFIELD_ll( TZFIELDS_ll, PPABST, 'PRESSUREZ::PPABST' )
+ CALL UPDATE_HALO_ll(TZFIELDS_ll,IINFO_ll)
+ CALL CLEANLIST_ll(TZFIELDS_ll)
+#else
+ CALL GET_HALO_D( PPABST,HNAME='PRESSUREZ::PPABST' )
+#endif
+
+!
+ IF( GWEST ) THEN
+ !$acc kernels async
+ PPABST(IIB,:,:) = ZPABS_W(:,:)
+ !$acc end kernels
+ END IF
+!
+ IF ( GEAST ) THEN
+ !$acc kernels async
+ PPABST(IIE+1,:,:) = ZPABS_E(:,:)
+ !$acc end kernels
+ END IF
+!
+ IF( GSOUTH ) THEN
+ !$acc kernels async
+ PPABST(:,IJB,:) = ZPABS_S(:,:)
+ !$acc end kernels
+ END IF
+!
+ IF ( GNORTH ) THEN
+ !$acc kernels async
+ PPABST(:,IJE+1,:) = ZPABS_N(:,:)
+ !$acc end kernels
+ END IF
+!
+!$acc wait
+!
+END IF
+!
+#ifdef MNH_OPENACC
+CALL MNH_REL_ZT3D ( IZPRHODJ,IZMXM_PRHODJ,IZMZM_PRHODJ,IZGZ_M_W,IZMYM_PRHODJ )
+#endif
+!-------------------------------------------------------------------------------
+!
+END SUBROUTINE PRESSUREZ
diff --git a/src/ZSOLVER/qlap.f90 b/src/ZSOLVER/qlap.f90
new file mode 100644
index 0000000000000000000000000000000000000000..5f76e50d9b5f77db9717497307716ce2d7e2fef0
--- /dev/null
+++ b/src/ZSOLVER/qlap.f90
@@ -0,0 +1,568 @@
+!MNH_LIC Copyright 1994-2020 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.
+!-----------------------------------------------------------------
+! ################
+ MODULE MODI_QLAP
+! ################
+!
+INTERFACE
+!
+ FUNCTION QLAP(HLBCX,HLBCY,PDXX,PDYY,PDZX,PDZY,PDZZ,PRHODJ,PTHETAV,PY) &
+ RESULT(PQLAP)
+!
+IMPLICIT NONE
+!
+CHARACTER (LEN=4), DIMENSION(2), INTENT(IN) :: HLBCX ! x-direction LBC type
+CHARACTER (LEN=4), DIMENSION(2), INTENT(IN) :: HLBCY ! y-direction LBC type
+!
+ ! Metric coefficients:
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDXX ! d*xx
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDYY ! d*yy
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDZX ! d*zx
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDZY ! d*zy
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDZZ ! d*zz
+!
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODJ ! density of reference * J
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PTHETAV ! virtual potential temp. at time t
+!
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PY ! field components
+!
+REAL, DIMENSION(SIZE(PY,1),SIZE(PY,2),SIZE(PY,3)) :: PQLAP ! final divergence
+!
+END FUNCTION QLAP
+!
+!
+#ifdef MNH_OPENACC
+SUBROUTINE QLAP_DEVICE(PQLAP,HLBCX,HLBCY,PDXX,PDYY,PDZX,PDZY,PDZZ,PRHODJ,PTHETAV,PY)
+!
+IMPLICIT NONE
+!
+REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PQLAP ! final divergence
+!
+CHARACTER (LEN=4), DIMENSION(2), INTENT(IN) :: HLBCX ! x-direction LBC type
+CHARACTER (LEN=4), DIMENSION(2), INTENT(IN) :: HLBCY ! y-direction LBC type
+!
+ ! Metric coefficients:
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDXX ! d*xx
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDYY ! d*yy
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDZX ! d*zx
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDZY ! d*zy
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDZZ ! d*zz
+!
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODJ ! density of reference * J
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PTHETAV ! virtual potential temp. at time t
+!
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PY ! field components
+!
+
+!
+END SUBROUTINE QLAP_DEVICE
+#endif
+END INTERFACE
+!
+END MODULE MODI_QLAP
+!
+!
+!
+! #########################################################################
+ FUNCTION QLAP(HLBCX,HLBCY,PDXX,PDYY,PDZX,PDZY,PDZZ,PRHODJ,PTHETAV,PY) &
+ RESULT(PQLAP)
+! #########################################################################
+!
+!!**** *QLAP * - compute the complete quasi-laplacien QLAP of a field P
+!!
+!! PURPOSE
+!! -------
+! This function computes the quasi-laplacien QLAP of the scalar field P
+! localized at a mass point, with non-vanishing orography.
+! The result is localized at a mass point and defined by:
+! for Durran and MAE anelastic equations
+! ( ( GX_M_U (PY) ) )
+! PQLAP = GDIV ( rho * CPd * Thetav * J ( GX_M_V (PY) ) )
+! ( ( GX_M_W (PY) ) )
+! or for Lipps and Hemler
+! ( ( GX_M_U (PY) ) )
+! PQLAP = GDIV ( rho * J ( GX_M_V (PY) ) )
+! ( ( GX_M_W (PY) ) )
+! Where GX_M_.. are the cartesian components of the gradient of PY and
+! GDIV is the operator acting on a vector AA:
+!
+! GDIV ( AA ) = J * divergence (1/J AA )
+!
+!!** METHOD
+!! ------
+!! First, we compute the gradients along x, y , z of the P field. The
+!! result is multiplied by rhod * CPd * Thetav or rhod depending on the
+!! chosen anelastic system where the suffixes indicate
+!! d dry and v for virtual.
+!! Then, the pseudo-divergence ( J * DIV (1/J o ) ) is computed by the
+!! subroutine GDIV. The result is localized at a mass point.
+!!
+!! EXTERNAL
+!! --------
+!! Function GX_M_U : compute the gradient along x
+!! Function GY_M_V : compute the gradient along y
+!! Function GZ_M_W : compute the gradient along z
+!! FUNCTION MXM: compute an average in the x direction for a variable
+!! at a mass localization
+!! FUNCTION MYM: compute an average in the y direction for a variable
+!! at a mass localization
+!! FUNCTION MZM: compute an average in the z direction for a variable
+!! at a mass localization
+!! Subroutine GDIV : compute J times the divergence of 1/J times a vector
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module MODD_PARAMETERS: JPHEXT, JPVEXT
+!! Module MODD_CONF: L2D,CEQNSYS
+!! Module MODD_CST : XCPD
+!!
+!! REFERENCE
+!! ---------
+!! Pressure solver documentation ( Scientific documentation )
+!!
+!! AUTHOR
+!! ------
+!! P. Hereil and J. Stein * Meteo France *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 11/07/94
+!! Modification 16/03/95 change the argument list of the gradient
+!! 14/01/97 New anelastic equation ( Stein )
+!! 17/12/97 include the case of non-vanishing orography
+!! at the lbc ( Stein )
+!! 06/12 V.Masson : update_halo due to CONTRAV changes
+!! J.Escobar : 15/09/2015 : WENO5 & JPHEXT <> 1
+! P. Wautelet 20/05/2019: add name argument to ADDnFIELD_ll + new ADD4DFIELD_ll subroutine
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODE_ll
+!
+USE MODD_PARAMETERS
+USE MODD_CONF
+USE MODD_CST
+USE MODI_GDIV
+USE MODI_GRADIENT_M
+USE MODI_SHUMAN
+!
+USE MODE_MPPDB
+!
+IMPLICIT NONE
+!
+!* 0.1 declarations of arguments
+!
+!
+CHARACTER (LEN=4), DIMENSION(2), INTENT(IN) :: HLBCX ! x-direction LBC type
+CHARACTER (LEN=4), DIMENSION(2), INTENT(IN) :: HLBCY ! y-direction LBC type
+!
+ ! Metric coefficients:
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDXX ! d*xx
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDYY ! d*yy
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDZX ! d*zx
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDZY ! d*zy
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDZZ ! d*zz
+!
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODJ ! density of reference * J
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PTHETAV ! virtual potential temp. at time t
+!
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PY ! field components
+!
+REAL, DIMENSION(SIZE(PY,1),SIZE(PY,2),SIZE(PY,3)) :: PQLAP ! final divergence
+!
+!* 0.2 declarations of local variables
+!
+REAL, DIMENSION(SIZE(PY,1),SIZE(PY,2),SIZE(PY,3)) :: ZU ! rho*J*gradient along x
+!
+REAL, DIMENSION(SIZE(PY,1),SIZE(PY,2),SIZE(PY,3)) :: ZV ! rho*J*gradient along y
+!
+REAL, DIMENSION(SIZE(PY,1),SIZE(PY,2),SIZE(PY,3)) :: ZW ! rho*J*gradient along z
+!
+INTEGER :: IIU,IJU,IKU ! I,J,K array sizes
+INTEGER :: JK,JJ,JI ! vertical loop index
+TYPE(LIST_ll), POINTER :: TZFIELDS_ll ! list of fields to exchange
+INTEGER :: IINFO_ll
+INTEGER :: IIB,IIE,IJB,IJE
+!-------------------------------------------------------------------------------
+!
+!
+!* 1. COMPUTE THE GRADIENT COMPONENTS
+! -------------------------------
+!
+CALL GET_DIM_EXT_ll('B',IIU,IJU)
+CALL GET_INDICE_ll (IIB,IJB,IIE,IJE)
+IKU=SIZE(PY,3)
+!
+ZU = GX_M_U(1,IKU,1,PY,PDXX,PDZZ,PDZX)
+CALL MPPDB_CHECK3D(ZU,'QLAP::ZU',PRECISION)
+!
+IF ( HLBCX(1) /= 'CYCL' .AND. LWEST_ll() ) THEN
+ DO JK=2,IKU-1
+ DO JJ=1,IJU
+ ZU(IIB,JJ,JK)= (PY(IIB,JJ,JK) - PY(IIB-1,JJ,JK) - 0.5 * ( &
+ PDZX(IIB,JJ,JK) * (PY(IIB,JJ,JK)-PY(IIB,JJ,JK-1)) / PDZZ(IIB,JJ,JK) &
+ +PDZX(IIB,JJ,JK+1) * (PY(IIB,JJ,JK+1)-PY(IIB,JJ,JK)) / PDZZ(IIB,JJ,JK+1) &
+ ) ) / PDXX(IIB,JJ,JK)
+ END DO
+ END DO
+END IF
+CALL MPPDB_CHECK3D(ZU,'QLAP::ZU/W',PRECISION)
+!
+IF ( HLBCX(1) /= 'CYCL' .AND. LEAST_ll() ) THEN
+ DO JK=2,IKU-1
+ DO JJ=1,IJU
+ ZU(IIE+1,JJ,JK)= (PY(IIE+1,JJ,JK) - PY(IIE+1-1,JJ,JK) - 0.5 * ( &
+ PDZX(IIE+1,JJ,JK) * (PY(IIE+1-1,JJ,JK)-PY(IIE+1-1,JJ,JK-1)) / PDZZ(IIE+1-1,JJ,JK) &
+ +PDZX(IIE+1,JJ,JK+1) * (PY(IIE+1-1,JJ,JK+1)-PY(IIE+1-1,JJ,JK)) / PDZZ(IIE+1-1,JJ,JK+1)&
+ ) ) / PDXX(IIE+1,JJ,JK)
+ END DO
+ END DO
+END IF
+CALL MPPDB_CHECK3D(ZU,'QLAP::ZU/E',PRECISION)
+!
+IF(.NOT. L2D) THEN
+!
+ ZV = GY_M_V(1,IKU,1,PY,PDYY,PDZZ,PDZY)
+ CALL MPPDB_CHECK3D(ZV,'QLAP::ZV',PRECISION)
+!
+ IF ( HLBCY(1) /= 'CYCL' .AND. LSOUTH_ll() ) THEN
+ DO JK=2,IKU-1
+ DO JI=1,IIU
+ ZV(JI,IJB,JK)= (PY(JI,IJB,JK) - PY(JI,IJB-1,JK) - 0.5 * ( &
+ PDZY(JI,IJB,JK) * (PY(JI,IJB,JK)-PY(JI,IJB,JK-1)) / PDZZ(JI,IJB,JK) &
+ +PDZY(JI,IJB,JK+1) * (PY(JI,IJB,JK+1)-PY(JI,IJB,JK)) / PDZZ(JI,IJB,JK+1) &
+ ) ) / PDYY(JI,IJB,JK)
+ END DO
+ END DO
+ END IF
+ CALL MPPDB_CHECK3D(ZV,'QLAP::ZV/S',PRECISION)
+ IF ( HLBCY(1) /= 'CYCL' .AND. LNORTH_ll() ) THEN
+!
+ DO JK=2,IKU-1
+ DO JI=1,IIU
+ ZV(JI,IJE+1,JK)= (PY(JI,IJE+1,JK) - PY(JI,IJE+1-1,JK) - 0.5 * ( &
+ PDZY(JI,IJE+1,JK) * (PY(JI,IJE+1-1,JK)-PY(JI,IJE+1-1,JK-1)) / PDZZ(JI,IJE+1-1,JK) &
+ +PDZY(JI,IJE+1,JK+1) * (PY(JI,IJE+1-1,JK+1)-PY(JI,IJE+1-1,JK)) / PDZZ(JI,IJE+1-1,JK+1)&
+ ) ) / PDYY(JI,IJE+1,JK)
+ END DO
+ END DO
+ END IF
+ CALL MPPDB_CHECK3D(ZV,'QLAP::ZV/N',PRECISION)
+!
+ELSE
+ ZV=0.
+ENDIF
+!
+IF ( CEQNSYS == 'DUR' .OR. CEQNSYS == 'MAE' ) THEN
+ ZU = MXM(PRHODJ * XCPD * PTHETAV) * ZU
+ IF(.NOT. L2D) THEN
+ ZV = MYM(PRHODJ * XCPD * PTHETAV) * ZV
+ END IF
+ ZW = MZM(PRHODJ * XCPD * PTHETAV) * GZ_M_W(1,IKU,1,PY,PDZZ)
+ELSEIF ( CEQNSYS == 'LHE' ) THEN
+ ZU = MXM(PRHODJ) * ZU
+ IF(.NOT. L2D) THEN
+ ZV = MYM(PRHODJ) * ZV
+ ENDIF
+ ZW = MZM(PRHODJ) * GZ_M_W(1,IKU,1,PY,PDZZ)
+END IF
+!
+!-------------------------------------------------------------------------------
+!
+!* 2. COMPUTE THE DIVERGENCE
+! ----------------------
+!
+NULLIFY(TZFIELDS_ll)
+CALL ADD3DFIELD_ll( TZFIELDS_ll, ZU, 'QLAP::ZU' )
+CALL ADD3DFIELD_ll( TZFIELDS_ll, ZV, 'QLAP::ZV' )
+CALL ADD3DFIELD_ll( TZFIELDS_ll, ZW, 'QLAP::ZW' )
+CALL UPDATE_HALO_ll(TZFIELDS_ll,IINFO_ll)
+CALL CLEANLIST_ll(TZFIELDS_ll)
+!
+CALL GDIV(HLBCX,HLBCY,PDXX,PDYY,PDZX,PDZY,PDZZ,ZU,ZV,ZW,PQLAP)
+!
+!-------------------------------------------------------------------------------
+!
+END FUNCTION QLAP
+
+#ifdef MNH_OPENACC
+! #########################################################################
+ SUBROUTINE QLAP_DEVICE(PQLAP,HLBCX,HLBCY,PDXX,PDYY,PDZX,PDZY,PDZZ,PRHODJ,PTHETAV,PY)
+! #########################################################################
+!
+!!**** *QLAP * - compute the complete quasi-laplacien QLAP of a field P
+!!
+!! PURPOSE
+!! -------
+! This function computes the quasi-laplacien QLAP of the scalar field P
+! localized at a mass point, with non-vanishing orography.
+! The result is localized at a mass point and defined by:
+! for Durran and MAE anelastic equations
+! ( ( GX_M_U (PY) ) )
+! PQLAP = GDIV ( rho * CPd * Thetav * J ( GX_M_V (PY) ) )
+! ( ( GX_M_W (PY) ) )
+! or for Lipps and Hemler
+! ( ( GX_M_U (PY) ) )
+! PQLAP = GDIV ( rho * J ( GX_M_V (PY) ) )
+! ( ( GX_M_W (PY) ) )
+! Where GX_M_.. are the cartesian components of the gradient of PY and
+! GDIV is the operator acting on a vector AA:
+!
+! GDIV ( AA ) = J * divergence (1/J AA )
+!
+!!** METHOD
+!! ------
+!! First, we compute the gradients along x, y , z of the P field. The
+!! result is multiplied by rhod * CPd * Thetav or rhod depending on the
+!! chosen anelastic system where the suffixes indicate
+!! d dry and v for virtual.
+!! Then, the pseudo-divergence ( J * DIV (1/J o ) ) is computed by the
+!! subroutine GDIV. The result is localized at a mass point.
+!!
+!! EXTERNAL
+!! --------
+!! Function GX_M_U : compute the gradient along x
+!! Function GY_M_V : compute the gradient along y
+!! Function GZ_M_W : compute the gradient along z
+!! FUNCTION MXM: compute an average in the x direction for a variable
+!! at a mass localization
+!! FUNCTION MYM: compute an average in the y direction for a variable
+!! at a mass localization
+!! FUNCTION MZM: compute an average in the z direction for a variable
+!! at a mass localization
+!! Subroutine GDIV : compute J times the divergence of 1/J times a vector
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module MODD_PARAMETERS: JPHEXT, JPVEXT
+!! Module MODD_CONF: L2D,CEQNSYS
+!! Module MODD_CST : XCPD
+!!
+!! REFERENCE
+!! ---------
+!! Pressure solver documentation ( Scientific documentation )
+!!
+!! AUTHOR
+!! ------
+!! P. Hereil and J. Stein * Meteo France *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 11/07/94
+!! Modification 16/03/95 change the argument list of the gradient
+!! 14/01/97 New anelastic equation ( Stein )
+!! 17/12/97 include the case of non-vanishing orography
+!! at the lbc ( Stein )
+!! 06/12 V.Masson : update_halo due to CONTRAV changes
+!! J.Escobar : 15/09/2015 : WENO5 & JPHEXT <> 1
+! P. Wautelet 20/05/2019: add name argument to ADDnFIELD_ll + new ADD4DFIELD_ll subroutine
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODE_ll
+!
+USE MODD_PARAMETERS
+USE MODD_CONF
+USE MODD_CST
+USE MODI_GDIV
+USE MODI_GRADIENT_M
+USE MODI_SHUMAN
+USE MODI_SHUMAN_DEVICE
+!
+USE MODE_MPPDB
+!
+USE MODE_MNH_ZWORK , ONLY : MNH_ALLOCATE_ZT3D , MNH_REL_ZT3D
+!
+USE MODI_GET_HALO
+!
+IMPLICIT NONE
+!
+!* 0.1 declarations of arguments
+!
+!
+REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PQLAP ! final divergence
+!
+CHARACTER (LEN=4), DIMENSION(2), INTENT(IN) :: HLBCX ! x-direction LBC type
+CHARACTER (LEN=4), DIMENSION(2), INTENT(IN) :: HLBCY ! y-direction LBC type
+!
+ ! Metric coefficients:
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDXX ! d*xx
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDYY ! d*yy
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDZX ! d*zx
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDZY ! d*zy
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDZZ ! d*zz
+!
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODJ ! density of reference * J
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PTHETAV ! virtual potential temp. at time t
+!
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PY ! field components
+!
+!* 0.2 declarations of local variables
+!
+REAL, DIMENSION(:,:,:) , POINTER , CONTIGUOUS :: ZU ! rho*J*gradient along x
+!
+REAL, DIMENSION(:,:,:) , POINTER , CONTIGUOUS :: ZV ! rho*J*gradient along y
+!
+REAL, DIMENSION(:,:,:) , POINTER , CONTIGUOUS :: ZW ! rho*J*gradient along z
+!
+INTEGER :: IZU,IZV,IZW
+!
+INTEGER :: IIU,IJU,IKU ! I,J,K array sizes
+INTEGER :: JK,JJ,JI ! vertical loop index
+TYPE(LIST_ll), POINTER :: TZFIELDS_ll ! list of fields to exchange
+INTEGER :: IINFO_ll
+INTEGER :: IIB,IIE,IJB,IJE
+!
+REAL, DIMENSION(:,:,:), pointer , contiguous :: ZMXM,ZMYM,ZMZM,ZRHODJ,ZGZMW
+INTEGER :: IZMXM,IZMYM,IZMZM,IZRHODJ,IZGZMW
+!
+LOGICAL :: GWEST,GEAST,GSOUTH,GNORTH
+!-------------------------------------------------------------------------------
+!
+!
+!* 1. COMPUTE THE GRADIENT COMPONENTS
+! -------------------------------
+!
+CALL GET_DIM_EXT_ll('B',IIU,IJU)
+CALL GET_INDICE_ll (IIB,IJB,IIE,IJE)
+IKU=SIZE(PY,3)
+!
+GWEST = ( HLBCX(1) /= 'CYCL' .AND. LWEST_ll() )
+GEAST = ( HLBCX(2) /= 'CYCL' .AND. LEAST_ll() )
+GSOUTH = ( HLBCY(1) /= 'CYCL' .AND. LSOUTH_ll() )
+GNORTH = ( HLBCY(2) /= 'CYCL' .AND. LNORTH_ll() )
+!
+IZU = MNH_ALLOCATE_ZT3D( ZU,IIU,IJU,IKU )
+IZV = MNH_ALLOCATE_ZT3D( ZV,IIU,IJU,IKU )
+IZW = MNH_ALLOCATE_ZT3D( ZW,IIU,IJU,IKU )
+!
+IZMXM = MNH_ALLOCATE_ZT3D( ZMXM,IIU,IJU,IKU )
+IZMYM = MNH_ALLOCATE_ZT3D( ZMYM,IIU,IJU,IKU )
+IZMZM = MNH_ALLOCATE_ZT3D( ZMZM,IIU,IJU,IKU )
+IZRHODJ = MNH_ALLOCATE_ZT3D( ZRHODJ ,IIU,IJU,IKU )
+IZGZMW = MNH_ALLOCATE_ZT3D( ZGZMW ,IIU,IJU,IKU )
+!
+CALL GX_M_U_DEVICE(1,IKU,1,PY,PDXX,PDZZ,PDZX,ZU)
+CALL MPPDB_CHECK3D(ZU,'QLAP::ZU',PRECISION)
+!
+IF ( GWEST ) THEN
+ !$acc kernels async
+ DO JK=2,IKU-1
+ DO JJ=1,IJU
+ ZU(IIB,JJ,JK)= (PY(IIB,JJ,JK) - PY(IIB-1,JJ,JK) - 0.5 * ( &
+ PDZX(IIB,JJ,JK) * (PY(IIB,JJ,JK)-PY(IIB,JJ,JK-1)) / PDZZ(IIB,JJ,JK) &
+ +PDZX(IIB,JJ,JK+1) * (PY(IIB,JJ,JK+1)-PY(IIB,JJ,JK)) / PDZZ(IIB,JJ,JK+1) &
+ ) ) / PDXX(IIB,JJ,JK)
+ END DO
+ END DO
+ !$acc end kernels
+END IF
+!
+IF ( GEAST ) THEN
+ !$acc kernels async
+ DO JK=2,IKU-1
+ DO JJ=1,IJU
+ ZU(IIE+1,JJ,JK)= (PY(IIE+1,JJ,JK) - PY(IIE+1-1,JJ,JK) - 0.5 * ( &
+ PDZX(IIE+1,JJ,JK) * (PY(IIE+1-1,JJ,JK)-PY(IIE+1-1,JJ,JK-1)) / PDZZ(IIE+1-1,JJ,JK) &
+ +PDZX(IIE+1,JJ,JK+1) * (PY(IIE+1-1,JJ,JK+1)-PY(IIE+1-1,JJ,JK)) / PDZZ(IIE+1-1,JJ,JK+1)&
+ ) ) / PDXX(IIE+1,JJ,JK)
+ END DO
+ END DO
+ !$acc end kernels
+END IF
+!$acc wait
+!
+CALL MPPDB_CHECK3D(ZU,'QLAP::ZU/W',PRECISION)
+CALL MPPDB_CHECK3D(ZU,'QLAP::ZU/E',PRECISION)
+!
+IF(.NOT. L2D) THEN
+!
+ CALL GY_M_V_DEVICE(1,IKU,1,PY,PDYY,PDZZ,PDZY,ZV)
+ CALL MPPDB_CHECK3D(ZV,'QLAP::ZV',PRECISION)
+!
+ IF ( GSOUTH ) THEN
+ !$acc kernels async
+ DO JK=2,IKU-1
+ DO JI=1,IIU
+ ZV(JI,IJB,JK)= (PY(JI,IJB,JK) - PY(JI,IJB-1,JK) - 0.5 * ( &
+ PDZY(JI,IJB,JK) * (PY(JI,IJB,JK)-PY(JI,IJB,JK-1)) / PDZZ(JI,IJB,JK) &
+ +PDZY(JI,IJB,JK+1) * (PY(JI,IJB,JK+1)-PY(JI,IJB,JK)) / PDZZ(JI,IJB,JK+1) &
+ ) ) / PDYY(JI,IJB,JK)
+ END DO
+ END DO
+ !$acc end kernels
+ END IF
+
+
+ IF ( GNORTH ) THEN
+ !$acc kernels async
+ DO JK=2,IKU-1
+ DO JI=1,IIU
+ ZV(JI,IJE+1,JK)= (PY(JI,IJE+1,JK) - PY(JI,IJE+1-1,JK) - 0.5 * ( &
+ PDZY(JI,IJE+1,JK) * (PY(JI,IJE+1-1,JK)-PY(JI,IJE+1-1,JK-1)) &
+ / PDZZ(JI,IJE+1-1,JK) &
+ +PDZY(JI,IJE+1,JK+1) * (PY(JI,IJE+1-1,JK+1)-PY(JI,IJE+1-1,JK)) &
+ / PDZZ(JI,IJE+1-1,JK+1)&
+ ) ) / PDYY(JI,IJE+1,JK)
+ END DO
+ END DO
+ !$acc end kernels
+ END IF
+ !$acc wait
+ CALL MPPDB_CHECK3D(ZV,'QLAP::ZV/S',PRECISION)
+ CALL MPPDB_CHECK3D(ZV,'QLAP::ZV/N',PRECISION)
+!
+ELSE
+ ZV=0.
+ENDIF
+!
+IF ( CEQNSYS == 'DUR' .OR. CEQNSYS == 'MAE' ) THEN
+ !$acc kernels
+ ZRHODJ = PRHODJ * XCPD * PTHETAV
+ !$acc end kernels
+ CALL MXM_DEVICE (ZRHODJ, ZMXM )
+ !$acc kernels
+ ZU = ZMXM * ZU
+ !$acc end kernels
+ IF(.NOT. L2D) THEN
+ CALL MYM_DEVICE (ZRHODJ, ZMYM )
+ !$acc kernels
+ ZV = ZMYM * ZV
+ !$acc end kernels
+ END IF
+ CALL MZM_DEVICE (ZRHODJ, ZMZM )
+ CALL GZ_M_W_DEVICE(1,IKU,1,PY,PDZZ,ZGZMW)
+ !$acc kernels
+ ZW = ZMZM * ZGZMW
+ !$acc end kernels
+ELSEIF ( CEQNSYS == 'LHE' ) THEN
+ ZU = MXM(PRHODJ) * ZU
+ IF(.NOT. L2D) THEN
+ ZV = MYM(PRHODJ) * ZV
+ ENDIF
+ ZW = MZM(PRHODJ) * GZ_M_W(1,IKU,1,PY,PDZZ)
+END IF
+!
+!-------------------------------------------------------------------------------
+!
+!* 2. COMPUTE THE DIVERGENCE
+! ----------------------
+!
+CALL GET_HALO_D(ZU,HNAME='QLAP::ZU')
+CALL GET_HALO_D(ZV,HNAME='QLAP::ZV')
+CALL GET_HALO_D(ZW,HNAME='QLAP::ZW')
+!
+CALL GDIV(HLBCX,HLBCY,PDXX,PDYY,PDZX,PDZY,PDZZ,ZU,ZV,ZW,PQLAP)
+!
+CALL MNH_REL_ZT3D ( IZU,IZV,IZW, IZMXM,IZMYM,IZMZM,IZRHODJ,IZGZMW )
+!-------------------------------------------------------------------------------
+!
+END SUBROUTINE QLAP_DEVICE
+#endif
diff --git a/src/ZSOLVER/read_exsegn.f90 b/src/ZSOLVER/read_exsegn.f90
new file mode 100644
index 0000000000000000000000000000000000000000..85e867132c14957b8d40a881ad9fe9d337879228
--- /dev/null
+++ b/src/ZSOLVER/read_exsegn.f90
@@ -0,0 +1,2853 @@
+!MNH_LIC Copyright 1994-2019 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.
+!-----------------------------------------------------------------
+! ######################
+ MODULE MODI_READ_EXSEG_n
+! ######################
+!
+INTERFACE
+!
+ SUBROUTINE READ_EXSEG_n(KMI,TPEXSEGFILE,HCONF,OFLAT,OUSERV, &
+ OUSERC,OUSERR,OUSERI,OUSECI,OUSERS,OUSERG,OUSERH, &
+ OUSECHEM,OUSECHAQ,OUSECHIC,OCH_PH,OCH_CONV_LINOX,OSALT, &
+ ODEPOS_SLT, ODUST,ODEPOS_DST, OCHTRANS, &
+ OORILAM,ODEPOS_AER, OLG,OPASPOL, &
+#ifdef MNH_FOREFIRE
+ OFOREFIRE, &
+#endif
+ OLNOX_EXPLICIT, &
+ OCONDSAMP,OBLOWSNOW, &
+ KRIMX,KRIMY, KSV_USER, &
+ HTURB,HTOM,ORMC01,HRAD,HDCONV,HSCONV,HCLOUD,HELEC, &
+ HEQNSYS,PTSTEP_ALL,HSTORAGE_TYPE,HINIFILEPGD )
+!
+USE MODD_IO, ONLY: TFILEDATA
+!
+INTEGER, INTENT(IN) :: KMI ! Model index
+TYPE(TFILEDATA), INTENT(IN) :: TPEXSEGFILE ! EXSEG file
+! The following variables are read by READ_DESFM in DESFM descriptor :
+CHARACTER (LEN=*), INTENT(IN) :: HCONF ! configuration var. linked to FMfile
+LOGICAL, INTENT(IN) :: OFLAT ! Logical for zero orography
+LOGICAL, INTENT(IN) :: OUSERV,OUSERC,OUSERR,OUSERI,OUSERS, &
+ OUSERG,OUSERH ! kind of moist variables in
+ ! FMfile
+LOGICAL, INTENT(IN) :: OUSECI ! ice concentration in
+ ! FMfile
+LOGICAL, INTENT(IN) :: OUSECHEM ! Chemical FLAG in FMFILE
+LOGICAL, INTENT(IN) :: OUSECHAQ ! Aqueous chemical FLAG in FMFILE
+LOGICAL, INTENT(IN) :: OUSECHIC ! Ice chemical FLAG in FMFILE
+LOGICAL, INTENT(IN) :: OCH_PH ! pH FLAG in FMFILE
+LOGICAL, INTENT(IN) :: OCH_CONV_LINOX ! LiNOx FLAG in FMFILE
+LOGICAL, INTENT(IN) :: ODUST ! Dust FLAG in FMFILE
+LOGICAL,DIMENSION(:), INTENT(IN) :: ODEPOS_DST ! Dust wet deposition FLAG in FMFILE
+LOGICAL,DIMENSION(:), INTENT(IN) :: ODEPOS_SLT ! Sea Salt wet deposition FLAG in FMFILE
+LOGICAL,DIMENSION(:), INTENT(IN) :: ODEPOS_AER ! Orilam wet deposition FLAG in FMFILE
+LOGICAL, INTENT(IN) :: OSALT ! Sea Salt FLAG in FMFILE
+LOGICAL, INTENT(IN) :: OORILAM ! Orilam FLAG in FMFILE
+LOGICAL, INTENT(IN) :: OPASPOL ! Passive pollutant FLAG in FMFILE
+#ifdef MNH_FOREFIRE
+LOGICAL, INTENT(IN) :: OFOREFIRE ! ForeFire FLAG in FMFILE
+#endif
+LOGICAL, INTENT(IN) :: OLNOX_EXPLICIT ! explicit LNOx FLAG in FMFILE
+LOGICAL, INTENT(IN) :: OCONDSAMP ! Conditional sampling FLAG in FMFILE
+LOGICAL, INTENT(IN) :: OBLOWSNOW ! Blowing snow FLAG in FMFILE
+LOGICAL, INTENT(IN) :: OCHTRANS ! LCHTRANS FLAG in FMFILE
+
+LOGICAL, INTENT(IN) :: OLG ! lagrangian FLAG in FMFILE
+INTEGER, INTENT(IN) :: KRIMX, KRIMY ! number of points for the
+ ! horizontal relaxation for the outermost verticals
+INTEGER, INTENT(IN) :: KSV_USER ! number of additional scalar
+ ! variables in FMfile
+CHARACTER (LEN=*), INTENT(IN) :: HTURB ! Kind of turbulence parameterization
+ ! used to produce FMFILE
+CHARACTER (LEN=*), INTENT(IN) :: HTOM ! Kind of third order moment
+LOGICAL, INTENT(IN) :: ORMC01 ! flag for RMC01 SBL computations
+CHARACTER (LEN=*), INTENT(IN) :: HRAD ! Kind of radiation scheme
+CHARACTER (LEN=4), INTENT(IN) :: HDCONV ! Kind of deep convection scheme
+CHARACTER (LEN=4), INTENT(IN) :: HSCONV ! Kind of shallow convection scheme
+CHARACTER (LEN=4), INTENT(IN) :: HCLOUD ! Kind of microphysical scheme
+CHARACTER (LEN=4), INTENT(IN) :: HELEC ! Kind of electrical scheme
+CHARACTER (LEN=*), INTENT(IN) :: HEQNSYS! type of equations' system
+REAL,DIMENSION(:), INTENT(INOUT):: PTSTEP_ALL ! Time STEP of ALL models
+CHARACTER (LEN=*), INTENT(IN) :: HSTORAGE_TYPE ! type of initial file
+CHARACTER (LEN=*), INTENT(IN) :: HINIFILEPGD ! name of PGD file
+!
+END SUBROUTINE READ_EXSEG_n
+!
+END INTERFACE
+!
+END MODULE MODI_READ_EXSEG_n
+!
+!
+! #########################################################################
+ SUBROUTINE READ_EXSEG_n(KMI,TPEXSEGFILE,HCONF,OFLAT,OUSERV, &
+ OUSERC,OUSERR,OUSERI,OUSECI,OUSERS,OUSERG,OUSERH, &
+ OUSECHEM,OUSECHAQ,OUSECHIC,OCH_PH,OCH_CONV_LINOX,OSALT, &
+ ODEPOS_SLT, ODUST,ODEPOS_DST, OCHTRANS, &
+ OORILAM,ODEPOS_AER, OLG,OPASPOL, &
+#ifdef MNH_FOREFIRE
+ OFOREFIRE, &
+#endif
+ OLNOX_EXPLICIT, &
+ OCONDSAMP, OBLOWSNOW, &
+ KRIMX,KRIMY, KSV_USER, &
+ HTURB,HTOM,ORMC01,HRAD,HDCONV,HSCONV,HCLOUD,HELEC, &
+ HEQNSYS,PTSTEP_ALL,HSTORAGE_TYPE,HINIFILEPGD )
+! #########################################################################
+!
+!!**** *READ_EXSEG_n * - routine to read the descriptor file EXSEG
+!!
+!! PURPOSE
+!! -------
+! The purpose of this routine is to read the descriptor file called
+! EXSEG and to control the coherence with FMfile data .
+!
+!!
+!!** METHOD
+!! ------
+!! The descriptor file is read. Namelists (NAMXXXn) which contain
+!! variables linked to one nested model are at the beginning of the file.
+!! Namelists (NAMXXX) which contain variables common to all models
+!! are at the end of the file. When the model index is different from 1,
+!! the end of the file (namelists NAMXXX) is not read.
+!!
+!! Coherence between the initial file (description read in DESFM file)
+!! and the segment to perform (description read in EXSEG file)
+!! is checked for segment achievement configurations
+!! or postprocessing configuration. The get indicators are set according
+!! to the following check :
+!!
+!! - segment achievement and preinit configurations :
+!!
+!! * if there is no turbulence kinetic energy in initial
+!! file (HTURB='NONE'), and the segment to perform requires a turbulence
+!! parameterization (CTURB /= 'NONE'), the get indicators for turbulence
+!! kinetic energy variables are set to 'INIT'; i.e. these variables will be
+!! set equal to zero by READ_FIELD according to the get indicators.
+!! * The same procedure is applied to the dissipation of TKE.
+!! * if there is no moist variables RRn in initial file (OUSERn=.FALSE.)
+!! and the segment to perform requires moist variables RRn
+!! (LUSERn=.TRUE.), the get indicators for moist variables RRn are set
+!! equal to 'INIT'; i.e. these variables will be set equal to zero by
+!! READ_FIELD according to the get indicators.
+!! * if there are KSV_USER additional scalar variables in initial file and the
+!! segment to perform needs more than KSV_USER additional variables, the get
+!! indicators for these (NSV_USER-KSV_USER) additional scalar variables are set
+!! equal to 'INIT'; i.e. these variables will be set equal to zero by
+!! READ_FIELD according to the get indicators. If the segment to perform
+!! needs less additional scalar variables than there are in initial file,
+!! the get indicators for these (KSV_USER - NSV_USER) additional scalar variables are
+!! set equal to 'SKIP'.
+!! * warning messages are printed if the fields in initial file are the
+!! same at time t and t-dt (HCONF='START') and a leap-frog advance
+!! at first time step will be used for the segment to perform
+!! (CCONF='RESTA'); It is likewise when HCONF='RESTA' and CCONF='START'.
+!! * A warning message is printed if the orography in initial file is zero
+!! (OFLAT=.TRUE.) and the segment to perform considers no-zero orography
+!! (LFLAT=.FALSE.). It is likewise for LFLAT=.TRUE. and OFLAT=.FALSE..
+!! If the segment to perform requires zero orography (LFLAT=.TRUE.), the
+!! orography (XZS) will not read in initial file but set equal to zero
+!! by SET_GRID.
+!! * check of the depths of the Lateral Damping Layer in x and y
+!! direction is performed
+!! * If some coupling files are specified, LSTEADYLS is set to T
+!! * If no coupling files are specified, LSTEADYLS is set to F
+!!
+!!
+!! EXTERNAL
+!! --------
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module MODN_CONF : CCONF,LTHINSHELL,LFLAT,NMODEL,NVERB
+!!
+!! Module MODN_DYN : LCORIO, LZDIFFU
+!!
+!! Module MODN_NESTING : NDAD(m),NDTRATIO(m),XWAY(m)
+!!
+!! Module MODN_BUDGET : CBUTYPE,XBULEN
+!!
+!! Module MODN_CONF1 : LUSERV,LUSERC,LUSERR,LUSERI,LUSERS,LUSERG,LUSERH,CSEG
+!!
+!! Module MODN_DYN1 : XTSTEP,CPRESOPT,NITR,XRELAX
+!!
+!! Module MODD_ADV1 : CMET_ADV_SCHEME,CSV_ADV_SCHEME,CUVW_ADV_SCHEME,NLITER
+!!
+!! Module MODN_PARAM1 : CTURB,CRAD,CDCONV,CSCONV
+!!
+!! Module MODN_LUNIT1 :
+!! Module MODN_LBC1 : CLBCX,CLBCY,NLBLX,NLBLY,XCPHASE,XPOND
+!!
+!! Module MODN_TURB_n : CTURBLEN,CTURBDIM
+!!
+!! Module MODD_GET1:
+!! CGETTKEM,CGETTKET,
+!! CGETRVM,CGETRCM,CGETRRM,CGETRIM,CGETRSM,CGETRGM,CGETRHM
+!! CGETRVT,CGETRCT,CGETRRT,CGETRIT,CGETRST,CGETRGT,CGETRHT,CGETSVM
+!! CGETSVT,CGETSIGS,CGETSRCM,CGETSRCT
+!! NCPL_NBR,NCPL_TIMES,NCPL_CUR
+!! Module MODN_LES : contains declaration of the control parameters
+!! for Large Eddy Simulations' storages
+!! for the forcing
+!!
+!! REFERENCE
+!! ---------
+!! Book2 of the documentation (routine READ_EXSEG_n)
+!!
+!!
+!! AUTHOR
+!! ------
+!! V. Ducrocq * Meteo France *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 07/06/94
+!! Modification 26/10/94 (Stein) remove NAM_GET from the Namelists
+!! present in DESFM + change the namelist names
+!! Modification 22/11/94 (Stein) add GET indicator for phi
+!! Modification 21/12/94 (Stein) add GET indicator for LS fields
+!! Modification 06/01/95 (Stein) bug in the test for Scalar Var.
+!! Modifications 09/01/95 (Stein) add the turbulence scheme
+!! Modifications 09/01/95 (Stein) add the 1D switch
+!! Modifications 10/03/95 (Mallet) add coherence in coupling case
+!! Modifications 16/03/95 (Stein) remove R from the historical variables
+!! Modifications 01/03/95 (Hereil) add the budget namelists
+!! Modifications 16/06/95 (Stein) coherence control for the
+!! microphysical scheme + remove the wrong messge for RESTA conf
+!! Modifications 30/06/95 (Stein) conditionnal reading of the fields
+!! used by the moist turbulence scheme
+!! Modifications 12/09/95 (Pinty) add the radiation scheme
+!! Modification 06/02/96 (J.Vila) implement scalar advection schemes
+!! Modifications 24/02/96 (Stein) change the default value for CCPLFILE
+!! Modifications 02/05/96 (Stein Jabouille) change the Z0SEA activation
+!! Modifications 24/05/96 (Stein) change the SRC SIGS control
+!! Modifications 08/09/96 (Masson) the coupling file names are reset to
+!! default value " " before reading in EXSEG1.nam
+!! to avoid extra non-existant coupling files
+!!
+!! Modifications 25/04/95 (K.Suhre)add namelist NAM_BLANK
+!! add read for LFORCING
+!! 25/04/95 (K.Suhre)add namelist NAM_FRC
+!! and switch checking
+!! 06/08/96 (K.Suhre)add namelist NAM_CH_MNHCn
+!! and NAM_CH_SOLVER
+!! Modifications 10/10/96 (Stein) change SRC into SRCM and SRCT
+!! Modifications 11/04/96 (Pinty) add the rain-ice microphysical scheme
+!! Modifications 11/01/97 (Pinty) add the deep convection scheme
+!! Modifications 22/05/97 (Lafore) gridnesting implementation
+!! Modifications 22/06/97 (Stein) add the absolute pressure + cleaning
+!! Modifications 25/08/97 (Masson) add tests on surface schemes
+!! 22/10/97 (Stein) remove the RIMX /= 0 control
+!! + new namelist + cleaning
+!! Modifications 17/04/98 (Masson) add tests on character variables
+!! Modification 15/03/99 (Masson) add tests on PROGRAM
+!! Modification 04/01/00 (Masson) removes TSZ0 case
+!! Modification 04/06/00 (Pinty) add C2R2 scheme
+!! 11/12/00 (Tomasini) add CSEA_FLUX to MODD_PARAMn
+!! delete the test on SST_FRC only in 1D
+!! Modification 22/01/01 (Gazen) change NSV,KSV to NSV_USER,KSV_USER and add
+!! NSV_* variables initialization
+!! Modification 15/10/01 (Mallet) allow namelists in different orders
+!! Modification 18/03/02 (Solmon) new radiation scheme test
+!! Modification 29/11/02 (JP Pinty) add C3R5, ICE2, ICE4, ELEC
+!! Modification 06/11/02 (Masson) new LES BL height diagnostic
+!! Modification 06/11/02 (Jabouille) remove LTHINSHELL LFORCING test
+!! Modification 01/12/03 (Gazen) change Chemical scheme interface
+!! Modification 01/2004 (Masson) removes surface (externalization)
+!! Modification 01/2005 (Masson) removes 1D and 2D switches
+!! Modification 04/2005 (Tulet) add dust, orilam
+!! Modification 03/2006 (O.Geoffroy) Add KHKO scheme
+!! Modification 04/2006 (Maric) include 4th order advection scheme
+!! Modification 05/2006 (Masson) add nudging
+!! Modification 05/2006 Remove KEPS
+!! Modification 04/2006 (Maric) include PPM advection scheme
+!! Modification 04/2006 (J.Escobar) Bug dollarn add CALL UPDATE_NAM_CONFN
+!! Modifications 01/2007 (Malardel,Pergaud) add the MF shallow
+!! convection scheme MODN_PARAM_MFSHALL_n
+!! Modification 09/2009 (J.Escobar) add more info on relaxation problems
+!! Modification 09/2011 (J.Escobar) re-add 'ZRESI' choose
+!! Modification 12/2011 (C.Lac) Adaptation to FIT temporal scheme
+!! Modification 12/2012 (S.Bielli) add NAM_NCOUT for netcdf output (removed 08/07/2016)
+!! Modification 02/2012 (Pialat/Tulet) add ForeFire
+!! Modification 02/2012 (T.Lunet) add of new Runge-Kutta methods
+!! Modification 01/2015 (C. Barthe) add explicit LNOx
+!! J.Escobar : 15/09/2015 : WENO5 & JPHEXT <> 1
+!! M.Leriche 18/12/2015 : bug chimie glace dans prep_real_case
+!! Modification 01/2016 (JP Pinty) Add LIMA
+!! Modification 02/2016 (M.Leriche) treat gas and aq. chemicals separately
+!! P.Wautelet 08/07/2016 : removed MNH_NCWRIT define
+!! Modification 10/2016 (C.LAC) Add OSPLIT_WENO + Add droplet
+!! deposition + Add max values
+!! Modification 11/2016 (Ph. Wautelet) Allocate/initialise some output/backup structures
+!! Modification 03/2017 (JP Chaboureau) Fix the initialization of
+!! LUSERx-type variables for LIMA
+!! M.Leriche 06/2017 for spawn and prep_real avoid abort if wet dep for
+!! aerosol and no cloud scheme defined
+!! Q.Libois 02/2018 ECRAD
+!! Philippe Wautelet: 05/2016-04/2018: new data structures and calls for I/O
+!! Modification 07/2017 (V. Vionnet) add blowing snow scheme
+!! Modification 01/2019 (Q. Rodier) define XCEDIS depending on BL89 or RM17 mixing length
+!! Modification 01/2019 (P. Wautelet) bugs correction: incorrect writes
+!! Modification 01/2019 (R. Honnert) remove SURF in CMF_UPDRAFT
+!! Bielli S. 02/2019 Sea salt : significant sea wave height influences salt emission; 5 salt modes
+! P. Wautelet 10/04/2019: replace ABORT and STOP calls by Print_msg
+!!------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+USE MODD_PARAMETERS
+USE MODD_CONF
+USE MODD_CONFZ
+USE MODD_CONF_n, ONLY: CSTORAGE_TYPE
+USE MODD_IO, ONLY: TFILEDATA
+USE MODD_LUNIT_n, ONLY: TLUOUT
+USE MODD_VAR_ll, ONLY: NPROC
+!
+USE MODN_BACKUP
+USE MODN_BUDGET
+USE MODN_LES
+USE MODN_CONF
+USE MODN_CONFZ
+USE MODN_FRC
+USE MODN_DYN
+USE MODN_NESTING
+USE MODN_OUTPUT
+USE MODN_CONF_n
+USE MODN_LBC_n ! routine is used for each nested model. This has been done
+USE MODN_DYN_n ! to avoid the duplication of this routine for each model.
+USE MODN_ADV_n ! The final filling of these modules for the model n is
+USE MODN_PARAM_n ! realized in subroutine ini_model n
+USE MODN_PARAM_RAD_n
+USE MODN_PARAM_ECRAD_n
+USE MODN_PARAM_KAFR_n
+USE MODN_PARAM_MFSHALL_n
+USE MODN_PARAM_ICE
+USE MODN_LUNIT_n
+USE MODN_NUDGING_n
+USE MODN_TURB_n
+USE MODN_DRAG_n
+USE MODN_BLANK
+USE MODN_CH_MNHC_n
+USE MODN_CH_SOLVER_n
+USE MODN_PARAM_C2R2, ONLY : EPARAM_CCN=>HPARAM_CCN, EINI_CCN=>HINI_CCN, &
+ WNUC=>XNUC, WALPHAC=>XALPHAC, NAM_PARAM_C2R2
+USE MODN_PARAM_C1R3, ONLY : NAM_PARAM_C1R3, CPRISTINE_ICE_C1R3, &
+ CHEVRIMED_ICE_C1R3
+USE MODN_PARAM_LIMA, ONLY : FINI_CCN=>HINI_CCN,NAM_PARAM_LIMA,NMOD_CCN,LSCAV, &
+ CPRISTINE_ICE_LIMA, CHEVRIMED_ICE_LIMA, NMOD_IFN, &
+ LCOLD, LACTI, LNUCL, XALPHAC, XNUC, LMEYERS, LHAIL
+USE MODN_ELEC
+USE MODN_SERIES
+USE MODN_SERIES_n
+USE MODN_TURB_CLOUD
+USE MODN_TURB
+USE MODN_MEAN
+USE MODN_DRAGTREE
+USE MODN_LATZ_EDFLX
+!
+USE MODD_NSV,NSV_USER_n=>NSV_USER
+USE MODD_DYN
+USE MODD_DYN_n, ONLY : LHORELAX_SVLIMA
+USE MODD_GET_n
+USE MODD_GR_FIELD_n
+!
+USE MODE_POS
+USE MODE_MSG
+!
+USE MODI_TEST_NAM_VAR
+USE MODI_INI_NSV
+USE MODI_CH_INIT_SCHEME_n
+USE MODN_CH_ORILAM
+USE MODD_CH_AEROSOL
+USE MODD_DUST
+USE MODD_SALT
+USE MODD_PASPOL
+#ifdef MNH_FOREFIRE
+USE MODD_FOREFIRE
+USE MODN_FOREFIRE
+#endif
+USE MODD_CONDSAMP
+USE MODD_BLOWSNOW
+USE MODN_DUST
+USE MODN_SALT
+USE MODD_CH_M9_n, ONLY : NEQ
+USE MODN_PASPOL
+USE MODN_CONDSAMP
+USE MODN_BLOWSNOW
+USE MODN_BLOWSNOW_n
+USE MODN_2D_FRC
+USE MODN_VISCOSITY
+USE MODD_VISCOSITY
+USE MODD_DRAG_n
+!
+IMPLICIT NONE
+!
+!* 0.1 declarations of arguments
+!
+!
+!
+INTEGER, INTENT(IN) :: KMI ! Model index
+TYPE(TFILEDATA), INTENT(IN) :: TPEXSEGFILE ! EXSEG file
+! The following variables are read by READ_DESFM in DESFM descriptor :
+CHARACTER (LEN=*), INTENT(IN) :: HCONF ! configuration var. linked to FMfile
+LOGICAL, INTENT(IN) :: OFLAT ! Logical for zero orography
+LOGICAL, INTENT(IN) :: OUSERV,OUSERC,OUSERR,OUSERI,OUSERS, &
+ OUSERG,OUSERH ! kind of moist variables in
+ ! FMfile
+LOGICAL, INTENT(IN) :: OUSECI ! ice concentration in
+ ! FMfile
+LOGICAL, INTENT(IN) :: OUSECHEM ! Chemical FLAG in FMFILE
+LOGICAL, INTENT(IN) :: OUSECHAQ ! Aqueous chemical FLAG in FMFILE
+LOGICAL, INTENT(IN) :: OUSECHIC ! Ice chemical FLAG in FMFILE
+LOGICAL, INTENT(IN) :: OCH_PH ! pH FLAG in FMFILE
+LOGICAL, INTENT(IN) :: OCH_CONV_LINOX ! LiNOx FLAG in FMFILE
+LOGICAL, INTENT(IN) :: ODUST ! Dust FLAG in FMFILE
+LOGICAL,DIMENSION(:), INTENT(IN) :: ODEPOS_DST ! Dust Deposition FLAG in FMFILE
+LOGICAL,DIMENSION(:), INTENT(IN) :: ODEPOS_SLT ! Sea Salt wet deposition FLAG in FMFILE
+LOGICAL,DIMENSION(:), INTENT(IN) :: ODEPOS_AER ! Orilam wet deposition FLAG in FMFILE
+LOGICAL, INTENT(IN) :: OSALT ! Sea Salt FLAG in FMFILE
+LOGICAL, INTENT(IN) :: OORILAM ! Orilam FLAG in FMFILE
+LOGICAL, INTENT(IN) :: OPASPOL ! Passive pollutant FLAG in FMFILE
+#ifdef MNH_FOREFIRE
+LOGICAL, INTENT(IN) :: OFOREFIRE ! ForeFire FLAG in FMFILE
+#endif
+LOGICAL, INTENT(IN) :: OLNOX_EXPLICIT ! explicit LNOx FLAG in FMFILE
+LOGICAL, INTENT(IN) :: OCONDSAMP ! Conditional sampling FLAG in FMFILE
+LOGICAL, INTENT(IN) :: OCHTRANS ! LCHTRANS FLAG in FMFILE
+LOGICAL, INTENT(IN) :: OBLOWSNOW ! Blowing snow FLAG in FMFILE
+
+LOGICAL, INTENT(IN) :: OLG ! lagrangian FLAG in FMFILE
+INTEGER, INTENT(IN) :: KRIMX, KRIMY ! number of points for the
+ ! horizontal relaxation for the outermost verticals
+INTEGER, INTENT(IN) :: KSV_USER ! number of additional scalar
+ ! variables in FMfile
+CHARACTER (LEN=*), INTENT(IN) :: HTURB ! Kind of turbulence parameterization
+ ! used to produce FMFILE
+CHARACTER (LEN=*), INTENT(IN) :: HTOM ! Kind of third order moment
+LOGICAL, INTENT(IN) :: ORMC01 ! flag for RMC01 SBL computations
+CHARACTER (LEN=*), INTENT(IN) :: HRAD ! Kind of radiation scheme
+CHARACTER (LEN=4), INTENT(IN) :: HDCONV ! Kind of deep convection scheme
+CHARACTER (LEN=4), INTENT(IN) :: HSCONV ! Kind of shallow convection scheme
+CHARACTER (LEN=4), INTENT(IN) :: HCLOUD ! Kind of microphysical scheme
+CHARACTER (LEN=4), INTENT(IN) :: HELEC ! Kind of electrical scheme
+CHARACTER (LEN=*), INTENT(IN) :: HEQNSYS! type of equations' system
+REAL,DIMENSION(:), INTENT(INOUT):: PTSTEP_ALL ! Time STEP of ALL models
+CHARACTER (LEN=*), INTENT(IN) :: HSTORAGE_TYPE ! type of initial file
+CHARACTER (LEN=*), INTENT(IN) :: HINIFILEPGD ! name of PGD file
+!
+!* 0.2 declarations of local variables
+!
+INTEGER :: ILUSEG,ILUOUT ! logical unit numbers of EXSEG file and outputlisting
+INTEGER :: JS,JCI,JI,JSV ! Loop indexes
+LOGICAL :: GRELAX
+LOGICAL :: GFOUND ! Return code when searching namelist
+!
+INTEGER :: IMOMENTS, JMODE, IMODEIDX, JMOM, JSV_NAME, JMOD, I
+!
+!-------------------------------------------------------------------------------
+!
+!* 1. READ EXSEG FILE
+! ---------------
+!
+CALL PRINT_MSG(NVERB_DEBUG,'IO','READ_EXSEG_n','called for '//TRIM(TPEXSEGFILE%CNAME))
+!
+ILUSEG = TPEXSEGFILE%NLU
+ILUOUT = TLUOUT%NLU
+!
+CALL INIT_NAM_LUNITN
+CCPLFILE(:)=" "
+CALL INIT_NAM_CONFN
+CALL INIT_NAM_DYNN
+CALL INIT_NAM_ADVN
+CALL INIT_NAM_PARAMN
+CALL INIT_NAM_PARAM_RADN
+#ifdef MNH_ECRAD
+CALL INIT_NAM_PARAM_ECRADN
+#endif
+CALL INIT_NAM_PARAM_KAFRN
+CALL INIT_NAM_PARAM_MFSHALLN
+CALL INIT_NAM_LBCN
+CALL INIT_NAM_NUDGINGN
+CALL INIT_NAM_TURBN
+CALL INIT_NAM_DRAGN
+CALL INIT_NAM_CH_MNHCN
+CALL INIT_NAM_CH_SOLVERN
+CALL INIT_NAM_SERIESN
+CALL INIT_NAM_BLOWSNOWN
+!
+WRITE(UNIT=ILUOUT,FMT="(/,'READING THE EXSEG.NAM FILE')")
+CALL POSNAM(ILUSEG,'NAM_LUNITN',GFOUND,ILUOUT)
+IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_LUNITn)
+CALL POSNAM(ILUSEG,'NAM_CONFN',GFOUND,ILUOUT)
+IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_CONFn)
+CALL POSNAM(ILUSEG,'NAM_DYNN',GFOUND,ILUOUT)
+IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_DYNn)
+CALL POSNAM(ILUSEG,'NAM_ADVN',GFOUND,ILUOUT)
+IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_ADVn)
+CALL POSNAM(ILUSEG,'NAM_PARAMN',GFOUND,ILUOUT)
+IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_PARAMn)
+CALL POSNAM(ILUSEG,'NAM_PARAM_RADN',GFOUND,ILUOUT)
+IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_PARAM_RADn)
+#ifdef MNH_ECRAD
+CALL POSNAM(ILUSEG,'NAM_PARAM_ECRADN',GFOUND,ILUOUT)
+IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_PARAM_ECRADn)
+#endif
+CALL POSNAM(ILUSEG,'NAM_PARAM_KAFRN',GFOUND,ILUOUT)
+IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_PARAM_KAFRn)
+CALL POSNAM(ILUSEG,'NAM_PARAM_MFSHALLN',GFOUND,ILUOUT)
+IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_PARAM_MFSHALLn)
+CALL POSNAM(ILUSEG,'NAM_LBCN',GFOUND,ILUOUT)
+IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_LBCn)
+CALL POSNAM(ILUSEG,'NAM_NUDGINGN',GFOUND,ILUOUT)
+IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_NUDGINGn)
+CALL POSNAM(ILUSEG,'NAM_TURBN',GFOUND,ILUOUT)
+IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_TURBn)
+CALL POSNAM(ILUSEG,'NAM_DRAGN',GFOUND,ILUOUT)
+IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_DRAGn)
+CALL POSNAM(ILUSEG,'NAM_CH_MNHCN',GFOUND,ILUOUT)
+IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_CH_MNHCn)
+CALL POSNAM(ILUSEG,'NAM_CH_SOLVERN',GFOUND,ILUOUT)
+IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_CH_SOLVERn)
+CALL POSNAM(ILUSEG,'NAM_SERIESN',GFOUND,ILUOUT)
+IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_SERIESn)
+CALL POSNAM(ILUSEG,'NAM_BLOWSNOWN',GFOUND,ILUOUT)
+IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_BLOWSNOWn)
+!
+IF (KMI == 1) THEN
+ WRITE(UNIT=ILUOUT,FMT="(' namelists common to all the models ')")
+ CALL POSNAM(ILUSEG,'NAM_CONF',GFOUND,ILUOUT)
+ IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_CONF)
+ CALL POSNAM(ILUSEG,'NAM_CONFZ',GFOUND,ILUOUT)
+ IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_CONFZ)
+ CALL POSNAM(ILUSEG,'NAM_DYN',GFOUND,ILUOUT)
+ IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_DYN)
+ CALL POSNAM(ILUSEG,'NAM_NESTING',GFOUND,ILUOUT)
+ IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_NESTING)
+ CALL POSNAM(ILUSEG,'NAM_BACKUP',GFOUND,ILUOUT)
+ IF (GFOUND) THEN
+ !Should have been allocated before in READ_DESFM_n
+ IF (.NOT.ALLOCATED(XBAK_TIME)) THEN
+ ALLOCATE(XBAK_TIME(NMODEL,JPOUTMAX))
+ XBAK_TIME(:,:) = XNEGUNDEF
+ END IF
+ IF (.NOT.ALLOCATED(XOUT_TIME)) THEN
+ ALLOCATE(XOUT_TIME(NMODEL,JPOUTMAX)) !Allocate *OUT* variables to prevent
+ XOUT_TIME(:,:) = XNEGUNDEF
+ END IF
+ IF (.NOT.ALLOCATED(NBAK_STEP)) THEN
+ ALLOCATE(NBAK_STEP(NMODEL,JPOUTMAX))
+ NBAK_STEP(:,:) = NNEGUNDEF
+ END IF
+ IF (.NOT.ALLOCATED(NOUT_STEP)) THEN
+ ALLOCATE(NOUT_STEP(NMODEL,JPOUTMAX)) !problems if NAM_OUTPUT does not exist
+ NOUT_STEP(:,:) = NNEGUNDEF
+ END IF
+ IF (.NOT.ALLOCATED(COUT_VAR)) THEN
+ ALLOCATE(COUT_VAR (NMODEL,JPOUTVARMAX))
+ COUT_VAR(:,:) = ''
+ END IF
+ READ(UNIT=ILUSEG,NML=NAM_BACKUP)
+ ELSE
+ CALL POSNAM(ILUSEG,'NAM_FMOUT',GFOUND)
+ IF (GFOUND) THEN
+ CALL PRINT_MSG(NVERB_FATAL,'IO','READ_EXSEG_n','use namelist NAM_BACKUP instead of namelist NAM_FMOUT')
+ ELSE
+ IF (CPROGRAM=='MESONH') CALL PRINT_MSG(NVERB_ERROR,'IO','READ_EXSEG_n','namelist NAM_BACKUP not found')
+ END IF
+ END IF
+ CALL POSNAM(ILUSEG,'NAM_OUTPUT',GFOUND,ILUOUT)
+ IF (GFOUND) THEN
+ !Should have been allocated before in READ_DESFM_n
+ IF (.NOT.ALLOCATED(XBAK_TIME)) THEN
+ ALLOCATE(XBAK_TIME(NMODEL,JPOUTMAX)) !Allocate *BAK* variables to prevent
+ XBAK_TIME(:,:) = XNEGUNDEF
+ END IF
+ IF (.NOT.ALLOCATED(XOUT_TIME)) THEN
+ ALLOCATE(XOUT_TIME(NMODEL,JPOUTMAX))
+ XOUT_TIME(:,:) = XNEGUNDEF
+ END IF
+ IF (.NOT.ALLOCATED(NBAK_STEP)) THEN
+ ALLOCATE(NBAK_STEP(NMODEL,JPOUTMAX)) !problems if NAM_BACKUP does not exist
+ NBAK_STEP(:,:) = NNEGUNDEF
+ END IF
+ IF (.NOT.ALLOCATED(NOUT_STEP)) THEN
+ ALLOCATE(NOUT_STEP(NMODEL,JPOUTMAX))
+ NOUT_STEP(:,:) = NNEGUNDEF
+ END IF
+ IF (.NOT.ALLOCATED(COUT_VAR)) THEN
+ ALLOCATE(COUT_VAR (NMODEL,JPOUTVARMAX))
+ COUT_VAR(:,:) = ''
+ END IF
+ READ(UNIT=ILUSEG,NML=NAM_OUTPUT)
+ END IF
+ CALL POSNAM(ILUSEG,'NAM_BUDGET',GFOUND,ILUOUT)
+ IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_BUDGET)
+ CALL POSNAM(ILUSEG,'NAM_BU_RU',GFOUND,ILUOUT)
+ IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_BU_RU)
+ CALL POSNAM(ILUSEG,'NAM_BU_RV',GFOUND,ILUOUT)
+ IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_BU_RV)
+ CALL POSNAM(ILUSEG,'NAM_BU_RW',GFOUND,ILUOUT)
+ IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_BU_RW)
+ CALL POSNAM(ILUSEG,'NAM_BU_RTH',GFOUND,ILUOUT)
+ IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_BU_RTH)
+ CALL POSNAM(ILUSEG,'NAM_BU_RTKE',GFOUND,ILUOUT)
+ IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_BU_RTKE)
+ CALL POSNAM(ILUSEG,'NAM_BU_RRV',GFOUND,ILUOUT)
+ IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_BU_RRV)
+ CALL POSNAM(ILUSEG,'NAM_BU_RRC',GFOUND,ILUOUT)
+ IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_BU_RRC)
+ CALL POSNAM(ILUSEG,'NAM_BU_RRR',GFOUND,ILUOUT)
+ IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_BU_RRR)
+ CALL POSNAM(ILUSEG,'NAM_BU_RRI',GFOUND,ILUOUT)
+ IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_BU_RRI)
+ CALL POSNAM(ILUSEG,'NAM_BU_RRS',GFOUND,ILUOUT)
+ IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_BU_RRS)
+ CALL POSNAM(ILUSEG,'NAM_BU_RRG',GFOUND,ILUOUT)
+ IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_BU_RRG)
+ CALL POSNAM(ILUSEG,'NAM_BU_RRH',GFOUND,ILUOUT)
+ IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_BU_RRH)
+ CALL POSNAM(ILUSEG,'NAM_BU_RSV',GFOUND,ILUOUT)
+ IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_BU_RSV)
+ CALL POSNAM(ILUSEG,'NAM_LES',GFOUND,ILUOUT)
+ IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_LES)
+ CALL POSNAM(ILUSEG,'NAM_MEAN',GFOUND,ILUOUT)
+ IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_MEAN)
+ CALL POSNAM(ILUSEG,'NAM_PDF',GFOUND,ILUOUT)
+ IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_PDF)
+ CALL POSNAM(ILUSEG,'NAM_BLANK',GFOUND,ILUOUT)
+ IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_BLANK)
+ CALL POSNAM(ILUSEG,'NAM_FRC',GFOUND,ILUOUT)
+ IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_FRC)
+ CALL POSNAM(ILUSEG,'NAM_PARAM_ICE',GFOUND,ILUOUT)
+ IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_PARAM_ICE)
+ CALL POSNAM(ILUSEG,'NAM_PARAM_C2R2',GFOUND,ILUOUT)
+ IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_PARAM_C2R2)
+ CALL POSNAM(ILUSEG,'NAM_PARAM_C1R3',GFOUND,ILUOUT)
+ IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_PARAM_C1R3)
+ CALL POSNAM(ILUSEG,'NAM_PARAM_LIMA',GFOUND,ILUOUT)
+ IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_PARAM_LIMA)
+ CALL POSNAM(ILUSEG,'NAM_ELEC',GFOUND,ILUOUT)
+ IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_ELEC)
+ CALL POSNAM(ILUSEG,'NAM_SERIES',GFOUND,ILUOUT)
+ IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_SERIES)
+ CALL POSNAM(ILUSEG,'NAM_TURB_CLOUD',GFOUND,ILUOUT)
+ IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_TURB_CLOUD)
+ CALL POSNAM(ILUSEG,'NAM_TURB',GFOUND,ILUOUT)
+ IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_TURB)
+ CALL POSNAM(ILUSEG,'NAM_CH_ORILAM',GFOUND,ILUOUT)
+ IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_CH_ORILAM)
+ CALL POSNAM(ILUSEG,'NAM_DUST',GFOUND,ILUOUT)
+ IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_DUST)
+ CALL POSNAM(ILUSEG,'NAM_SALT',GFOUND,ILUOUT)
+ IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_SALT)
+ CALL POSNAM(ILUSEG,'NAM_PASPOL',GFOUND,ILUOUT)
+ IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_PASPOL)
+#ifdef MNH_FOREFIRE
+ CALL POSNAM(ILUSEG,'NAM_FOREFIRE',GFOUND,ILUOUT)
+ IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_FOREFIRE)
+#endif
+ CALL POSNAM(ILUSEG,'NAM_CONDSAMP',GFOUND,ILUOUT)
+ IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_CONDSAMP)
+ CALL POSNAM(ILUSEG,'NAM_DRAGTREE',GFOUND,ILUOUT)
+ IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_DRAGTREE)
+ CALL POSNAM(ILUSEG,'NAM_2D_FRC',GFOUND,ILUOUT)
+ IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_2D_FRC)
+ CALL POSNAM(ILUSEG,'NAM_LATZ_EDFLX',GFOUND)
+ IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_LATZ_EDFLX)
+ CALL POSNAM(ILUSEG,'NAM_BLOWSNOW',GFOUND,ILUOUT)
+ IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_BLOWSNOW)
+ CALL POSNAM(ILUSEG,'NAM_VISC',GFOUND,ILUOUT)
+ IF (GFOUND) READ(UNIT=ILUSEG,NML=NAM_VISC)
+END IF
+!
+!-------------------------------------------------------------------------------
+!
+CALL TEST_NAM_VAR(ILUOUT,'CPRESOPT',CPRESOPT,'RICHA','CGRAD','CRESI','ZRESI','ZSOLV',&
+ 'ZGRAD')
+!
+CALL TEST_NAM_VAR(ILUOUT,'CUVW_ADV_SCHEME',CUVW_ADV_SCHEME, &
+ 'CEN4TH','CEN2ND','WENO_K' )
+CALL TEST_NAM_VAR(ILUOUT,'CMET_ADV_SCHEME',CMET_ADV_SCHEME, &
+ &'PPM_00','PPM_01','PPM_02')
+CALL TEST_NAM_VAR(ILUOUT,'CSV_ADV_SCHEME',CSV_ADV_SCHEME, &
+ &'PPM_00','PPM_01','PPM_02')
+CALL TEST_NAM_VAR(ILUOUT,'CTEMP_SCHEME',CTEMP_SCHEME, &
+ &'RK11','RK21','RK33','RKC4','RK53','RK4B','RK62','RK65','NP32','SP32','LEFR')
+!
+CALL TEST_NAM_VAR(ILUOUT,'CTURB',CTURB,'NONE','TKEL')
+CALL TEST_NAM_VAR(ILUOUT,'CRAD',CRAD,'NONE','FIXE','ECMW',&
+#ifdef MNH_ECRAD
+ 'ECRA',&
+#endif
+ 'TOPA')
+CALL TEST_NAM_VAR(ILUOUT,'CCLOUD',CCLOUD,'NONE','REVE','KESS', &
+ & 'ICE3','ICE4','C2R2','C3R5','KHKO','LIMA')
+CALL TEST_NAM_VAR(ILUOUT,'CDCONV',CDCONV,'NONE','KAFR')
+CALL TEST_NAM_VAR(ILUOUT,'CSCONV',CSCONV,'NONE','KAFR','EDKF')
+CALL TEST_NAM_VAR(ILUOUT,'CELEC',CELEC,'NONE','ELE3','ELE4')
+!
+CALL TEST_NAM_VAR(ILUOUT,'CAER',CAER,'TANR','TEGE','SURF','NONE')
+CALL TEST_NAM_VAR(ILUOUT,'CAOP',CAOP,'CLIM','EXPL')
+CALL TEST_NAM_VAR(ILUOUT,'CLW',CLW,'RRTM','MORC')
+CALL TEST_NAM_VAR(ILUOUT,'CEFRADL',CEFRADL,'PRES','OCLN','MART','C2R2','LIMA')
+CALL TEST_NAM_VAR(ILUOUT,'CEFRADI',CEFRADI,'FX40','LIOU','SURI','C3R5','LIMA')
+CALL TEST_NAM_VAR(ILUOUT,'COPWLW',COPWLW,'SAVI','SMSH','LILI','MALA')
+CALL TEST_NAM_VAR(ILUOUT,'COPILW',COPILW,'FULI','EBCU','SMSH','FU98')
+CALL TEST_NAM_VAR(ILUOUT,'COPWSW',COPWSW,'SLIN','FOUQ','MALA')
+CALL TEST_NAM_VAR(ILUOUT,'COPISW',COPISW,'FULI','EBCU','FU96')
+!
+CALL TEST_NAM_VAR(ILUOUT,'CLBCX(1)',CLBCX(1),'CYCL','WALL','OPEN')
+CALL TEST_NAM_VAR(ILUOUT,'CLBCX(2)',CLBCX(2),'CYCL','WALL','OPEN')
+CALL TEST_NAM_VAR(ILUOUT,'CLBCY(1)',CLBCY(1),'CYCL','WALL','OPEN')
+CALL TEST_NAM_VAR(ILUOUT,'CLBCY(2)',CLBCY(2),'CYCL','WALL','OPEN')
+!
+CALL TEST_NAM_VAR(ILUOUT,'CTURBDIM',CTURBDIM,'1DIM','3DIM')
+CALL TEST_NAM_VAR(ILUOUT,'CTURBLEN',CTURBLEN,'DELT','BL89','RM17','DEAR','BLKR')
+CALL TEST_NAM_VAR(ILUOUT,'CTOM',CTOM,'NONE','TM06')
+CALL TEST_NAM_VAR(ILUOUT,'CSUBG_AUCV',CSUBG_AUCV,'NONE','CLFR','SIGM','PDF')
+!
+CALL TEST_NAM_VAR(ILUOUT,'CCH_TDISCRETIZATION',CCH_TDISCRETIZATION, &
+ 'SPLIT ','CENTER ','LAGGED ')
+!
+CALL TEST_NAM_VAR(ILUOUT,'CCONF',CCONF,'START','RESTA')
+CALL TEST_NAM_VAR(ILUOUT,'CEQNSYS',CEQNSYS,'LHE','DUR','MAE')
+CALL TEST_NAM_VAR(ILUOUT,'CSPLIT',CSPLIT,'BSPLITTING','XSPLITTING','YSPLITTING')
+!
+CALL TEST_NAM_VAR(ILUOUT,'CBUTYPE',CBUTYPE,'NONE','CART','MASK')
+!
+CALL TEST_NAM_VAR(ILUOUT,'CRELAX_HEIGHT_TYPE',CRELAX_HEIGHT_TYPE,'FIXE','THGR')
+!
+CALL TEST_NAM_VAR(ILUOUT,'CLES_NORM_TYPE',CLES_NORM_TYPE,'NONE','CONV','EKMA','MOBU')
+CALL TEST_NAM_VAR(ILUOUT,'CBL_HEIGHT_DEF',CBL_HEIGHT_DEF,'TKE','KE','WTV','FRI','DTH')
+CALL TEST_NAM_VAR(ILUOUT,'CTURBLEN_CLOUD',CTURBLEN_CLOUD,'NONE','DEAR','DELT','BL89')
+!
+! The test on the mass flux scheme for shallow convection
+!
+CALL TEST_NAM_VAR(ILUOUT,'CMF_UPDRAFT',CMF_UPDRAFT,'NONE','EDKF','RHCJ',&
+ 'HRIO','BOUT')
+CALL TEST_NAM_VAR(ILUOUT,'CMF_CLOUD',CMF_CLOUD,'NONE','STAT','DIRE')
+!
+! The test on the CSOLVER name is made elsewhere
+!
+CALL TEST_NAM_VAR(ILUOUT,'CPRISTINE_ICE',CPRISTINE_ICE,'PLAT','COLU','BURO')
+CALL TEST_NAM_VAR(ILUOUT,'CSEDIM',CSEDIM,'SPLI','STAT','NONE')
+IF( CCLOUD == 'C3R5' ) THEN
+ CALL TEST_NAM_VAR(ILUOUT,'CPRISTINE_ICE_C1R3',CPRISTINE_ICE_C1R3, &
+ 'PLAT','COLU','BURO')
+ CALL TEST_NAM_VAR(ILUOUT,'CHEVRIMED_ICE_C1R3',CHEVRIMED_ICE_C1R3, &
+ 'GRAU','HAIL')
+END IF
+!
+IF( CCLOUD == 'LIMA' ) THEN
+ CALL TEST_NAM_VAR(ILUOUT,'CPRISTINE_ICE_LIMA',CPRISTINE_ICE_LIMA, &
+ 'PLAT','COLU','BURO')
+ CALL TEST_NAM_VAR(ILUOUT,'CHEVRIMED_ICE_LIMA',CHEVRIMED_ICE_LIMA, &
+ 'GRAU','HAIL')
+END IF
+IF(LBLOWSNOW) THEN
+ CALL TEST_NAM_VAR(ILUOUT,'CSNOWSEDIM',CSNOWSEDIM,'NONE','MITC','CARR','TABC')
+ IF (XALPHA_SNOW .NE. 3 .AND. CSNOWSEDIM=='TABC') THEN
+ WRITE(ILUOUT,*) '*****************************************'
+ WRITE(ILUOUT,*) '* XALPHA_SNW must be set to 3 when '
+ WRITE(ILUOUT,*) '* CSNOWSEDIM = TABC '
+ WRITE(ILUOUT,*) '* Update the look-up table in BLOWSNOW_SEDIM_LKT1D '
+ WRITE(ILUOUT,*) '* to use TABC with a different value of XEMIALPHA_SNW'
+ WRITE(ILUOUT,*) '*****************************************'
+ !callabortstop
+ CALL PRINT_MSG(NVERB_FATAL,'GEN','READ_EXSEG_n','')
+ ENDIF
+END IF
+!
+!-------------------------------------------------------------------------------!
+!* 2. FIRST INITIALIZATIONS
+! ---------------------
+!
+!* 2.1 Time step in gridnesting case
+!
+IF (KMI /= 1 .AND. NDAD(KMI) /= KMI) THEN
+ XTSTEP = PTSTEP_ALL(NDAD(KMI)) / NDTRATIO(KMI)
+END IF
+PTSTEP_ALL(KMI) = XTSTEP
+!
+!* 2.2 Fill the global configuration module
+!
+! Check coherence between the microphysical scheme and water species and
+!initialize the logicals LUSERn
+!
+SELECT CASE ( CCLOUD )
+ CASE ( 'NONE' )
+ IF (.NOT. ( (.NOT. LUSERC) .AND. (.NOT. LUSERR) .AND. (.NOT. LUSERI) .AND. &
+ (.NOT. LUSERS) .AND. (.NOT. LUSERG) .AND. (.NOT. LUSERH) &
+ ) .AND. CPROGRAM=='MESONH' ) THEN
+!
+ LUSERC=.FALSE.
+ LUSERR=.FALSE.; LUSERI=.FALSE.
+ LUSERS=.FALSE.; LUSERG=.FALSE.
+ LUSERH=.FALSE.
+!
+ END IF
+!
+ IF (CSUBG_AUCV == 'SIGM') THEN
+!
+ WRITE(UNIT=ILUOUT,FMT=9002) KMI
+ WRITE(UNIT=ILUOUT,FMT=*) 'YOU WANT TO USE THE SUBGRID AUTOCONVERSION SCHEME '
+ WRITE(UNIT=ILUOUT,FMT=*) ' WITHOUT MICROPHYSICS'
+ WRITE(UNIT=ILUOUT,FMT=*) ' CSUBG_AUCV IS PUT TO "NONE"'
+!
+ CSUBG_AUCV = 'NONE'
+!
+ END IF
+!
+ CASE ( 'REVE' )
+ IF (.NOT. ( LUSERV .AND. LUSERC .AND. (.NOT. LUSERR) .AND. (.NOT. LUSERI) &
+ .AND. (.NOT. LUSERS) .AND. (.NOT. LUSERG) .AND. (.NOT. LUSERH) &
+ ) ) THEN
+!
+ WRITE(UNIT=ILUOUT,FMT=9002) KMI
+ WRITE(UNIT=ILUOUT,FMT='("YOU WANT TO USE A REVERSIBLE MICROPHYSICAL " ,&
+ &" SCHEME. YOU WILL ONLY HAVE VAPOR AND CLOUD WATER ",/, &
+ &" LUSERV AND LUSERC ARE TO TRUE AND THE OTHERS TO FALSE ")')
+!
+ LUSERV=.TRUE. ; LUSERC=.TRUE.
+ LUSERR=.FALSE.; LUSERI=.FALSE.
+ LUSERS=.FALSE.; LUSERG=.FALSE.
+ LUSERH=.FALSE.
+ END IF
+!
+ IF (CSUBG_AUCV == 'SIGM') THEN
+!
+ WRITE(UNIT=ILUOUT,FMT=9003) KMI
+ WRITE(UNIT=ILUOUT,FMT=*) 'YOU WANT TO USE BOTH A REVERSIBLE MICROPHYSICAL SCHEME '
+ WRITE(UNIT=ILUOUT,FMT=*) ' AND THE SUBGRID AUTOCONVERSION SCHEME '
+ WRITE(UNIT=ILUOUT,FMT=*) 'BUT YOU DO NOT HAVE RAIN in the "REVE" SCHEME'
+ WRITE(UNIT=ILUOUT,FMT=*) ' CSUBG_AUCV IS PUT TO "NONE"'
+!
+ CSUBG_AUCV = 'NONE'
+!
+ END IF
+!
+ CASE ( 'KESS' )
+ IF (.NOT. ( LUSERV .AND. LUSERC .AND. LUSERR .AND. (.NOT. LUSERI) .AND. &
+ (.NOT. LUSERS) .AND. (.NOT. LUSERG) .AND. (.NOT. LUSERH) &
+ ) ) THEN
+!
+ WRITE(UNIT=ILUOUT,FMT=9002) KMI
+ WRITE(UNIT=ILUOUT,FMT='("YOU WANT TO USE A KESSLER MICROPHYSICAL " , &
+ &" SCHEME. YOU WILL ONLY HAVE VAPOR, CLOUD WATER AND RAIN ",/, &
+ &" LUSERV, LUSERC AND LUSERR ARE SET TO TRUE AND THE OTHERS TO FALSE ")')
+!
+ LUSERV=.TRUE. ; LUSERC=.TRUE. ; LUSERR=.TRUE.
+ LUSERI=.FALSE.; LUSERS=.FALSE.
+ LUSERG=.FALSE.; LUSERH=.FALSE.
+ END IF
+!
+ IF (CSUBG_AUCV == 'SIGM') THEN
+!
+ WRITE(UNIT=ILUOUT,FMT=9003) KMI
+ WRITE(UNIT=ILUOUT,FMT=*) 'YOU WANT TO USE BOTH A KESSLER MICROPHYSICAL SCHEME '
+ WRITE(UNIT=ILUOUT,FMT=*) ' AND THE SUBGRID AUTOCONVERSION SCHEME USING'
+ WRITE(UNIT=ILUOUT,FMT=*) 'SIGMA_RC.'
+ WRITE(UNIT=ILUOUT,FMT=*) 'THIS IS NOT YET AVAILABLE.'
+ WRITE(UNIT=ILUOUT,FMT=*) 'SET CSUBG_AUCV TO "CLFR" or "NONE" OR CCLOUD TO "ICE3"'
+!
+ !callabortstop
+ CALL PRINT_MSG(NVERB_FATAL,'GEN','READ_EXSEG_n','')
+ END IF
+!
+ CASE ( 'ICE3' )
+ IF (.NOT. ( LUSERV .AND. LUSERC .AND. LUSERR .AND. LUSERI .AND. LUSECI &
+ .AND. LUSERS .AND. LUSERG .AND. (.NOT. LUSERH)) &
+ .AND. CPROGRAM=='MESONH' ) THEN
+ !
+ WRITE(UNIT=ILUOUT,FMT=9002) KMI
+ WRITE(UNIT=ILUOUT,FMT=*) 'YOU WANT TO USE THE ice3 SIMPLE MIXED PHASE'
+ WRITE(UNIT=ILUOUT,FMT=*) 'MICROPHYSICAL SCHEME. YOU WILL ONLY HAVE VAPOR, CLOUD WATER,'
+ WRITE(UNIT=ILUOUT,FMT=*) 'RAIN WATER, CLOUD ICE (MIXING RATIO AND CONCENTRATION)'
+ WRITE(UNIT=ILUOUT,FMT=*) 'SNOW-AGGREGATES AND GRAUPELN.'
+ WRITE(UNIT=ILUOUT,FMT=*) 'LUSERV,LUSERC,LUSERR,LUSERI,LUSECI,LUSERS,LUSERG ARE SET TO TRUE'
+ WRITE(UNIT=ILUOUT,FMT=*) 'AND LUSERH TO FALSE'
+!
+ LUSERV=.TRUE. ; LUSERC=.TRUE. ; LUSERR=.TRUE.
+ LUSERI=.TRUE. ; LUSECI=.TRUE.
+ LUSERS=.TRUE. ; LUSERG=.TRUE.
+ LUSERH=.FALSE.
+ END IF
+!
+ IF (CSUBG_AUCV == 'SIGM' .AND. .NOT. LSUBG_COND) THEN
+ WRITE(UNIT=ILUOUT,FMT=9002) KMI
+ WRITE(UNIT=ILUOUT,FMT=*) 'YOU WANT TO USE SUBGRID AUTOCONVERSION SCHEME'
+ WRITE(UNIT=ILUOUT,FMT=*) ' WITHOUT THE SUBGRID CONDENSATION SCHEME.'
+ WRITE(UNIT=ILUOUT,FMT=*) 'THIS IS NOT ALLOWED: CSUBG_AUCV is SET to NONE'
+ CSUBG_AUCV='NONE'
+ END IF
+!
+ IF (CSUBG_AUCV == 'CLFR' .AND. CSCONV /= 'EDKF') THEN
+ WRITE(UNIT=ILUOUT,FMT=9002) KMI
+ WRITE(UNIT=ILUOUT,FMT=*) 'YOU WANT TO USE SUBGRID AUTOCONVERSION SCHEME'
+ WRITE(UNIT=ILUOUT,FMT=*) 'WITH THE CONVECTIVE CLOUD FRACTION WITHOUT EDKF'
+ WRITE(UNIT=ILUOUT,FMT=*) 'THIS IS NOT ALLOWED: CSUBG_AUCV is SET to NONE'
+ CSUBG_AUCV='NONE'
+ END IF
+!
+ CASE ( 'ICE4' )
+ IF (.NOT. ( LUSERV .AND. LUSERC .AND. LUSERR .AND. LUSERI .AND. LUSECI &
+ .AND. LUSERS .AND. LUSERG .AND. LUSERH) &
+ .AND. CPROGRAM=='MESONH' ) THEN
+ !
+ WRITE(UNIT=ILUOUT,FMT=9002) KMI
+ WRITE(UNIT=ILUOUT,FMT=*) 'YOU WANT TO USE THE ice4 SIMPLE MIXED PHASE'
+ WRITE(UNIT=ILUOUT,FMT=*) 'MICROPHYSICAL SCHEME. YOU WILL ONLY HAVE VAPOR, CLOUD WATER,'
+ WRITE(UNIT=ILUOUT,FMT=*) 'RAIN WATER, CLOUD ICE (MIXING RATIO AND CONCENTRATION)'
+ WRITE(UNIT=ILUOUT,FMT=*) 'SNOW-AGGREGATES, GRAUPELN AND HAILSTONES.'
+ WRITE(UNIT=ILUOUT,FMT=*) 'LUSERV,LUSERC,LUSERR,LUSERI,LUSECI,LUSERS,LUSERG'
+ WRITE(UNIT=ILUOUT,FMT=*) 'AND LUSERH ARE SET TO TRUE'
+!
+ LUSERV=.TRUE. ; LUSERC=.TRUE. ; LUSERR=.TRUE.
+ LUSERI=.TRUE. ; LUSECI=.TRUE.
+ LUSERS=.TRUE. ; LUSERG=.TRUE. ; LUSERH=.TRUE.
+ END IF
+!
+ IF (CSUBG_AUCV /= 'NONE' .AND. .NOT. LSUBG_COND) THEN
+ WRITE(UNIT=ILUOUT,FMT=9002) KMI
+ WRITE(UNIT=ILUOUT,FMT=*) 'YOU WANT TO USE SUBGRID AUTOCONVERSION SCHEME'
+ WRITE(UNIT=ILUOUT,FMT=*) ' WITHOUT THE SUBGRID CONDENSATION SCHEME.'
+ WRITE(UNIT=ILUOUT,FMT=*) 'THIS IS NOT ALLOWED: CSUBG_AUCV is SET to NONE'
+ CSUBG_AUCV='NONE'
+ END IF
+!
+ CASE ( 'C2R2','C3R5', 'KHKO' )
+ IF (( EPARAM_CCN == 'XXX') .OR. (EINI_CCN == 'XXX')) THEN
+ WRITE(UNIT=ILUOUT,FMT='("YOU WANT TO USE A 2-MOMENT MICROPHYSICAL ", &
+ &" SCHEME BUT YOU DIDNT FILL CORRECTLY NAM_PARAM_C2R2", &
+ &" YOU HAVE TO FILL HPARAM_CCN and HINI_CCN ")')
+ !callabortstop
+ CALL PRINT_MSG(NVERB_FATAL,'GEN','READ_EXSEG_n','')
+ END IF
+ IF (HCLOUD == 'NONE') THEN
+ CGETCLOUD = 'SKIP'
+ ELSE IF (HCLOUD == 'REVE' ) THEN
+ CGETCLOUD = 'INI1'
+ ELSE IF (HCLOUD == 'KESS' ) THEN
+ CGETCLOUD = 'INI2'
+ ELSE IF (HCLOUD == 'ICE3' ) THEN
+ IF (CCLOUD == 'C3R5') THEN
+ CGETCLOUD = 'INI2'
+ ELSE
+ WRITE(UNIT=ILUOUT,FMT=9003) KMI
+ WRITE(UNIT=ILUOUT,FMT='("YOU WANT TO USE THE WARM MICROPHYSICAL ", &
+ &" SCHEME BUT YOU WERE USING THE ICE3 SCHEME PREVIOUSLY.",/, &
+ &" AS THIS IS A LITTLE BIT STUPID IT IS NOT AUTHORIZED !!!")')
+ !callabortstop
+ CALL PRINT_MSG(NVERB_FATAL,'GEN','READ_EXSEG_n','')
+ END IF
+ ELSE
+ CGETCLOUD = 'READ' ! This is automatically done
+ END IF
+!
+ IF ((CCLOUD == 'C2R2' ).OR. (CCLOUD == 'KHKO' )) THEN
+ IF (.NOT. ( LUSERV .AND. LUSERC .AND. LUSERR .AND. (.NOT. LUSERI) .AND. &
+ (.NOT. LUSERS) .AND. (.NOT. LUSERG) .AND. (.NOT. LUSERH) &
+ ) ) THEN
+ WRITE(UNIT=ILUOUT,FMT=9002) KMI
+ WRITE(UNIT=ILUOUT,FMT='("YOU WANT TO USE THE C2R2 MICROPHYSICAL ", &
+ &" SCHEME. YOU WILL ONLY HAVE VAPOR, CLOUD WATER AND RAIN ",/, &
+ &"LUSERV, LUSERC AND LUSERR ARE SET TO TRUE AND THE OTHERS TO FALSE ")')
+!
+ LUSERV=.TRUE. ; LUSERC=.TRUE. ; LUSERR=.TRUE.
+ LUSERI=.FALSE.; LUSERS=.FALSE.
+ LUSERG=.FALSE.; LUSERH=.FALSE.
+ END IF
+ ELSE IF (CCLOUD == 'C3R5') THEN
+ IF (.NOT. ( LUSERV .AND. LUSERC .AND. LUSERR .AND. LUSERI .AND. &
+ LUSERS .AND. LUSERG .AND. (.NOT. LUSERH) &
+ ) ) THEN
+ WRITE(UNIT=ILUOUT,FMT=9002) KMI
+ WRITE(UNIT=ILUOUT,FMT='("YOU WANT TO USE THE C3R5 MICROPHYS. SCHEME.",&
+ &" YOU WILL HAVE VAPOR, CLOUD WATER/ICE, RAIN, SNOW AND GRAUPEL ",/, &
+ &"LUSERV, LUSERC, LUSERR, LUSERI, LUSERS, LUSERG ARE SET TO TRUE")' )
+!
+ LUSERV=.TRUE. ; LUSERC=.TRUE. ; LUSERR=.TRUE.
+ LUSERI=.TRUE. ; LUSECI=.TRUE.
+ LUSERS=.TRUE. ; LUSERG=.TRUE.
+ LUSERH=.FALSE.
+ END IF
+ ELSE IF (CCLOUD == 'LIMA') THEN
+ IF (.NOT. ( LUSERV .AND. LUSERC .AND. LUSERR .AND. LUSERI .AND. &
+ LUSERS .AND. LUSERG .AND. (.NOT. LUSERH) &
+ ) ) THEN
+ WRITE(UNIT=ILUOUT,FMT=9002) KMI
+ WRITE(UNIT=ILUOUT,FMT='("YOU WANT TO USE THE LIMA MICROPHYS. SCHEME.",&
+ &" YOU WILL HAVE VAPOR, CLOUD WATER/ICE, RAIN, SNOW AND GRAUPEL ",/, &
+ &"LUSERV, LUSERC, LUSERR, LUSERI, LUSERS, LUSERG ARE SET TO TRUE")' )
+!
+ LUSERV=.TRUE. ; LUSERC=.TRUE. ; LUSERR=.TRUE.
+ LUSERI=.TRUE. ; LUSECI=.TRUE.
+ LUSERS=.TRUE. ; LUSERG=.TRUE.
+ LUSERH=.FALSE.
+ END IF
+ END IF
+!
+ IF (LSUBG_COND) THEN
+ WRITE(UNIT=ILUOUT,FMT=9003) KMI
+ WRITE(UNIT=ILUOUT,FMT=*) 'YOU WANT TO USE BOTH THE SIMPLE MIXED PHASE'
+ WRITE(UNIT=ILUOUT,FMT=*) 'MICROPHYS. SCHEME AND THE SUBGRID COND. SCHEME.'
+ WRITE(UNIT=ILUOUT,FMT=*) 'THIS IS NOT YET AVAILABLE.'
+ WRITE(UNIT=ILUOUT,FMT=*) 'SET LSUBG_COND TO FALSE OR CCLOUD TO "REVE", "KESS"'
+ !callabortstop
+ CALL PRINT_MSG(NVERB_FATAL,'GEN','READ_EXSEG_n','')
+ END IF
+!
+ IF ( CEFRADL /= 'C2R2') THEN
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(UNIT=ILUOUT,FMT=*) ' YOU DID NOT CHOOSE CEFRADL=C2R2 FOR RADIATION'
+ WRITE(UNIT=ILUOUT,FMT=*) ' IT IS ADVISED TO USE CEFRADL=C2R2 '
+ WRITE(UNIT=ILUOUT,FMT=*) ' WITH A 2-MOMENT MICROPHYSICAL SCHEME'
+ END IF
+!
+ IF ( CCLOUD == 'C3R5' .AND. CEFRADI /= 'C3R5') THEN
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(UNIT=ILUOUT,FMT=*) ' YOU DID NOT CHOOSE CEFRADI=C3R5 FOR RADIATION'
+ WRITE(UNIT=ILUOUT,FMT=*) ' IT IS ADVISED TO USE CEFRADI=C3R5 '
+ WRITE(UNIT=ILUOUT,FMT=*) ' WITH A 2-MOMENT MICROPHYSICAL SCHEME'
+ END IF
+!
+ IF ( WALPHAC /= 3.0 .OR. WNUC /= 2.0) THEN
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(UNIT=ILUOUT,FMT=*) 'IT IS ADVISED TO USE XALPHAC=3. and XNUC=2.'
+ WRITE(UNIT=ILUOUT,FMT=*) 'FOR STRATOCUMULUS WITH KHKO SCHEME. '
+ END IF
+!
+ IF ( CEFRADL /= 'C2R2') THEN
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(UNIT=ILUOUT,FMT=*) ' YOU DID NOT CHOOSE CEFRADL=C2R2 FOR RADIATION'
+ WRITE(UNIT=ILUOUT,FMT=*) ' IT IS ADVISED TO USE CEFRADL=C2R2 '
+ WRITE(UNIT=ILUOUT,FMT=*) ' WITH A 2-MOMENT MICROPHYSICAL SCHEME'
+ END IF
+!
+ CASE ( 'LIMA')
+ IF ((LACTI .AND. FINI_CCN == 'XXX')) THEN
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(UNIT=ILUOUT,FMT='("YOU WANT TO USE A 2-MOMENT MICROPHYSICAL ", &
+ &" SCHEME BUT YOU DIDNT FILL CORRECTLY NAM_PARAM_LIMA", &
+ &" YOU HAVE TO FILL FINI_CCN ")')
+ call Print_msg( NVERB_FATAL, 'GEN', 'READ_EXSEG_n', '' )
+ END IF
+!
+ IF(LACTI .AND. NMOD_CCN == 0) THEN
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(UNIT=ILUOUT,FMT='("ACTIVATION OF AEROSOL PARTICLES IS NOT ", &
+ &"POSSIBLE IF NMOD_CCN HAS VALUE ZERO. YOU HAVE TO SET AN UPPER ", &
+ &"VALUE OF NMOD_CCN IN ORDER TO USE LIMA WARM ACTIVATION SCHEME.")')
+ call Print_msg( NVERB_FATAL, 'GEN', 'READ_EXSEG_n', '' )
+ END IF
+!
+ IF(LNUCL .AND. NMOD_IFN == 0 .AND. (.NOT.LMEYERS)) THEN
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(UNIT=ILUOUT,FMT='("NUCLEATION BY DEPOSITION AND CONTACT IS NOT ", &
+ &"POSSIBLE IF NMOD_IFN HAS VALUE ZERO. YOU HAVE TO SET AN UPPER", &
+ &"VALUE OF NMOD_IFN IN ORDER TO USE LIMA COLD NUCLEATION SCHEME.")')
+ END IF
+!
+ IF (HCLOUD == 'NONE') THEN
+ CGETCLOUD = 'SKIP'
+ ELSE IF (HCLOUD == 'REVE' ) THEN
+ CGETCLOUD = 'INI1'
+ ELSE IF (HCLOUD == 'KESS' ) THEN
+ CGETCLOUD = 'INI2'
+ ELSE IF (HCLOUD == 'ICE3' ) THEN
+ CGETCLOUD = 'INI2'
+ ELSE
+ CGETCLOUD = 'READ' ! This is automatically done
+ END IF
+!
+ IF (LWARM) THEN
+ LUSERV=.TRUE. ; LUSERC=.TRUE. ; LUSERR=.TRUE.
+ LUSERI=.FALSE.; LUSERS=.FALSE. ; LUSERG=.FALSE.; LUSERH=.FALSE.
+ END IF
+!
+ IF (LCOLD) THEN
+ LUSERV=.TRUE. ; LUSERC=.TRUE. ; LUSERR=.TRUE.
+ LUSERI=.TRUE. ; LUSERS=.TRUE. ; LUSERG=.TRUE.
+ LUSERH=LHAIL
+ END IF
+!
+ IF (LSUBG_COND .AND. LCOLD) THEN
+ WRITE(UNIT=ILUOUT,FMT=9003) KMI
+ WRITE(UNIT=ILUOUT,FMT=*) 'YOU WANT TO USE BOTH THE SIMPLE MIXED PHASE'
+ WRITE(UNIT=ILUOUT,FMT=*) 'MICROPHYS. SCHEME AND THE SUBGRID COND. SCHEME.'
+ WRITE(UNIT=ILUOUT,FMT=*) 'THIS IS NOT YET AVAILABLE. SET LSUBG_COND '
+ WRITE(UNIT=ILUOUT,FMT=*) 'TO FALSE OR CCLOUD TO "REVE", "KESS" '
+ !callabortstop
+ CALL PRINT_MSG(NVERB_FATAL,'GEN','READ_EXSEG_n','')
+ END IF
+!
+ IF ( XALPHAC /= 3.0 .OR. XNUC /= 2.0) THEN
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(UNIT=ILUOUT,FMT=*) 'IT IS ADVISED TO USE XALPHAC=3. and XNUC=2.'
+ WRITE(UNIT=ILUOUT,FMT=*) 'FOR STRATOCUMULUS. '
+ END IF
+!
+ IF ( CEFRADL /= 'LIMA') THEN
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(UNIT=ILUOUT,FMT=*) ' YOU DID NOT CHOOSE CEFRADL=LIMA FOR RADIATION'
+ WRITE(UNIT=ILUOUT,FMT=*) ' IT IS ADVISED TO USE CEFRADL=LIMA '
+ WRITE(UNIT=ILUOUT,FMT=*) ' WITH A 2-MOMENT MICROPHYSICAL SCHEME "LIMA"'
+ END IF
+
+ IF (LUSECHEM ) THEN
+ WRITE(UNIT=ILUOUT,FMT=*) 'YOU WANT TO USE BOTH LIMA MICROPHYS. SCHEME AND CHEMISTRY'
+ WRITE(UNIT=ILUOUT,FMT=*) 'THIS IS NOT YET AVAILABLE. SET LUSECHEM '
+ WRITE(UNIT=ILUOUT,FMT=*) 'TO FALSE OR CCLOUD TO "ICE3" '
+ !callabortstop
+ CALL PRINT_MSG(NVERB_FATAL,'GEN','READ_EXSEG_n','')
+ END IF
+ IF (LDUST ) THEN
+ WRITE(UNIT=ILUOUT,FMT=*) 'YOU WANT TO USE BOTH LIMA MICROPHYS. SCHEME AND DUSTS '
+ WRITE(UNIT=ILUOUT,FMT=*) 'THIS IS NOT YET AVAILABLE. SET LDUST '
+ WRITE(UNIT=ILUOUT,FMT=*) 'TO FALSE OR CCLOUD TO "ICE3" '
+ !callabortstop
+ CALL PRINT_MSG(NVERB_FATAL,'GEN','READ_EXSEG_n','')
+ END IF
+ IF (LSALT ) THEN
+ WRITE(UNIT=ILUOUT,FMT=*) 'YOU WANT TO USE BOTH LIMA MICROPHYS. SCHEME AND SEA SALTS '
+ WRITE(UNIT=ILUOUT,FMT=*) 'THIS IS NOT YET AVAILABLE. SET LSALT '
+ WRITE(UNIT=ILUOUT,FMT=*) 'TO FALSE OR CCLOUD TO "ICE3" '
+ !callabortstop
+ CALL PRINT_MSG(NVERB_FATAL,'GEN','READ_EXSEG_n','')
+ END IF
+!
+END SELECT
+!
+LUSERV_G(KMI) = LUSERV
+LUSERC_G(KMI) = LUSERC
+LUSERR_G(KMI) = LUSERR
+LUSERI_G(KMI) = LUSERI
+LUSERS_G(KMI) = LUSERS
+LUSERG_G(KMI) = LUSERG
+LUSERH_G(KMI) = LUSERH
+LUSETKE(KMI) = (CTURB /= 'NONE')
+!
+!-------------------------------------------------------------------------------
+!
+!* 2.3 Chemical and NSV_* variables initializations
+!
+CALL UPDATE_NAM_PARAMN
+CALL UPDATE_NAM_DYNN
+CALL UPDATE_NAM_CONFN
+!
+IF (LORILAM .AND. .NOT. LUSECHEM) THEN
+ WRITE(UNIT=ILUOUT,FMT=9002) KMI
+ WRITE(ILUOUT,FMT=*) 'YOU CANNOT USE ORILAM AEROSOL SCHEME WITHOUT '
+ WRITE(ILUOUT,FMT=*) 'CHEMICAL GASEOUS CHEMISTRY '
+ WRITE(ILUOUT,FMT=*) 'THEREFORE LUSECHEM IS SET TO TRUE '
+ LUSECHEM=.TRUE.
+END IF
+!
+IF (LUSECHAQ.AND.(.NOT.LUSECHEM)) THEN
+ WRITE(UNIT=ILUOUT,FMT=9003) KMI
+ WRITE(UNIT=ILUOUT,FMT=*) 'YOU WANT TO USE AQUEOUS PHASE CHEMISTRY'
+ WRITE(UNIT=ILUOUT,FMT=*) 'BUT THE CHEMISTRY IS NOT ACTIVATED'
+ WRITE(UNIT=ILUOUT,FMT=*) 'SET LUSECHEM TO TRUE IF YOU WANT REALLY USE CHEMISTRY'
+ WRITE(UNIT=ILUOUT,FMT=*) 'OR SET LUSECHAQ TO FALSE IF YOU DO NOT WANT USE IT'
+ !callabortstop
+ CALL PRINT_MSG(NVERB_FATAL,'GEN','READ_EXSEG_n','')
+END IF
+IF (LUSECHAQ.AND.(.NOT.LUSERC).AND.CPROGRAM=='MESONH') THEN
+ WRITE(UNIT=ILUOUT,FMT=9003) KMI
+ WRITE(UNIT=ILUOUT,FMT=*) 'YOU WANT TO USE AQUEOUS PHASE CHEMISTRY'
+ WRITE(UNIT=ILUOUT,FMT=*) 'BUT CLOUD MICROPHYSICS IS NOT ACTIVATED'
+ WRITE(UNIT=ILUOUT,FMT=*) 'LUSECHAQ IS SET TO FALSE'
+ LUSECHAQ = .FALSE.
+END IF
+IF (LUSECHAQ.AND.CCLOUD(1:3) == 'ICE'.AND. .NOT. LUSECHIC) THEN
+ WRITE(UNIT=ILUOUT,FMT=9002) KMI
+ WRITE(UNIT=ILUOUT,FMT=*) 'YOU WANT TO USE AQUEOUS PHASE CHEMISTRY'
+ WRITE(UNIT=ILUOUT,FMT=*) 'WITH MIXED PHASE CLOUD MICROPHYSICS'
+ WRITE(UNIT=ILUOUT,FMT=*) 'SET LUSECHIC TO TRUE IF YOU WANT TO ACTIVATE'
+ WRITE(UNIT=ILUOUT,FMT=*) 'ICE PHASE CHEMICAL SPECIES'
+ IF (LCH_RET_ICE) THEN
+ WRITE(UNIT=ILUOUT,FMT=*) 'LCH_RET_ICE TRUE MEANS ALL SOLUBLE'
+ WRITE(UNIT=ILUOUT,FMT=*) 'GASES ARE RETAINED IN ICE PHASE'
+ WRITE(UNIT=ILUOUT,FMT=*) 'WHEN SUPERCOOLED WATER FREEZES'
+ ELSE
+ WRITE(UNIT=ILUOUT,FMT=*) 'LCH_RET_ICE FALSE MEANS ALL SOLUBLE'
+ WRITE(UNIT=ILUOUT,FMT=*) 'GASES GO BACK TO THE GAS PHASE WHEN'
+ WRITE(UNIT=ILUOUT,FMT=*) 'SUPERCOOLED WATER FREEZES'
+ ENDIF
+ENDIF
+IF (LUSECHIC.AND. .NOT. CCLOUD(1:3) == 'ICE'.AND.CPROGRAM=='MESONH') THEN
+ WRITE(UNIT=ILUOUT,FMT=9003) KMI
+ WRITE(UNIT=ILUOUT,FMT=*) 'YOU WANT TO USE ICE PHASE CHEMISTRY'
+ WRITE(UNIT=ILUOUT,FMT=*) 'BUT MIXED PHASE CLOUD MICROPHYSICS IS NOT ACTIVATED'
+ WRITE(UNIT=ILUOUT,FMT=*) 'LUSECHIC IS SET TO FALSE'
+ LUSECHIC= .FALSE.
+ENDIF
+IF (LCH_PH.AND. (.NOT. LUSECHAQ)) THEN
+ WRITE(UNIT=ILUOUT,FMT=9003) KMI
+ WRITE(UNIT=ILUOUT,FMT=*) 'DIAGNOSTIC PH COMPUTATION IS ACTIVATED'
+ WRITE(UNIT=ILUOUT,FMT=*) 'BUT AQUEOUS PHASE CHEMISTRY IS NOT ACTIVATED'
+ WRITE(UNIT=ILUOUT,FMT=*) 'SET LUSECHAQ TO TRUE IF YOU WANT TO ACTIVATE IT'
+ WRITE(UNIT=ILUOUT,FMT=*) 'LCH_PH IS SET TO FALSE'
+ LCH_PH= .FALSE.
+ENDIF
+IF (LUSECHIC.AND.(.NOT.LUSECHAQ)) THEN
+ WRITE(UNIT=ILUOUT,FMT=9003) KMI
+ WRITE(UNIT=ILUOUT,FMT=*) 'YOU WANT TO USE ICE PHASE CHEMISTRY'
+ WRITE(UNIT=ILUOUT,FMT=*) 'BUT THE AQUEOUS PHASE CHEMISTRY IS NOT ACTIVATED'
+ WRITE(UNIT=ILUOUT,FMT=*) 'SET LUSECHAQ TO TRUE IF YOU WANT REALLY USE CLOUD CHEMISTRY'
+ WRITE(UNIT=ILUOUT,FMT=*) 'OR SET LUSECHIC TO FALSE IF YOU DO NOT WANT USE IT'
+!callabortstop
+ CALL PRINT_MSG(NVERB_FATAL,'GEN','READ_EXSEG_n','')
+END IF
+IF ((LUSECHIC).AND.(LCH_RET_ICE)) THEN
+ WRITE(UNIT=ILUOUT,FMT=9003) KMI
+ WRITE(UNIT=ILUOUT,FMT=*) 'YOU WANT TO USE RETENTION OF SOLUBLE GASES IN ICE'
+ WRITE(UNIT=ILUOUT,FMT=*) 'BUT THE ICE PHASE CHEMISTRY IS ACTIVATED'
+ WRITE(UNIT=ILUOUT,FMT=*) 'FLAG LCH_RET_ICE IS ONLY USES WHEN LUSECHIC IS SET'
+ WRITE(UNIT=ILUOUT,FMT=*) 'TO FALSE IE NO CHEMICAL SPECIES IN ICE'
+ENDIF
+!
+IF (LUSECHEM) THEN
+ CALL CH_INIT_SCHEME_n(KMI,LUSECHAQ,LUSECHIC,LCH_PH,ILUOUT,NVERB)
+ IF (LORILAM) CALL CH_AER_INIT_SOA(ILUOUT, NVERB)
+END IF
+!
+
+CALL UPDATE_NAM_CH_MNHCN
+CALL INI_NSV(KMI)
+!
+! From this point, all NSV* variables contain valid values for model KMI
+!
+DO JSV = 1,NSV
+ LUSESV(JSV,KMI) = .TRUE.
+END DO
+!
+IF ( CAOP=='EXPL' .AND. .NOT.LDUST .AND. .NOT.LORILAM &
+ .AND. .NOT.LSALT .AND. .NOT.(CCLOUD=='LIMA') ) THEN
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(UNIT=ILUOUT,FMT=*) ' YOU WANT TO USE EXPLICIT AEROSOL OPTICAL '
+ WRITE(UNIT=ILUOUT,FMT=*) 'PROPERTIES BUT YOU DONT HAVE DUST OR '
+ WRITE(UNIT=ILUOUT,FMT=*) 'AEROSOL OR SALT THEREFORE CAOP=CLIM'
+ CAOP='CLIM'
+END IF
+!-------------------------------------------------------------------------------
+!
+!* 3. CHECK COHERENCE BETWEEN EXSEG VARIABLES AND FMFILE ATTRIBUTES
+! -------------------------------------------------------------
+!
+!
+!* 3.1 Turbulence variable
+!
+IF ((CTURB /= 'NONE').AND.(HTURB == 'NONE')) THEN
+ CGETTKET ='INIT'
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(UNIT=ILUOUT,FMT=*)'YOU WANT TO USE TURBULENCE KINETIC ENERGY TKE'
+ WRITE(UNIT=ILUOUT,FMT=*)'WHEREAS IT IS NOT IN INITIAL FMFILE'
+ WRITE(UNIT=ILUOUT,FMT=*)'TKE WILL BE INITIALIZED TO ZERO'
+ELSE
+ IF (CTURB /= 'NONE') THEN
+ CGETTKET ='READ'
+ IF ((CCONF=='START') .AND. CPROGRAM /= 'DIAG') CGETTKET='INIT'
+ ELSE
+ CGETTKET ='SKIP'
+ END IF
+END IF
+!
+!
+IF ((CTOM == 'TM06').AND.(HTOM /= 'TM06')) THEN
+ CGETBL_DEPTH ='INIT'
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(UNIT=ILUOUT,FMT=*)'YOU WANT TO USE BL DEPTH FOR THIRD ORDER MOMENTS'
+ WRITE(UNIT=ILUOUT,FMT=*)'WHEREAS IT IS NOT IN INITIAL FMFILE'
+ WRITE(UNIT=ILUOUT,FMT=*)'IT WILL BE INITIALIZED TO ZERO'
+ELSE
+ IF (CTOM == 'TM06') THEN
+ CGETBL_DEPTH ='READ'
+ ELSE
+ CGETBL_DEPTH ='SKIP'
+ END IF
+END IF
+!
+IF (LRMC01 .AND. .NOT. ORMC01) THEN
+ CGETSBL_DEPTH ='INIT'
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(UNIT=ILUOUT,FMT=*)'YOU WANT TO USE SBL DEPTH FOR RMC01'
+ WRITE(UNIT=ILUOUT,FMT=*)'WHEREAS IT IS NOT IN INITIAL FMFILE'
+ WRITE(UNIT=ILUOUT,FMT=*)'IT WILL BE INITIALIZED TO ZERO'
+ELSE
+ IF (LRMC01) THEN
+ CGETSBL_DEPTH ='READ'
+ ELSE
+ CGETSBL_DEPTH ='SKIP'
+ END IF
+END IF
+!
+!
+!* 3.2 Moist variables
+!
+IF (LUSERV.AND. (.NOT.OUSERV)) THEN
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(UNIT=ILUOUT,FMT='("YOU WANT TO USE VAPOR VARIABLE Rv WHEREAS IT ", &
+ & "IS NOT IN INITIAL FMFILE",/, &
+ & "Rv WILL BE INITIALIZED TO ZERO")')
+ CGETRVT='INIT'
+ELSE
+ IF (LUSERV) THEN
+ CGETRVT='READ'
+ ELSE
+ CGETRVT='SKIP'
+ END IF
+END IF
+!
+IF (LUSERC.AND. (.NOT.OUSERC)) THEN
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(UNIT=ILUOUT,FMT='("YOU WANT TO USE CLOUD VARIABLE Rc WHEREAS IT ", &
+ & " IS NOT IN INITIAL FMFILE",/, &
+ & "Rc WILL BE INITIALIZED TO ZERO")')
+ CGETRCT='INIT'
+ELSE
+ IF (LUSERC) THEN
+ CGETRCT='READ'
+! IF(CCONF=='START') CGETRCT='INIT'
+ ELSE
+ CGETRCT='SKIP'
+ END IF
+END IF
+!
+IF (LUSERR.AND. (.NOT.OUSERR)) THEN
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(UNIT=ILUOUT,FMT='("YOU WANT TO USE RAIN VARIABLE Rr WHEREAS IT ", &
+ & "IS NOT IN INITIAL FMFILE",/, &
+ & " Rr WILL BE INITIALIZED TO ZERO")')
+
+ CGETRRT='INIT'
+ELSE
+ IF (LUSERR) THEN
+ CGETRRT='READ'
+! IF( (CCONF=='START').AND. CPROGRAM /= 'DIAG') CGETRRT='INIT'
+ ELSE
+ CGETRRT='SKIP'
+ END IF
+END IF
+!
+IF (LUSERI.AND. (.NOT.OUSERI)) THEN
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(UNIT=ILUOUT,FMT='("YOU WANT TO USE ICE VARIABLE Ri WHEREAS IT ", &
+ & "IS NOT IN INITIAL FMFILE",/, &
+ & " Ri WILL BE INITIALIZED TO ZERO")')
+ CGETRIT='INIT'
+ELSE
+ IF (LUSERI) THEN
+ CGETRIT='READ'
+! IF(CCONF=='START') CGETRIT='INIT'
+ ELSE
+ CGETRIT='SKIP'
+ END IF
+END IF
+!
+IF (LUSECI.AND. (.NOT.OUSECI)) THEN
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(UNIT=ILUOUT,FMT='("YOU WANT TO USE ICE CONC. VARIABLE Ci WHEREAS IT ",&
+ & "IS NOT IN INITIAL FMFILE",/, &
+ & " Ci WILL BE INITIALIZED TO ZERO")')
+ CGETCIT='INIT'
+ELSE
+ IF (LUSECI) THEN
+ CGETCIT='READ'
+ ELSE
+ CGETCIT='SKIP'
+ END IF
+END IF
+!
+IF (LUSERS.AND. (.NOT.OUSERS)) THEN
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(UNIT=ILUOUT,FMT='("YOU WANT TO USE SNOW VARIABLE Rs WHEREAS IT ",&
+ & "IS NOT IN INITIAL FMFILE",/, &
+ & " Rs WILL BE INITIALIZED TO ZERO")')
+ CGETRST='INIT'
+ELSE
+ IF (LUSERS) THEN
+ CGETRST='READ'
+! IF ( (CCONF=='START').AND. CPROGRAM /= 'DIAG') CGETRST='INIT'
+ ELSE
+ CGETRST='SKIP'
+ END IF
+END IF
+!
+IF (LUSERG.AND. (.NOT.OUSERG)) THEN
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(UNIT=ILUOUT,FMT='("YOU WANT TO USE GRAUPEL VARIABLE Rg WHEREAS ",&
+ & " IT IS NOTIN INITIAL FMFILE",/, &
+ & "Rg WILL BE INITIALIZED TO ZERO")')
+ CGETRGT='INIT'
+ELSE
+ IF (LUSERG) THEN
+ CGETRGT='READ'
+! IF ( (CCONF=='START') .AND. CPROGRAM /= 'DIAG') CGETRGT='INIT'
+ ELSE
+ CGETRGT='SKIP'
+ END IF
+END IF
+!
+IF (LUSERH.AND. (.NOT.OUSERH)) THEN
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(UNIT=ILUOUT,FMT='("YOU WANT TO USE HAIL VARIABLE Rh WHEREAS",&
+ & "IT IS NOT IN INITIAL FMFILE",/, &
+ & " Rh WILL BE INITIALIZED TO ZERO")')
+ CGETRHT='INIT'
+ELSE
+ IF (LUSERH) THEN
+ CGETRHT='READ'
+! IF ( (CCONF=='START') .AND. CPROGRAM /= 'DIAG') CGETRHT='INIT'
+ ELSE
+ CGETRHT='SKIP'
+ END IF
+END IF
+!
+IF (LUSERC.AND. (.NOT.OUSERC)) THEN
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(UNIT=ILUOUT,FMT=*) 'THE CLOUD FRACTION WILL BE INITIALIZED ACCORDING'
+ WRITE(UNIT=ILUOUT,FMT=*) 'TO CLOUD MIXING RATIO VALUE OR SET TO 0'
+ CGETCLDFR = 'INIT'
+ELSE
+ IF ( LUSERC ) THEN
+ CGETCLDFR = 'READ'
+ IF ( (CCONF=='START') .AND. CPROGRAM /= 'DIAG') CGETCLDFR='INIT'
+ ELSE
+ CGETCLDFR = 'SKIP'
+ END IF
+END IF
+!
+IF(CTURBLEN=='RM17') THEN
+ XCEDIS=0.34
+ELSE
+ XCEDIS=0.84
+END IF
+!
+!* 3.3 Moist turbulence
+!
+IF ( LUSERC .AND. CTURB /= 'NONE' ) THEN
+ IF ( .NOT. (OUSERC .AND. HTURB /= 'NONE') ) THEN
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(UNIT=ILUOUT,FMT='("YOU WANT TO USE MOIST TURBULENCE WHEREAS IT ",/, &
+ & " WAS NOT THE CASE FOR THE INITIAL FMFILE GENERATION",/, &
+ & "SRC AND SIGS ARE INITIALIZED TO 0")')
+ CGETSRCT ='INIT'
+ CGETSIGS ='INIT'
+ ELSE
+ CGETSRCT ='READ'
+ IF ( (CCONF=='START') .AND. CPROGRAM /= 'DIAG') CGETSRCT ='INIT'
+ CGETSIGS ='READ'
+ END IF
+ELSE
+ CGETSRCT ='SKIP'
+ CGETSIGS ='SKIP'
+END IF
+!
+IF(NMODEL_CLOUD==KMI .AND. CTURBLEN_CLOUD/='NONE') THEN
+ IF (CTURB=='NONE' .OR. .NOT.LUSERC) THEN
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(UNIT=ILUOUT,FMT='("YOU WANT TO COMPUTE A MIXING LENGTH FOR CLOUD=", &
+ & A4,/, &
+ & ", WHEREAS YOU DO NOT SPECIFY A TURBULENCE SCHEME OR ", &
+ & "USE OF RC,",/," CTURBLEN_CLOUD IS SET TO NONE")') &
+ CTURBLEN_CLOUD
+ CTURBLEN_CLOUD='NONE'
+ END IF
+ IF( XCEI_MIN > XCEI_MAX ) THEN
+ WRITE(UNIT=ILUOUT,FMT=9003) KMI
+ WRITE(UNIT=ILUOUT,FMT='("PROBLEM OF CEI LIMITS FOR CLOUD MIXING ",/, &
+ & "LENGTH COMPUTATION: XCEI_MIN=",E9.3,", XCEI_MAX=",E9.3)')&
+ XCEI_MIN,XCEI_MAX
+ !callabortstop
+ CALL PRINT_MSG(NVERB_FATAL,'GEN','READ_EXSEG_n','')
+ END IF
+END IF
+!
+IF ( LSIGMAS ) THEN
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(UNIT=ILUOUT,FMT='("YOU WANT TO USE SIGMA_S FROM TURBULENCE SCHEME",/, &
+ & " IN ICE SUBGRID CONDENSATION, SO YOUR SIGMA_S"/, &
+ & " MIGHT BE SMALL ABOVE PBL DEPENDING ON LENGTH SCALE")')
+END IF
+!
+IF (LSUBG_COND .AND. CTURB=='NONE' ) THEN
+ WRITE(UNIT=ILUOUT,FMT=9002) KMI
+ WRITE(UNIT=ILUOUT,FMT=*) 'YOU WANT TO USE SUBGRID CONDENSATION'
+ WRITE(UNIT=ILUOUT,FMT=*) ' WITHOUT TURBULENCE '
+ WRITE(UNIT=ILUOUT,FMT=*) 'THIS IS NOT ALLOWED: LSUBG_COND is SET to FALSE'
+ LSUBG_COND=.FALSE.
+END IF
+!
+IF (L1D .AND. CTURB/='NONE' .AND. CTURBDIM == '3DIM') THEN
+ WRITE(UNIT=ILUOUT,FMT=9002) KMI
+ WRITE(UNIT=ILUOUT,FMT=*) 'YOU WANT TO USE 3D TURBULENCE IN 1D CONFIGURATION '
+ WRITE(UNIT=ILUOUT,FMT=*) 'THIS IS NOT POSSIBLE: CTURBDIM IS SET TO 1DIM'
+ CTURBDIM = '1DIM'
+END IF
+!
+!* 3.4 Additional scalar variables
+!
+IF (NSV_USER == KSV_USER) THEN
+ DO JS = 1,KSV_USER ! to read all the variables in initial file
+ CGETSVT(JS)='READ' ! and to initialize them
+! IF(CCONF=='START')CGETSVT(JS)='INIT' ! with these values
+ END DO
+ELSEIF (NSV_USER > KSV_USER) THEN
+ IF (KSV_USER == 0) THEN
+ CGETSVT(1:NSV_USER)='INIT'
+ ELSE
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(UNIT=ILUOUT,FMT='("YOU WANT TO USE MORE ADDITIONAL SCALAR " ,&
+ &" VARIABLES THAN THERE ARE IN INITIAL FMFILE",/, &
+ & "THE SUPPLEMENTARY VARIABLES HAVE BEEN INITIALIZED TO ZERO ")')
+ DO JS = 1,KSV_USER ! to read all the variables in initial file
+ CGETSVT(JS)='READ' ! and to initialize them
+! IF(CCONF=='START')CGETSVT(JS)='INIT' ! with these values
+ END DO
+ DO JS = KSV_USER+1, NSV_USER ! to initialize to zero supplementary
+ CGETSVT(JS)='INIT' ! initial file)
+ END DO
+ END IF
+ELSE
+ WRITE(UNIT=ILUOUT,FMT=9000) KMI
+ WRITE(UNIT=ILUOUT,FMT='("YOU WANT TO USE LESS ADDITIONAL SCALAR " ,&
+ &" VARIABLES THAN THERE ARE IN INITIAL FMFILE")')
+ DO JS = 1,NSV_USER ! to read the first NSV_USER variables in initial file
+ CGETSVT(JS)='READ' ! and to initialize with these values
+! IF(CCONF=='START') CGETSVT(JS)='INIT'
+ END DO
+ DO JS = NSV_USER + 1, KSV_USER ! to skip the last (KSV_USER-NSV_USER) variables
+ CGETSVT(JS)='SKIP'
+ END DO
+END IF
+!
+! C2R2 and KHKO SV case
+!
+IF (CCLOUD == 'C2R2' .OR. CCLOUD == 'C3R5' .OR. CCLOUD == 'KHKO') THEN
+ IF (HCLOUD == 'C2R2' .OR. HCLOUD == 'C3R5' .OR. HCLOUD == 'KHKO') THEN
+ CGETSVT(NSV_C2R2BEG:NSV_C2R2END)='READ'
+! IF(CCONF=='START') CGETSVT(NSV_C2R2BEG:NSV_C2R2END)='INIT'
+ ELSE
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(UNIT=ILUOUT,FMT='("THERE IS NO SCALAR VARIABLES FOR C2R2 &
+ & (or KHKO) SCHEME IN INITIAL FMFILE",/,&
+ & "THE C2R2 (or KHKO) VARIABLES HAVE BEEN INITIALIZED TO ZERO ")')
+ CGETSVT(NSV_C2R2BEG:NSV_C2R2END)='INIT'
+ END IF
+END IF
+!
+! C3R5 SV case
+!
+IF (CCLOUD == 'C3R5') THEN
+ IF (HCLOUD == 'C3R5') THEN
+ CGETSVT(NSV_C1R3BEG:NSV_C1R3END)='READ'
+! IF(CCONF=='START') CGETSVT(NSV_C1R3BEG:NSV_C1R3END)='INIT'
+ ELSE
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(UNIT=ILUOUT,FMT='("THERE IS NO SCALAR VARIABLES FOR C3R5 &
+ &SCHEME IN INITIAL FMFILE",/,&
+ & "THE C1R3 VARIABLES HAVE BEEN INITIALIZED TO ZERO ")')
+ CGETSVT(NSV_C1R3BEG:NSV_C1R3END)='INIT'
+ END IF
+END IF
+!
+! LIMA SV case
+!
+IF (CCLOUD == 'LIMA') THEN
+ IF (HCLOUD == 'LIMA') THEN
+ CGETSVT(NSV_LIMA_BEG:NSV_LIMA_END)='READ'
+!!JPP IF(HSTORAGE_TYPE=='TT') CGETSVT(NSV_LIMA_BEG:NSV_LIMA_END)='INIT'
+ ELSE
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(UNIT=ILUOUT,FMT='("THERE IS NO SCALAR VARIABLES FOR LIMA &
+ & SCHEME IN INITIAL FMFILE",/,&
+ & "THE LIMA VARIABLES HAVE BEEN INITIALIZED TO ZERO ")')
+ CGETSVT(NSV_LIMA_BEG:NSV_LIMA_END)='INIT'
+ END IF
+END IF
+!
+! Electrical SV case
+!
+IF (CELEC /= 'NONE') THEN
+ IF (HELEC /= 'NONE') THEN
+ CGETSVT(NSV_ELECBEG:NSV_ELECEND)='READ'
+! IF(CCONF=='START') CGETSVT(NSV_ELECBEG:NSV_ELECEND)='INIT'
+ ELSE
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(UNIT=ILUOUT,FMT='("THERE IS NO SCALAR VARIABLES FOR ELECTRICAL &
+ &SCHEME IN INITIAL FMFILE",/,&
+ & "THE ELECTRICAL VARIABLES HAVE BEEN INITIALIZED TO ZERO ")')
+ CGETSVT(NSV_ELECBEG:NSV_ELECEND)='INIT'
+ END IF
+END IF
+!
+! (explicit) LINOx SV case
+!
+IF (CELEC /= 'NONE' .AND. LLNOX_EXPLICIT) THEN
+ IF (HELEC /= 'NONE' .AND. OLNOX_EXPLICIT) THEN
+ CGETSVT(NSV_LNOXBEG:NSV_LNOXEND)='READ'
+ ELSE
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(UNIT=ILUOUT,FMT='("THERE IS NO SCALAR VARIABLES FOR LINOX &
+ & IN INITIAL FMFILE",/,&
+ & "THE LINOX VARIABLES HAVE BEEN INITIALIZED TO ZERO ")')
+ CGETSVT(NSV_LNOXBEG:NSV_LNOXEND)='INIT'
+ END IF
+END IF
+!
+! Chemical SV case (excluding aqueous chemical species)
+!
+IF (LUSECHEM) THEN
+ IF (OUSECHEM) THEN
+ CGETSVT(NSV_CHGSBEG:NSV_CHGSEND)='READ'
+ IF(CCONF=='START' .AND. LCH_INIT_FIELD ) CGETSVT(NSV_CHGSBEG:NSV_CHGSEND)='INIT'
+ ELSE
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(UNIT=ILUOUT,FMT='("THERE IS NO SCALAR VARIABLES FOR CHEMICAL &
+ &SCHEME IN INITIAL FMFILE",/,&
+ & "THE CHEMICAL VARIABLES HAVE BEEN INITIALIZED TO ZERO ")')
+ CGETSVT(NSV_CHGSBEG:NSV_CHGSEND)='INIT'
+ END IF
+END IF
+! add aqueous chemical species
+IF (LUSECHAQ) THEN
+ IF (OUSECHAQ) THEN
+ CGETSVT(NSV_CHACBEG:NSV_CHACEND)='READ'
+! IF(CCONF=='START') CGETSVT(NSV_CHACBEG:NSV_CHACEND)='INIT'
+ ELSE
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(UNIT=ILUOUT,FMT='("THERE IS NO SCALAR VARIABLES FOR CHEMICAL &
+ &SCHEME IN AQUEOUS PHASE IN INITIAL FMFILE",/,&
+ & "THE AQUEOUS PHASE CHEMICAL VARIABLES HAVE BEEN INITIALIZED TO ZERO ")')
+ CGETSVT(NSV_CHACBEG:NSV_CHACEND)='INIT'
+ END IF
+END IF
+! add ice phase chemical species
+IF (LUSECHIC) THEN
+ IF (OUSECHIC) THEN
+ CGETSVT(NSV_CHICBEG:NSV_CHICEND)='READ'
+! IF(CCONF=='START') CGETSVT(NSV_CHICBEG:NSV_CHICEND)='INIT'
+ ELSE
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(UNIT=ILUOUT,FMT='("THERE IS NO SCALAR VARIABLES FOR CHEMICAL &
+ &SPECIES IN ICE PHASE IN INITIAL FMFILE",/,&
+ & "THE ICE PHASE CHEMICAL VARIABLES HAVE BEEN INITIALIZED TO ZERO ")')
+ CGETSVT(NSV_CHICBEG:NSV_CHICEND)='INIT'
+ END IF
+END IF
+! pH values = diagnostics
+IF (LCH_PH .AND. .NOT. OCH_PH) THEN
+ CGETPHC ='INIT' !will be initialized to XCH_PHINIT
+ IF (LUSERR) THEN
+ CGETPHR = 'INIT' !idem
+ ELSE
+ CGETPHR = 'SKIP'
+ ENDIF
+ELSE
+ IF (LCH_PH) THEN
+ CGETPHC ='READ'
+ IF (LUSERR) THEN
+ CGETPHR = 'READ'
+ ELSE
+ CGETPHR = 'SKIP'
+ ENDIF
+ ELSE
+ CGETPHC ='SKIP'
+ CGETPHR ='SKIP'
+ END IF
+END IF
+!
+! Dust case
+!
+IF (LDUST) THEN
+ IF (ODUST) THEN
+ CGETSVT(NSV_DSTBEG:NSV_DSTEND)='READ'
+! IF(CCONF=='START') CGETSVT(NSV_DSTBEG:NSV_DSTEND)='INIT'
+ ELSE
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(UNIT=ILUOUT,FMT='("THERE IS NO SCALAR VARIABLES FOR DUST &
+ &SCHEME IN INITIAL FMFILE",/,&
+ & "THE DUST VARIABLES HAVE BEEN INITIALIZED TO ZERO ")')
+ CGETSVT(NSV_DSTBEG:NSV_DSTEND)='INIT'
+ END IF
+ IF (LDEPOS_DST(KMI)) THEN
+
+ IF((CCLOUD /= 'ICE3').AND.(CCLOUD /= 'ICE4').AND.(CCLOUD /= 'KESS')&
+ .AND.(CCLOUD /= 'KHKO').AND.(CCLOUD /= 'C2R2').AND. &
+ (CPROGRAM/='SPAWN').AND.(CPROGRAM/='REAL')) THEN
+ WRITE(UNIT=ILUOUT,FMT=9003) KMI
+ WRITE(UNIT=ILUOUT,FMT='("ERROR: WET DEPOSITION OF DUST IS ONLY CODED FOR THE",/,&
+ & "MICROPHYSICAL SCHEME as ICE3, ICE4, KESS, KHKO and C2R2")')
+ !callabortstop
+ CALL PRINT_MSG(NVERB_FATAL,'GEN','READ_EXSEG_n','')
+ END IF
+
+ IF (ODEPOS_DST(KMI) ) THEN
+ CGETSVT(NSV_DSTDEPBEG:NSV_DSTDEPEND)='READ'
+! IF(CCONF=='START') CGETSVT(NSV_DSTDEPBEG:NSV_DSTDEPEND)='INIT'
+ ELSE
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(UNIT=ILUOUT,FMT='("THERE IS NO SCALAR VARIABLES FOR RAIN and CLOUD DUST &
+ & SCHEME IN INITIAL FMFILE",/,&
+ & "THE MOIST DUST VARIABLES HAVE BEEN INITIALIZED TO ZERO ")')
+ CGETSVT(NSV_DSTDEPBEG:NSV_DSTDEPEND)='INIT'
+ END IF
+ END IF
+
+ IF(NMODE_DST.GT.3 .OR. NMODE_DST.LT.1) THEN
+ WRITE(UNIT=ILUOUT,FMT=9003) KMI
+ WRITE(UNIT=ILUOUT,FMT='("DUST MODES MUST BE BETWEEN 1 and 3 ")')
+ !callabortstop
+ CALL PRINT_MSG(NVERB_FATAL,'GEN','READ_EXSEG_n','')
+ END IF
+ IF(.NOT.ALLOCATED(CDUSTNAMES)) THEN
+ IMOMENTS = (NSV_DSTEND - NSV_DSTBEG +1 )/NMODE_DST
+ ALLOCATE(CDUSTNAMES(IMOMENTS*NMODE_DST))
+ !Loop on all dust modes
+ IF (IMOMENTS == 1) THEN
+ DO JMODE=1,NMODE_DST
+ IMODEIDX=JPDUSTORDER(JMODE)
+ JSV_NAME = (IMODEIDX - 1)*3 + 2
+ CDUSTNAMES(JMODE) = YPDUST_INI(JSV_NAME)
+ END DO
+ ELSE
+ DO JMODE=1,NMODE_DST
+ !Find which mode we are dealing with
+ IMODEIDX=JPDUSTORDER(JMODE)
+ DO JMOM=1,IMOMENTS
+ !Find which number this is of the list of scalars
+ JSV = (JMODE-1)*IMOMENTS + JMOM
+ !Find what name this corresponds to, always 3 moments assumed in YPDUST_INI
+ JSV_NAME = (IMODEIDX - 1)*3 + JMOM
+ !Get the right CDUSTNAMES which should follow the list of scalars transported in XSVM/XSVT
+ CDUSTNAMES(JSV) = YPDUST_INI(JSV_NAME)
+ ENDDO ! Loop on moments
+ ENDDO ! Loop on dust modes
+ END IF
+ END IF
+ ! Initialization of deposition scheme
+ IF (LDEPOS_DST(KMI)) THEN
+ IF(.NOT.ALLOCATED(CDEDSTNAMES)) THEN
+ ALLOCATE(CDEDSTNAMES(NMODE_DST*2))
+ DO JMODE=1,NMODE_DST
+ IMODEIDX=JPDUSTORDER(JMODE)
+ CDEDSTNAMES(JMODE) = YPDEDST_INI(IMODEIDX)
+ CDEDSTNAMES(NMODE_DST+JMODE) = YPDEDST_INI(NMODE_DST+IMODEIDX)
+ ENDDO
+ ENDIF
+ ENDIF
+
+END IF
+!
+! Sea Salt case
+!
+IF (LSALT) THEN
+ IF (OSALT) THEN
+ CGETSVT(NSV_SLTBEG:NSV_SLTEND)='READ'
+ CGETZWS='READ'
+! IF(CCONF=='START') CGETSVT(NSV_SLTBEG:NSV_SLTEND)='INIT'
+ ELSE
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(UNIT=ILUOUT,FMT='("THERE IS NO SCALAR VARIABLES FOR SALT &
+ &SCHEME IN INITIAL FMFILE",/,&
+ & "THE SALT VARIABLES HAVE BEEN INITIALIZED TO ZERO ")')
+ CGETSVT(NSV_SLTBEG:NSV_SLTEND)='INIT'
+ CGETZWS='INIT'
+ END IF
+ IF (LDEPOS_SLT(KMI)) THEN
+
+ IF((CCLOUD /= 'ICE3').AND.(CCLOUD /= 'ICE4').AND.(CCLOUD /= 'KESS')&
+ .AND.(CCLOUD /= 'KHKO').AND.(CCLOUD /= 'C2R2').AND. &
+ (CPROGRAM/='SPAWN').AND.(CPROGRAM/='REAL')) THEN
+ WRITE(UNIT=ILUOUT,FMT=9003) KMI
+ WRITE(UNIT=ILUOUT,FMT='("ERROR: WET DEPOSITION OF SEA SALT AEROSOLS IS ONLY CODED FOR THE",/,&
+ & "MICROPHYSICAL SCHEME as ICE3, ICE4, KESS, KHKO and C2R2")')
+ !callabortstop
+ CALL PRINT_MSG(NVERB_FATAL,'GEN','READ_EXSEG_n','')
+ END IF
+
+ IF (ODEPOS_SLT(KMI) ) THEN
+ CGETSVT(NSV_SLTDEPBEG:NSV_SLTDEPEND)='READ'
+! IF(CCONF=='START') CGETSVT(NSV_SLTDEPBEG:NSV_SLTDEPEND)='INIT'
+ ELSE
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(UNIT=ILUOUT,FMT='("THERE IS NO SCALAR VARIABLES FOR RAIN and CLOUD SEA SALT &
+ & SCHEME IN INITIAL FMFILE",/,&
+ & "THE MOIST SEA SALT VARIABLES HAVE BEEN INITIALIZED TO ZERO ")')
+ CGETSVT(NSV_SLTDEPBEG:NSV_SLTDEPEND)='INIT'
+ END IF
+ END IF
+ IF(NMODE_SLT.GT.5 .OR. NMODE_SLT.LT.1) THEN
+ WRITE(UNIT=ILUOUT,FMT=9003) KMI
+ WRITE(UNIT=ILUOUT,FMT='("SALT MODES MUST BE BETWEEN 1 and 5 ")')
+ !callabortstop
+ CALL PRINT_MSG(NVERB_FATAL,'GEN','READ_EXSEG_n','')
+ END IF
+ IF(.NOT.ALLOCATED(CSALTNAMES)) THEN
+ IMOMENTS = (NSV_SLTEND - NSV_SLTBEG +1 )/NMODE_SLT
+ ALLOCATE(CSALTNAMES(IMOMENTS*NMODE_SLT))
+ !Loop on all dust modes
+ IF (IMOMENTS == 1) THEN
+ DO JMODE=1,NMODE_SLT
+ IMODEIDX=JPSALTORDER(JMODE)
+ JSV_NAME = (IMODEIDX - 1)*3 + 2
+ CSALTNAMES(JMODE) = YPSALT_INI(JSV_NAME)
+ END DO
+ ELSE
+ DO JMODE=1,NMODE_SLT
+ !Find which mode we are dealing with
+ IMODEIDX=JPSALTORDER(JMODE)
+ DO JMOM=1,IMOMENTS
+ !Find which number this is of the list of scalars
+ JSV = (JMODE-1)*IMOMENTS + JMOM
+ !Find what name this corresponds to, always 3 moments assumed in YPSALT_INI
+ JSV_NAME = (IMODEIDX - 1)*3 + JMOM
+ !Get the right CSALTNAMES which should follow the list of scalars transported in XSVM/XSVT
+ CSALTNAMES(JSV) = YPSALT_INI(JSV_NAME)
+ ENDDO ! Loop on moments
+ ENDDO ! Loop on dust modes
+ END IF
+ END IF
+ ! Initialization of deposition scheme
+ IF (LDEPOS_SLT(KMI)) THEN
+ IF(.NOT.ALLOCATED(CDESLTNAMES)) THEN
+ ALLOCATE(CDESLTNAMES(NMODE_SLT*2))
+ DO JMODE=1,NMODE_SLT
+ IMODEIDX=JPSALTORDER(JMODE)
+ CDESLTNAMES(JMODE) = YPDESLT_INI(IMODEIDX)
+ CDESLTNAMES(NMODE_SLT+JMODE) = YPDESLT_INI(NMODE_SLT+IMODEIDX)
+ ENDDO
+ ENDIF
+ ENDIF
+END IF
+!
+! Orilam SV case
+!
+IF (LORILAM) THEN
+ IF (OORILAM) THEN
+ CGETSVT(NSV_AERBEG:NSV_AEREND)='READ'
+! IF(CCONF=='START') CGETSVT(NSV_AERBEG:NSV_AEREND)='INIT'
+ ELSE
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(UNIT=ILUOUT,FMT='("THERE IS NO SCALAR VARIABLES FOR AEROSOL &
+ &SCHEME IN INITIAL FMFILE",/,&
+ & "THE AEROSOLS VARIABLES HAVE BEEN INITIALIZED TO ZERO ")')
+ CGETSVT(NSV_AERBEG:NSV_AEREND)='INIT'
+ END IF
+ IF (LDEPOS_AER(KMI)) THEN
+
+ IF((CCLOUD /= 'ICE3').AND.(CCLOUD /= 'ICE4').AND.(CCLOUD /= 'KESS')&
+ .AND.(CCLOUD /= 'KHKO').AND.(CCLOUD /= 'C2R2').AND. &
+ (CPROGRAM/='SPAWN').AND.(CPROGRAM/='REAL')) THEN
+ WRITE(UNIT=ILUOUT,FMT=9003) KMI
+ WRITE(UNIT=ILUOUT,FMT='("ERROR: WET DEPOSITION OF ORILAM AEROSOLS IS ONLY CODED FOR THE",/,&
+ & "MICROPHYSICAL SCHEME as ICE3, ICE4, KESS, KHKO and C2R2")')
+ !callabortstop
+ CALL PRINT_MSG(NVERB_FATAL,'GEN','READ_EXSEG_n','')
+ END IF
+
+ IF (ODEPOS_AER(KMI) ) THEN
+ CGETSVT(NSV_AERDEPBEG:NSV_AERDEPEND)='READ'
+! IF(CCONF=='START') CGETSVT(NSV_AERDEPBEG:NSV_AERDEPEND)='INIT'
+ ELSE
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(UNIT=ILUOUT,FMT='("THERE IS NO SCALAR VARIABLES FOR RAIN and IN CLOUD &
+ & AEROSOL SCHEME IN INITIAL FMFILE",/,&
+ & "THE MOIST AEROSOL VARIABLES HAVE BEEN INITIALIZED TO ZERO ")')
+ CGETSVT(NSV_AERDEPBEG:NSV_AERDEPEND)='INIT'
+ END IF
+ END IF
+! Initialization of deposition scheme
+ IF (LDEPOS_AER(KMI)) THEN
+ IF(.NOT.ALLOCATED(CDEAERNAMES)) THEN
+ ALLOCATE(CDEAERNAMES(JPMODE*2))
+ CDEAERNAMES(:) = YPDEAER_INI(:)
+ ENDIF
+ ENDIF
+END IF
+!
+! Lagrangian variables
+!
+IF (LINIT_LG .AND. .NOT.(LLG)) THEN
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(UNIT=ILUOUT,FMT='("IT IS INCOHERENT TO HAVE LINIT_LG=.T. AND LLG=.F.",/,&
+ & "IF YOU WANT LAGRANGIAN TRACERS CHANGE LLG TO .T. ")')
+ENDIF
+IF (LLG) THEN
+ IF (OLG .AND. .NOT.(LINIT_LG .AND. CPROGRAM=='MESONH')) THEN
+ CGETSVT(NSV_LGBEG:NSV_LGEND)='READ'
+! IF(CCONF=='START') CGETSVT(NSV_LGBEG:NSV_LGEND)='INIT'
+ ELSE
+ IF(.NOT.(LINIT_LG) .AND. CPROGRAM=='MESONH') THEN
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(UNIT=ILUOUT,FMT='("THERE IS NO LAGRANGIAN VARIABLES IN INITIAL FMFILE",/,&
+ & "THE LAGRANGIAN VARIABLES HAVE BEEN REINITIALIZED")')
+ LINIT_LG=.TRUE.
+ ENDIF
+ CGETSVT(NSV_LGBEG:NSV_LGEND)='INIT'
+ END IF
+END IF
+!
+!
+! LINOx SV case
+!
+IF (.NOT.LUSECHEM .AND. LCH_CONV_LINOX) THEN
+ IF (.NOT.OUSECHEM .AND. OCH_CONV_LINOX) THEN
+ CGETSVT(NSV_LNOXBEG:NSV_LNOXEND)='READ'
+ ELSE
+ WRITE(UNIT=ILUOUT,FMT=9002) KMI
+ WRITE(UNIT=ILUOUT,FMT='("THERE IS NO SCALAR VARIABLES FOR LINOX &
+ &IN INITIAL FMFILE",/,&
+ & "THE LINOX VARIABLES HAVE BEEN INITIALIZED TO ZERO ")')
+ CGETSVT(NSV_LNOXBEG:NSV_LNOXEND)='INIT'
+ END IF
+END IF
+!
+! Passive pollutant case
+!
+IF (LPASPOL) THEN
+ IF (OPASPOL) THEN
+ CGETSVT(NSV_PPBEG:NSV_PPEND)='READ'
+! IF(CCONF=='START') CGETSVT(NSV_PPBEG:NSV_PPEND)='INIT'
+ ELSE
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(UNIT=ILUOUT,FMT='("THERE IS NO PASSIVE SCALAR VARIABLES IN INITIAL FMFILE",/,&
+ & "THE VARIABLES HAVE BEEN INITIALIZED TO ZERO")')
+ CGETSVT(NSV_PPBEG:NSV_PPEND)='INIT'
+ END IF
+END IF
+!
+#ifdef MNH_FOREFIRE
+! ForeFire
+!
+IF (LFOREFIRE) THEN
+ IF (OFOREFIRE) THEN
+ CGETSVT(NSV_FFBEG:NSV_FFEND)='READ'
+ IF(HSTORAGE_TYPE=='TT') THEN
+ CGETSVT(NSV_FFBEG:NSV_FFEND)='INIT'
+ END IF
+ ELSE
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(UNIT=ILUOUT,FMT='("THERE IS NO FOREFIRE SCALAR VARIABLES IN INITIAL FMFILE",/,&
+ & "THE VARIABLES HAVE BEEN INITIALIZED TO ZERO")')
+ CGETSVT(NSV_FFBEG:NSV_FFEND)='INIT'
+ END IF
+END IF
+#endif
+!
+! Conditional sampling case
+!
+IF (LCONDSAMP) THEN
+ IF (OCONDSAMP) THEN
+ CGETSVT(NSV_CSBEG:NSV_CSEND)='READ'
+! IF(CCONF=='START') CGETSVT(NSV_CSBEG:NSV_CSEND)='INIT'
+ ELSE
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(UNIT=ILUOUT,FMT='("THERE IS NO PASSIVE SCALAR VARIABLES IN INITIAL FMFILE",/,&
+ & "THE VARIABLES HAVE BEEN INITIALIZED TO ZERO")')
+ CGETSVT(NSV_CSBEG:NSV_CSEND)='INIT'
+ END IF
+END IF
+!
+! Blowing snow scheme
+!
+IF (LBLOWSNOW) THEN
+ IF (OBLOWSNOW) THEN
+ CGETSVT(NSV_SNWBEG:NSV_SNWEND)='READ'
+ ELSE
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(UNIT=ILUOUT,FMT='("THERE IS NO SCALAR VARIABLES FOR BLOWING SNOW &
+ &SCHEME IN INITIAL FMFILE",/,&
+ & "THE BLOWING SNOW VARIABLES HAVE BEEN INITIALIZED TO ZERO ")')
+ CGETSVT(NSV_SNWBEG:NSV_SNWEND)='INIT'
+ END IF
+ IF(.NOT.ALLOCATED(CSNOWNAMES)) THEN
+ IMOMENTS = (NSV_SNWEND - NSV_SNWBEG +1 )
+ ALLOCATE(CSNOWNAMES(IMOMENTS))
+ DO JMOM=1,IMOMENTS
+ CSNOWNAMES(JMOM) = YPSNOW_INI(JMOM)
+ ENDDO ! Loop on moments
+ END IF
+END IF
+!
+!
+!
+!* 3.5 Check coherence between the radiation control parameters
+!
+IF( CRAD == 'ECMW' .AND. CPROGRAM=='MESONH' ) THEN
+ IF(CLW == 'RRTM' .AND. COPILW == 'SMSH') THEN
+ WRITE(UNIT=ILUOUT,FMT=9003) KMI
+ WRITE(UNIT=ILUOUT,FMT=*) 'the SMSH parametrisation of LW optical properties for cloud ice'
+ WRITE(UNIT=ILUOUT,FMT=*) '(COPILW) can not be used with RRTM radiation scheme'
+ !callabortstop
+ CALL PRINT_MSG(NVERB_FATAL,'GEN','READ_EXSEG_n','')
+ ENDIF
+ IF(CLW == 'MORC' .AND. COPWLW == 'LILI') THEN
+ WRITE(UNIT=ILUOUT,FMT=9003) KMI
+ WRITE(UNIT=ILUOUT,FMT=*) 'the LILI parametrisation of LW optical properties for cloud water'
+ WRITE(UNIT=ILUOUT,FMT=*) '(COPWLW) can not be used with MORC radiation scheme'
+ !callabortstop
+ CALL PRINT_MSG(NVERB_FATAL,'GEN','READ_EXSEG_n','')
+ ENDIF
+ IF( .NOT. LSUBG_COND) THEN
+ WRITE(UNIT=ILUOUT,FMT=9000) KMI
+ WRITE(UNIT=ILUOUT,FMT=*) 'YOU DO NOT WANT TO USE SUBGRID CONDENSATION'
+ WRITE(UNIT=ILUOUT,FMT=*) 'THE OVERLAP OPTION IS NOVLP=5 IN ini_radconf.f90'
+ ELSE IF (CLW == 'MORC') THEN
+ WRITE(UNIT=ILUOUT,FMT=9000) KMI
+ WRITE(UNIT=ILUOUT,FMT=*) 'YOU WANT TO USE MORCRETTE LW SCHEME'
+ WRITE(UNIT=ILUOUT,FMT=*) 'THE OVERLAP OPTION IS NOVLP=5 IN ini_radconf.f90'
+ ELSE
+ WRITE(UNIT=ILUOUT,FMT=9000) KMI
+ WRITE(UNIT=ILUOUT,FMT=*) 'THE OVERLAP OPTION IS NOVLP=6 IN ini_radconf.f90'
+ ENDIF
+!
+ IF( LCLEAR_SKY .AND. XDTRAD_CLONLY /= XDTRAD) THEN
+ ! Check the validity of the LCLEAR_SKY approximation
+ WRITE(UNIT=ILUOUT,FMT=9003) KMI
+ WRITE(UNIT=ILUOUT,FMT=*) 'YOU WANT TO USE BOTH THE CLEAR-SKY APPROXIMATION'
+ WRITE(UNIT=ILUOUT,FMT=*) '(i.e. AVERAGE THE WHOLE CLOUDFREE VERTICALS BUT KEEP'
+ WRITE(UNIT=ILUOUT,FMT=*) 'ALL THE CLOUDY VERTICALS) AND'
+ WRITE(UNIT=ILUOUT,FMT=*) 'THE CLOUD-ONLY APPROXIMATION (i.e. YOU CALL MORE OFTEN THE'
+ WRITE(UNIT=ILUOUT,FMT=*) 'RADIATIONS FOR THE CLOUDY VERTICALS THAN FOR CLOUDFREE ONES).'
+ WRITE(UNIT=ILUOUT,FMT=*) 'THIS IS NOT POSSIBLE, SO CHOOSE BETWEEN :'
+ WRITE(UNIT=ILUOUT,FMT=*) 'XDTRAD_CLONLY = XDTRAD and LCLEAR_SKY = FALSE'
+!
+ !callabortstop
+ CALL PRINT_MSG(NVERB_FATAL,'GEN','READ_EXSEG_n','')
+ END IF
+!
+ IF( XDTRAD_CLONLY > XDTRAD ) THEN
+ WRITE(UNIT=ILUOUT,FMT=9003) KMI
+ WRITE(UNIT=ILUOUT,FMT='("BAD USE OF THE CLOUD-ONLY APPROXIMATION " ,&
+ &" XDTRAD SHOULD BE LARGER THAN XDTRAD_CLONLY ")')
+!
+ !callabortstop
+ CALL PRINT_MSG(NVERB_FATAL,'GEN','READ_EXSEG_n','')
+ END IF
+!
+ IF(( XDTRAD < XTSTEP ).OR. ( XDTRAD_CLONLY < XTSTEP )) THEN
+ WRITE(UNIT=ILUOUT,FMT=9003) KMI
+ WRITE(UNIT=ILUOUT,FMT='("THE RADIATION CALL XDTRAD OR XDTRAD_CLONLY " ,&
+ &" IS MORE FREQUENT THAN THE TIME STEP SO ADJUST XDTRAD OR XDTRAD_CLONLY ")')
+!
+ !callabortstop
+ CALL PRINT_MSG(NVERB_FATAL,'GEN','READ_EXSEG_n','')
+ END IF
+END IF
+!
+IF ( CRAD /= 'NONE' .AND. CPROGRAM=='MESONH' ) THEN
+ CGETRAD='READ'
+ IF( HRAD == 'NONE' .AND. CCONF=='RESTA') THEN
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(UNIT=ILUOUT,FMT=*) 'YOU ARE PERFORMING A RESTART. FOR THIS SEGMENT, YOU ARE USING A RADIATION'
+ WRITE(UNIT=ILUOUT,FMT=*) 'SCHEME AND NO RADIATION SCHEME WAS USED FOR THE PREVIOUS SEGMENT.'
+ CGETRAD='INIT'
+ END IF
+ IF(CCONF=='START') THEN
+ CGETRAD='INIT'
+ END IF
+END IF
+!
+! 3.6 check the initialization of the deep convection scheme
+!
+IF ( (CDCONV /= 'KAFR') .AND. &
+ (CSCONV /= 'KAFR') .AND. LCHTRANS ) THEN
+ WRITE(UNIT=ILUOUT,FMT=9003) KMI
+ WRITE(UNIT=ILUOUT,FMT='("YOU WANT TO USE THE LCHTRANS OPTION= ",&
+ &"CONVECTIVE TRANSPORT OF TRACERS BUT IT CAN ONLY",&
+ &"BE USED FOR THE KAIN FRITSCH SCHEME ")')
+ !callabortstop
+ CALL PRINT_MSG(NVERB_FATAL,'GEN','READ_EXSEG_n','')
+END IF
+!
+SELECT CASE ( CDCONV )
+ CASE( 'KAFR' )
+ IF (.NOT. ( LUSERV ) ) THEN
+ WRITE(UNIT=ILUOUT,FMT=9002) KMI
+ WRITE(UNIT=ILUOUT,FMT='("YOU WANT TO USE THE KAIN-FRITSCH DEEP CONV. ",&
+ &" SCHEME. YOU MUST HAVE VAPOR ",/,"LUSERV IS SET TO TRUE ")')
+ LUSERV=.TRUE.
+ ELSE IF (.NOT. ( LUSERI ) ) THEN
+ WRITE(UNIT=ILUOUT,FMT=9002) KMI
+ WRITE(UNIT=ILUOUT,FMT='("YOU WANT TO USE THE KAIN-FRITSCH",&
+ &" DEEP CONV. SCHEME. BUT THE DETRAINED CLOUD ICE WILL BE ADDED TO ",&
+ &" THE CLOUD WATER ")')
+ ELSE IF (.NOT. ( LUSERI.AND.LUSERC ) ) THEN
+ WRITE(UNIT=ILUOUT,FMT=9002) KMI
+ WRITE(UNIT=ILUOUT,FMT='("YOU WANT TO USE THE KAIN-FRITSCH",&
+ &" DEEP CONV. SCHEME. BUT THE DETRAINED CLOUD WATER AND CLOUD ICE ",&
+ &" WILL BE ADDED TO THE WATER VAPOR FIELD ")')
+ END IF
+ IF ( LCHTRANS .AND. NSV == 0 ) THEN
+ WRITE(UNIT=ILUOUT,FMT=9002) KMI
+ WRITE(UNIT=ILUOUT,FMT='("YOU WANT TO USE THE LCHTRANS OPTION= ",&
+ &"CONVECTIVE TRANSPORT OF TRACERS BUT YOUR TRACER ",&
+ &"NUMBER NSV IS ZERO ",/,"LCHTRANS IS SET TO FALSE")')
+ LCHTRANS=.FALSE.
+ END IF
+END SELECT
+!
+IF ( CDCONV == 'KAFR' .AND. LCHTRANS .AND. NSV > 0 ) THEN
+ IF( OCHTRANS ) THEN
+ CGETSVCONV='READ'
+ ELSE
+ CGETSVCONV='INIT'
+ END IF
+END IF
+!
+SELECT CASE ( CSCONV )
+ CASE( 'KAFR' )
+ IF (.NOT. ( LUSERV ) ) THEN
+ WRITE(UNIT=ILUOUT,FMT=9002) KMI
+ WRITE(UNIT=ILUOUT,FMT='("YOU WANT TO USE THE KAIN-FRITSCH SHALLOW CONV. ",&
+ &" SCHEME. YOU MUST HAVE VAPOR ",/,"LUSERV IS SET TO TRUE ")')
+ LUSERV=.TRUE.
+ ELSE IF (.NOT. ( LUSERI ) ) THEN
+ WRITE(UNIT=ILUOUT,FMT=9002) KMI
+ WRITE(UNIT=ILUOUT,FMT='("YOU WANT TO USE THE KAIN-FRITSCH",&
+ &" SHALLOW CONV. SCHEME. BUT THE DETRAINED CLOUD ICE WILL BE ADDED TO ",&
+ &" THE CLOUD WATER ")')
+ ELSE IF (.NOT. ( LUSERI.AND.LUSERC ) ) THEN
+ WRITE(UNIT=ILUOUT,FMT=9002) KMI
+ WRITE(UNIT=ILUOUT,FMT='("YOU WANT TO USE THE KAIN-FRITSCH",&
+ &" SHALLOW CONV. SCHEME. BUT THE DETRAINED CLOUD WATER AND CLOUD ICE ",&
+ &" WILL BE ADDED TO THE WATER VAPOR FIELD ")')
+ END IF
+ IF ( LCHTRANS .AND. NSV == 0 ) THEN
+ WRITE(UNIT=ILUOUT,FMT=9002) KMI
+ WRITE(UNIT=ILUOUT,FMT='("YOU WANT TO USE THE LCHTRANS OPTION= ",&
+ &"CONVECTIVE TRANSPORT OF TRACERS BUT YOUR TRACER ",&
+ &"NUMBER NSV IS ZERO ",/,"LCHTRANS IS SET TO FALSE")')
+ LCHTRANS=.FALSE.
+ END IF
+ CASE( 'EDKF' )
+ IF (CTURB == 'NONE' ) THEN
+ WRITE(UNIT=ILUOUT,FMT=9003) KMI
+ WRITE(UNIT=ILUOUT,FMT='("YOU WANT TO USE THE EDKF ", &
+ &"SHALLOW CONVECTION WITHOUT TURBULENCE SCHEME : ", &
+ &"IT IS NOT POSSIBLE")')
+!
+ !callabortstop
+ CALL PRINT_MSG(NVERB_FATAL,'GEN','READ_EXSEG_n','')
+ END IF
+END SELECT
+!
+!
+CGETCONV = 'SKIP'
+!
+IF ( (CDCONV /= 'NONE' .OR. CSCONV == 'KAFR' ) .AND. CPROGRAM=='MESONH') THEN
+ CGETCONV = 'READ'
+ IF( HDCONV == 'NONE' .AND. CCONF=='RESTA') THEN
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(UNIT=ILUOUT,FMT='(" YOU ARE PERFORMING A RESTART. FOR THIS ",&
+ &" SEGMENT, YOU ARE USING A DEEP CONVECTION SCHEME AND NO DEEP ",&
+ &" CONVECTION SCHEME WAS USED FOR THE PREVIOUS SEGMENT. ")')
+!
+ CGETCONV = 'INIT'
+ END IF
+ IF(CCONF=='START') THEN
+ CGETCONV = 'INIT'
+ END IF
+END IF
+!
+!* 3.7 configuration and model version
+!
+IF (KMI == 1) THEN
+!
+ IF (L1D.AND.(CLBCX(1)/='CYCL'.AND.CLBCX(2)/='CYCL' &
+ .AND.CLBCY(1)/='CYCL'.AND.CLBCY(2)/='CYCL')) THEN
+ WRITE(UNIT=ILUOUT,FMT=9003) KMI
+ WRITE(UNIT=ILUOUT,FMT='("YOU WANT TO USE A 1D MODEL VERSION WITH NON-CYCL",&
+ & "CLBCX OR CLBCY VALUES")')
+ !callabortstop
+ CALL PRINT_MSG(NVERB_FATAL,'GEN','READ_EXSEG_n','')
+ END IF
+ IF (L2D.AND.(CLBCY(1)/='CYCL'.AND.CLBCY(2)/='CYCL')) THEN
+ WRITE(UNIT=ILUOUT,FMT=9003) KMI
+ WRITE(UNIT=ILUOUT,FMT='("YOU WANT TO USE A 2D MODEL VERSION WITH NON-CYCL",&
+ & " CLBCY VALUES")')
+ !callabortstop
+ CALL PRINT_MSG(NVERB_FATAL,'GEN','READ_EXSEG_n','')
+ END IF
+ !
+ IF ( (.NOT. LCARTESIAN) .AND. ( LCORIO) .AND. (.NOT. LGEOST_UV_FRC) ) THEN
+ WRITE(UNIT=ILUOUT,FMT=9002) KMI
+ WRITE(UNIT=ILUOUT,FMT='("BE CAREFUL YOU COULD HAVE SPURIOUS MOTIONS " ,&
+ & " NEAR THE LBC AS LCORIO=T and LGEOST_UV_FRC=F")')
+ END IF
+ !
+ IF ((.NOT.LFLAT).AND.OFLAT) THEN
+ WRITE(UNIT=ILUOUT,FMT=9002) KMI
+ WRITE(UNIT=ILUOUT,FMT=*) 'ZERO OROGRAPHY IN INITIAL FILE'
+ WRITE(UNIT=ILUOUT,FMT=*) '***** ALL TERMS HAVE BEEN NEVERTHELESS COMPUTED WITHOUT SIMPLIFICATION*****'
+ WRITE(UNIT=ILUOUT,FMT=*) 'THIS SHOULD LEAD TO ERRORS IN THE PRESSURE COMPUTATION'
+ END IF
+ IF (LFLAT.AND.(.NOT.OFLAT)) THEN
+ WRITE(UNIT=ILUOUT,FMT=9002) KMI
+ WRITE(UNIT=ILUOUT,FMT='(" OROGRAPHY IS NOT EQUAL TO ZERO ", &
+ & "IN INITIAL FILE" ,/, &
+ & "******* OROGRAPHY HAS BEEN SET TO ZERO *********",/, &
+ & "ACCORDING TO ZERO OROGRAPHY, SIMPLIFICATIONS HAVE ", &
+ & "BEEN MADE IN COMPUTATIONS")')
+ END IF
+END IF
+!
+!* 3.8 System of equations
+!
+IF ( HEQNSYS /= CEQNSYS ) THEN
+ WRITE(UNIT=ILUOUT,FMT=9003) KMI
+ WRITE(ILUOUT,FMT=*) 'YOU HAVE CHANGED THE SYSTEM OF EQUATIONS'
+ WRITE(ILUOUT,FMT=*) 'THE ANELASTIC CONSTRAINT IS PERHAPS CHANGED :'
+ WRITE(ILUOUT,FMT=*) 'FOR THE INITIAL FILE YOU HAVE USED ',HEQNSYS
+ WRITE(ILUOUT,FMT=*) 'FOR THE RUN YOU PLAN TO USE ',CEQNSYS
+ WRITE(ILUOUT,FMT=*) 'THIS CAN LEAD TO A NUMERICAL EXPLOSION IN THE FIRST TIME STEPS'
+ !callabortstop
+ CALL PRINT_MSG(NVERB_FATAL,'GEN','READ_EXSEG_n','')
+END IF
+!
+! 3.9 Numerical schemes
+!
+IF ( (CUVW_ADV_SCHEME == 'CEN4TH') .AND. &
+ (CTEMP_SCHEME /= 'LEFR') .AND. (CTEMP_SCHEME /= 'RKC4') ) THEN
+ WRITE(UNIT=ILUOUT,FMT=9003) KMI
+ WRITE(UNIT=ILUOUT,FMT='("CEN4TH SCHEME HAS TO BE USED WITH ",&
+ &"CTEMP_SCHEME = LEFR of RKC4 ONLY")')
+ !callabortstop
+ CALL PRINT_MSG(NVERB_FATAL,'GEN','READ_EXSEG_n','')
+END IF
+!
+IF ( (CUVW_ADV_SCHEME == 'WENO_K') .AND. LNUMDIFU ) THEN
+ WRITE(UNIT=ILUOUT,FMT=9002) KMI
+ WRITE(UNIT=ILUOUT,FMT='("YOU WANT TO USE NUMERICAL DIFFUSION ",&
+ &"WITH WENO SCHEME ALREADY DIFFUSIVE")')
+END IF
+!-------------------------------------------------------------------------------
+!
+!* 4. CHECK COHERENCE BETWEEN EXSEG VARIABLES
+! ---------------------------------------
+!
+!* 4.1 coherence between coupling variables in EXSEG file
+!
+IF (KMI == 1) THEN
+ NCPL_NBR = 0
+ DO JCI = 1,JPCPLFILEMAX
+ IF (LEN_TRIM(CCPLFILE(JCI)) /= 0) THEN ! Finds the number
+ NCPL_NBR = NCPL_NBR + 1 ! of coupling files
+ ENDIF
+ IF (JCI/=JPCPLFILEMAX) THEN ! Deplaces the coupling files
+ IF ((LEN_TRIM(CCPLFILE(JCI)) == 0) .AND. &! names if one missing
+ (LEN_TRIM(CCPLFILE(JCI+1)) /= 0)) THEN
+ DO JI=JCI,JPCPLFILEMAX-1
+ CCPLFILE(JI)=CCPLFILE(JI+1)
+ END DO
+ CCPLFILE(JPCPLFILEMAX)=' '
+ END IF
+ END IF
+ END DO
+!
+ IF (NCPL_NBR /= 0) THEN
+ LSTEADYLS = .FALSE.
+ ELSE
+ LSTEADYLS = .TRUE.
+ ENDIF
+END IF
+!
+!* 4.3 check consistency in forcing switches
+!
+IF ( LFORCING ) THEN
+ IF ( LRELAX_THRV_FRC .AND. ( LTEND_THRV_FRC .OR. LGEOST_TH_FRC ) ) THEN
+ WRITE(UNIT=ILUOUT,FMT=9002) KMI
+ WRITE(ILUOUT,FMT=*) 'YOU CHOSE A TEMPERATURE AND HUMIDITY RELAXATION'
+ WRITE(ILUOUT,FMT=*) 'TOGETHER WITH TENDENCY OR GEOSTROPHIC FORCING'
+ WRITE(ILUOUT,FMT=*) &
+ 'YOU MIGHT CHECK YOUR SWITCHES: LRELAX_THRV_FRC, LTEND_THRV_FRC, AND'
+ WRITE(ILUOUT,FMT=*) 'LGEOST_TH_FRC'
+ END IF
+!
+ IF ( LRELAX_UV_FRC .AND. LGEOST_UV_FRC ) THEN
+ WRITE(UNIT=ILUOUT,FMT=9003) KMI
+ WRITE(ILUOUT,FMT=*) 'YOU MUST NOT USE A WIND RELAXATION'
+ WRITE(ILUOUT,FMT=*) 'TOGETHER WITH A GEOSTROPHIC FORCING'
+ WRITE(ILUOUT,FMT=*) 'CHECK SWITCHES: LRELAX_UV_FRC, LGEOST_UV_FRC'
+ !callabortstop
+ CALL PRINT_MSG(NVERB_FATAL,'GEN','READ_EXSEG_n','')
+ END IF
+!
+ IF ( CRELAX_HEIGHT_TYPE.NE."FIXE" .AND. CRELAX_HEIGHT_TYPE.NE."THGR" ) THEN
+ WRITE(UNIT=ILUOUT,FMT=9003) KMI
+ WRITE(ILUOUT,FMT=*) 'CRELAX_HEIGHT_TYPE MUST BE EITHER "FIXE" OR "THGR"'
+ WRITE(ILUOUT,FMT=*) 'BUT IT IS "', CRELAX_HEIGHT_TYPE, '"'
+ !callabortstop
+ CALL PRINT_MSG(NVERB_FATAL,'GEN','READ_EXSEG_n','')
+ END IF
+!
+ IF ( .NOT.LCORIO .AND. LGEOST_UV_FRC ) THEN
+ WRITE(UNIT=ILUOUT,FMT=9003) KMI
+ WRITE(ILUOUT,FMT=*) 'YOU CANNOT HAVE A GEOSTROPHIC FORCING WITHOUT'
+ WRITE(ILUOUT,FMT=*) 'ACTIVATING LCORIOLIS OPTION'
+ !callabortstop
+ CALL PRINT_MSG(NVERB_FATAL,'GEN','READ_EXSEG_n','')
+ END IF
+!
+ IF ( LPGROUND_FRC ) THEN
+ WRITE(ILUOUT,FMT=*) 'SURFACE PRESSURE FORCING NOT YET IMPLEMENTED'
+ !callabortstop
+ CALL PRINT_MSG(NVERB_FATAL,'GEN','READ_EXSEG_n','')
+ END IF
+!
+END IF
+!
+IF (LTRANS .AND. .NOT. LFLAT ) THEN
+ WRITE(UNIT=ILUOUT,FMT=9003) KMI
+ WRITE(ILUOUT,FMT=*) 'YOU ASK FOR A CONSTANT SPEED DOMAIN TRANSLATION '
+ WRITE(ILUOUT,FMT=*) 'BUT NOT IN THE FLAT TERRAIN CASE:'
+ WRITE(ILUOUT,FMT=*) 'THIS IS NOT ALLOWED ACTUALLY'
+ !callabortstop
+ CALL PRINT_MSG(NVERB_FATAL,'GEN','READ_EXSEG_n','')
+END IF
+!
+!* 4.4 Check the coherence between the LUSERn and LHORELAX
+!
+IF (.NOT. LUSERV .AND. LHORELAX_RV) THEN
+ LHORELAX_RV=.FALSE.
+ WRITE(UNIT=ILUOUT,FMT=9002) KMI
+ WRITE(ILUOUT,FMT=*) 'YOU WANT TO RELAX RV FIELD BUT IT DOES NOT EXIST.'
+ WRITE(ILUOUT,FMT=*) 'THEREFORE LHORELAX_RV=FALSE'
+END IF
+!
+IF (.NOT. LUSERC .AND. LHORELAX_RC) THEN
+ LHORELAX_RC=.FALSE.
+ WRITE(UNIT=ILUOUT,FMT=9002) KMI
+ WRITE(ILUOUT,FMT=*) 'YOU WANT TO RELAX RC FIELD BUT IT DOES NOT EXIST.'
+ WRITE(ILUOUT,FMT=*) 'THEREFORE LHORELAX_RC=FALSE'
+END IF
+!
+IF (.NOT. LUSERR .AND. LHORELAX_RR) THEN
+ LHORELAX_RR=.FALSE.
+ WRITE(UNIT=ILUOUT,FMT=9002) KMI
+ WRITE(ILUOUT,FMT=*) 'YOU WANT TO RELAX RR FIELD BUT IT DOES NOT EXIST.'
+ WRITE(ILUOUT,FMT=*) 'THEREFORE LHORELAX_RR=FALSE'
+END IF
+!
+IF (.NOT. LUSERI .AND. LHORELAX_RI) THEN
+ LHORELAX_RI=.FALSE.
+ WRITE(UNIT=ILUOUT,FMT=9002) KMI
+ WRITE(ILUOUT,FMT=*) 'YOU WANT TO RELAX RI FIELD BUT IT DOES NOT EXIST.'
+ WRITE(ILUOUT,FMT=*) 'THEREFORE LHORELAX_RI=FALSE'
+END IF
+!
+IF (.NOT. LUSERS .AND. LHORELAX_RS) THEN
+ LHORELAX_RS=.FALSE.
+ WRITE(UNIT=ILUOUT,FMT=9002) KMI
+ WRITE(ILUOUT,FMT=*) 'YOU WANT TO RELAX RS FIELD BUT IT DOES NOT EXIST.'
+ WRITE(ILUOUT,FMT=*) 'THEREFORE LHORELAX_RS=FALSE'
+END IF
+!
+IF (.NOT. LUSERG .AND. LHORELAX_RG) THEN
+ LHORELAX_RG=.FALSE.
+ WRITE(UNIT=ILUOUT,FMT=9002) KMI
+ WRITE(ILUOUT,FMT=*) 'YOU WANT TO RELAX RG FIELD BUT IT DOES NOT EXIST.'
+ WRITE(ILUOUT,FMT=*) 'THEREFORE LHORELAX_RG=FALSE'
+END IF
+!
+IF (.NOT. LUSERH .AND. LHORELAX_RH) THEN
+ LHORELAX_RH=.FALSE.
+ WRITE(UNIT=ILUOUT,FMT=9002) KMI
+ WRITE(ILUOUT,FMT=*) 'YOU WANT TO RELAX RH FIELD BUT IT DOES NOT EXIST.'
+ WRITE(ILUOUT,FMT=*) 'THEREFORE LHORELAX_RH=FALSE'
+END IF
+!
+IF (CTURB=='NONE' .AND. LHORELAX_TKE) THEN
+ LHORELAX_TKE=.FALSE.
+ WRITE(UNIT=ILUOUT,FMT=9002) KMI
+ WRITE(ILUOUT,FMT=*) 'YOU WANT TO RELAX TKE FIELD BUT IT DOES NOT EXIST.'
+ WRITE(ILUOUT,FMT=*) 'THEREFORE LHORELAX_TKE=FALSE'
+END IF
+!
+!
+IF (CCLOUD/='C2R2' .AND. CCLOUD/='KHKO' .AND. LHORELAX_SVC2R2) THEN
+ LHORELAX_SVC2R2=.FALSE.
+ WRITE(UNIT=ILUOUT,FMT=9002) KMI
+ WRITE(ILUOUT,FMT=*) 'YOU WANT TO RELAX C2R2 or KHKO FIELD BUT IT DOES NOT EXIST.'
+ WRITE(ILUOUT,FMT=*) 'THEREFORE LHORELAX_SVC2R2=FALSE'
+END IF
+!
+IF (CCLOUD/='C3R5' .AND. LHORELAX_SVC1R3) THEN
+ LHORELAX_SVC1R3=.FALSE.
+ WRITE(UNIT=ILUOUT,FMT=9002) KMI
+ WRITE(ILUOUT,FMT=*) 'YOU WANT TO RELAX C3R5 FIELD BUT IT DOES NOT EXIST.'
+ WRITE(ILUOUT,FMT=*) 'THEREFORE LHORELAX_SVC1R3=FALSE'
+END IF
+!
+IF (CCLOUD/='LIMA' .AND. LHORELAX_SVLIMA) THEN
+ LHORELAX_SVLIMA=.FALSE.
+ WRITE(UNIT=ILUOUT,FMT=9002) KMI
+ WRITE(ILUOUT,FMT=*) 'YOU WANT TO RELAX LIMA FIELD BUT IT DOES NOT EXIST.'
+ WRITE(ILUOUT,FMT=*) 'THEREFORE LHORELAX_SVLIMA=FALSE'
+END IF
+!
+IF (CELEC(1:3) /= 'ELE' .AND. LHORELAX_SVELEC) THEN
+ LHORELAX_SVELEC=.FALSE.
+ WRITE(UNIT=ILUOUT,FMT=9002) KMI
+ WRITE(ILUOUT,FMT=*) 'YOU WANT TO RELAX ELEC FIELD BUT IT DOES NOT EXIST.'
+ WRITE(ILUOUT,FMT=*) 'THEREFORE LHORELAX_SVELEC=FALSE'
+END IF
+!
+IF (.NOT. LUSECHEM .AND. LHORELAX_SVCHEM) THEN
+ LHORELAX_SVCHEM=.FALSE.
+ WRITE(UNIT=ILUOUT,FMT=9002) KMI
+ WRITE(ILUOUT,FMT=*) 'YOU WANT TO RELAX CHEM FIELD BUT IT DOES NOT EXIST.'
+ WRITE(ILUOUT,FMT=*) 'THEREFORE LHORELAX_SVCHEM=FALSE'
+END IF
+!
+IF (.NOT. LUSECHIC .AND. LHORELAX_SVCHIC) THEN
+ LHORELAX_SVCHIC=.FALSE.
+ WRITE(UNIT=ILUOUT,FMT=9002) KMI
+ WRITE(ILUOUT,FMT=*) 'YOU WANT TO RELAX ICE CHEM FIELD BUT IT DOES NOT EXIST.'
+ WRITE(ILUOUT,FMT=*) 'THEREFORE LHORELAX_SVCHIC=FALSE'
+END IF
+!
+IF (.NOT. LORILAM .AND. LHORELAX_SVAER) THEN
+ LHORELAX_SVAER=.FALSE.
+ WRITE(UNIT=ILUOUT,FMT=9002) KMI
+ WRITE(ILUOUT,FMT=*) 'YOU WANT TO RELAX AEROSOL FIELD BUT IT DOES NOT EXIST.'
+ WRITE(ILUOUT,FMT=*) 'THEREFORE LHORELAX_SVAER=FALSE'
+END IF
+
+IF (.NOT. LDUST .AND. LHORELAX_SVDST) THEN
+ LHORELAX_SVDST=.FALSE.
+ WRITE(UNIT=ILUOUT,FMT=9002) KMI
+ WRITE(ILUOUT,FMT=*) 'YOU WANT TO RELAX DUST FIELD BUT IT DOES NOT EXIST.'
+ WRITE(ILUOUT,FMT=*) 'THEREFORE LHORELAX_SVDST=FALSE'
+END IF
+
+IF (.NOT. LSALT .AND. LHORELAX_SVSLT) THEN
+ LHORELAX_SVSLT=.FALSE.
+ WRITE(UNIT=ILUOUT,FMT=9002) KMI
+ WRITE(ILUOUT,FMT=*) 'YOU WANT TO RELAX SEA SALT FIELD BUT IT DOES NOT EXIST.'
+ WRITE(ILUOUT,FMT=*) 'THEREFORE LHORELAX_SVSLT=FALSE'
+END IF
+
+IF (.NOT. LPASPOL .AND. LHORELAX_SVPP) THEN
+ LHORELAX_SVPP=.FALSE.
+ WRITE(UNIT=ILUOUT,FMT=9002) KMI
+ WRITE(ILUOUT,FMT=*) 'YOU WANT TO RELAX PASSIVE POLLUTANT FIELD BUT IT DOES NOT EXIST.'
+ WRITE(ILUOUT,FMT=*) 'THEREFORE LHORELAX_SVPP=FALSE'
+END IF
+#ifdef MNH_FOREFIRE
+IF (.NOT. LFOREFIRE .AND. LHORELAX_SVFF) THEN
+ LHORELAX_SVFF=.FALSE.
+ WRITE(UNIT=ILUOUT,FMT=9002) KMI
+ WRITE(ILUOUT,FMT=*) 'YOU WANT TO RELAX FOREFIRE FLUXES BUT THEY DO NOT EXIST.'
+ WRITE(ILUOUT,FMT=*) 'THEREFORE LHORELAX_SVFF=FALSE'
+END IF
+#endif
+IF (.NOT. LCONDSAMP .AND. LHORELAX_SVCS) THEN
+ LHORELAX_SVCS=.FALSE.
+ WRITE(UNIT=ILUOUT,FMT=9002) KMI
+ WRITE(ILUOUT,FMT=*) 'YOU WANT TO RELAX CONDITIONAL SAMPLING FIELD BUT IT DOES NOT EXIST.'
+ WRITE(ILUOUT,FMT=*) 'THEREFORE LHORELAX_SVCS=FALSE'
+END IF
+
+IF (.NOT. LBLOWSNOW .AND. LHORELAX_SVSNW) THEN
+ LHORELAX_SVSNW=.FALSE.
+ WRITE(UNIT=ILUOUT,FMT=9002) KMI
+ WRITE(ILUOUT,FMT=*) 'YOU WANT TO RELAX BLOWING SNOW FIELD BUT IT DOES NOT EXIST.'
+ WRITE(ILUOUT,FMT=*) 'THEREFORE LHORELAX_SVSNW=FALSE'
+END IF
+
+IF (ANY(LHORELAX_SV(NSV+1:))) THEN
+ LHORELAX_SV(NSV+1:)=.FALSE.
+ WRITE(UNIT=ILUOUT,FMT=9002) KMI
+ WRITE(ILUOUT,FMT=*) 'YOU WANT TO RELAX SV(NSV+1:) FIELD BUT IT DOES NOT EXIST.'
+ WRITE(ILUOUT,FMT=*) 'THEREFORE LHORELAX_SV(NSV+1:)=FALSE'
+END IF
+!
+!* 4.5 check the number of points for the horizontal relaxation
+!
+IF ( NRIMX > KRIMX .AND. .NOT.LHORELAX_SVELEC ) THEN
+ NRIMX = KRIMX
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(ILUOUT,FMT=*) 'YOU WANT TO USE A LARGER NUMBER OF POINTS '
+ WRITE(ILUOUT,FMT=*) 'FOR THE HORIZONTAL RELAXATION THAN THE '
+ WRITE(ILUOUT,FMT=*) 'CORRESPONDING NUMBER OF LARGE SCALE FIELDS:'
+ WRITE(ILUOUT,FMT=*) 'IT IS THEREFORE REDUCED TO NRIMX =',NRIMX
+END IF
+!
+IF ( L2D .AND. KRIMY>0 ) THEN
+ NRIMY = 0
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(ILUOUT,FMT=*) 'YOU WANT TO USE A 2D MODEL THEREFORE NRIMY=0 '
+END IF
+!
+IF ( NRIMY > KRIMY .AND. .NOT.LHORELAX_SVELEC ) THEN
+ NRIMY = KRIMY
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(ILUOUT,FMT=*) 'YOU WANT TO USE A LARGER NUMBER OF POINTS '
+ WRITE(ILUOUT,FMT=*) 'FOR THE HORIZONTAL RELAXATION THAN THE '
+ WRITE(ILUOUT,FMT=*) 'CORRESPONDING NUMBER OF LARGE SCALE FIELDS:'
+ WRITE(ILUOUT,FMT=*) 'IT IS THEREFORE REDUCED TO NRIMY =',NRIMY
+END IF
+!
+IF ( (.NOT. LHORELAX_UVWTH) .AND. (.NOT.(ANY(LHORELAX_SV))) .AND. &
+ (.NOT. LHORELAX_SVC2R2).AND. (.NOT. LHORELAX_SVC1R3) .AND. &
+ (.NOT. LHORELAX_SVLIMA).AND. &
+ (.NOT. LHORELAX_SVELEC).AND. (.NOT. LHORELAX_SVCHEM) .AND. &
+ (.NOT. LHORELAX_SVLG) .AND. (.NOT. LHORELAX_SVPP) .AND. &
+ (.NOT. LHORELAX_SVCS) .AND. &
+#ifdef MNH_FOREFIRE
+ (.NOT. LHORELAX_SVFF) .AND. &
+#endif
+ (.NOT. LHORELAX_RV) .AND. (.NOT. LHORELAX_RC) .AND. &
+ (.NOT. LHORELAX_RR) .AND. (.NOT. LHORELAX_RI) .AND. &
+ (.NOT. LHORELAX_RS) .AND. (.NOT. LHORELAX_RG) .AND. &
+ (.NOT. LHORELAX_RH) .AND. (.NOT. LHORELAX_TKE) .AND. &
+ (.NOT. LHORELAX_SVCHIC).AND. &
+ (NRIMX /= 0 .OR. NRIMY /= 0)) THEN
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(ILUOUT,FMT=*) 'YOU DO NOT WANT TO USE THE HORIZONTAL RELAXATION '
+ WRITE(ILUOUT,FMT=*) 'THEREFORE NRIMX=NRIMY=0 '
+ NRIMX=0
+ NRIMY=0
+END IF
+!
+IF ((LHORELAX_UVWTH .OR. LHORELAX_SVPP .OR. &
+ LHORELAX_SVCS .OR. &
+#ifdef MNH_FOREFIRE
+ LHORELAX_SVFF .OR. &
+#endif
+ LHORELAX_SVC2R2 .OR. LHORELAX_SVC1R3 .OR. &
+ LHORELAX_SVLIMA .OR. &
+ LHORELAX_SVELEC .OR. LHORELAX_SVCHEM .OR. &
+ LHORELAX_SVLG .OR. ANY(LHORELAX_SV) .OR. &
+ LHORELAX_RV .OR. LHORELAX_RC .OR. &
+ LHORELAX_RR .OR. LHORELAX_RI .OR. &
+ LHORELAX_RG .OR. LHORELAX_RS .OR. &
+ LHORELAX_RH .OR. LHORELAX_TKE.OR. &
+ LHORELAX_SVCHIC ) &
+ .AND. (NRIMX==0 .OR. (NRIMY==0 .AND. .NOT.(L2D) ))) THEN
+ WRITE(UNIT=ILUOUT,FMT=9003) KMI
+ WRITE(ILUOUT,FMT=*) 'YOU WANT TO USE THE HORIZONTAL RELAXATION '
+ WRITE(ILUOUT,FMT=*) 'BUT NRIMX OR NRIMY=0 CHANGE YOUR VALUES '
+ WRITE(ILUOUT,FMT=*) "LHORELAX_UVWTH=",LHORELAX_UVWTH
+ WRITE(ILUOUT,FMT=*) "LHORELAX_SVC2R2=",LHORELAX_SVC2R2
+ WRITE(ILUOUT,FMT=*) "LHORELAX_SVC1R3=",LHORELAX_SVC1R3
+ WRITE(ILUOUT,FMT=*) "LHORELAX_SVLIMA=",LHORELAX_SVLIMA
+ WRITE(ILUOUT,FMT=*) "LHORELAX_SVELEC=",LHORELAX_SVELEC
+ WRITE(ILUOUT,FMT=*) "LHORELAX_SVCHEM=",LHORELAX_SVCHEM
+ WRITE(ILUOUT,FMT=*) "LHORELAX_SVCHIC=",LHORELAX_SVCHIC
+ WRITE(ILUOUT,FMT=*) "LHORELAX_SVLG=",LHORELAX_SVLG
+ WRITE(ILUOUT,FMT=*) "LHORELAX_SVPP=",LHORELAX_SVPP
+#ifdef MNH_FOREFIRE
+ WRITE(ILUOUT,FMT=*) "LHORELAX_SVFF=",LHORELAX_SVFF
+#endif
+ WRITE(ILUOUT,FMT=*) "LHORELAX_SVCS=",LHORELAX_SVCS
+ WRITE(ILUOUT,FMT=*) "LHORELAX_SV=",LHORELAX_SV
+ WRITE(ILUOUT,FMT=*) "LHORELAX_RV=",LHORELAX_RV
+ WRITE(ILUOUT,FMT=*) "LHORELAX_RC=",LHORELAX_RC
+ WRITE(ILUOUT,FMT=*) "LHORELAX_RR=",LHORELAX_RR
+ WRITE(ILUOUT,FMT=*) "LHORELAX_RI=",LHORELAX_RI
+ WRITE(ILUOUT,FMT=*) "LHORELAX_RG=",LHORELAX_RG
+ WRITE(ILUOUT,FMT=*) "LHORELAX_RS=",LHORELAX_RS
+ WRITE(ILUOUT,FMT=*) "LHORELAX_RH=",LHORELAX_RH
+ WRITE(ILUOUT,FMT=*) "LHORELAX_TKE=", LHORELAX_TKE
+ WRITE(ILUOUT,FMT=*) "NRIMX=",NRIMX
+ WRITE(ILUOUT,FMT=*) "NRIMY=",NRIMY
+ WRITE(ILUOUT,FMT=*) "L2D=",L2D
+ !callabortstop
+ CALL PRINT_MSG(NVERB_FATAL,'GEN','READ_EXSEG_n','')
+END IF
+!
+IF ((LHORELAX_UVWTH .OR. LHORELAX_SVPP .OR. &
+ LHORELAX_SVCS .OR. &
+#ifdef MNH_FOREFIRE
+ LHORELAX_SVFF .OR. &
+#endif
+ LHORELAX_SVC2R2 .OR. LHORELAX_SVC1R3 .OR. &
+ LHORELAX_SVLIMA .OR. &
+ LHORELAX_SVELEC .OR. LHORELAX_SVCHEM .OR. &
+ LHORELAX_SVLG .OR. ANY(LHORELAX_SV) .OR. &
+ LHORELAX_RV .OR. LHORELAX_RC .OR. &
+ LHORELAX_RR .OR. LHORELAX_RI .OR. &
+ LHORELAX_RG .OR. LHORELAX_RS .OR. &
+ LHORELAX_RH .OR. LHORELAX_TKE.OR. &
+ LHORELAX_SVCHIC ) &
+ .AND. (KMI /=1)) THEN
+ WRITE(UNIT=ILUOUT,FMT=9003) KMI
+ WRITE(ILUOUT,FMT=*) 'YOU WANT TO USE THE HORIZONTAL RELAXATION '
+ WRITE(ILUOUT,FMT=*) 'FOR A NESTED MODEL BUT THE COUPLING IS ALREADY DONE'
+ WRITE(ILUOUT,FMT=*) 'BY THE GRID NESTING. CHANGE LHORELAX TO FALSE'
+ !callabortstop
+ CALL PRINT_MSG(NVERB_FATAL,'GEN','READ_EXSEG_n','')
+END IF
+!
+IF (KMI==1) THEN
+ GRELAX = .NOT.(OUSERV) .AND. LUSERV .AND. LHORELAX_RV
+ELSE
+ GRELAX = .NOT.(LUSERV_G(NDAD(KMI))) .AND. LUSERV_G(KMI).AND. LHORELAX_RV
+END IF
+!
+IF ( GRELAX ) THEN
+ LHORELAX_RV=.FALSE.
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(ILUOUT,FMT=*) 'YOU WANT TO RELAX THE RV FIELD'
+ WRITE(ILUOUT,FMT=*) 'TOWARDS THE LARGE SCALE FIELD OF MODEL',NDAD(KMI)
+ WRITE(ILUOUT,FMT=*) 'BUT IT DOES NOT EXIST.'
+ WRITE(ILUOUT,FMT=*) 'THEREFORE LHORELAX_RV=FALSE'
+END IF
+!
+IF (KMI==1) THEN
+ GRELAX = .NOT.(OUSERC) .AND. LUSERC .AND. LHORELAX_RC
+ELSE
+ GRELAX = .NOT.(LUSERC_G(NDAD(KMI))) .AND. LUSERC_G(KMI).AND. LHORELAX_RC
+END IF
+!
+IF ( GRELAX ) THEN
+ LHORELAX_RC=.FALSE.
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(ILUOUT,FMT=*) 'YOU WANT TO RELAX THE RC FIELD'
+ WRITE(ILUOUT,FMT=*) 'TOWARDS THE LARGE SCALE FIELD OF MODEL',NDAD(KMI)
+ WRITE(ILUOUT,FMT=*) 'BUT IT DOES NOT EXIST.'
+ WRITE(ILUOUT,FMT=*) 'THEREFORE LHORELAX_RC=FALSE'
+END IF
+!
+IF (KMI==1) THEN
+ GRELAX = .NOT.(OUSERR) .AND. LUSERR .AND. LHORELAX_RR
+ELSE
+ GRELAX = .NOT.(LUSERR_G(NDAD(KMI))) .AND. LUSERR_G(KMI).AND. LHORELAX_RR
+END IF
+!
+IF ( GRELAX ) THEN
+ LHORELAX_RR=.FALSE.
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(ILUOUT,FMT=*) 'YOU WANT TO RELAX THE RR FIELD'
+ WRITE(ILUOUT,FMT=*) 'TOWARDS THE LARGE SCALE FIELD OF MODEL',NDAD(KMI)
+ WRITE(ILUOUT,FMT=*) 'BUT IT DOES NOT EXIST.'
+ WRITE(ILUOUT,FMT=*) 'THEREFORE LHORELAX_RR=FALSE'
+END IF
+!
+IF (KMI==1) THEN
+ GRELAX = .NOT.(OUSERI) .AND. LUSERI .AND. LHORELAX_RI
+ELSE
+ GRELAX = .NOT.(LUSERI_G(NDAD(KMI))) .AND. LUSERI_G(KMI).AND. LHORELAX_RI
+END IF
+!
+IF ( GRELAX ) THEN
+ LHORELAX_RI=.FALSE.
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(ILUOUT,FMT=*) 'YOU WANT TO RELAX THE RI FIELD'
+ WRITE(ILUOUT,FMT=*) 'TOWARDS THE LARGE SCALE FIELD OF MODEL',NDAD(KMI)
+ WRITE(ILUOUT,FMT=*) 'BUT IT DOES NOT EXIST.'
+ WRITE(ILUOUT,FMT=*) 'THEREFORE LHORELAX_RI=FALSE'
+END IF
+!
+IF (KMI==1) THEN
+ GRELAX = .NOT.(OUSERG) .AND. LUSERG .AND. LHORELAX_RG
+ELSE
+ GRELAX = .NOT.(LUSERG_G(NDAD(KMI))) .AND. LUSERG_G(KMI).AND. LHORELAX_RG
+END IF
+!
+IF ( GRELAX ) THEN
+ LHORELAX_RG=.FALSE.
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(ILUOUT,FMT=*) 'YOU WANT TO RELAX THE RG FIELD'
+ WRITE(ILUOUT,FMT=*) 'TOWARDS THE LARGE SCALE FIELD OF MODEL',NDAD(KMI)
+ WRITE(ILUOUT,FMT=*) 'BUT IT DOES NOT EXIST.'
+ WRITE(ILUOUT,FMT=*) 'THEREFORE LHORELAX_RG=FALSE'
+END IF
+!
+IF (KMI==1) THEN
+ GRELAX = .NOT.(OUSERH) .AND. LUSERH .AND. LHORELAX_RH
+ELSE
+ GRELAX = .NOT.(LUSERH_G(NDAD(KMI))) .AND. LUSERH_G(KMI).AND. LHORELAX_RH
+END IF
+!
+IF ( GRELAX ) THEN
+ LHORELAX_RH=.FALSE.
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(ILUOUT,FMT=*) 'YOU WANT TO RELAX THE RH FIELD'
+ WRITE(ILUOUT,FMT=*) 'TOWARDS THE LARGE SCALE FIELD OF MODEL',NDAD(KMI)
+ WRITE(ILUOUT,FMT=*) 'BUT IT DOES NOT EXIST.'
+ WRITE(ILUOUT,FMT=*) 'THEREFORE LHORELAX_RH=FALSE'
+END IF
+!
+IF (KMI==1) THEN
+ GRELAX = .NOT.(OUSERS) .AND. LUSERS .AND. LHORELAX_RS
+ELSE
+ GRELAX = .NOT.(LUSERS_G(NDAD(KMI))) .AND. LUSERS_G(KMI).AND. LHORELAX_RS
+END IF
+!
+IF ( GRELAX ) THEN
+ LHORELAX_RS=.FALSE.
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(ILUOUT,FMT=*) 'YOU WANT TO RELAX THE RS FIELD'
+ WRITE(ILUOUT,FMT=*) 'TOWARDS THE LARGE SCALE FIELD OF MODEL',NDAD(KMI)
+ WRITE(ILUOUT,FMT=*) 'BUT IT DOES NOT EXIST.'
+ WRITE(ILUOUT,FMT=*) 'THEREFORE LHORELAX_RS=FALSE'
+END IF
+!
+IF (KMI==1) THEN
+ GRELAX = HTURB=='NONE' .AND. LUSETKE(1).AND. LHORELAX_TKE
+ELSE
+ GRELAX = .NOT.(LUSETKE(NDAD(KMI))) .AND. LUSETKE(KMI) .AND. LHORELAX_TKE
+END IF
+!
+IF ( GRELAX ) THEN
+ LHORELAX_TKE=.FALSE.
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(ILUOUT,FMT=*) 'YOU WANT TO RELAX THE TKE FIELD'
+ WRITE(ILUOUT,FMT=*) 'TOWARDS THE LARGE SCALE FIELD OF MODEL',NDAD(KMI)
+ WRITE(ILUOUT,FMT=*) 'BUT IT DOES NOT EXIST.'
+ WRITE(ILUOUT,FMT=*) 'THEREFORE LHORELAX_TKE=FALSE'
+END IF
+!
+!
+DO JSV = 1,NSV_USER
+!
+ IF (KMI==1) THEN
+ GRELAX = KSV_USER<JSV .AND. LUSESV(JSV,1).AND. LHORELAX_SV(JSV)
+ ELSE
+ GRELAX = .NOT.(LUSESV(JSV,NDAD(KMI))) .AND. LUSESV(JSV,KMI) .AND. LHORELAX_SV(JSV)
+ END IF
+ !
+ IF ( GRELAX ) THEN
+ LHORELAX_SV(JSV)=.FALSE.
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(ILUOUT,FMT=*) 'YOU WANT TO RELAX THE ',JSV,' SV FIELD'
+ WRITE(ILUOUT,FMT=*) 'TOWARDS THE LARGE SCALE FIELD OF MODEL',NDAD(KMI)
+ WRITE(ILUOUT,FMT=*) 'BUT IT DOES NOT EXIST.'
+ WRITE(ILUOUT,FMT=*) 'THEREFORE LHORELAX_SV(',JSV,')=FALSE'
+ END IF
+END DO
+!
+!* 4.6 consistency in LES diagnostics choices
+!
+IF (CLES_NORM_TYPE=='EKMA' .AND. .NOT. LCORIO) THEN
+ WRITE(UNIT=ILUOUT,FMT=9002) KMI
+ WRITE(ILUOUT,FMT=*) 'YOU WANT TO USE THE EKMAN NORMALIZATION'
+ WRITE(ILUOUT,FMT=*) 'BUT CORIOLIS FORCE IS NOT USED (LCORIO=.FALSE.)'
+ WRITE(ILUOUT,FMT=*) 'THEN, NO NORMALIZATION IS PERFORMED'
+ CLES_NORM_TYPE='NONE'
+END IF
+!
+!* 4.7 Check the coherence with LNUMDIFF
+!
+IF (L1D .AND. (LNUMDIFU .OR. LNUMDIFTH .OR. LNUMDIFSV) ) THEN
+ WRITE(UNIT=ILUOUT,FMT=9002) KMI
+ WRITE(ILUOUT,FMT=*) 'YOU WANT TO USE HORIZONTAL DIFFUSION '
+ WRITE(ILUOUT,FMT=*) 'BUT YOU ARE IN A COLUMN MODEL (L1D=.TRUE.).'
+ WRITE(ILUOUT,FMT=*) 'THEREFORE LNUMDIFU and LNUMDIFTH and LNUMDIFSV'
+ WRITE(ILUOUT,FMT=*) 'ARE SET TO FALSE'
+ LNUMDIFU=.FALSE.
+ LNUMDIFTH=.FALSE.
+ LNUMDIFSV=.FALSE.
+END IF
+!
+IF (.NOT. LNUMDIFTH .AND. LZDIFFU) THEN
+ WRITE(UNIT=ILUOUT,FMT=9002) KMI
+ WRITE(ILUOUT,FMT=*) 'YOU DO NOT WANT TO USE HORIZONTAL DIFFUSION (LNUMDIFTH=F)'
+ WRITE(ILUOUT,FMT=*) 'BUT YOU WANT TO USE Z-NUMERICAL DIFFUSION '
+ WRITE(ILUOUT,FMT=*) 'THEREFORE LNUMDIFTH IS SET TO TRUE'
+ LNUMDIFTH=.TRUE.
+END IF
+!
+!* 4.8 Other
+!
+IF (XTNUDGING < 4.*XTSTEP) THEN
+ XTNUDGING = 4.*XTSTEP
+ WRITE(UNIT=ILUOUT,FMT=9002) KMI
+ WRITE(UNIT=ILUOUT,FMT='("TIME SCALE FOR NUDGING CAN NOT BE SMALLER THAN", &
+ & " FOUR TIMES THE TIME STEP")')
+ WRITE(ILUOUT,FMT=*) 'XTNUDGING is SET TO ',XTNUDGING
+END IF
+!
+!
+IF (XWAY(KMI) == 3. ) THEN
+ XWAY(KMI) = 2.
+ WRITE(UNIT=ILUOUT,FMT=9002) KMI
+ WRITE(UNIT=ILUOUT,FMT='("XWAY=3 DOES NOT EXIST ANYMORE; ", &
+ & " IT IS REPLACED BY XWAY=2 ")')
+END IF
+!
+IF ( (KMI == 1) .AND. XWAY(KMI) /= 0. ) THEN
+ XWAY(KMI) = 0.
+ WRITE(UNIT=ILUOUT,FMT=9002) KMI
+ WRITE(UNIT=ILUOUT,FMT='("XWAY MUST BE EQUAL TO 0 FOR DAD MODEL")')
+END IF
+!
+!JUANZ ZRESI solver need BSPLITTING
+IF ( CPRESOPT == 'ZRESI' .AND. CSPLIT /= 'BSPLITTING' ) THEN
+ WRITE(UNIT=ILUOUT,FMT=9003) KMI
+ WRITE(UNIT=ILUOUT,FMT='("Paralleliez in Z solver CPRESOPT=ZRESI need also CSPLIT=BSPLITTING ")')
+ WRITE(ILUOUT,FMT=*) ' ERROR you have to set also CSPLIT=BSPLITTING '
+ !callabortstop
+ CALL PRINT_MSG(NVERB_FATAL,'GEN','READ_EXSEG_n','')
+END IF
+!
+IF ( LEN_TRIM(HINIFILEPGD)>0 ) THEN
+ IF ( CINIFILEPGD/=HINIFILEPGD ) THEN
+ WRITE(UNIT=ILUOUT,FMT=9001) KMI
+ WRITE(ILUOUT,FMT=*) ' ERROR : in EXSEG1.nam, in NAM_LUNITn you have CINIFILEPGD= ',CINIFILEPGD
+ WRITE(ILUOUT,FMT=*) ' whereas in .des you have CINIFILEPGD= ',HINIFILEPGD
+ WRITE(ILUOUT,FMT=*) ' Please check your Namelist '
+ WRITE(ILUOUT,FMT=*) ' For example, you may have specified the un-nested PGD file instead of the nested PGD file '
+ WRITE(ILUOUT,FMT=*)
+ WRITE(ILUOUT,FMT=*) '###############'
+ WRITE(ILUOUT,FMT=*) ' MESONH ABORTS'
+ WRITE(ILUOUT,FMT=*) '###############'
+ WRITE(ILUOUT,FMT=*)
+ !callabortstop
+ CALL PRINT_MSG(NVERB_FATAL,'GEN','READ_EXSEG_n','')
+ END IF
+ELSE
+ CINIFILEPGD = ''
+!* note that after a spawning, there is no value for CINIFILEPGD in the .des file,
+! so the checking cannot be made if the user starts a simulation directly from
+! a spawned file (without the prep_real_case stage)
+END IF
+!-------------------------------------------------------------------------------
+!
+!* 5. WE DO NOT FORGET TO UPDATE ALL DOLLARN NAMELIST VARIABLES
+! ---------------------------------------------------------
+!
+CALL UPDATE_NAM_LUNITN
+CALL UPDATE_NAM_CONFN
+CALL UPDATE_NAM_DYNN
+CALL UPDATE_NAM_ADVN
+CALL UPDATE_NAM_PARAMN
+CALL UPDATE_NAM_PARAM_RADN
+#ifdef MNH_ECRAD
+CALL UPDATE_NAM_PARAM_ECRADN
+#endif
+CALL UPDATE_NAM_PARAM_KAFRN
+CALL UPDATE_NAM_PARAM_MFSHALLN
+CALL UPDATE_NAM_LBCN
+CALL UPDATE_NAM_NUDGINGN
+CALL UPDATE_NAM_TURBN
+CALL UPDATE_NAM_CH_MNHCN
+CALL UPDATE_NAM_CH_SOLVERN
+CALL UPDATE_NAM_SERIESN
+CALL UPDATE_NAM_BLOWSNOWN
+!-------------------------------------------------------------------------------
+WRITE(UNIT=ILUOUT,FMT='(/)')
+!-------------------------------------------------------------------------------
+!
+!* 6. FORMATS
+! -------
+!
+9000 FORMAT(/,'NOTE IN READ_EXSEG FOR MODEL ', I2, ' : ',/, &
+ '--------------------------------')
+9001 FORMAT(/,'CAUTION ERROR IN READ_EXSEG FOR MODEL ', I2,' : ',/, &
+ '----------------------------------------' )
+9002 FORMAT(/,'WARNING IN READ_EXSEG FOR MODEL ', I2,' : ',/, &
+ '----------------------------------' )
+9003 FORMAT(/,'FATAL ERROR IN READ_EXSEG FOR MODEL ', I2,' : ',/, &
+ '--------------------------------------' )
+!
+!-------------------------------------------------------------------------------
+!
+END SUBROUTINE READ_EXSEG_n
diff --git a/src/ZSOLVER/spectre.f90 b/src/ZSOLVER/spectre.f90
new file mode 100644
index 0000000000000000000000000000000000000000..545c60629410ef29c5a16bfd5289f96038c41e28
--- /dev/null
+++ b/src/ZSOLVER/spectre.f90
@@ -0,0 +1,217 @@
+!MNH_LIC Copyright 2011-2019 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.
+!-----------------------------------------------------------------
+! ######spl
+ PROGRAM SPECTRE
+! ############
+!
+!!****
+!!
+!! PURPOSE
+!! -------
+!! compute energy spectra from a MESONH file
+!!
+!!
+!!
+!!
+!! Modifications:
+!! Philippe Wautelet: 05/2016-04/2018: new data structures and calls for I/O
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+!
+USE MODD_CONF
+USE MODD_IO, ONLY: NIO_VERB,NVERB_DEBUG,TFILEDATA
+USE MODD_LUNIT
+USE MODD_LUNIT_n
+USE MODD_TIME_n
+USE MODD_DIM_ll
+USE MODD_SPECTRE
+!
+USE MODI_SPECTRE_MESONH
+USE MODI_SPECTRE_AROME
+!
+USE MODE_MSG
+USE MODE_POS
+USE MODE_IO, only: IO_Config_set, IO_Init
+USE MODE_IO_FILE, only: IO_File_close, IO_File_open
+USE MODE_IO_MANAGE_STRUCT, only: IO_File_add2list, IO_Filelist_print
+use mode_init_ll, only: END_PARA_ll
+USE MODE_MODELN_HANDLER
+!USE MODD_TYPE_DATE
+USE MODI_VERSION
+!
+USE MODN_CONFZ
+USE MODN_CONFIO, ONLY : NAM_CONFIO
+!
+IMPLICIT NONE
+!
+!* 0.1 declarations of local variables
+!
+CHARACTER (LEN=28), DIMENSION(1) :: YINIFILE ! names of the INPUT FM-file
+CHARACTER (LEN=50) :: YOUTFILE ! names of the OUTPUT FM-file
+INTEGER :: IRESP ! return code in FM routines
+INTEGER :: ILUOUT0 ! Logical unit number for the output listing
+INTEGER :: ILUNAM ! Logical unit numbers for the namelist file
+ ! and for output_listing file
+LOGICAL :: GFOUND ! Return code when searching namelist
+!
+INTEGER :: IINFO_ll ! return code for _ll routines
+!
+REAL,DIMENSION(:,:,:),ALLOCATABLE:: ZWORK ! work array
+REAL,DIMENSION(:,:,:),ALLOCATABLE:: ZWORKAROME ! work array
+INTEGER :: NI,NJ,NK
+REAL ::XDELTAX,XDELTAY
+TYPE(TFILEDATA),POINTER :: TZNMLFILE => NULL()
+!
+NAMELIST/NAM_SPECTRE/ LSPECTRE_U,LSPECTRE_V,LSPECTRE_W,LSPECTRE_TH,LSPECTRE_RV,&
+ LSPECTRE_LSU,LSPECTRE_LSV,LSPECTRE_LSW,LSPECTRE_LSTH,LSPECTRE_LSRV,LSMOOTH
+!
+NAMELIST/NAM_SPECTRE_FILE/ YINIFILE,CTYPEFILE,YOUTFILE,LSTAT
+NAMELIST/NAM_ZOOM_SPECTRE/ LZOOM,NITOT,NJTOT,NXDEB,NYDEB
+NAMELIST/NAM_DOMAIN_AROME/ NI,NJ,NK,XDELTAX,XDELTAY
+!
+!-------------------------------------------------------------------------------
+!
+!* 0.0 Initializations
+! ---------------
+!
+!
+CALL GOTO_MODEL(1)
+!
+CALL VERSION
+CPROGRAM='SPEC '
+!
+CALL IO_Init()
+!
+! initialization
+YINIFILE(:) = ' '
+CTYPEFILE = 'MESONH'
+LSPECTRE_U = .FALSE.
+LSPECTRE_V = .FALSE.
+LSPECTRE_W = .FALSE.
+LSPECTRE_TH = .FALSE.
+LSPECTRE_RV = .FALSE.
+LSPECTRE_LSU = .FALSE.
+LSPECTRE_LSV = .FALSE.
+LSPECTRE_LSW = .FALSE.
+LSPECTRE_LSTH = .FALSE.
+LSPECTRE_LSRV = .FALSE.
+LSMOOTH = .FALSE.
+LZOOM = .FALSE.
+YOUTFILE = ' '
+LSTAT = .FALSE.
+NI=750
+NJ=720
+NK=60
+XDELTAX=2500.
+XDELTAY=2500.
+!
+!
+!-------------------------------------------------------------------------------
+!
+!* 1.0 Namelist reading
+! ----------------
+!
+PRINT*, ' '
+PRINT*, '*********************************************************************'
+PRINT*, '*********************************************************************'
+PRINT*, ' '
+!
+CALL IO_File_add2list(TZNMLFILE,'SPEC1.nam','NML','READ')
+CALL IO_File_open(TZNMLFILE)
+ILUNAM = TZNMLFILE%NLU
+!
+PRINT*, 'READ THE SPEC1.NAM FILE'
+!
+CALL POSNAM(ILUNAM,'NAM_SPECTRE',GFOUND)
+IF (GFOUND) THEN
+ READ(UNIT=ILUNAM,NML=NAM_SPECTRE)
+ PRINT*, ' namelist NAM_SPECTRE read'
+END IF
+!
+!
+CALL POSNAM(ILUNAM,'NAM_SPECTRE_FILE',GFOUND)
+IF (GFOUND) THEN
+ READ(UNIT=ILUNAM,NML=NAM_SPECTRE_FILE)
+ PRINT*, ' namelist NAM_SPECTRE_FILE read'
+END IF
+!
+CALL POSNAM(ILUNAM,'NAM_ZOOM_SPECTRE',GFOUND)
+IF (GFOUND) THEN
+ READ(UNIT=ILUNAM,NML=NAM_ZOOM_SPECTRE)
+ PRINT*, ' namelist NAM_ZOOM_SPECTRE read'
+END IF
+!
+CALL POSNAM(ILUNAM,'NAM_DOMAIN_AROME',GFOUND)
+IF (GFOUND) THEN
+ READ(UNIT=ILUNAM,NML=NAM_DOMAIN_AROME)
+ PRINT*, ' namelist NAM_DOMAIN_AROME read'
+END IF
+!
+CALL POSNAM(ILUNAM,'NAM_CONFZ',GFOUND)
+IF (GFOUND) THEN
+ READ(UNIT=ILUNAM,NML=NAM_CONFZ)
+ PRINT*, ' namelist NAM_CONFZ read'
+END IF
+!
+CALL POSNAM(ILUNAM,'NAM_CONFIO',GFOUND)
+IF (GFOUND) THEN
+ READ(UNIT=ILUNAM,NML=NAM_CONFIO)
+ PRINT*, ' namelist NAM_CONFIO read'
+END IF
+CALL IO_Config_set()
+!
+CALL IO_File_close(TZNMLFILE)
+!
+CINIFILE = YINIFILE(1)
+!
+!-------------------------------------------------------------------------------
+!
+!* 2.0 file
+! -----------
+!
+IF ( LEN_TRIM(CINIFILE)==0 ) THEN
+ CALL PRINT_MSG(NVERB_FATAL,'GEN','SPECTRE','LEN_TRIM(CINIFILE)==0')
+ENDIF
+!
+IF ( LEN_TRIM(YOUTFILE)==0 ) THEN
+ WRITE(YOUTFILE,FMT='(A,A)') "spectra_",TRIM(ADJUSTL(CINIFILE))
+ENDIF
+!
+!-------------------------------------------------------------------------------
+!
+!* 3.0 Fields initialization and spectra computation
+!
+IF (CTYPEFILE=='MESONH') THEN
+ CALL SPECTRE_MESONH(YOUTFILE)
+ !
+ CALL IO_File_close(LUNIT_MODEL(1)%TINIFILE)
+ IF(NIO_VERB>=NVERB_DEBUG) CALL IO_Filelist_print()
+ CALL IO_File_close(TLUOUT0)
+ CALL IO_File_close(TLUOUT)
+ELSEIF (CTYPEFILE=='AROME ')THEN
+ CALL SPECTRE_AROME(CINIFILE,YOUTFILE,XDELTAX,XDELTAY,NI,NJ,NK)
+ELSE
+ print*,"This type of file is not accept for SPECTRE PROGRAM"
+ENDIF
+!
+!-------------------------------------------------------------------------------
+!
+!* 4. FINALIZE THE PARALLEL SESSION
+! -----------------------------
+!
+CALL END_PARA_ll(IINFO_ll)
+!
+PRINT*, ' '
+PRINT*, '****************************************************'
+PRINT*, '* EXIT SPECTRE CORRECTLY *'
+PRINT*, '****************************************************'
+PRINT*, ' '
+!-------------------------------------------------------------------------------
+END PROGRAM SPECTRE
+
diff --git a/src/ZSOLVER/tensorproductmultigrid_Source/communication.f90 b/src/ZSOLVER/tensorproductmultigrid_Source/communication.f90
new file mode 100644
index 0000000000000000000000000000000000000000..794ac3a6f7c58f7c1bfdfb1baf02ed5b37386273
--- /dev/null
+++ b/src/ZSOLVER/tensorproductmultigrid_Source/communication.f90
@@ -0,0 +1,2022 @@
+!=== COPYRIGHT AND LICENSE STATEMENT ===
+!
+! This file is part of the TensorProductMultigrid code.
+!
+! (c) The copyright relating to this work is owned jointly by the
+! Crown, Met Office and NERC [2014]. However, it has been created
+! with the help of the GungHo Consortium, whose members are identified
+! at https://puma.nerc.ac.uk/trac/GungHo/wiki .
+!
+! Main Developer: Eike Mueller
+!
+! TensorProductMultigrid is free software: you can redistribute it and/or
+! modify it under the terms of the GNU Lesser General Public License as
+! published by the Free Software Foundation, either version 3 of the
+! License, or (at your option) any later version.
+!
+! TensorProductMultigrid is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU Lesser General Public License for more details.
+!
+! You should have received a copy of the GNU Lesser General Public License
+! along with TensorProductMultigrid (see files COPYING and COPYING.LESSER).
+! If not, see <http://www.gnu.org/licenses/>.
+!
+!=== COPYRIGHT AND LICENSE STATEMENT ===
+
+
+!==================================================================
+!
+! MPI communication routines for multigrid code
+!
+! Eike Mueller, University of Bath, Feb 2012
+!
+!==================================================================
+
+module communication
+ use messages
+ use datatypes
+
+#ifndef MNH
+ use mpi
+#else
+ use modd_mpif
+#endif
+ use timer
+
+ use mode_mnh_allocate_mg_halo
+
+ implicit none
+
+public::comm_preinitialise
+public::comm_initialise
+public::comm_finalise
+public::scalarprod_mnh
+public::scalarprod
+public::print_scalaprod2
+public::boundary_mnh
+public::haloswap_mnh
+public::haloswap
+public::ihaloswap_mnh
+public::ihaloswap
+public::collect
+public::distribute
+public::i_am_master_mpi
+public::master_rank
+public::pproc
+public::MPI_COMM_HORIZ
+public::comm_parameters
+public::comm_measuretime
+
+
+ ! Number of processors
+ ! n_proc = 2^(2*pproc), with integer pproc
+ integer :: pproc
+
+! Rank of master process
+ integer, parameter :: master_rank = 0
+! Am I the master process?
+ logical :: i_am_master_mpi
+
+ integer, parameter :: dim = 3 ! Dimension
+ integer, parameter :: dim_horiz = 2 ! Horizontal dimension
+ integer :: MPI_COMM_HORIZ ! Communicator with horizontal partitioning
+
+private
+
+! Data types for halo exchange in both x- and y-direction
+ integer, dimension(:,:,:), allocatable :: halo_type
+
+! Array for Halo Exchange <-> GPU copy/managed
+ type type_halo_T
+ real, dimension(:,:,:), pointer, contiguous :: haloTin,haloTout
+ end type type_halo_T
+! MPI vector data types
+ ! Halo for data exchange in north-south direction
+ integer, allocatable, dimension(:,:) :: halo_ns
+ integer, allocatable, dimension(:,:) :: halo_nst
+ type(type_halo_T), allocatable, dimension(:,:) :: tab_halo_nt
+ type(type_halo_T), allocatable, dimension(:,:) :: tab_halo_st
+ integer, allocatable, dimension(:,:) :: halo_wet
+ type(type_halo_T), allocatable, dimension(:,:) :: tab_halo_wt
+ type(type_halo_T), allocatable, dimension(:,:) :: tab_halo_et
+ ! Vector data type for interior of field a(level,m)
+ integer, allocatable, dimension(:,:) :: interior
+ integer, allocatable, dimension(:,:) :: interiorT
+ type(type_halo_T), allocatable, dimension(:,:) :: tab_interiorT_ne,tab_interiorT_sw,tab_interiorT_se
+ ! Vector data type for one quarter of interior of field
+ ! at level a(level,m). This has the same size (and can be
+ ! used for communications with) the interior of a(level,m+1)
+ integer, allocatable, dimension(:,:) :: sub_interior
+ integer, allocatable, dimension(:,:) :: sub_interiorT
+ type(type_halo_T), allocatable, dimension(:,:) :: tab_sub_interiorT_ne,tab_sub_interiorT_sw,tab_sub_interiorT_se
+ ! Timer for halo swaps
+ type(time), allocatable, dimension(:,:) :: t_haloswap
+ ! Timer for collect and distribute
+ type(time), allocatable, dimension(:) :: t_collect
+ type(time), allocatable, dimension(:) :: t_distribute
+ ! Parallelisation parameters
+ ! Measure communication times?
+ logical :: comm_measuretime
+
+ ! Parallel communication parameters
+ type comm_parameters
+ ! Size of halos
+ integer :: halo_size
+ end type comm_parameters
+
+ type(comm_parameters) :: comm_param
+
+! Data layout
+! ===========
+!
+! The number of processes has to be of the form nproc = 2^(2*pproc) to
+! ensure that data can be distributed between processes.
+! The processes are arranged in a (2^pproc) x (2^pproc) cartesian grid
+! in the horizontal plane (i.e. vertical columns are always local to one
+! process), which is implemented via the communicator MPI_COMM_HORIZ.
+! This MPI_cart_rank() and MPI_cart_shift() can then be used to
+! easily identify neighbouring processes.
+
+! The number of data grid cells in each direction has to be a multiply
+! of 2**(L-1) where L is the number of levels (including the coarse
+! and fine level), with the coarse level corresponding to level=1.
+! Also define L_split as the level where we start to pull together
+! data. For levels > L_split each position in the cartesian grid is
+! included in the work, below this only a subset of processes is
+! used.
+!
+! Each grid a(level,m) is identified by two numbers:
+! (1) The multigrid level it belongs to (level)
+! (2) The number of active processes that operate on it (2^(2*m)).
+!
+! For level > L_split, m=procp. For L_split we store a(L_split,pproc) and
+! a(L_split,pproc-1), and only processes with even coordinates in both
+! horizontal directions use this grid.
+! Below that level, store a(L_split-1,pproc-1) and a(L_split-1,pproc-2),
+! where only processes for which both horiontal coordinates are
+! multiples of four use the latter. This is continued until only on
+! process is left.
+!
+!
+! level
+! L a(L,pproc)
+! L-1 a(L-1,pproc)
+! ...
+! L_split a(L_split,pproc) a(L_split ,pproc-1)
+! L_split-1 a(L_split-1,pproc-1) a(L_split-1,pproc-2)
+!
+! ... a(3,1)
+! a(2,1)
+! a(1,1)
+!
+! When moving from left to right in the above graph the total number of
+! grid cells does not change, but the number of data points per process
+! increases by a factor of 4.
+!
+! Parallel operations
+! ===================
+!
+! (*) Halo exchange. Update halo with data from neighbouring
+! processors in cartesian grid on current (level,m)
+! (*) Collect data on all processes at (level,m) on those
+! processes that are still active on (level,m-1).
+! (*) Distribute data at (level,m-1) and duplicate on all processes
+! that are active at (level,m).
+!
+! Note that in the cartesian processor grid the first coordinate
+! is the North-South (y-) direction, the second coordinate is the
+! East-West (x-) direction, i.e. the layout is this:
+!
+! p_0 (0,0) p_1 (0,1) p_2 (0,2) p_3 (0,3)
+!
+! p_4 (1,0) p_5 (1,1) p_6 (1,2) p_7 (1,3)
+!
+! p_8 (2,0) p_9 (2,1) p_10 (2,2) p_11 (2,3)
+!
+! [...]
+!
+!
+! Normal multigrid restriction and prolongation are used to
+! move between levels with fixed m.
+!
+!
+
+contains
+
+!==================================================================
+! Pre-initialise communication routines
+!==================================================================
+ subroutine comm_preinitialise()
+ implicit none
+ integer :: nproc, ierr, rank
+ call mpi_comm_size(MPI_COMM_WORLD, nproc, ierr)
+ call mpi_comm_rank(MPI_COMM_WORLD, rank, ierr)
+ i_am_master_mpi = (rank == master_rank)
+ ! Check that nproc = 2^(2*p)
+ pproc = floor(log(1.0d0*nproc)/log(4.0d0))
+ if ( (nproc - 4**pproc) .ne. 0) then
+ call fatalerror("Number of processors has to be 2^(2*pproc) with integer pproc.")
+ end if
+ if (i_am_master_mpi) then
+ write(STDOUT,'("PARALLEL RUN")')
+ write(STDOUT,'("Number of processors : 2^(2*pproc) = ",I10," with pproc = ",I6)') &
+ nproc, pproc
+ end if
+ ! Create halo data types
+
+ end subroutine comm_preinitialise
+
+!==================================================================
+! Initialise communication routines
+!==================================================================
+ subroutine comm_initialise(n_lev, & !} multigrid parameters
+ lev_split, & !}
+ grid_param, & ! Grid parameters
+ comm_param_in) ! Parallel communication
+ ! parameters
+ implicit none
+ integer, intent(in) :: n_lev
+ integer, intent(in) :: lev_split
+ type(grid_parameters), intent(inout) :: grid_param
+ type(comm_parameters), intent(in) :: comm_param_in
+ integer :: n
+ integer :: nz
+ integer :: rank, nproc, ierr
+ integer :: count, blocklength, stride
+ integer, dimension(2) :: p_horiz
+ integer :: m, level, nlocal
+ logical :: reduced_m
+ integer :: halo_size
+ character(len=32) :: t_label
+
+ integer,parameter :: nb_dims=3
+ integer,dimension(nb_dims) :: profil_tab,profil_sous_tab,coord_debut
+
+ n = grid_param%n
+ nz = grid_param%nz
+
+ comm_param = comm_param_in
+ halo_size = comm_param%halo_size
+
+ call mpi_comm_size(MPI_COMM_WORLD, nproc, ierr)
+
+ ! Create cartesian topology
+ call mpi_cart_create(MPI_COMM_WORLD, & ! Old communicator name
+ dim_horiz, & ! horizontal dimension
+ (/2**pproc,2**pproc/), & ! extent in each horizontal direction
+ (/.false.,.false./), & ! periodic?
+ .true., & ! reorder?
+ MPI_COMM_HORIZ, & ! Name of new communicator
+ ierr)
+ ! calculate and display rank and corrdinates in cartesian grid
+ call mpi_comm_rank(MPI_COMM_HORIZ, rank, ierr)
+ call mpi_cart_coords(MPI_COMM_HORIZ,rank,dim_horiz,p_horiz,ierr)
+
+ ! Local size of (horizontal) grid
+ nlocal = n/2**pproc
+
+ ! === Set up data types ===
+ ! Halo for exchange in north-south direction
+ if (LUseO) allocate(halo_ns(n_lev,0:pproc))
+ if (LUseT) allocate(halo_nst(n_lev,0:pproc))
+ if (LUseT) allocate(tab_halo_nt(n_lev,0:pproc))
+ if (LUseT) allocate(tab_halo_st(n_lev,0:pproc))
+ if (LUseT) allocate(halo_wet(n_lev,0:pproc))
+ if (LUseT) allocate(tab_halo_wt(n_lev,0:pproc))
+ if (LUseT) allocate(tab_halo_et(n_lev,0:pproc))
+ ! Interior data types
+ if (LUseO) allocate(interior(n_lev,0:pproc))
+ if (LUseO) allocate(sub_interior(n_lev,0:pproc))
+ if (LUseT) allocate(interiorT(n_lev,0:pproc))
+ if (LUseT) allocate(sub_interiorT(n_lev,0:pproc))
+ if (LUseT) allocate(tab_interiorT_ne(n_lev,0:pproc))
+ if (LUseT) allocate(tab_interiorT_sw(n_lev,0:pproc))
+ if (LUseT) allocate(tab_interiorT_se(n_lev,0:pproc))
+ if (LUseT) allocate(tab_sub_interiorT_ne(n_lev,0:pproc))
+ if (LUseT) allocate(tab_sub_interiorT_sw(n_lev,0:pproc))
+ if (LUseT) allocate(tab_sub_interiorT_se(n_lev,0:pproc))
+ ! Timer
+ allocate(t_haloswap(n_lev,0:pproc))
+ allocate(t_collect(0:pproc))
+ allocate(t_distribute(0:pproc))
+ do m=0,pproc
+ write(t_label,'("t_collect(",I3,")")') m
+ call initialise_timer(t_collect(m),t_label)
+ write(t_label,'("t_distribute(",I3,")")') m
+ call initialise_timer(t_distribute(m),t_label)
+ end do
+
+ m = pproc
+ level = n_lev
+ reduced_m = .false.
+ do while (level > 0)
+ ! --- Create halo data types ---
+ if (LUseO) then
+ ! NS- (y-) direction
+ count = nlocal
+ blocklength = (nz+2)*halo_size
+ stride = (nlocal+2*halo_size)*(nz+2)
+ call mpi_type_vector(count,blocklength,stride,MPI_DOUBLE_PRECISION, &
+ halo_ns(level,m),ierr)
+ call mpi_type_commit(halo_ns(level,m),ierr)
+ endif
+ ! tranpose
+ if (LUseT) then
+ ! NS- (y-) transpose direction
+ count = nz+2 ! nlocal
+ blocklength = nlocal*halo_size ! (nz+2)*halo_size
+ stride = (nlocal+2*halo_size) * (nlocal+2*halo_size) ! (nlocal+2*halo_size)*(nz+2)
+ call mpi_type_vector(count,blocklength,stride,MPI_DOUBLE_PRECISION, &
+ halo_nst(level,m),ierr)
+ call mpi_type_commit(halo_nst(level,m),ierr)
+ ! allocate send/recv buffer for GPU copy/managed
+ call mnh_allocate_mg_halo(tab_halo_nt(level,m)%haloTin,nlocal,halo_size,nz+2)
+ call mnh_allocate_mg_halo(tab_halo_nt(level,m)%haloTout,nlocal,halo_size,nz+2)
+ call mnh_allocate_mg_halo(tab_halo_st(level,m)%haloTin,nlocal,halo_size,nz+2)
+ call mnh_allocate_mg_halo(tab_halo_st(level,m)%haloTout,nlocal,halo_size,nz+2)
+
+ ! WE- (x-) transpose direction
+ count = (nz+2)*(nlocal+2*halo_size)*halo_size ! nlocal
+ blocklength = 1*halo_size ! (nz+2)*halo_size
+ stride = nlocal+2*halo_size ! (nlocal+2*halo_size)*(nz+2)
+ call mpi_type_vector(count,blocklength,stride,MPI_DOUBLE_PRECISION, &
+ halo_wet(level,m),ierr)
+ call mpi_type_commit(halo_wet(level,m),ierr)
+ ! allocate send/recv buffer for GPU copy/managed !
+ call mnh_allocate_mg_halo(tab_halo_wt(level,m)%haloTin,halo_size,nlocal+2*halo_size,nz+2)
+ call mnh_allocate_mg_halo(tab_halo_wt(level,m)%haloTout,halo_size,nlocal+2*halo_size,nz+2)
+ call mnh_allocate_mg_halo(tab_halo_et(level,m)%haloTin,halo_size,nlocal+2*halo_size,nz+2)
+ call mnh_allocate_mg_halo(tab_halo_et(level,m)%haloTout,halo_size,nlocal+2*halo_size,nz+2)
+ endif
+#ifndef NDEBUG
+ if (ierr .ne. 0) &
+ call fatalerror("Commit halo_ns failed in mpi_type_commit().")
+#endif
+ ! --- Create interior data types ---
+ if (LUseO) then
+ count = nlocal
+ blocklength = nlocal*(nz+2)
+ stride = (nz+2)*(nlocal+2*halo_size)
+ call mpi_type_vector(count,blocklength,stride,MPI_DOUBLE_PRECISION,interior(level,m),ierr)
+ call mpi_type_commit(interior(level,m),ierr)
+ count = nlocal/2
+ blocklength = nlocal/2*(nz+2)
+ stride = (nlocal+2*halo_size)*(nz+2)
+ call mpi_type_vector(count,blocklength,stride,MPI_DOUBLE_PRECISION,sub_interior(level,m),ierr)
+ call mpi_type_commit(sub_interior(level,m),ierr)
+ end if
+ if (LUseT) then
+ ! interiorT
+ if ( nlocal /= 0 ) then
+ profil_tab = (/ nlocal+2*halo_size , nlocal+2*halo_size , nz+2 /)
+ profil_sous_tab = (/ nlocal , nlocal , nz+2 /)
+ coord_debut = (/ 0 , 0 , 0 /)
+ call MPI_TYPE_CREATE_SUBARRAY(nb_dims,profil_tab,profil_sous_tab,coord_debut,&
+ MPI_ORDER_FORTRAN,MPI_DOUBLE_PRECISION,interiorT(level,m),ierr)
+ call mpi_type_commit(interiorT(level,m),ierr)
+ call mnh_allocate_mg_halo(tab_interiorT_ne(level,m)%haloTin,nlocal,nlocal,nz+2)
+ call mnh_allocate_mg_halo(tab_interiorT_ne(level,m)%haloTout,nlocal,nlocal,nz+2)
+ call mnh_allocate_mg_halo(tab_interiorT_sw(level,m)%haloTin,nlocal,nlocal,nz+2)
+ call mnh_allocate_mg_halo(tab_interiorT_sw(level,m)%haloTout,nlocal,nlocal,nz+2)
+ call mnh_allocate_mg_halo(tab_interiorT_se(level,m)%haloTin,nlocal,nlocal,nz+2)
+ call mnh_allocate_mg_halo(tab_interiorT_se(level,m)%haloTout,nlocal,nlocal,nz+2)
+ end if
+ ! sub_interiorT
+ if ( (nlocal/2) /= 0 ) then
+ profil_tab = (/ nlocal+2*halo_size , nlocal+2*halo_size , nz+2 /)
+ profil_sous_tab = (/ nlocal/2 , nlocal/2 , nz+2 /)
+ coord_debut = (/ 0 , 0 , 0 /)
+ call MPI_TYPE_CREATE_SUBARRAY(nb_dims,profil_tab,profil_sous_tab,coord_debut,&
+ MPI_ORDER_FORTRAN,MPI_DOUBLE_PRECISION,sub_interiorT(level,m),ierr)
+ call mpi_type_commit(sub_interiorT(level,m),ierr)
+ call mnh_allocate_mg_halo(tab_sub_interiorT_ne(level,m)%haloTin,nlocal/2,nlocal/2,nz+2)
+ call mnh_allocate_mg_halo(tab_sub_interiorT_ne(level,m)%haloTout,nlocal/2,nlocal/2,nz+2)
+ call mnh_allocate_mg_halo(tab_sub_interiorT_sw(level,m)%haloTin,nlocal/2,nlocal/2,nz+2)
+ call mnh_allocate_mg_halo(tab_sub_interiorT_sw(level,m)%haloTout,nlocal/2,nlocal/2,nz+2)
+ call mnh_allocate_mg_halo(tab_sub_interiorT_se(level,m)%haloTin,nlocal/2,nlocal/2,nz+2)
+ call mnh_allocate_mg_halo(tab_sub_interiorT_se(level,m)%haloTout,nlocal/2,nlocal/2,nz+2)
+ end if
+ end if
+ ! --- Create timers ---
+ write(t_label,'("t_haloswap(",I3,",",I3,")")') level,m
+ call initialise_timer(t_haloswap(level,m),t_label)
+
+ ! If we are below L_split, split data
+ if ( (level .le. lev_split) .and. (m > 0) .and. (.not. reduced_m)) then
+ reduced_m = .true.
+ m = m-1
+ nlocal = 2*nlocal
+ cycle
+ end if
+ reduced_m = .false.
+ level = level-1
+ nlocal = nlocal/2
+ end do
+
+ end subroutine comm_initialise
+
+!==================================================================
+! Finalise communication routines
+!==================================================================
+ subroutine comm_finalise(n_lev, & ! } Multigrid parameters
+ lev_split, & !}
+ grid_param ) ! } Grid parameters
+ implicit none
+ integer, intent(in) :: n_lev
+ integer, intent(in) :: lev_split
+ type(grid_parameters), intent(in) :: grid_param
+ ! local var
+ logical :: reduced_m
+ integer :: level, m
+ integer :: ierr
+ integer :: nlocal,n
+ character(len=80) :: s
+
+ ! Local size of (horizontal) grid
+ n = grid_param%n
+ nlocal = n/2**pproc
+
+ m = pproc
+ level = n_lev
+ reduced_m = .false.
+ if (i_am_master_mpi) then
+ write(STDOUT,'(" *** Finalising communications ***")')
+ end if
+ call print_timerinfo("--- Communication timing results ---")
+ do while (level > 0)
+ write(s,'("level = ",I3,", m = ",I3)') level, m
+ call print_timerinfo(s)
+ ! --- Print out timer information ---
+ call print_elapsed(t_haloswap(level,m),.True.,1.0_rl)
+ ! --- Free halo data types ---
+ if (LUseO) call mpi_type_free(halo_ns(level,m),ierr)
+ if (LUseT) call mpi_type_free(halo_nst(level,m),ierr)
+ if (LUseT) call mpi_type_free(halo_wet(level,m),ierr)
+ ! --- Free interior data types ---
+ if (LUseO) call mpi_type_free(interior(level,m),ierr)
+ if (LUseO) call mpi_type_free(sub_interior(level,m),ierr)
+ if (LUseT .and. (nlocal /= 0 ) ) call mpi_type_free(interiorT(level,m),ierr)
+ if (LUseT .and. ( (nlocal/2) /= 0 ) ) call mpi_type_free(sub_interiorT(level,m),ierr)
+ ! If we are below L_split, split data
+ if ( (level .le. lev_split) .and. (m > 0) .and. (.not. reduced_m)) then
+ reduced_m = .true.
+ m = m-1
+ nlocal = 2*nlocal
+ cycle
+ end if
+ reduced_m = .false.
+ level = level-1
+ nlocal = nlocal/2
+ end do
+ do m=pproc,0,-1
+ write(s,'("m = ",I3)') m
+ call print_timerinfo(s)
+ ! --- Print out timer information ---
+ call print_elapsed(t_collect(m),.True.,1.0_rl)
+ call print_elapsed(t_distribute(m),.True.,1.0_rl)
+ end do
+
+ ! Deallocate arrays
+ if (LUseO) deallocate(halo_ns)
+ if (LUseT) deallocate(halo_nst,halo_wet)
+ if (LUseO) deallocate(interior)
+ if (LUseO) deallocate(sub_interior)
+ if (LUseT) deallocate(interiorT)
+ if (LUseT) deallocate(sub_interiorT)
+
+ deallocate(t_haloswap)
+ deallocate(t_collect)
+ deallocate(t_distribute)
+ if (i_am_master_mpi) then
+ write(STDOUT,'("")')
+ end if
+
+ end subroutine comm_finalise
+
+!==================================================================
+! Scalar product of two fields
+!==================================================================
+ subroutine scalarprod_mnh(m, a, b, s)
+ implicit none
+ integer, intent(in) :: m
+ type(scalar3d), intent(in) :: a
+ type(scalar3d), intent(in) :: b
+ real(kind=rl), intent(out) :: s
+ !local var
+ integer :: nprocs, rank, ierr
+ integer :: p_horiz(2)
+ integer :: stepsize
+ integer, parameter :: dim_horiz = 2
+ real(kind=rl) :: local_sum, global_sum
+ real(kind=rl) :: local_sumt,global_sumt
+ integer :: nlocal, nz, i
+ integer :: ix,iy,iz
+ real(kind=rl) :: ddot
+
+ integer :: iy_min,iy_max, ix_min,ix_max
+ real , dimension(:,:,:) , pointer , contiguous :: za_st,zb_st
+
+ nlocal = a%ix_max-a%ix_min+1
+ nz = a%grid_param%nz
+
+ iy_min = a%iy_min
+ iy_max = a%iy_max
+ ix_min = a%ix_min
+ ix_max = a%ix_max
+
+ ! Work out coordinates of processor
+ call mpi_comm_size(MPI_COMM_HORIZ,nprocs,ierr)
+ call mpi_comm_rank(MPI_COMM_HORIZ,rank,ierr)
+ stepsize = 2**(pproc-m)
+ if (nprocs > 1) then
+ ! Only inlcude local sum if the processor coordinates
+ ! are multiples of stepsize
+ call mpi_cart_coords(MPI_COMM_HORIZ,rank,dim_horiz,p_horiz,ierr)
+ if ( (stepsize == 1) .or. &
+ ( (stepsize > 1) .and. &
+ (mod(p_horiz(1),stepsize)==0) .and. &
+ (mod(p_horiz(2),stepsize)==0) ) ) then
+ if (LUseO) then
+ local_sum = 0.0_rl
+ do i = 1, nlocal
+ local_sum = local_sum &
+ + ddot((nz+2)*nlocal,a%s(0,1,i),1,b%s(0,1,i),1)
+ end do
+ end if
+ if (LUseT) then
+ local_sumt = 0.0_rl
+ !$acc kernels loop collapse(3)
+ do iz=0,nz+1
+ do iy=a%icompy_min,a%icompy_max
+ do ix=a%icompx_min,a%icompx_max
+ local_sumt = local_sumt &
+ + a%st(ix,iy,iz)*b%st(ix,iy,iz)
+ end do
+ end do
+ end do
+ end if
+ else
+ if (LUseO) local_sum = 0.0_rl
+ if (LUseT) local_sumt = 0.0_rl
+ end if
+ if (LUseO) call mpi_allreduce(local_sum,global_sum,1,MPI_DOUBLE_PRECISION, &
+ MPI_SUM,MPI_COMM_HORIZ,ierr)
+ if (LUseT) call mpi_allreduce(local_sumt,global_sumt,1,MPI_DOUBLE_PRECISION, &
+ MPI_SUM,MPI_COMM_HORIZ,ierr)
+ else
+ if (LUseO) then
+ global_sum = 0.0_rl
+ do i = 1, nlocal
+ global_sum = global_sum &
+ + ddot((nz+2)*nlocal,a%s(0,1,i),1,b%s(0,1,i),1)
+ end do
+ endif
+ if (LUseT) then
+ za_st => a%st
+ zb_st => b%st
+ global_sumt = 0.0_rl
+ !$acc kernels
+ do iz=0,nz+1
+ do iy=iy_min,iy_max
+ do ix=ix_min,ix_max
+ global_sumt = global_sumt &
+ + za_st(ix,iy,iz)*zb_st(ix,iy,iz)
+ end do
+ end do
+ end do
+ !$acc end kernels
+ endif
+ end if
+ if (LUseO) then
+ s = global_sum
+ else
+ s = global_sumt
+ end if
+
+ end subroutine scalarprod_mnh
+!-------------------------------------------------------------------------------
+ subroutine scalarprod(m, a, b, s)
+ implicit none
+ integer, intent(in) :: m
+ type(scalar3d), intent(in) :: a
+ type(scalar3d), intent(in) :: b
+ real(kind=rl), intent(out) :: s
+ integer :: nprocs, rank, ierr
+ integer :: p_horiz(2)
+ integer :: stepsize
+ integer, parameter :: dim_horiz = 2
+ real(kind=rl) :: local_sum, global_sum
+ integer :: nlocal, nz, i
+ real(kind=rl) :: ddot
+
+ nlocal = a%ix_max-a%ix_min+1
+ nz = a%grid_param%nz
+ ! Work out coordinates of processor
+ call mpi_comm_size(MPI_COMM_HORIZ,nprocs,ierr)
+ call mpi_comm_rank(MPI_COMM_HORIZ,rank,ierr)
+ stepsize = 2**(pproc-m)
+ if (nprocs > 1) then
+ ! Only inlcude local sum if the processor coordinates
+ ! are multiples of stepsize
+ call mpi_cart_coords(MPI_COMM_HORIZ,rank,dim_horiz,p_horiz,ierr)
+ if ( (stepsize == 1) .or. &
+ ( (stepsize > 1) .and. &
+ (mod(p_horiz(1),stepsize)==0) .and. &
+ (mod(p_horiz(2),stepsize)==0) ) ) then
+ local_sum = 0.0_rl
+ do i = 1, nlocal
+ local_sum = local_sum &
+ + ddot((nz+2)*nlocal,a%s(0,1,i),1,b%s(0,1,i),1)
+ end do
+ else
+ local_sum = 0.0_rl
+ end if
+ call mpi_allreduce(local_sum,global_sum,1,MPI_DOUBLE_PRECISION, &
+ MPI_SUM,MPI_COMM_HORIZ,ierr)
+ else
+ global_sum = 0.0_rl
+ do i = 1, nlocal
+ global_sum = global_sum &
+ + ddot((nz+2)*nlocal,a%s(0,1,i),1,b%s(0,1,i),1)
+ end do
+ end if
+ s = global_sum
+ end subroutine scalarprod
+!==================================================================
+! Pritn Scalar product^2 of 1 fields
+!==================================================================
+ subroutine print_scalaprod2(l,m, a, message )
+ implicit none
+ integer, intent(in) :: l,m
+ type(scalar3d), intent(in) :: a
+ character(len=*) , intent(in) :: message
+
+ !local
+ real(kind=rl) :: s
+
+ call scalarprod_mnh(m, a, a, s)
+ s = sqrt(s)
+ if (i_am_master_mpi) then
+ write(STDOUT,'("Print_norm::",A,2I3,E23.15)') message, l,m,s
+ call flush(STDOUT)
+ end if
+
+ end subroutine print_scalaprod2
+!==================================================================
+! Boundary Neumann
+!==================================================================
+ subroutine boundary_mnh(a) ! data field
+
+ implicit none
+
+ type(scalar3d), intent(inout) :: a
+
+ !local var
+ integer :: n, ix_min,ix_max,iy_min,iy_max
+ integer :: icompx_max,icompy_max
+
+ real , dimension(:,:,:) , pointer , contiguous :: za_st
+
+ ! Update Real Boundary for Newman case u(0) = u(1) , etc ...
+
+ !return
+
+ n = a%grid_param%n
+ ix_min = a%ix_min
+ ix_max = a%ix_max
+ iy_min = a%iy_min
+ iy_max = a%iy_max
+ if (LUseO) then
+ if ( ix_min == 1 ) then
+ a%s(:,:,0) = a%s(:,:,1)
+ endif
+ if ( ix_max == n ) then
+ a%s(:,:,a%icompx_max+1) = a%s(:,:,a%icompx_max)
+ endif
+ if ( iy_min == 1 ) then
+ a%s(:,0,:) = a%s(:,1,:)
+ endif
+ if ( iy_max == n ) then
+ a%s(:,a%icompy_max+1,:) = a%s(:,a%icompy_max,:)
+ endif
+ endif
+ if (LUseT) then
+ ! transpose
+
+ za_st => a%st
+ icompx_max = a%icompx_max
+ icompy_max = a%icompy_max
+
+ !$acc kernels
+ if ( ix_min == 1 ) then
+ !acc kernels
+ za_st(0,:,:) = za_st(1,:,:)
+ !acc end kernels
+ endif
+ if ( ix_max == n ) then
+ !acc kernels
+ za_st(icompx_max+1,:,:) = za_st(icompx_max,:,:)
+ !acc end kernels
+ endif
+ if ( iy_min == 1 ) then
+ !acc kernels
+ za_st(:,0,:) = za_st(:,1,:)
+ !acc end kernels
+ endif
+ if ( iy_max == n ) then
+ !acc kernels
+ za_st(:,icompy_max+1,:) = za_st(:,icompy_max,:)
+ !acc end kernels
+ endif
+ !$acc end kernels
+
+ endif
+
+ end subroutine boundary_mnh
+!==================================================================
+! Initiate asynchronous halo exchange
+!
+! For all processes with horizontal indices that are multiples
+! of 2^(pproc-m), update halos with information held by
+! neighbouring processes, e.g. for pproc-m = 1, stepsize=2
+!
+! N (0,2)
+! ^
+! !
+! v
+!
+! W (2,0) <--> (2,2) <--> E (2,4)
+!
+! ^
+! !
+! v
+! S (4,2)
+!
+!==================================================================
+ subroutine ihaloswap_mnh(level,m, & ! multigrid- and processor- level
+ a, & ! data field
+ send_requests, & ! send requests (OUT)
+ recv_requests, & ! recv requests (OUT)
+ send_requestsT, & ! send requests T (OUT)
+ recv_requestsT & ! recv requests T (OUT)
+ )
+ implicit none
+ integer, intent(in) :: level
+ integer, intent(in) :: m
+ integer, intent(out), dimension(4) :: send_requests
+ integer, intent(out), dimension(4) :: recv_requests
+ integer, intent(out), dimension(4) :: send_requestsT
+ integer, intent(out), dimension(4) :: recv_requestsT
+ type(scalar3d), intent(inout) :: a
+ integer :: a_n ! horizontal grid size
+ integer :: nz ! vertical grid size
+ integer, dimension(2) :: p_horiz
+ integer :: stepsize
+ integer :: ierr, rank, sendtag, recvtag
+ integer :: stat(MPI_STATUS_SIZE)
+ integer :: halo_size
+ integer :: neighbour_n_rank
+ integer :: neighbour_s_rank
+ integer :: neighbour_e_rank
+ integer :: neighbour_w_rank
+ integer :: yoffset, blocklength
+
+ halo_size = comm_param%halo_size
+
+ ! Do nothing if we are only using one processor
+ if (m > 0) then
+ a_n = a%ix_max-a%ix_min+1
+ nz = a%grid_param%nz
+ stepsize = 2**(pproc-m)
+
+ ! Work out rank, only execute on relevant processes
+ call mpi_comm_rank(MPI_COMM_HORIZ, rank, ierr)
+ call mpi_cart_coords(MPI_COMM_HORIZ,rank,dim_horiz,p_horiz,ierr)
+
+ ! Work out ranks of neighbours
+ ! W -> E
+ call mpi_cart_shift(MPI_COMM_HORIZ,1, stepsize, &
+ neighbour_w_rank,neighbour_e_rank,ierr)
+ ! N -> S
+ call mpi_cart_shift(MPI_COMM_HORIZ,0, stepsize, &
+ neighbour_n_rank,neighbour_s_rank,ierr)
+ if ( (stepsize == 1) .or. &
+ ( (mod(p_horiz(1),stepsize) == 0) .and. &
+ (mod(p_horiz(2),stepsize) == 0) ) ) then
+ if (halo_size == 1) then
+ ! Do not include corners in send/recv
+ yoffset = 1
+ blocklength = a_n*(nz+2)*halo_size
+ else
+ yoffset = 1-halo_size
+ blocklength = (a_n+2*halo_size)*(nz+2)*halo_size
+ end if
+ ! Receive from north
+ recvtag = 1002
+ if (LUseO) call mpi_irecv(a%s(0,0-(halo_size-1),1),1, &
+ halo_ns(level,m),neighbour_n_rank,recvtag, &
+ MPI_COMM_HORIZ, recv_requests(1), ierr)
+ recvtag = 1012
+ if (LUseT) then
+ call mpi_irecv(a%st(1,0-(halo_size-1),0),1, &
+ halo_nst(level,m),neighbour_n_rank,recvtag, &
+ MPI_COMM_HORIZ, recv_requestsT(1), ierr)
+ end if
+ ! Receive from south
+ recvtag = 1003
+ if (LUseO) call mpi_irecv(a%s(0,a_n+1,1),1, &
+ halo_ns(level,m),neighbour_s_rank,recvtag, &
+ MPI_COMM_HORIZ, recv_requests(2), ierr)
+ recvtag = 1013
+ if (LUseT) then
+ call mpi_irecv(a%st(1,a_n+1,0),1, &
+ halo_nst(level,m),neighbour_s_rank,recvtag, &
+ MPI_COMM_HORIZ, recv_requestsT(2), ierr)
+ end if
+ ! Send to south
+ sendtag = 1002
+ if (LUseO) call mpi_isend(a%s(0,a_n-(halo_size-1),1),1, &
+ halo_ns(level,m),neighbour_s_rank,sendtag, &
+ MPI_COMM_HORIZ, send_requests(1), ierr)
+ sendtag = 1012
+ if (LUseT) then
+ call mpi_isend(a%st(1,a_n-(halo_size-1),0),1, &
+ halo_nst(level,m),neighbour_s_rank,sendtag, &
+ MPI_COMM_HORIZ, send_requestsT(1), ierr)
+ end if
+ ! Send to north
+ sendtag = 1003
+ if (LUseO) call mpi_isend(a%s(0,1,1),1, &
+ halo_ns(level,m),neighbour_n_rank,sendtag, &
+ MPI_COMM_HORIZ, send_requests(2), ierr)
+ sendtag = 1013
+ if (LUseT) then
+ call mpi_isend(a%st(1,1,0),1, &
+ halo_nst(level,m),neighbour_n_rank,sendtag, &
+ MPI_COMM_HORIZ, send_requestsT(2), ierr)
+ end if
+ ! Receive from west
+ recvtag = 1000
+ if (LUseO) call mpi_irecv(a%s(0,yoffset,0-(halo_size-1)),blocklength, &
+ MPI_DOUBLE_PRECISION,neighbour_w_rank,recvtag, &
+ MPI_COMM_HORIZ, recv_requests(3), ierr)
+ recvtag = 1010
+ if (LUseT) then
+ call mpi_irecv(a%st(0-(halo_size-1),0,0),1, &
+ halo_wet(level,m),neighbour_w_rank,recvtag, &
+ MPI_COMM_HORIZ, recv_requestsT(3), ierr)
+ end if
+ ! Receive from east
+ sendtag = 1001
+ if (LUseO) call mpi_irecv(a%s(0,yoffset,a_n+1),blocklength, &
+ MPI_DOUBLE_PRECISION,neighbour_e_rank,recvtag, &
+ MPI_COMM_HORIZ, recv_requests(4), ierr)
+ sendtag = 1011
+ if (LUseT) then
+ call mpi_irecv(a%st(a_n+1,0,0),1, &
+ halo_wet(level,m),neighbour_e_rank,recvtag, &
+ MPI_COMM_HORIZ, recv_requestsT(4), ierr)
+ end if
+ ! Send to east
+ sendtag = 1000
+ if (LUseO) call mpi_isend(a%s(0,yoffset,a_n-(halo_size-1)),blocklength, &
+ MPI_DOUBLE_PRECISION,neighbour_e_rank,sendtag, &
+ MPI_COMM_HORIZ, send_requests(3), ierr)
+ sendtag = 1010
+ if (LUseT) then
+ call mpi_isend(a%st(a_n-(halo_size-1),0,0),1, &
+ halo_wet(level,m),neighbour_e_rank,sendtag, &
+ MPI_COMM_HORIZ, send_requestsT(3), ierr)
+ end if
+ ! Send to west
+ recvtag = 1001
+ if (LUseO) call mpi_isend(a%s(0,yoffset,1),blocklength, &
+ MPI_DOUBLE_PRECISION,neighbour_w_rank,sendtag, &
+ MPI_COMM_HORIZ, send_requests(4), ierr)
+ recvtag = 1011
+ if (LUseT) then
+ call mpi_isend(a%st(1,0,0),1, &
+ halo_wet(level,m),neighbour_w_rank,sendtag, &
+ MPI_COMM_HORIZ, send_requestsT(4), ierr)
+ end if
+ end if
+ end if
+ end subroutine ihaloswap_mnh
+!==================================================================
+ subroutine ihaloswap(level,m, & ! multigrid- and processor- level
+ a, & ! data field
+ send_requests, & ! send requests (OUT)
+ recv_requests & ! recv requests (OUT)
+ )
+ implicit none
+ integer, intent(in) :: level
+ integer, intent(in) :: m
+ integer, intent(out), dimension(4) :: send_requests
+ integer, intent(out), dimension(4) :: recv_requests
+ type(scalar3d), intent(inout) :: a
+ integer :: a_n ! horizontal grid size
+ integer :: nz ! vertical grid size
+ integer, dimension(2) :: p_horiz
+ integer :: stepsize
+ integer :: ierr, rank, sendtag, recvtag
+ integer :: stat(MPI_STATUS_SIZE)
+ integer :: halo_size
+ integer :: neighbour_n_rank
+ integer :: neighbour_s_rank
+ integer :: neighbour_e_rank
+ integer :: neighbour_w_rank
+ integer :: yoffset, blocklength
+
+ halo_size = comm_param%halo_size
+
+ ! Do nothing if we are only using one processor
+ if (m > 0) then
+ a_n = a%ix_max-a%ix_min+1
+ nz = a%grid_param%nz
+ stepsize = 2**(pproc-m)
+
+ ! Work out rank, only execute on relevant processes
+ call mpi_comm_rank(MPI_COMM_HORIZ, rank, ierr)
+ call mpi_cart_coords(MPI_COMM_HORIZ,rank,dim_horiz,p_horiz,ierr)
+
+ ! Work out ranks of neighbours
+ ! W -> E
+ call mpi_cart_shift(MPI_COMM_HORIZ,1, stepsize, &
+ neighbour_w_rank,neighbour_e_rank,ierr)
+ ! N -> S
+ call mpi_cart_shift(MPI_COMM_HORIZ,0, stepsize, &
+ neighbour_n_rank,neighbour_s_rank,ierr)
+ if ( (stepsize == 1) .or. &
+ ( (mod(p_horiz(1),stepsize) == 0) .and. &
+ (mod(p_horiz(2),stepsize) == 0) ) ) then
+ if (halo_size == 1) then
+ ! Do not include corners in send/recv
+ yoffset = 1
+ blocklength = a_n*(nz+2)*halo_size
+ else
+ yoffset = 1-halo_size
+ blocklength = (a_n+2*halo_size)*(nz+2)*halo_size
+ end if
+ ! Receive from north
+ recvtag = 2
+ call mpi_irecv(a%s(0,0-(halo_size-1),1),1, &
+ halo_ns(level,m),neighbour_n_rank,recvtag, &
+ MPI_COMM_HORIZ, recv_requests(1), ierr)
+ ! Receive from south
+ recvtag = 3
+ call mpi_irecv(a%s(0,a_n+1,1),1, &
+ halo_ns(level,m),neighbour_s_rank,recvtag, &
+ MPI_COMM_HORIZ, recv_requests(2), ierr)
+ ! Send to south
+ sendtag = 2
+ call mpi_isend(a%s(0,a_n-(halo_size-1),1),1, &
+ halo_ns(level,m),neighbour_s_rank,sendtag, &
+ MPI_COMM_HORIZ, send_requests(1), ierr)
+ ! Send to north
+ sendtag = 3
+ call mpi_isend(a%s(0,1,1),1, &
+ halo_ns(level,m),neighbour_n_rank,sendtag, &
+ MPI_COMM_HORIZ, send_requests(2), ierr)
+ ! Receive from west
+ recvtag = 0
+ call mpi_irecv(a%s(0,yoffset,0-(halo_size-1)),blocklength, &
+ MPI_DOUBLE_PRECISION,neighbour_w_rank,recvtag, &
+ MPI_COMM_HORIZ, recv_requests(3), ierr)
+ ! Receive from east
+ sendtag = 1
+ call mpi_irecv(a%s(0,yoffset,a_n+1),blocklength, &
+ MPI_DOUBLE_PRECISION,neighbour_e_rank,recvtag, &
+ MPI_COMM_HORIZ, recv_requests(4), ierr)
+ ! Send to east
+ sendtag = 0
+ call mpi_isend(a%s(0,yoffset,a_n-(halo_size-1)),blocklength, &
+ MPI_DOUBLE_PRECISION,neighbour_e_rank,sendtag, &
+ MPI_COMM_HORIZ, send_requests(3), ierr)
+ ! Send to west
+ recvtag = 1
+ call mpi_isend(a%s(0,yoffset,1),blocklength, &
+ MPI_DOUBLE_PRECISION,neighbour_w_rank,sendtag, &
+ MPI_COMM_HORIZ, send_requests(4), ierr)
+ end if
+ end if
+ end subroutine ihaloswap
+
+!==================================================================
+! Halo exchange
+!
+! For all processes with horizontal indices that are multiples
+! of 2^(pproc-m), update halos with information held by
+! neighbouring processes, e.g. for pproc-m = 1, stepsize=2
+!
+! N (0,2)
+! ^
+! !
+! v
+!
+! W (2,0) <--> (2,2) <--> E (2,4)
+!
+! ^
+! !
+! v
+! S (4,2)
+!
+!==================================================================
+ subroutine haloswap_mnh(level,m, & ! multigrid- and processor- level
+ a) ! data field
+ implicit none
+ integer, intent(in) :: level
+ integer, intent(in) :: m
+ type(scalar3d), intent(inout) :: a
+ !local var
+ integer :: a_n ! horizontal grid size
+ integer :: nz ! vertical grid size
+ integer, dimension(2) :: p_horiz
+ integer :: stepsize
+ integer :: ierr, rank, sendtag, recvtag
+ integer :: stat(MPI_STATUS_SIZE)
+ integer :: halo_size
+ integer :: neighbour_n_rank
+ integer :: neighbour_s_rank
+ integer :: neighbour_e_rank
+ integer :: neighbour_w_rank
+ integer :: yoffset, blocklength
+ integer, dimension(4) :: requests_ns
+ integer, dimension(4) :: requests_ew
+ integer, dimension(4) :: requests_nsT
+ integer, dimension(4) :: requests_ewT
+
+ integer :: ii,ij,ik
+ real , pointer , contiguous , dimension(:,:,:) :: zst
+ !
+ real , pointer , contiguous , dimension(:,:,:) :: ztab_halo_st_haloTin,ztab_halo_nt_haloTin
+ real , pointer , contiguous , dimension(:,:,:) :: ztab_halo_et_haloTin,ztab_halo_wt_haloTin
+ !
+ real , pointer , contiguous , dimension(:,:,:) :: ztab_halo_nt_haloTout,ztab_halo_st_haloTout
+ real , pointer , contiguous , dimension(:,:,:) :: ztab_halo_wt_haloTout,ztab_halo_et_haloTout
+
+ halo_size = comm_param%halo_size
+
+ ! Do nothing if we are only using one processor
+ if (m > 0) then
+ if (comm_measuretime) then
+ call start_timer(t_haloswap(level,m))
+ end if
+ a_n = a%ix_max-a%ix_min+1
+ nz = a%grid_param%nz
+ stepsize = 2**(pproc-m)
+
+ ! Work out rank, only execute on relevant processes
+ call mpi_comm_rank(MPI_COMM_HORIZ, rank, ierr)
+ call mpi_cart_coords(MPI_COMM_HORIZ,rank,dim_horiz,p_horiz,ierr)
+
+ ! Work out ranks of neighbours
+ ! W -> E
+ call mpi_cart_shift(MPI_COMM_HORIZ,1, stepsize, &
+ neighbour_w_rank,neighbour_e_rank,ierr)
+ ! N -> S
+ call mpi_cart_shift(MPI_COMM_HORIZ,0, stepsize, &
+ neighbour_n_rank,neighbour_s_rank,ierr)
+ if ( (stepsize == 1) .or. &
+ ( (mod(p_horiz(1),stepsize) == 0) .and. &
+ (mod(p_horiz(2),stepsize) == 0) ) ) then
+ if (halo_size == 1) then
+ ! Do not include corners in send/recv
+ yoffset = 1
+ blocklength = a_n*(nz+2)*halo_size
+ else
+ yoffset = 1-halo_size
+ blocklength = (a_n+2*halo_size)*(nz+2)*halo_size
+ end if
+ !
+ zst => a%st
+ !
+#ifdef MNH_GPUDIRECT
+ if (LUseT) then
+ !
+ ! Copy send buffer async to GPU
+ !
+ ! Send to south
+ ztab_halo_st_haloTin => tab_halo_st(level,m)%haloTin
+ !$acc parallel loop collapse(3) async(1)
+ do concurrent ( ii=1:a_n,ij=1:halo_size,ik=1:nz+2 )
+ ztab_halo_st_haloTin(ii,ij,ik) = zst(ii,ij+a_n-halo_size,ik-1)
+ end do
+ ! Send to north
+ ztab_halo_nt_haloTin => tab_halo_nt(level,m)%haloTin
+ !$acc parallel loop collapse(3) async(1)
+ do concurrent ( ii=1:a_n,ij=1:halo_size,ik=1:nz+2 )
+ ztab_halo_nt_haloTin(ii,ij,ik) = zst(ii,ij,ik-1)
+ end do
+ ! Send to east
+ ztab_halo_et_haloTin => tab_halo_et(level,m)%haloTin
+ !$acc parallel loop collapse(3) async(1)
+ do concurrent ( ii=1:halo_size,ij=1:a_n+2*halo_size,ik=1:nz+2 )
+ ztab_halo_et_haloTin(ii,ij,ik) = zst(ii+a_n-halo_size,ij-halo_size,ik-1)
+ end do
+ ! Send to west
+ ztab_halo_wt_haloTin => tab_halo_wt(level,m)%haloTin
+ !$acc parallel loop collapse(3) async(1)
+ do concurrent ( ii=1:halo_size,ij=1:a_n+2*halo_size,ik=1:nz+2 )
+ ztab_halo_wt_haloTin(ii,ij,ik) = zst(ii,ij-halo_size,ik-1)
+ end do
+ end if
+#endif
+ ! Receive from north
+ recvtag = 1002
+ if (LUseO) call mpi_irecv(a%s(0,0-(halo_size-1),1),1, &
+ halo_ns(level,m),neighbour_n_rank,recvtag, &
+ MPI_COMM_HORIZ, requests_ns(1), ierr)
+ recvtag = 1012
+ if (LUseT) then
+#ifdef MNH_GPUDIRECT
+ ztab_halo_nt_haloTout => tab_halo_nt(level,m)%haloTout
+ !$acc host_data use_device(ztab_halo_nt_haloTout)
+ call mpi_irecv(ztab_halo_nt_haloTout,size(ztab_halo_nt_haloTout), &
+ MPI_DOUBLE_PRECISION,neighbour_n_rank,recvtag, &
+ MPI_COMM_HORIZ, requests_nsT(1), ierr)
+ !$acc end host_data
+#else
+ call mpi_irecv(a%st(1,0-(halo_size-1),0),1, &
+ halo_nst(level,m),neighbour_n_rank,recvtag, &
+ MPI_COMM_HORIZ, requests_nsT(1), ierr)
+#endif
+ end if
+ ! Receive from south
+ recvtag = 1003
+ if (LUseO) call mpi_irecv(a%s(0,a_n+1,1),1, &
+ halo_ns(level,m),neighbour_s_rank,recvtag, &
+ MPI_COMM_HORIZ, requests_ns(2), ierr)
+ recvtag = 1013
+ if (LUseT) then
+#ifdef MNH_GPUDIRECT
+ ztab_halo_st_haloTout => tab_halo_st(level,m)%haloTout
+ !$acc host_data use_device (ztab_halo_st_haloTout)
+ call mpi_irecv(ztab_halo_st_haloTout,size(ztab_halo_st_haloTout), &
+ MPI_DOUBLE_PRECISION,neighbour_s_rank,recvtag, &
+ MPI_COMM_HORIZ, requests_nsT(2), ierr)
+ !$acc end host_data
+#else
+ call mpi_irecv(a%st(1,a_n+1,0),1, &
+ halo_nst(level,m),neighbour_s_rank,recvtag, &
+ MPI_COMM_HORIZ, requests_nsT(2), ierr)
+#endif
+ end if
+#ifdef MNH_GPUDIRECT
+ if (LUseT) then
+ ! wait for async copy of send buffer to GPU
+ !$acc wait(1)
+ end if
+#endif
+ ! Send to south
+ sendtag = 1002
+ if (LUseO) call mpi_isend(a%s(0,a_n-(halo_size-1),1),1, &
+ halo_ns(level,m),neighbour_s_rank,sendtag, &
+ MPI_COMM_HORIZ, requests_ns(3), ierr)
+ sendtag = 1012
+ if (LUseT) then
+#ifdef MNH_GPUDIRECT
+ !$acc host_data use_device(ztab_halo_st_haloTin)
+ call mpi_isend(ztab_halo_st_haloTin,size(ztab_halo_st_haloTin), &
+ MPI_DOUBLE_PRECISION,neighbour_s_rank,sendtag, &
+ MPI_COMM_HORIZ, requests_nsT(3), ierr)
+ !$acc end host_data
+#else
+ call mpi_isend(a%st(1,a_n-(halo_size-1),0),1, &
+ halo_nst(level,m),neighbour_s_rank,sendtag, &
+ MPI_COMM_HORIZ, requests_nsT(3), ierr)
+#endif
+ end if
+ ! Send to north
+ sendtag = 1003
+ if (LUseO) call mpi_isend(a%s(0,1,1),1, &
+ halo_ns(level,m),neighbour_n_rank,sendtag, &
+ MPI_COMM_HORIZ, requests_ns(4), ierr)
+ sendtag = 1013
+ if (LUseT) then
+#ifdef MNH_GPUDIRECT
+ !$acc host_data use_device(ztab_halo_nt_haloTin)
+ call mpi_isend(ztab_halo_nt_haloTin,size(ztab_halo_nt_haloTin), &
+ MPI_DOUBLE_PRECISION,neighbour_n_rank,sendtag, &
+ MPI_COMM_HORIZ, requests_nsT(4), ierr)
+ !$acc end host_data
+#else
+ call mpi_isend(a%st(1,1,0),1, &
+ halo_nst(level,m),neighbour_n_rank,sendtag, &
+ MPI_COMM_HORIZ, requests_nsT(4), ierr)
+#endif
+ end if
+ if (halo_size > 1) then
+ ! Wait for North <-> South communication to complete
+ if (LUseO) call mpi_waitall(4,requests_ns, MPI_STATUSES_IGNORE, ierr)
+ if (LUseT) call mpi_waitall(4,requests_nsT, MPI_STATUSES_IGNORE, ierr)
+ end if
+ ! Receive from west
+ recvtag = 1000
+ if (LUseO) call mpi_irecv(a%s(0,yoffset,0-(halo_size-1)),blocklength, &
+ MPI_DOUBLE_PRECISION,neighbour_w_rank,recvtag, &
+ MPI_COMM_HORIZ, requests_ew(1), ierr)
+ recvtag = 1010
+ if (LUseT) then
+#ifdef MNH_GPUDIRECT
+ ztab_halo_wt_haloTout => tab_halo_wt(level,m)%haloTout
+ !$acc host_data use_device(ztab_halo_wt_haloTout)
+ call mpi_irecv(ztab_halo_wt_haloTout,size(ztab_halo_wt_haloTout), &
+ MPI_DOUBLE_PRECISION,neighbour_w_rank,recvtag, &
+ MPI_COMM_HORIZ, requests_ewT(1), ierr)
+ !$acc end host_data
+#else
+ call mpi_irecv(a%st(0-(halo_size-1),0,0),1, &
+ halo_wet(level,m),neighbour_w_rank,recvtag, &
+ MPI_COMM_HORIZ, requests_ewT(1), ierr)
+#endif
+ end if
+ ! Receive from east
+ sendtag = 1001
+ if (LUseO) call mpi_irecv(a%s(0,yoffset,a_n+1),blocklength, &
+ MPI_DOUBLE_PRECISION,neighbour_e_rank,recvtag, &
+ MPI_COMM_HORIZ, requests_ew(2), ierr)
+ sendtag = 1011
+ if (LUseT) then
+#ifdef MNH_GPUDIRECT
+ ztab_halo_et_haloTout => tab_halo_et(level,m)%haloTout
+ !$acc host_data use_device(ztab_halo_et_haloTout)
+ call mpi_irecv(ztab_halo_et_haloTout,size(ztab_halo_et_haloTout), &
+ MPI_DOUBLE_PRECISION,neighbour_e_rank,recvtag, &
+ MPI_COMM_HORIZ, requests_ewT(2), ierr)
+ !$acc end host_data
+#else
+ call mpi_irecv(a%st(a_n+1,0,0),1, &
+ halo_wet(level,m),neighbour_e_rank,recvtag, &
+ MPI_COMM_HORIZ, requests_ewT(2), ierr)
+
+#endif
+ end if
+ ! Send to east
+ sendtag = 1000
+ if (LUseO) call mpi_isend(a%s(0,yoffset,a_n-(halo_size-1)),blocklength, &
+ MPI_DOUBLE_PRECISION,neighbour_e_rank,sendtag, &
+ MPI_COMM_HORIZ, requests_ew(3), ierr)
+ sendtag = 1010
+ if (LUseT) then
+#ifdef MNH_GPUDIRECT
+ !$acc host_data use_device(ztab_halo_et_haloTin)
+ call mpi_isend(ztab_halo_et_haloTin,size(ztab_halo_et_haloTin), &
+ MPI_DOUBLE_PRECISION,neighbour_e_rank,sendtag, &
+ MPI_COMM_HORIZ, requests_ewT(3), ierr)
+ !$acc end host_data
+#else
+ call mpi_isend(a%st(a_n-(halo_size-1),0,0),1, &
+ halo_wet(level,m),neighbour_e_rank,sendtag, &
+ MPI_COMM_HORIZ, requests_ewT(3), ierr)
+#endif
+ end if
+ ! Send to west
+ recvtag = 1001
+ if (LUseO) call mpi_isend(a%s(0,yoffset,1),blocklength, &
+ MPI_DOUBLE_PRECISION,neighbour_w_rank,sendtag, &
+ MPI_COMM_HORIZ, requests_ew(4), ierr)
+ recvtag = 1011
+ if (LUseT) then
+#ifdef MNH_GPUDIRECT
+ !$acc host_data use_device(ztab_halo_wt_haloTin)
+ call mpi_isend(ztab_halo_wt_haloTin,size(ztab_halo_wt_haloTin), &
+ MPI_DOUBLE_PRECISION,neighbour_w_rank,sendtag, &
+ MPI_COMM_HORIZ, requests_ewT(4), ierr)
+ !$acc end host_data
+#else
+ call mpi_isend(a%st(1,0,0),1, &
+ halo_wet(level,m),neighbour_w_rank,sendtag, &
+ MPI_COMM_HORIZ, requests_ewT(4), ierr)
+#endif
+ end if
+ ! Wait for East <-> West communication to complete
+ if (halo_size == 1) then
+ ! Wait for North <-> South communication to complete
+ if (LUseO) call mpi_waitall(4,requests_ns, MPI_STATUSES_IGNORE, ierr)
+ if (LUseT) call mpi_waitall(4,requests_nsT, MPI_STATUSES_IGNORE, ierr)
+ end if
+ if (LUseO) call mpi_waitall(4,requests_ew, MPI_STATUSES_IGNORE, ierr)
+ if (LUseT) call mpi_waitall(4,requests_ewT, MPI_STATUSES_IGNORE, ierr)
+#ifdef MNH_GPUDIRECT
+ if (LUseT) then
+ ! copy north halo for GPU managed
+ !$acc parallel loop collapse(3) async(3)
+ do concurrent ( ii=1:a_n,ij=1:halo_size,ik=1:nz+2 )
+ zst(ii,ij-halo_size,ik-1) = ztab_halo_nt_haloTout(ii,ij,ik)
+ end do
+ ! copy south halo for GPU managed
+ !$acc parallel loop collapse(3) async(3)
+ do concurrent ( ii=1:a_n,ij=1:halo_size,ik=1:nz+2 )
+ zst(ii,ij+a_n,ik-1) = ztab_halo_st_haloTout(ii,ij,ik)
+ end do
+ ! copy west halo for GPU managed
+ !$acc parallel loop collapse(3) async(3)
+ do concurrent ( ii=1:halo_size,ij=1:a_n+2*halo_size,ik=1:nz+2 )
+ zst(ii-halo_size,ij-halo_size,ik-1) = ztab_halo_wt_haloTout(ii,ij,ik)
+ end do
+ ! copy east halo for GPU managed
+ !$acc parallel loop collapse(3) async(3)
+ do concurrent ( ii=1:halo_size,ij=1:a_n+2*halo_size,ik=1:nz+2 )
+ zst(ii+a_n,ij-halo_size,ik-1) = ztab_halo_et_haloTout(ii,ij,ik)
+ end do
+ !$acc wait(3)
+ end if
+#endif
+ end if! (stepsize == 1) ...
+ if (comm_measuretime) then
+ call finish_timer(t_haloswap(level,m))
+ end if
+ end if
+
+ end subroutine haloswap_mnh
+!==================================================================
+ subroutine haloswap(level,m, & ! multigrid- and processor- level
+ a) ! data field
+ implicit none
+ integer, intent(in) :: level
+ integer, intent(in) :: m
+ type(scalar3d), intent(inout) :: a
+ integer :: a_n ! horizontal grid size
+ integer :: nz ! vertical grid size
+ integer, dimension(2) :: p_horiz
+ integer :: stepsize
+ integer :: ierr, rank, sendtag, recvtag
+ integer :: stat(MPI_STATUS_SIZE)
+ integer :: halo_size
+ integer :: neighbour_n_rank
+ integer :: neighbour_s_rank
+ integer :: neighbour_e_rank
+ integer :: neighbour_w_rank
+ integer :: yoffset, blocklength
+ integer, dimension(4) :: requests_ns
+ integer, dimension(4) :: requests_ew
+
+ halo_size = comm_param%halo_size
+
+ ! Do nothing if we are only using one processor
+ if (m > 0) then
+ if (comm_measuretime) then
+ call start_timer(t_haloswap(level,m))
+ end if
+ a_n = a%ix_max-a%ix_min+1
+ nz = a%grid_param%nz
+ stepsize = 2**(pproc-m)
+
+ ! Work out rank, only execute on relevant processes
+ call mpi_comm_rank(MPI_COMM_HORIZ, rank, ierr)
+ call mpi_cart_coords(MPI_COMM_HORIZ,rank,dim_horiz,p_horiz,ierr)
+
+ ! Work out ranks of neighbours
+ ! W -> E
+ call mpi_cart_shift(MPI_COMM_HORIZ,1, stepsize, &
+ neighbour_w_rank,neighbour_e_rank,ierr)
+ ! N -> S
+ call mpi_cart_shift(MPI_COMM_HORIZ,0, stepsize, &
+ neighbour_n_rank,neighbour_s_rank,ierr)
+ if ( (stepsize == 1) .or. &
+ ( (mod(p_horiz(1),stepsize) == 0) .and. &
+ (mod(p_horiz(2),stepsize) == 0) ) ) then
+ if (halo_size == 1) then
+ ! Do not include corners in send/recv
+ yoffset = 1
+ blocklength = a_n*(nz+2)*halo_size
+ else
+ yoffset = 1-halo_size
+ blocklength = (a_n+2*halo_size)*(nz+2)*halo_size
+ end if
+ ! Receive from north
+ recvtag = 2
+ call mpi_irecv(a%s(0,0-(halo_size-1),1),1, &
+ halo_ns(level,m),neighbour_n_rank,recvtag, &
+ MPI_COMM_HORIZ, requests_ns(1), ierr)
+ ! Receive from south
+ recvtag = 3
+ call mpi_irecv(a%s(0,a_n+1,1),1, &
+ halo_ns(level,m),neighbour_s_rank,recvtag, &
+ MPI_COMM_HORIZ, requests_ns(2), ierr)
+ ! Send to south
+ sendtag = 2
+ call mpi_isend(a%s(0,a_n-(halo_size-1),1),1, &
+ halo_ns(level,m),neighbour_s_rank,sendtag, &
+ MPI_COMM_HORIZ, requests_ns(3), ierr)
+ ! Send to north
+ sendtag = 3
+ call mpi_isend(a%s(0,1,1),1, &
+ halo_ns(level,m),neighbour_n_rank,sendtag, &
+ MPI_COMM_HORIZ, requests_ns(4), ierr)
+ if (halo_size > 1) then
+ ! Wait for North <-> South communication to complete
+ call mpi_waitall(4,requests_ns, MPI_STATUSES_IGNORE, ierr)
+ end if
+ ! Receive from west
+ recvtag = 0
+ call mpi_irecv(a%s(0,yoffset,0-(halo_size-1)),blocklength, &
+ MPI_DOUBLE_PRECISION,neighbour_w_rank,recvtag, &
+ MPI_COMM_HORIZ, requests_ew(1), ierr)
+ ! Receive from east
+ sendtag = 1
+ call mpi_irecv(a%s(0,yoffset,a_n+1),blocklength, &
+ MPI_DOUBLE_PRECISION,neighbour_e_rank,recvtag, &
+ MPI_COMM_HORIZ, requests_ew(2), ierr)
+ ! Send to east
+ sendtag = 0
+ call mpi_isend(a%s(0,yoffset,a_n-(halo_size-1)),blocklength, &
+ MPI_DOUBLE_PRECISION,neighbour_e_rank,sendtag, &
+ MPI_COMM_HORIZ, requests_ew(3), ierr)
+ ! Send to west
+ recvtag = 1
+ call mpi_isend(a%s(0,yoffset,1),blocklength, &
+ MPI_DOUBLE_PRECISION,neighbour_w_rank,sendtag, &
+ MPI_COMM_HORIZ, requests_ew(4), ierr)
+ ! Wait for East <-> West communication to complete
+ if (halo_size == 1) then
+ ! Wait for North <-> South communication to complete
+ call mpi_waitall(4,requests_ns, MPI_STATUSES_IGNORE, ierr)
+ end if
+ call mpi_waitall(4,requests_ew, MPI_STATUSES_IGNORE, ierr)
+ end if
+ if (comm_measuretime) then
+ call finish_timer(t_haloswap(level,m))
+ end if
+ end if
+ end subroutine haloswap
+!==================================================================
+! Collect from a(level,m) and store on less processors
+! in b(level,m-1)
+!
+! Example for pproc-m = 1, i.e. stepsize = 2:
+!
+! NW (0,0) <-- NE (0,2)
+!
+! ^ .
+! ! .
+! .
+! SW (2,0) SE (2,2) [send to 0,0]
+!
+!==================================================================
+ subroutine collect(level,m, & ! multigrid and processor level
+ a, & ! IN: data on level (level,m)
+ b) ! OUT: data on level (level,m-1)
+ implicit none
+ integer, intent(in) :: level
+ integer, intent(in) :: m
+ type(scalar3d), intent(in) :: a
+ type(scalar3d), intent(inout) :: b
+ integer :: a_n, b_n ! horizontal grid sizes
+ integer :: nz ! vertical grid size
+ integer, dimension(2) :: p_horiz
+ integer :: stepsize
+ integer :: ierr, source_rank, dest_rank, rank, recv_tag, send_tag, iz
+ logical :: corner_nw, corner_ne, corner_sw, corner_se
+ integer :: recv_request(3)
+ integer :: recv_requestT(3)
+
+ integer :: ii,ij,ik
+
+ real , pointer , contiguous , dimension(:,:,:) :: za_st,zb_st
+
+ real , pointer , contiguous , dimension(:,:,:) :: ztab_interiorT_ne_m_haloTin
+ real , pointer , contiguous , dimension(:,:,:) :: ztab_interiorT_sw_m_haloTin
+ real , pointer , contiguous , dimension(:,:,:) :: ztab_interiorT_se_m_haloTin
+
+ real , pointer , contiguous , dimension(:,:,:) :: ztab_sub_interiorT_ne_m_1_haloTout
+ real , pointer , contiguous , dimension(:,:,:) :: ztab_sub_interiorT_sw_m_1_haloTout
+ real , pointer , contiguous , dimension(:,:,:) :: ztab_sub_interiorT_se_m_1_haloTout
+
+ call start_timer(t_collect(m))
+
+ stepsize = 2**(pproc-m)
+
+ a_n = a%ix_max-a%ix_min+1
+ b_n = b%ix_max-b%ix_min+1
+ nz = b%grid_param%nz
+
+ ! Work out rank, only execute on relevant processes
+ call mpi_comm_rank(MPI_COMM_HORIZ, rank, ierr)
+ ! Store position in process grid in in p_horiz
+ ! Note we can NOT use cart_shift as we need diagonal neighburs as well
+ call mpi_cart_coords(MPI_COMM_HORIZ,rank,dim_horiz,p_horiz,ierr)
+
+ ! Ignore all processes that do not participate at this level
+ if ( (stepsize .eq. 1) .or. ((mod(p_horiz(1),stepsize) == 0) .and. (mod(p_horiz(2),stepsize)) == 0)) then
+ ! Determine position in local 2x2 block
+ if (stepsize .eq. 1) then
+ corner_nw = ((mod(p_horiz(1),2) == 0) .and. (mod(p_horiz(2),2) == 0))
+ corner_ne = ((mod(p_horiz(1),2) == 0) .and. (mod(p_horiz(2),2) == 1))
+ corner_sw = ((mod(p_horiz(1),2) == 1) .and. (mod(p_horiz(2),2) == 0))
+ corner_se = ((mod(p_horiz(1),2) == 1) .and. (mod(p_horiz(2),2) == 1))
+ else
+ corner_nw = ((mod(p_horiz(1)/stepsize,2) == 0) .and. (mod(p_horiz(2)/stepsize,2) == 0))
+ corner_ne = ((mod(p_horiz(1)/stepsize,2) == 0) .and. (mod(p_horiz(2)/stepsize,2) == 1))
+ corner_sw = ((mod(p_horiz(1)/stepsize,2) == 1) .and. (mod(p_horiz(2)/stepsize,2) == 0))
+ corner_se = ((mod(p_horiz(1)/stepsize,2) == 1) .and. (mod(p_horiz(2)/stepsize,2) == 1))
+ end if
+ ! NW receives from the other three processes
+ if ( corner_nw ) then
+ ! Receive from NE
+ call mpi_cart_rank(MPI_COMM_HORIZ, &
+ (/p_horiz(1),p_horiz(2)+stepsize/), &
+ source_rank, &
+ ierr)
+ recv_tag = 1000
+ if (LUseO) call mpi_irecv(b%s(0,1,b_n/2+1),1,sub_interior(level,m-1),source_rank, recv_tag, MPI_COMM_HORIZ, &
+ recv_request(1),ierr)
+ recv_tag = 1010
+ if (LUseT) then
+#ifdef MNH_GPUDIRECT
+ ztab_sub_interiorT_ne_m_1_haloTout => tab_sub_interiorT_ne(level,m-1)%haloTout
+ !$acc host_data use_device(ztab_sub_interiorT_ne_m_1_haloTout)
+ call mpi_irecv(ztab_sub_interiorT_ne_m_1_haloTout,size(ztab_sub_interiorT_ne_m_1_haloTout), &
+ MPI_DOUBLE_PRECISION,source_rank, recv_tag, MPI_COMM_HORIZ, &
+ recv_requestT(1),ierr)
+ !$acc end host_data
+#else
+ call mpi_irecv(b%st(b_n/2+1,1,0),1,sub_interiorT(level,m-1), source_rank, recv_tag, MPI_COMM_HORIZ, &
+ recv_requestT(1),ierr)
+#endif
+ end if
+#ifndef NDEBUG
+ if (ierr .ne. 0) &
+ call fatalerror("Collect: receive from NE failed in mpi_irecv().")
+#endif
+ ! Receive from SW
+ call mpi_cart_rank(MPI_COMM_HORIZ, &
+ (/p_horiz(1)+stepsize,p_horiz(2)/), &
+ source_rank, &
+ ierr)
+ recv_tag = 1001
+ if (LUseO) call mpi_irecv(b%s(0,b_n/2+1,1),1,sub_interior(level,m-1), source_rank, recv_tag, MPI_COMM_HORIZ, &
+ recv_request(2),ierr)
+ recv_tag = 1011
+ if (LUseT) then
+#ifdef MNH_GPUDIRECT
+ ztab_sub_interiorT_sw_m_1_haloTout => tab_sub_interiorT_sw(level,m-1)%haloTout
+ !$acc host_data use_device(ztab_sub_interiorT_sw_m_1_haloTout)
+ call mpi_irecv(ztab_sub_interiorT_sw_m_1_haloTout,size(ztab_sub_interiorT_sw_m_1_haloTout), &
+ MPI_DOUBLE_PRECISION,source_rank, recv_tag, MPI_COMM_HORIZ, &
+ recv_requestT(2),ierr)
+ !$acc end host_data
+#else
+ call mpi_irecv(b%st(1,b_n/2+1,0),1,sub_interiorT(level,m-1), source_rank, recv_tag, MPI_COMM_HORIZ, &
+ recv_requestT(2),ierr)
+#endif
+ endif
+
+#ifndef NDEBUG
+ if (ierr .ne. 0) &
+ call fatalerror("Collect: receive from SW failed in mpi_irecv().")
+#endif
+ ! Receive from SE
+ call mpi_cart_rank(MPI_COMM_HORIZ, &
+ (/p_horiz(1)+stepsize,p_horiz(2)+stepsize/), &
+ source_rank, &
+ ierr)
+ recv_tag = 1002
+ if (LUseO) call mpi_irecv(b%s(0,b_n/2+1,b_n/2+1),1,sub_interior(level,m-1), source_rank, recv_tag, MPI_COMM_HORIZ, &
+ recv_request(3),ierr)
+ recv_tag = 1012
+ if (LUseT) then
+#ifdef MNH_GPUDIRECT
+ ztab_sub_interiorT_se_m_1_haloTout => tab_sub_interiorT_se(level,m-1)%haloTout
+ !$acc host_data use_device(ztab_sub_interiorT_se_m_1_haloTout)
+ call mpi_irecv(ztab_sub_interiorT_se_m_1_haloTout,size(ztab_sub_interiorT_se_m_1_haloTout), &
+ MPI_DOUBLE_PRECISION,source_rank, recv_tag, MPI_COMM_HORIZ, &
+ recv_requestT(3),ierr)
+ !$acc end host_data
+#else
+ call mpi_irecv(b%st(b_n/2+1,b_n/2+1,0),1,sub_interiorT(level,m-1), source_rank, recv_tag, MPI_COMM_HORIZ, &
+ recv_requestT(3),ierr)
+#endif
+ end if
+#ifndef NDEBUG
+ if (ierr .ne. 0) &
+ call fatalerror("Collect: receive from SE failed in mpi_irecv().")
+#endif
+ ! Copy local data while waiting for data from other processes
+ if (LUseO) b%s(0:nz+1,1:a_n,1:a_n) = a%s(0:nz+1,1:a_n,1:a_n)
+ if (LUseT) then
+#ifdef MNH_GPUDIRECT
+ zb_st => b%st
+ za_st => a%st
+ !$acc parallel loop collapse(3)
+ do concurrent (ii=1:a_n,ij=1:a_n,ik=1:nz+2)
+ zb_st(ii,ij,ik-1) = za_st(ii,ij,ik-1)
+ end do
+#else
+ b%st(1:a_n,1:a_n,0:nz+1) = a%st(1:a_n,1:a_n,0:nz+1)
+#endif
+ end if
+ ! Wait for receives to complete before proceeding
+ if (LUseO) call mpi_waitall(3,recv_request,MPI_STATUSES_IGNORE,ierr)
+ if (LUseT) call mpi_waitall(3,recv_requestT,MPI_STATUSES_IGNORE,ierr)
+#ifdef MNH_GPUDIRECT
+ if (LUseT) then
+ zb_st => b%st
+ ! copy from buffer for GPU DIRECT
+ ! Receive from NE
+ !$acc parallel loop collapse(3)
+ do concurrent (ii=1:b_n/2,ij=1:b_n/2,ik=1:nz+2)
+ zb_st(ii+b_n/2,ij,ik-1) = ztab_sub_interiorT_ne_m_1_haloTout(ii,ij,ik)
+ end do
+ ! Receive from SW
+ !$acc parallel loop collapse(3)
+ do concurrent (ii=1:b_n/2,ij=1:b_n/2,ik=1:nz+2)
+ zb_st(ii,ij+b_n/2,ik-1) = ztab_sub_interiorT_sw_m_1_haloTout(ii,ij,ik)
+ end do
+ ! Receive from SE
+ !$acc parallel loop collapse(3)
+ do concurrent (ii=1:b_n/2,ij=1:b_n/2,ik=1:nz+2)
+ zb_st(ii+b_n/2,ij+b_n/2,ik-1) = ztab_sub_interiorT_se_m_1_haloTout(ii,ij,ik)
+ end do
+ end if
+#endif
+ end if
+ if ( corner_ne ) then
+ ! Send to NW
+ call mpi_cart_rank(MPI_COMM_HORIZ, &
+ (/p_horiz(1),p_horiz(2)-stepsize/), &
+ dest_rank, &
+ ierr)
+
+ za_st => a%st
+
+ send_tag = 1000
+ if (LUseO) call mpi_send(a%s(0,1,1),1,interior(level,m),dest_rank,send_tag,MPI_COMM_HORIZ,ierr)
+ send_tag = 1010
+ if (LUseT) then
+#ifdef MNH_GPUDIRECT
+ ztab_interiorT_ne_m_haloTin => tab_interiorT_ne(level,m)%haloTin
+ !$acc parallel loop collapse(3)
+ do concurrent (ii=1:a_n,ij=1:a_n,ik=1:nz+2)
+ ztab_interiorT_ne_m_haloTin(ii,ij,ik) = za_st(ii,ij,ik-1)
+ end do
+ !$acc host_data use_device(ztab_interiorT_ne_m_haloTin)
+ call mpi_send(ztab_interiorT_ne_m_haloTin,size(ztab_interiorT_ne_m_haloTin), &
+ MPI_DOUBLE_PRECISION,dest_rank,send_tag,MPI_COMM_HORIZ,ierr)
+ !$acc end host_data
+#else
+ call mpi_send(a%st(1,1,0),1,interiorT(level,m),dest_rank,send_tag,MPI_COMM_HORIZ,ierr)
+#endif
+ end if
+#ifndef NDEBUG
+ if (ierr .ne. 0) &
+ call fatalerror("Collect: send from NE failed in mpi_send().")
+#endif
+ end if
+ if ( corner_sw ) then
+ ! Send to NW
+ call mpi_cart_rank(MPI_COMM_HORIZ, &
+ (/p_horiz(1)-stepsize,p_horiz(2)/), &
+ dest_rank, &
+ ierr)
+
+ za_st => a%st
+
+ send_tag = 1001
+ if (LUseO) call mpi_send(a%s(0,1,1),1,interior(level,m),dest_rank,send_tag,MPI_COMM_HORIZ,ierr)
+ send_tag = 1011
+ if (LUseT) then
+#ifdef MNH_GPUDIRECT
+ ztab_interiorT_sw_m_haloTin => tab_interiorT_sw(level,m)%haloTin
+ !$acc parallel loop collapse(3)
+ do concurrent (ii=1:a_n,ij=1:a_n,ik=1:nz+2)
+ ztab_interiorT_sw_m_haloTin(ii,ij,ik) = za_st(ii,ij,ik-1)
+ end do
+ !$acc host_data use_device(ztab_interiorT_sw_m_haloTin)
+ call mpi_send(ztab_interiorT_sw_m_haloTin,size(ztab_interiorT_sw_m_haloTin), &
+ MPI_DOUBLE_PRECISION,dest_rank,send_tag,MPI_COMM_HORIZ,ierr)
+ !$acc end host_data
+#else
+ call mpi_send(a%st(1,1,0),1,interiorT(level,m),dest_rank,send_tag,MPI_COMM_HORIZ,ierr)
+#endif
+ end if
+#ifndef NDEBUG
+ if (ierr .ne. 0) &
+ call fatalerror("Collect: send from SW failed in mpi_send().")
+#endif
+ end if
+ if ( corner_se ) then
+ ! send to NW
+ call mpi_cart_rank(MPI_COMM_HORIZ, &
+ (/p_horiz(1)-stepsize,p_horiz(2)-stepsize/), &
+ dest_rank, &
+ ierr)
+
+ za_st => a%st
+
+ send_tag = 1002
+ if (LUseO) call mpi_send(a%s(0,1,1),1,interior(level,m),dest_rank,send_tag,MPI_COMM_HORIZ,ierr)
+ send_tag = 1012
+ if (LUseT) then
+#ifdef MNH_GPUDIRECT
+ ztab_interiorT_se_m_haloTin => tab_interiorT_se(level,m)%haloTin
+ !$acc parallel loop collapse(3)
+ do concurrent (ii=1:a_n,ij=1:a_n,ik=1:nz+2)
+ ztab_interiorT_se_m_haloTin(ii,ij,ik) = za_st(ii,ij,ik-1)
+ end do
+ !$acc host_data use_device(ztab_interiorT_se_m_haloTin)
+ call mpi_send(ztab_interiorT_se_m_haloTin,size(ztab_interiorT_se_m_haloTin), &
+ MPI_DOUBLE_PRECISION,dest_rank,send_tag,MPI_COMM_HORIZ,ierr)
+ !$acc end host_data
+#else
+ call mpi_send(a%st(1,1,0),1,interiorT(level,m),dest_rank,send_tag,MPI_COMM_HORIZ,ierr)
+#endif
+ end if
+#ifndef NDEBUG
+ if (ierr .ne. 0) &
+ call fatalerror("Collect: send from SE failed in mpi_send().")
+#endif
+ end if
+
+ end if
+ call finish_timer(t_collect(m))
+
+ end subroutine collect
+
+!==================================================================
+! Distribute data in a(level,m-1) and store in b(level,m)
+!
+! Example for p-m = 1, i.e. stepsize = 2:
+!
+! NW (0,0) --> NE (2,0)
+!
+! ! .
+! v .
+! .
+! SW (0,2) SE (2,2) [receive from to 0,0]
+!==================================================================
+ subroutine distribute(level,m, & ! multigrid and processor level
+ a, & ! IN: Data on level (level,m-1)
+ b) ! OUT: Data on level (level,m)
+ implicit none
+ integer, intent(in) :: level
+ integer, intent(in) :: m
+ type(scalar3d), intent(in) :: a
+ type(scalar3d), intent(inout) :: b
+ integer :: a_n, b_n ! horizontal grid sizes
+ integer :: nz ! vertical grid size
+ integer, dimension(2) :: p_horiz
+ integer :: stepsize
+ integer :: ierr, source_rank, dest_rank, send_tag, recv_tag, rank, iz
+ integer :: stat(MPI_STATUS_SIZE)
+ integer :: send_request(3)
+ integer :: send_requestT(3)
+ logical :: corner_nw, corner_ne, corner_sw, corner_se
+
+ integer :: ii,ij,ik
+
+ real , pointer , contiguous , dimension(:,:,:) :: za_st,zb_st
+
+ real , pointer , contiguous , dimension(:,:,:) :: ztab_sub_interiorT_ne_m_1_haloTin
+ real , pointer , contiguous , dimension(:,:,:) :: ztab_sub_interiorT_sw_m_1_haloTin
+ real , pointer , contiguous , dimension(:,:,:) :: ztab_sub_interiorT_se_m_1_haloTin
+
+ real , pointer , contiguous , dimension(:,:,:) :: ztab_interiorT_ne_m_haloTout
+ real , pointer , contiguous , dimension(:,:,:) :: ztab_interiorT_sw_m_haloTout
+ real , pointer , contiguous , dimension(:,:,:) :: ztab_interiorT_se_m_haloTout
+
+ call start_timer(t_distribute(m))
+
+ stepsize = 2**(pproc-m)
+
+ a_n = a%ix_max-a%ix_min+1
+ b_n = b%ix_max-b%ix_min+1
+ nz = a%grid_param%nz
+
+ ! Work out rank, only execute on relevant processes
+ call mpi_comm_rank(MPI_COMM_HORIZ, rank, ierr)
+ call mpi_cart_coords(MPI_COMM_HORIZ,rank,dim_horiz,p_horiz,ierr)
+
+ ! Ignore all processes that do not participate at this level
+ if ( (stepsize .eq. 1) .or. ((mod(p_horiz(1),stepsize) == 0) .and. (mod(p_horiz(2),stepsize)) == 0)) then
+ ! Work out coordinates in local 2 x 2 block
+ if (stepsize .eq. 1) then
+ corner_nw = ((mod(p_horiz(1),2) == 0) .and. (mod(p_horiz(2),2) == 0))
+ corner_ne = ((mod(p_horiz(1),2) == 0) .and. (mod(p_horiz(2),2) == 1))
+ corner_sw = ((mod(p_horiz(1),2) == 1) .and. (mod(p_horiz(2),2) == 0))
+ corner_se = ((mod(p_horiz(1),2) == 1) .and. (mod(p_horiz(2),2) == 1))
+ else
+ corner_nw = ((mod(p_horiz(1)/stepsize,2) == 0) .and. (mod(p_horiz(2)/stepsize,2) == 0))
+ corner_ne = ((mod(p_horiz(1)/stepsize,2) == 0) .and. (mod(p_horiz(2)/stepsize,2) == 1))
+ corner_sw = ((mod(p_horiz(1)/stepsize,2) == 1) .and. (mod(p_horiz(2)/stepsize,2) == 0))
+ corner_se = ((mod(p_horiz(1)/stepsize,2) == 1) .and. (mod(p_horiz(2)/stepsize,2) == 1))
+ end if
+ if ( corner_nw ) then
+ ! (Asynchronous) send to NE
+ call mpi_cart_rank(MPI_COMM_HORIZ, &
+ (/p_horiz(1),p_horiz(2)+stepsize/), &
+ dest_rank, &
+ ierr)
+
+ za_st => a%st
+
+ send_tag = 1000
+ if (LUseO) call mpi_isend(a%s(0,1,a_n/2+1), 1,sub_interior(level,m-1),dest_rank, send_tag, &
+ MPI_COMM_HORIZ,send_request(1),ierr)
+ send_tag = 1010
+ if (LUseT) then
+#ifdef MNH_GPUDIRECT
+ ztab_sub_interiorT_ne_m_1_haloTin => tab_sub_interiorT_ne(level,m-1)%haloTin
+ !$acc parallel loop collapse(3)
+ do concurrent (ii=1:a_n/2,ij=1:a_n/2,ik=1:nz+2)
+ ztab_sub_interiorT_ne_m_1_haloTin(ii,ij,ik) = za_st(ii+a_n/2,ij,ik-1)
+ end do
+ !$acc host_data use_device(ztab_sub_interiorT_ne_m_1_haloTin)
+ call mpi_isend(ztab_sub_interiorT_ne_m_1_haloTin,size(ztab_sub_interiorT_ne_m_1_haloTin), &
+ MPI_DOUBLE_PRECISION,dest_rank, send_tag, &
+ MPI_COMM_HORIZ,send_requestT(1),ierr)
+ !$acc end host_data
+#else
+ call mpi_isend(a%st(a_n/2+1,1,0), 1,sub_interiorT(level,m-1),dest_rank, send_tag, &
+ MPI_COMM_HORIZ,send_requestT(1),ierr)
+#endif
+ end if
+#ifndef NDEBUG
+ if (ierr .ne. 0) &
+ call fatalerror("Distribute: send to NE failed in mpi_isend().")
+#endif
+ ! (Asynchronous) send to SW
+ call mpi_cart_rank(MPI_COMM_HORIZ, &
+ (/p_horiz(1)+stepsize,p_horiz(2)/), &
+ dest_rank, &
+ ierr)
+ send_tag = 1001
+ if (LUseO) call mpi_isend(a%s(0,a_n/2+1,1),1,sub_interior(level,m-1), dest_rank, send_tag, &
+ MPI_COMM_HORIZ, send_request(2), ierr)
+ send_tag = 1011
+ if (LUseT) then
+#ifdef MNH_GPUDIRECT
+ ztab_sub_interiorT_sw_m_1_haloTin => tab_sub_interiorT_sw(level,m-1)%haloTin
+ !$acc parallel loop collapse(3)
+ do concurrent (ii=1:a_n/2,ij=1:a_n/2,ik=1:nz+2)
+ ztab_sub_interiorT_sw_m_1_haloTin(ii,ij,ik) = za_st(ii,ij+a_n/2,ik-1)
+ end do
+ !$acc host_data use_device(ztab_sub_interiorT_sw_m_1_haloTin)
+ call mpi_isend(ztab_sub_interiorT_sw_m_1_haloTin,size(ztab_sub_interiorT_sw_m_1_haloTin), &
+ MPI_DOUBLE_PRECISION, dest_rank, send_tag, &
+ MPI_COMM_HORIZ, send_requestT(2), ierr)
+ !$acc end host_data
+#else
+ call mpi_isend(a%st(1,a_n/2+1,0),1,sub_interiorT(level,m-1), dest_rank, send_tag, &
+ MPI_COMM_HORIZ, send_requestT(2), ierr)
+#endif
+ end if
+
+#ifndef NDEBUG
+ if (ierr .ne. 0) &
+ call fatalerror("Distribute: send to SW failed in mpi_isend().")
+#endif
+ ! (Asynchronous) send to SE
+ call mpi_cart_rank(MPI_COMM_HORIZ, &
+ (/p_horiz(1)+stepsize,p_horiz(2)+stepsize/), &
+ dest_rank, &
+ ierr)
+ send_tag = 1002
+ if (LUseO) call mpi_isend(a%s(0,a_n/2+1,a_n/2+1),1,sub_interior(level,m-1), dest_rank, send_tag, &
+ MPI_COMM_HORIZ, send_request(3), ierr)
+ send_tag = 1012
+ if (LUseT) then
+#ifdef MNH_GPUDIRECT
+ ztab_sub_interiorT_se_m_1_haloTin => tab_sub_interiorT_se(level,m-1)%haloTin
+ !$acc parallel loop collapse(3)
+ do concurrent (ii=1:a_n/2,ij=1:a_n/2,ik=1:nz+2)
+ ztab_sub_interiorT_se_m_1_haloTin(ii,ij,ik) = za_st(ii+a_n/2,ij+a_n/2,ik-1)
+ end do
+ !$acc host_data use_device(ztab_sub_interiorT_se_m_1_haloTin)
+ call mpi_isend(ztab_sub_interiorT_se_m_1_haloTin,size(ztab_sub_interiorT_se_m_1_haloTin), &
+ MPI_DOUBLE_PRECISION, dest_rank, send_tag, &
+ MPI_COMM_HORIZ, send_requestT(3), ierr)
+ !$acc end host_data
+#else
+ call mpi_isend(a%st(a_n/2+1,a_n/2+1,0),1,sub_interiorT(level,m-1), dest_rank, send_tag, &
+ MPI_COMM_HORIZ, send_requestT(3), ierr)
+#endif
+ end if
+#ifndef NDEBUG
+ if (ierr .ne. 0) &
+ call fatalerror("Distribute: send to SE failed in mpi_isend().")
+#endif
+ ! While sending, copy local data
+ if (LUseO) b%s(0:nz+1,1:b_n,1:b_n) = a%s(0:nz+1,1:b_n,1:b_n)
+ if (LUseT) then
+#ifdef MNH_GPUDIRECT
+ zb_st => b%st
+ za_st => a%st
+ !$acc parallel loop collapse(3)
+ do concurrent (ii=1:b_n,ij=1:b_n,ik=1:nz+2)
+ zb_st(ii,ij,ik-1) = za_st(ii,ij,ik-1)
+ end do
+#else
+ b%st(1:b_n,1:b_n,0:nz+1) = a%st(1:b_n,1:b_n,0:nz+1)
+#endif
+ end if
+ ! Only proceed when async sends to complete
+ if (LUseO) call mpi_waitall(3, send_request, MPI_STATUSES_IGNORE, ierr)
+ if (LUseT) call mpi_waitall(3, send_requestT, MPI_STATUSES_IGNORE, ierr)
+ end if
+ if ( corner_ne ) then
+
+ ! Receive from NW
+ call mpi_cart_rank(MPI_COMM_HORIZ, &
+ (/p_horiz(1),p_horiz(2)-stepsize/), &
+ source_rank, &
+ ierr)
+
+ zb_st => b%st
+
+ recv_tag = 1000
+ if (LUseO) call mpi_recv(b%s(0,1,1),1,interior(level,m),source_rank,recv_tag,MPI_COMM_HORIZ,stat,ierr)
+ recv_tag = 1010
+ if (LUseT) then
+#ifdef MNH_GPUDIRECT
+ ztab_interiorT_ne_m_haloTout => tab_interiorT_ne(level,m)%haloTout
+ !$acc host_data use_device(ztab_interiorT_ne_m_haloTout)
+ call mpi_recv(ztab_interiorT_ne_m_haloTout,size(ztab_interiorT_ne_m_haloTout), &
+ MPI_DOUBLE_PRECISION,source_rank,recv_tag,MPI_COMM_HORIZ,stat,ierr)
+ !$acc end host_data
+ !$acc parallel loop collapse(3)
+ do concurrent (ii=1:b_n,ij=1:b_n,ik=1:nz+2)
+ zb_st(ii,ij,ik-1) = ztab_interiorT_ne_m_haloTout(ii,ij,ik)
+ end do
+#else
+ call mpi_recv(b%st(1,1,0),1,interiorT(level,m),source_rank,recv_tag,MPI_COMM_HORIZ,stat,ierr)
+#endif
+ end if
+#ifndef NDEBUG
+ if (ierr .ne. 0) &
+ call fatalerror("Distribute: receive on NE failed in mpi_recv().")
+#endif
+ end if
+ if ( corner_sw ) then
+ ! Receive from NW
+ call mpi_cart_rank(MPI_COMM_HORIZ, &
+ (/p_horiz(1)-stepsize,p_horiz(2)/), &
+ source_rank, &
+ ierr)
+
+ zb_st => b%st
+
+ recv_tag = 1001
+ if (LUseO) call mpi_recv(b%s(0,1,1),1,interior(level,m),source_rank,recv_tag,MPI_COMM_HORIZ,stat,ierr)
+ recv_tag = 1011
+ if (LUseT) then
+#ifdef MNH_GPUDIRECT
+ ztab_interiorT_sw_m_haloTout => tab_interiorT_sw(level,m)%haloTout
+ !$acc host_data use_device(ztab_interiorT_sw_m_haloTout)
+ call mpi_recv(ztab_interiorT_sw_m_haloTout,size(ztab_interiorT_sw_m_haloTout), &
+ MPI_DOUBLE_PRECISION,source_rank,recv_tag,MPI_COMM_HORIZ,stat,ierr)
+ !$acc end host_data
+ !$acc parallel loop collapse(3)
+ do concurrent (ii=1:b_n,ij=1:b_n,ik=1:nz+2)
+ zb_st(ii,ij,ik-1) = ztab_interiorT_sw_m_haloTout(ii,ij,ik)
+ end do
+#else
+ call mpi_recv(b%st(1,1,0),1,interiorT(level,m),source_rank,recv_tag,MPI_COMM_HORIZ,stat,ierr)
+#endif
+ end if
+#ifndef NDEBUG
+ if (ierr .ne. 0) &
+ call fatalerror("Distribute: receive on SW failed in mpi_recv().")
+#endif
+ end if
+ if ( corner_se ) then
+ ! Receive from NW
+ call mpi_cart_rank(MPI_COMM_HORIZ, &
+ (/p_horiz(1)-stepsize,p_horiz(2)-stepsize/), &
+ source_rank, &
+ ierr)
+
+ zb_st => b%st
+
+ recv_tag = 1002
+ if (LUseO) call mpi_recv(b%s(0,1,1),1,interior(level,m),source_rank,recv_tag,MPI_COMM_HORIZ,stat,ierr)
+ recv_tag = 1012
+ if (LUseT) then
+#ifdef MNH_GPUDIRECT
+ ztab_interiorT_se_m_haloTout => tab_interiorT_se(level,m)%haloTout
+ !$acc host_data use_device(ztab_interiorT_se_m_haloTout)
+ call mpi_recv(ztab_interiorT_se_m_haloTout,size(ztab_interiorT_se_m_haloTout), &
+ MPI_DOUBLE_PRECISION,source_rank,recv_tag,MPI_COMM_HORIZ,stat,ierr)
+ !$acc end host_data
+ !$acc parallel loop collapse(3)
+ do concurrent (ii=1:b_n,ij=1:b_n,ik=1:nz+2)
+ zb_st(ii,ij,ik-1) = ztab_interiorT_se_m_haloTout(ii,ij,ik)
+ end do
+#else
+ call mpi_recv(b%st(1,1,0),1,interiorT(level,m),source_rank,recv_tag,MPI_COMM_HORIZ,stat,ierr)
+#endif
+ end if
+#ifndef NDEBUG
+ if (ierr .ne. 0) &
+ call fatalerror("Distribute: receive on NW failed in mpi_recv().")
+#endif
+ end if
+
+ end if
+ call finish_timer(t_distribute(m))
+
+ end subroutine distribute
+
+end module communication
diff --git a/src/ZSOLVER/tensorproductmultigrid_Source/compile_tensor b/src/ZSOLVER/tensorproductmultigrid_Source/compile_tensor
new file mode 100755
index 0000000000000000000000000000000000000000..07637c68a0da31c9f105c3cea9208f4a40223d00
--- /dev/null
+++ b/src/ZSOLVER/tensorproductmultigrid_Source/compile_tensor
@@ -0,0 +1,48 @@
+#!/bin/bash
+
+set -x
+set -e
+
+OPT_BASE=" -Mbackslash -Mextend -Kieee -nofma -Mallocatable=95 "
+#OPT_BASE=" -Mbackslash -Mextend -Mallocatable=95 "
+
+#OPTLEVEL=" -O2 -ta=multicore,tesla:nofma,managed "
+#OPTLEVEL=" -g -O2 -ta=multicore,tesla:managed "
+#OPTLEVEL=" -tp=px -O2 -ta=multicore,tesla,nofma,cc35,cc50,cc70,cuda10.1,managed -Minfo=accel,ccff -Mprof=ccff "
+#OPTLEVEL=" -O2 -ta=multicore,tesla,nofma,cc70,cuda11.0,managed -Minfo=accel "
+OPTLEVEL_MAN=" -Mpreprocess -O4 -ta=host,tesla,nofma,cc70,cuda11.0,managed -Minfo=accel "
+OPTLEVEL_ACC=" -Mpreprocess -O4 -ta=host,tesla,nofma,cc70,cuda11.0 -Minfo=accel "
+#OPTLEVEL=" -Mpreprocess -O2 -ta=host,tesla,nofma,cc70,cuda11.0,managed -Minfo=accel "
+#OPTLEVEL=" -O2 -ta=tesla:nofma,managed "
+
+#OPT="-r8 -DCARTESIANGEOMETRY -DOVERLAPCOMMS -DPIECEWISELINEAR -Mpreprocess ${OPT_BASE} ${OPTLEVEL} "
+OPT="-r8 -DMNH_GPUDIRECT -DCARTESIANGEOMETRY -DPIECEWISELINEAR -Mpreprocess ${OPT_BASE} ${OPTLEVEL_MAN} "
+
+OPT_ACC="-r8 -DMNH_GPUDIRECT -DCARTESIANGEOMETRY -DPIECEWISELINEAR -Mpreprocess ${OPT_BASE} ${OPTLEVEL_ACC} "
+
+F90="mpif90 ${OPT} "
+
+F90_ACC="mpif90 ${OPT_ACC} "
+
+rm -f *.o *.mod mg_main_mnh
+
+pgf90 -show ${OPT} mg_main_mnh.f90
+
+${F90_ACC} -c mode_mnh_allocate_mg_halo.f90
+
+for file in mode_openacc_set_device.f90 parameters.f90 messages.f90 datatypes.f90 timer.f90 communication.f90 discretisation.f90 \
+ solver.f90 conjugategradient.f90 multigrid.f90 profiles.f90 mode_mg_read_param.f90 \
+ mode_mg.f90 mode_mg_read_param.f90 \
+ dblas.f90
+do
+echo ====== file=$file
+${F90} -c $file
+done
+
+
+${F90} -o mg_main_mnh${XYZ} mg_main_mnh.f90 *.o
+
+rm -f *.o *.mod
+
+
+
diff --git a/src/ZSOLVER/tensorproductmultigrid_Source/conjugategradient.f90 b/src/ZSOLVER/tensorproductmultigrid_Source/conjugategradient.f90
new file mode 100644
index 0000000000000000000000000000000000000000..30277d8625ad6735444ad7335b761ab6ed369b7a
--- /dev/null
+++ b/src/ZSOLVER/tensorproductmultigrid_Source/conjugategradient.f90
@@ -0,0 +1,529 @@
+!=== COPYRIGHT AND LICENSE STATEMENT ===
+!
+! This file is part of the TensorProductMultigrid code.
+!
+! (c) The copyright relating to this work is owned jointly by the
+! Crown, Met Office and NERC [2014]. However, it has been created
+! with the help of the GungHo Consortium, whose members are identified
+! at https://puma.nerc.ac.uk/trac/GungHo/wiki .
+!
+! Main Developer: Eike Mueller
+!
+! TensorProductMultigrid is free software: you can redistribute it and/or
+! modify it under the terms of the GNU Lesser General Public License as
+! published by the Free Software Foundation, either version 3 of the
+! License, or (at your option) any later version.
+!
+! TensorProductMultigrid is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU Lesser General Public License for more details.
+!
+! You should have received a copy of the GNU Lesser General Public License
+! along with TensorProductMultigrid (see files COPYING and COPYING.LESSER).
+! If not, see <http://www.gnu.org/licenses/>.
+!
+!=== COPYRIGHT AND LICENSE STATEMENT ===
+
+
+!==================================================================
+!
+! Conjugate gradient solver
+!
+! Eike Mueller, University of Bath, Feb 2012
+!
+!==================================================================
+module conjugategradient
+
+ use parameters
+ use datatypes
+ use discretisation
+ use messages
+ use communication
+#ifndef MNH
+ use mpi
+#else
+ use modd_mpif
+#endif
+
+ implicit none
+
+public::cg_parameters
+public::cg_initialise
+public::cg_finalise
+public::cg_solve_mnh
+public::cg_solve
+
+private
+
+ ! --- Conjugate gradient parameters type ---
+ type cg_parameters
+ ! Verbosity level
+ integer :: verbose
+ ! Maximal number of iterations
+ integer :: maxiter
+ ! Required residual reduction
+ real(kind=rl) :: resreduction
+ ! Smoother iterations in preconditioner
+ integer :: n_prec
+ end type cg_parameters
+
+! --- Parameters ---
+ type(cg_parameters) :: cg_param
+ type(grid_parameters) :: grid_param
+
+contains
+
+!==================================================================
+! Initialise conjugate gradient module,
+!==================================================================
+ subroutine cg_initialise(cg_param_in) & ! Conjugate gradient
+ & ! parameters
+ implicit none
+ type(cg_parameters), intent(in) :: cg_param_in
+
+ if (i_am_master_mpi) then
+ write(STDOUT,*) '*** Initialising Conjugate gradient ***'
+ write(STDOUT,*) ''
+ end if
+ cg_param = cg_param_in
+ end subroutine cg_initialise
+
+!==================================================================
+! Finalise conjugate gradient module,
+!==================================================================
+ subroutine cg_finalise()
+ implicit none
+
+ if (i_am_master_mpi) then
+ write(STDOUT,*) '*** Finalising Conjugate gradient ***'
+ write(STDOUT,*) ''
+ end if
+ end subroutine cg_finalise
+
+!==================================================================
+! Solve A.u = b.
+!==================================================================
+ subroutine cg_solve_mnh(level,m,b,u)
+ implicit none
+ integer, intent(in) :: level
+ integer, intent(in) :: m
+ type(scalar3d), intent(in) :: b ! RHS vector
+ type(scalar3d), intent(inout) :: u ! solution vector
+ type(scalar3d) :: p ! } Auxilliary vectors
+ type(scalar3d) :: r ! } Auxilliary vectors
+ type(scalar3d) :: Ap ! }
+ type(scalar3d) :: z ! }
+ integer :: n_lin
+ real(kind=rl) :: res0, rz, rz_old, res, alpha
+ integer :: i
+ logical :: solver_converged = .false.
+ integer :: n, nz, nlocal, halo_size
+ real(kind=rl) :: pAp
+
+ ! Initialise auxiliary fields
+ p%grid_param = u%grid_param
+ p%ix_min = u%ix_min
+ p%ix_max = u%ix_max
+ p%iy_min = u%iy_min
+ p%iy_max = u%iy_max
+ p%icompx_min = u%icompx_min
+ p%icompx_max = u%icompx_max
+ p%icompy_min = u%icompy_min
+ p%icompy_max = u%icompy_max
+ p%halo_size = u%halo_size
+
+ r%grid_param = u%grid_param
+ r%ix_min = u%ix_min
+ r%ix_max = u%ix_max
+ r%iy_min = u%iy_min
+ r%iy_max = u%iy_max
+ r%icompx_min = u%icompx_min
+ r%icompx_max = u%icompx_max
+ r%icompy_min = u%icompy_min
+ r%icompy_max = u%icompy_max
+ r%halo_size = u%halo_size
+
+ z%grid_param = u%grid_param
+ z%ix_min = u%ix_min
+ z%ix_max = u%ix_max
+ z%iy_min = u%iy_min
+ z%iy_max = u%iy_max
+ z%icompx_min = u%icompx_min
+ z%icompx_max = u%icompx_max
+ z%icompy_min = u%icompy_min
+ z%icompy_max = u%icompy_max
+ z%halo_size = u%halo_size
+
+ Ap%grid_param = u%grid_param
+ Ap%ix_min = u%ix_min
+ Ap%ix_max = u%ix_max
+ Ap%iy_min = u%iy_min
+ Ap%iy_max = u%iy_max
+ Ap%icompx_min = u%icompx_min
+ Ap%icompx_max = u%icompx_max
+ Ap%icompy_min = u%icompy_min
+ Ap%icompy_max = u%icompy_max
+ Ap%halo_size = u%halo_size
+
+ n = u%ix_max-u%ix_min+1
+ nz = u%grid_param%nz
+
+ nlocal = u%ix_max - u%ix_min + 1
+ halo_size = u%halo_size
+
+ n_lin = (nlocal+2*halo_size)**2 * (nz+2)
+
+ if (LUseO) then
+ allocate(r%s(0:nz+1, &
+ 1-halo_size:nlocal+halo_size, &
+ 1-halo_size:nlocal+halo_size) )
+ allocate(z%s(0:nz+1, &
+ 1-halo_size:nlocal+halo_size, &
+ 1-halo_size:nlocal+halo_size) )
+ allocate(p%s(0:nz+1, &
+ 1-halo_size:nlocal+halo_size, &
+ 1-halo_size:nlocal+halo_size) )
+ allocate(Ap%s(0:nz+1, &
+ 1-halo_size:nlocal+halo_size, &
+ 1-halo_size:nlocal+halo_size) )
+ r%s = 0.0_rl
+ z%s = 0.0_rl
+ p%s = 0.0_rl
+ Ap%s = 0.0_rl
+ endif
+
+ if (LUseT) then
+ allocate(r%st(1-halo_size:nlocal+halo_size, &
+ 1-halo_size:nlocal+halo_size, &
+ 0:nz+1) )
+ allocate(z%st(1-halo_size:nlocal+halo_size, &
+ 1-halo_size:nlocal+halo_size, &
+ 0:nz+1) )
+ allocate(p%st(1-halo_size:nlocal+halo_size, &
+ 1-halo_size:nlocal+halo_size, &
+ 0:nz+1) )
+ allocate(Ap%st(1-halo_size:nlocal+halo_size, &
+ 1-halo_size:nlocal+halo_size, &
+ 0:nz+1) )
+ r%st = 0.0_rl
+ z%st = 0.0_rl
+ p%st = 0.0_rl
+ Ap%st = 0.0_rl
+ endif
+
+
+ ! Initialise
+ ! r <- b - A.u
+ call calculate_residual_mnh(level,m,b,u,r)
+ ! z <- M^{-1} r
+ if (cg_param%n_prec > 0) then
+ call smooth_mnh(level,m,cg_param%n_prec,DIRECTION_FORWARD,r,z)
+ call smooth_mnh(level,m,cg_param%n_prec,DIRECTION_BACKWARD,r,z)
+ else
+ if (LUseO) call dcopy(n_lin,r%s,1,z%s,1)
+ if (LUseT) call dcopy(n_lin,r%st,1,z%st,1)
+ end if
+ ! p <- z
+ if (LUseO) call dcopy(n_lin,z%s,1,p%s,1)
+ if (LUseT) call dcopy(n_lin,z%st,1,p%st,1)
+ ! rz_old = <r,z>
+ call scalarprod_mnh(m,r,z,rz_old)
+ ! res0 <- ||r||
+ call scalarprod_mnh(m,r,r,res0)
+ res0 = dsqrt(res0)
+ if (cg_param%verbose > 0) then
+ if (i_am_master_mpi) then
+ write(STDOUT,'(" *** CG Solver ( ",I10," dof ) ***")') n_lin
+ write(STDOUT,'(" <CG> Initial residual ||r_0|| = ",E12.6)') res0
+ end if
+ endif
+ if (res0 > tolerance) then
+ do i=1,cg_param%maxiter
+ ! Ap <- A.p
+ call haloswap_mnh(level,m,p)
+ call apply_mnh(p,Ap)
+ ! alpha <- res_old / <p,A.p>
+ call scalarprod_mnh(m,p,Ap,pAp)
+ alpha = rz_old/pAp
+ ! x <- x + alpha*p
+ if (LUseO) call daxpy(n_lin,alpha,p%s,1,u%s,1)
+ if (LUseT) call daxpy(n_lin,alpha,p%st,1,u%st,1)
+ ! r <- r - alpha*A.p
+ if (LUseO) call daxpy(n_lin,-alpha,Ap%s,1,r%s,1)
+ if (LUseT) call daxpy(n_lin,-alpha,Ap%st,1,r%st,1)
+ call scalarprod_mnh(m,r,r,res)
+ res = dsqrt(res)
+ if (cg_param%verbose > 1) then
+ if (i_am_master_mpi) then
+ write(STDOUT,'(" <CG> Iteration ",I6," ||r|| = ",E12.6)') &
+ i, res
+ end if
+ end if
+ if ( (res/res0 < cg_param%resreduction) .or. &
+ (res < tolerance ) ) then
+ solver_converged = .true.
+ exit
+ end if
+ ! z <- M^{-1} r
+ if (LUseO) z%s = 0.0_rl
+ if (LUseT) z%st = 0.0_rl
+ if (cg_param%n_prec > 0) then
+ call smooth_mnh(level,m,cg_param%n_prec,DIRECTION_FORWARD,r,z)
+ call smooth_mnh(level,m,cg_param%n_prec,DIRECTION_BACKWARD,r,z)
+ else
+ if (LUseO) call dcopy(n_lin,r%s,1,z%s,1)
+ if (LUseT) call dcopy(n_lin,r%st,1,z%st,1)
+ end if
+ call scalarprod_mnh(m,r,z,rz)
+ ! p <- res/res_old*p
+ if (LUseO) call dscal(n_lin,rz/rz_old,p%s,1)
+ if (LUseT) call dscal(n_lin,rz/rz_old,p%st,1)
+ ! p <- p + z
+ if (LUseO) call daxpy(n_lin,1.0_rl,z%s,1,p%s,1)
+ if (LUseT) call daxpy(n_lin,1.0_rl,z%st,1,p%st,1)
+ rz_old = rz
+ end do
+ else
+ res = res0
+ solver_converged = .true.
+ end if
+ if (cg_param%verbose>0) then
+ if (solver_converged) then
+ if (i_am_master_mpi) then
+ write(STDOUT,'(" <CG> Final residual ||r|| = ",E12.6)') res
+ write(STDOUT,'(" <CG> CG solver converged after ",I6," iterations rho_avg = ",F10.6)') i, (res/res0)**(1.0_rl/i)
+ end if
+ else
+ call warning(" <CG> Solver did not converge")
+ endif
+ end if
+
+ if (LUseO) then
+ deallocate(r%s)
+ deallocate(z%s)
+ deallocate(p%s)
+ deallocate(Ap%s)
+ end if
+
+ if (LUseT) then
+ deallocate(r%st)
+ deallocate(z%st)
+ deallocate(p%st)
+ deallocate(Ap%st)
+ end if
+
+ end subroutine cg_solve_mnh
+!==================================================================
+! Solve A.u = b.
+!==================================================================
+ subroutine cg_solve(level,m,b,u)
+ implicit none
+ integer, intent(in) :: level
+ integer, intent(in) :: m
+ type(scalar3d), intent(in) :: b ! RHS vector
+ type(scalar3d), intent(inout) :: u ! solution vector
+ type(scalar3d) :: p ! } Auxilliary vectors
+ type(scalar3d) :: r ! } Auxilliary vectors
+ type(scalar3d) :: Ap ! }
+ type(scalar3d) :: z ! }
+ integer :: n_lin
+ real(kind=rl) :: res0, rz, rz_old, res, alpha
+ integer :: i
+ logical :: solver_converged = .false.
+ integer :: n, nz, nlocal, halo_size
+ real(kind=rl) :: pAp
+
+ ! Initialise auxiliary fields
+ p%grid_param = u%grid_param
+ p%ix_min = u%ix_min
+ p%ix_max = u%ix_max
+ p%iy_min = u%iy_min
+ p%iy_max = u%iy_max
+ p%icompx_min = u%icompx_min
+ p%icompx_max = u%icompx_max
+ p%icompy_min = u%icompy_min
+ p%icompy_max = u%icompy_max
+ p%halo_size = u%halo_size
+
+ r%grid_param = u%grid_param
+ r%ix_min = u%ix_min
+ r%ix_max = u%ix_max
+ r%iy_min = u%iy_min
+ r%iy_max = u%iy_max
+ r%icompx_min = u%icompx_min
+ r%icompx_max = u%icompx_max
+ r%icompy_min = u%icompy_min
+ r%icompy_max = u%icompy_max
+ r%halo_size = u%halo_size
+
+ z%grid_param = u%grid_param
+ z%ix_min = u%ix_min
+ z%ix_max = u%ix_max
+ z%iy_min = u%iy_min
+ z%iy_max = u%iy_max
+ z%icompx_min = u%icompx_min
+ z%icompx_max = u%icompx_max
+ z%icompy_min = u%icompy_min
+ z%icompy_max = u%icompy_max
+ z%halo_size = u%halo_size
+
+ Ap%grid_param = u%grid_param
+ Ap%ix_min = u%ix_min
+ Ap%ix_max = u%ix_max
+ Ap%iy_min = u%iy_min
+ Ap%iy_max = u%iy_max
+ Ap%icompx_min = u%icompx_min
+ Ap%icompx_max = u%icompx_max
+ Ap%icompy_min = u%icompy_min
+ Ap%icompy_max = u%icompy_max
+ Ap%halo_size = u%halo_size
+
+ n = u%ix_max-u%ix_min+1
+ nz = u%grid_param%nz
+
+ nlocal = u%ix_max - u%ix_min + 1
+ halo_size = u%halo_size
+
+ n_lin = (nlocal+2*halo_size)**2 * (nz+2)
+
+ if (LUseO) then
+ allocate(r%s(0:nz+1, &
+ 1-halo_size:nlocal+halo_size, &
+ 1-halo_size:nlocal+halo_size) )
+ allocate(z%s(0:nz+1, &
+ 1-halo_size:nlocal+halo_size, &
+ 1-halo_size:nlocal+halo_size) )
+ allocate(p%s(0:nz+1, &
+ 1-halo_size:nlocal+halo_size, &
+ 1-halo_size:nlocal+halo_size) )
+ allocate(Ap%s(0:nz+1, &
+ 1-halo_size:nlocal+halo_size, &
+ 1-halo_size:nlocal+halo_size) )
+ r%s = 0.0_rl
+ z%s = 0.0_rl
+ p%s = 0.0_rl
+ Ap%s = 0.0_rl
+ end if
+
+ if (LUseT) then
+ allocate(r%st(1-halo_size:nlocal+halo_size, &
+ 1-halo_size:nlocal+halo_size, &
+ 0:nz+1) )
+ allocate(z%st(1-halo_size:nlocal+halo_size, &
+ 1-halo_size:nlocal+halo_size, &
+ 0:nz+1) )
+ allocate(p%st(1-halo_size:nlocal+halo_size, &
+ 1-halo_size:nlocal+halo_size, &
+ 0:nz+1) )
+ allocate(Ap%st(1-halo_size:nlocal+halo_size, &
+ 1-halo_size:nlocal+halo_size, &
+ 0:nz+1) )
+ r%st = 0.0_rl
+ z%st = 0.0_rl
+ p%st = 0.0_rl
+ Ap%st = 0.0_rl
+ end if
+
+ ! Initialise
+ ! r <- b - A.u
+ call calculate_residual(level,m,b,u,r)
+ ! z <- M^{-1} r
+ if (cg_param%n_prec > 0) then
+ call smooth(level,m,cg_param%n_prec,DIRECTION_FORWARD,r,z)
+ call smooth(level,m,cg_param%n_prec,DIRECTION_BACKWARD,r,z)
+ else
+ if (LUseO) call dcopy(n_lin,r%s,1,z%s,1)
+ if (LUseT) call dcopy(n_lin,r%st,1,z%st,1)
+ end if
+ ! p <- z
+ if (LUseO) call dcopy(n_lin,z%s,1,p%s,1)
+ if (LUseT) call dcopy(n_lin,z%st,1,p%st,1)
+ ! rz_old = <r,z>
+ call scalarprod(m,r,z,rz_old)
+ ! res0 <- ||r||
+ call scalarprod(m,r,r,res0)
+ res0 = dsqrt(res0)
+ if (cg_param%verbose > 0) then
+ if (i_am_master_mpi) then
+ write(STDOUT,'(" *** CG Solver ( ",I10," dof ) ***")') n_lin
+ write(STDOUT,'(" <CG> Initial residual ||r_0|| = ",E12.6)') res0
+ end if
+ endif
+ if (res0 > tolerance) then
+ do i=1,cg_param%maxiter
+ ! Ap <- A.p
+ call haloswap(level,m,p)
+ call apply(p,Ap)
+ ! alpha <- res_old / <p,A.p>
+ call scalarprod(m,p,Ap,pAp)
+ alpha = rz_old/pAp
+ ! x <- x + alpha*p
+ if (LUseO) call daxpy(n_lin,alpha,p%s,1,u%s,1)
+ if (LUseT) call daxpy(n_lin,alpha,p%st,1,u%st,1)
+ ! r <- r - alpha*A.p
+ if (LUseO) call daxpy(n_lin,-alpha,Ap%s,1,r%s,1)
+ if (LUseT) call daxpy(n_lin,-alpha,Ap%st,1,r%st,1)
+ call scalarprod(m,r,r,res)
+ res = dsqrt(res)
+ if (cg_param%verbose > 1) then
+ if (i_am_master_mpi) then
+ write(STDOUT,'(" <CG> Iteration ",I6," ||r|| = ",E12.6)') &
+ i, res
+ end if
+ end if
+ if ( (res/res0 < cg_param%resreduction) .or. &
+ (res < tolerance ) ) then
+ solver_converged = .true.
+ exit
+ end if
+ ! z <- M^{-1} r
+ if (LUseO) z%s = 0.0_rl
+ if (LUseT) z%st = 0.0_rl
+ if (cg_param%n_prec > 0) then
+ call smooth(level,m,cg_param%n_prec,DIRECTION_FORWARD,r,z)
+ call smooth(level,m,cg_param%n_prec,DIRECTION_BACKWARD,r,z)
+ else
+ if (LUseO) call dcopy(n_lin,r%s,1,z%s,1)
+ if (LUseT) call dcopy(n_lin,r%st,1,z%st,1)
+ end if
+ call scalarprod(m,r,z,rz)
+ ! p <- res/res_old*p
+ if (LUseO) call dscal(n_lin,rz/rz_old,p%s,1)
+ if (LUseT) call dscal(n_lin,rz/rz_old,p%st,1)
+ ! p <- p + z
+ if (LUseO) call daxpy(n_lin,1.0_rl,z%s,1,p%s,1)
+ if (LUseT) call daxpy(n_lin,1.0_rl,z%st,1,p%st,1)
+ rz_old = rz
+ end do
+ else
+ res = res0
+ solver_converged = .true.
+ end if
+ if (cg_param%verbose>0) then
+ if (solver_converged) then
+ if (i_am_master_mpi) then
+ write(STDOUT,'(" <CG> Final residual ||r|| = ",E12.6)') res
+ write(STDOUT,'(" <CG> CG solver converged after ",I6," iterations rho_avg = ",F10.6)') i, (res/res0)**(1.0_rl/i)
+ end if
+ else
+ call warning(" <CG> Solver did not converge")
+ endif
+ end if
+
+ if (LUseO) then
+ deallocate(r%s)
+ deallocate(z%s)
+ deallocate(p%s)
+ deallocate(Ap%s)
+ end if
+ if (LUseT) then
+ deallocate(r%st)
+ deallocate(z%st)
+ deallocate(p%st)
+ deallocate(Ap%st)
+ end if
+ end subroutine cg_solve
+
+end module conjugategradient
+
diff --git a/src/ZSOLVER/tensorproductmultigrid_Source/datatypes.f90 b/src/ZSOLVER/tensorproductmultigrid_Source/datatypes.f90
new file mode 100644
index 0000000000000000000000000000000000000000..d0ddee6daae5fa031349db044389cb510c92b144
--- /dev/null
+++ b/src/ZSOLVER/tensorproductmultigrid_Source/datatypes.f90
@@ -0,0 +1,519 @@
+!=== COPYRIGHT AND LICENSE STATEMENT ===
+!
+! This file is part of the TensorProductMultigrid code.
+!
+! (c) The copyright relating to this work is owned jointly by the
+! Crown, Met Office and NERC [2014]. However, it has been created
+! with the help of the GungHo Consortium, whose members are identified
+! at https://puma.nerc.ac.uk/trac/GungHo/wiki .
+!
+! Main Developer: Eike Mueller
+!
+! TensorProductMultigrid is free software: you can redistribute it and/or
+! modify it under the terms of the GNU Lesser General Public License as
+! published by the Free Software Foundation, either version 3 of the
+! License, or (at your option) any later version.
+!
+! TensorProductMultigrid is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU Lesser General Public License for more details.
+!
+! You should have received a copy of the GNU Lesser General Public License
+! along with TensorProductMultigrid (see files COPYING and COPYING.LESSER).
+! If not, see <http://www.gnu.org/licenses/>.
+!
+!=== COPYRIGHT AND LICENSE STATEMENT ===
+
+
+!==================================================================
+!
+! Grid data types for three dimensional cell centred grids.
+! We always assume that the number of gridcells and size in
+! the x- and y- direction is identical.
+!
+! Eike Mueller, University of Bath, Feb 2012
+!
+!==================================================================
+
+
+module datatypes
+
+#ifndef MNH
+ use mpi
+#else
+ use modd_mpif
+#endif
+ use parameters
+ use messages
+
+ implicit none
+
+! Vertical boundary conditions
+ integer, parameter :: VERTBC_DIRICHLET = 1
+ integer, parameter :: VERTBC_NEUMANN = 2
+
+! Parameters of three dimensional grid
+ type grid_parameters
+ integer :: n ! Total number of grid cells in horizontal direction
+ integer :: nz ! Total number of grid cells in vertical direction
+ real(kind=rl) :: L ! Global extent of grid in horizontal direction
+ real(kind=rl) :: H ! Global extent of grid in vertical direction
+ integer :: vertbc ! Vertical boundary condition (see VERTBC_DIRICHLET
+ ! and VERTBC_NEUMANN)
+ logical :: graded ! Is the vertical grid graded?
+ end type grid_parameters
+
+! Three dimensional scalar field s(z,y,x)
+ type scalar3d
+ integer :: ix_min ! } (Inclusive) range of locally owned cells
+ integer :: ix_max ! } in the x-direction
+ integer :: iy_min ! } (these ranges DO NOT include halo cells)
+ integer :: iy_max ! } in the y-direction
+ integer :: icompx_min ! } (Inclusive) ranges of computational cells,
+ integer :: icompx_max ! } in local coords. All cells in these ranges
+ integer :: icompy_min ! } are included in calculations, e.g. in the
+ integer :: icompy_max ! } smoother. This allows duplicating operations
+ ! } on part of the halo for RB Gauss Seidel
+ integer :: halo_size ! Size of halos
+ logical :: isactive ! Is this field active, i.e. used on one of the
+ ! active processes on coarser grids?
+ real(kind=rl),allocatable :: s(:,:,:)
+ real(kind=rl),pointer, contiguous :: st(:,:,:)
+ type(grid_parameters) :: grid_param
+ end type scalar3d
+
+public::VERTBC_DIRICHLET
+public::VERTBC_NEUMANN
+public::scalar3d
+public::grid_parameters
+public::L2norm_mnh
+public::L2norm
+public::daxpy_scalar3d
+public::save_scalar3d
+public::create_scalar3d
+public::volscale_scalar3d_mnh
+public::volscale_scalar3d
+public::destroy_scalar3d
+public::volume_of_element
+public::r_grid
+
+private
+
+ ! Vertical grid, this array of length n_z+1 stores the
+ ! vertices of the grid in the vertical direction
+ real(kind=rl), allocatable :: r_grid(:)
+
+ contains
+
+!==================================================================
+! volume of element on cubed sphere grid
+! NB: ix,iy are global indices
+!==================================================================
+ real(kind=rl) function volume_of_element(ix,iy,grid_param)
+ implicit none
+ integer, intent(in) :: ix
+ integer, intent(in) :: iy
+ type(grid_parameters), intent(in) :: grid_param
+ real(kind=rl) :: h
+ real(kind=rl) :: rho_i, sigma_j
+ h = 2.0_rl/grid_param%n
+ rho_i = 2.0_rl*(ix-0.5_rl)/grid_param%n-1.0_rl
+ sigma_j = 2.0_rl*(iy-0.5_rl)/grid_param%n-1.0_rl
+ volume_of_element = (1.0_rl+rho_i**2+sigma_j**2)**(-1.5_rl)*h**2
+ end function volume_of_element
+
+!==================================================================
+! Create scalar3d field on fine grid and set to zero
+!==================================================================
+ subroutine create_scalar3d(comm_horiz,grid_param, halo_size, phi)
+ implicit none
+
+ integer :: comm_horiz ! Horizontal communicator
+ type(grid_parameters), intent(in) :: grid_param ! Grid parameters
+ integer, intent(in) :: halo_size ! Halo size
+ type(scalar3d), intent(inout) :: phi ! Field to create
+ integer :: nproc ! Number of processes
+ integer :: rank, ierr ! rank and MPI error
+ integer, dimension(2) :: p_horiz ! position in 2d
+ ! processor grid
+ integer :: nlocal ! Local number of
+ ! cells in horizontal
+ ! direction
+ integer, parameter :: dim_horiz = 2 ! horiz. dimension
+
+ real(kind=rl) , dimension(:,:,:), pointer , contiguous :: zphi_st
+
+ phi%grid_param = grid_param
+ call mpi_comm_size(comm_horiz, nproc, ierr)
+ nlocal = grid_param%n/sqrt(1.0*nproc)
+
+ ! Work out position in 2d processor grid
+ call mpi_comm_rank(comm_horiz, rank, ierr)
+ call mpi_cart_coords(comm_horiz,rank,dim_horiz,p_horiz,ierr)
+ ! Set local data ranges
+ ! NB: p_horiz stores (py,px) in that order (see comment in
+ ! communication module)
+ phi%iy_min = p_horiz(1)*nlocal + 1
+ phi%iy_max = (p_horiz(1)+1)*nlocal
+ phi%ix_min = p_horiz(2)*nlocal + 1
+ phi%ix_max = (p_horiz(2)+1)*nlocal
+ ! Set computational ranges. Note that these are different at
+ ! the edges of the domain!
+ if (p_horiz(1) == 0) then
+ phi%icompy_min = 1
+ else
+ phi%icompy_min = 1 - (halo_size - 1)
+ end if
+ if (p_horiz(1) == floor(sqrt(1.0_rl*nproc))-1) then
+ phi%icompy_max = nlocal
+ else
+ phi%icompy_max = nlocal + (halo_size - 1)
+ end if
+ if (p_horiz(2) == 0) then
+ phi%icompx_min = 1
+ else
+ phi%icompx_min = 1 - (halo_size - 1)
+ end if
+ if (p_horiz(2) == floor(sqrt(1.0_rl*nproc))-1) then
+ phi%icompx_max = nlocal
+ else
+ phi%icompx_max = nlocal + (halo_size - 1)
+ end if
+ ! Set halo size
+ phi%halo_size = halo_size
+ ! Set field to active
+ phi%isactive = .true.
+ ! Allocate memory
+ if (LUseO) then
+ allocate(phi%s(0:grid_param%nz+1, &
+ 1-halo_size:nlocal+halo_size, &
+ 1-halo_size:nlocal+halo_size))
+ phi%s(:,:,:) = 0.0_rl
+ end if
+ if (LUseT) then
+ allocate(zphi_st(1-halo_size:nlocal+halo_size, &
+ 1-halo_size:nlocal+halo_size, &
+ 0:grid_param%nz+1))
+ phi%st => zphi_st
+ !$acc kernels
+ zphi_st(:,:,:) = 0.0_rl
+ !$acc end kernels
+ end if
+
+ end subroutine create_scalar3d
+
+!==================================================================
+! Destroy scalar3d field on fine grid
+!==================================================================
+ subroutine destroy_scalar3d(phi)
+ implicit none
+ type(scalar3d), intent(inout) :: phi
+
+ if (LUseO) deallocate(phi%s)
+ if (LUseT) deallocate(phi%st)
+
+ end subroutine destroy_scalar3d
+
+!==================================================================
+! Scale fields with volume of element
+! Either multiply with volume factor |T| v_k (power = 1)
+! or divide by it (power = -1)
+!==================================================================
+ subroutine volscale_scalar3d_mnh(phi,power)
+ implicit none
+ type(scalar3d), intent(inout) :: phi
+ integer, intent(in) :: power
+ integer :: ix, iy, iz
+ integer :: ierr
+ integer :: nlocalx, nlocaly, nz
+ real(kind=rl) :: vol_h, vol_r, h, tmp
+
+ real , dimension(:,:,:), pointer , contiguous :: zphi_st
+
+ if (.not. ( ( power .eq. 1) .or. (power .eq. -1) ) ) then
+ call fatalerror("power has to be -1 or 1 when volume-scaling fields")
+ end if
+
+ if (phi%isactive) then
+
+ nlocalx = phi%ix_max-phi%ix_min+1
+ nlocaly = phi%iy_max-phi%iy_min+1
+ nz = phi%grid_param%nz
+
+ h = phi%grid_param%L/phi%grid_param%n
+ vol_h = h**2
+ vol_r = 1.0_rl ! r_grid(iz+1)-r_grid(iz)
+ if (power == 1) then
+ tmp = vol_h*vol_r
+ else
+ tmp = 1.0_rl/(vol_h*vol_r)
+ end if
+
+ if (LUseO) phi%s (1:nz,1:nlocaly,1:nlocalx) = tmp*phi%s (1:nz,1:nlocaly,1:nlocalx)
+ if (LUseT) then
+ zphi_st => phi%st
+ !$acc kernels
+ zphi_st(1:nlocalx,1:nlocaly,1:nz) = tmp*zphi_st(1:nlocalx,1:nlocaly,1:nz)
+ !$acc end kernels
+ end if
+
+ end if
+
+ end subroutine volscale_scalar3d_mnh
+
+!==================================================================
+! Scale fields with volume of element
+! Either multiply with volume factor |T| v_k (power = 1)
+! or divide by it (power = -1)
+!==================================================================
+ subroutine volscale_scalar3d(phi,power)
+ implicit none
+ type(scalar3d), intent(inout) :: phi
+ integer, intent(in) :: power
+ integer :: ix, iy, iz
+ integer :: ierr
+ integer :: nlocalx, nlocaly
+ real(kind=rl) :: vol_h, vol_r, h, tmp
+
+ if (.not. ( ( power .eq. 1) .or. (power .eq. -1) ) ) then
+ call fatalerror("power has to be -1 or 1 when volume-scaling fields")
+ end if
+
+ nlocalx = phi%ix_max-phi%ix_min+1
+ nlocaly = phi%iy_max-phi%iy_min+1
+
+ if (phi%isactive) then
+ do ix=1,nlocalx
+ do iy=1,nlocaly
+#ifdef CARTESIANGEOMETRY
+ h = phi%grid_param%L/phi%grid_param%n
+ vol_h = h**2
+#else
+ vol_h = volume_of_element(ix+(phi%ix_min-1), &
+ iy+(phi%iy_min-1), &
+ phi%grid_param)
+#endif
+ do iz=1,phi%grid_param%nz
+#ifdef CARTESIANGEOMETRY
+ vol_r = r_grid(iz+1)-r_grid(iz)
+#else
+ vol_r = (r_grid(iz+1)**3 - r_grid(iz)**3)/3.0_rl
+#endif
+ if (power == 1) then
+ tmp = vol_h*vol_r
+ else
+ tmp = 1.0_rl/(vol_h*vol_r)
+ end if
+ if (LUseO) phi%s(iz,iy,ix) = tmp*phi%s(iz,iy,ix)
+ if (LUseT) phi%st(ix,iy,iz) = tmp*phi%st(ix,iy,iz)
+ end do
+ end do
+ end do
+ end if
+
+ end subroutine volscale_scalar3d
+
+!==================================================================
+! Calculate L2 norm
+! If phi_is_volumeintegral is .true. then phi is interpreted
+! as the volume integral in a cell, otherwise it is interpreted as the
+! average value in a cell.
+!==================================================================
+ real(kind=rl) function l2norm_mnh(phi,phi_is_volumeintegral)
+ implicit none
+ type(scalar3d), intent(in) :: phi
+ logical, optional :: phi_is_volumeintegral
+ !local var
+ integer :: ix, iy, iz
+ real(kind=rl) :: tmp, global_tmp
+ real(kind=rl) :: tmpt, global_tmpt
+ integer :: ierr
+ integer :: nlocalx, nlocaly, nz
+ real(kind=rl) :: vol_h, vol_r, h
+ logical :: divide_by_volume
+ real(kind=rl) :: volume_factor
+
+ real , dimension(:,:,:) , pointer , contiguous :: zphi_st
+
+ nlocalx = phi%ix_max-phi%ix_min+1
+ nlocaly = phi%iy_max-phi%iy_min+1
+ nz = phi%grid_param%nz
+
+ tmp = 0.0_rl
+ tmpt = 0.0_rl
+ if (phi%isactive) then
+
+ if (LUseO) then
+ do ix=1,nlocalx
+ do iy=1,nlocaly
+ do iz=1,nz
+ tmp = tmp + phi%s(iz,iy,ix)**2 ! * volume_factor
+ end do
+ end do
+ end do
+ end if
+
+ if (LUseT) then
+ zphi_st => phi%st
+ !$acc kernels loop collapse(3)
+ do iz=1,nz
+ do iy=1,nlocaly
+ do ix=1,nlocalx
+ tmpt = tmpt + zphi_st(ix,iy,iz)**2 ! * volume_factor
+ end do
+ end do
+ end do
+ !$acc end kernels
+
+ end if
+ end if
+
+ if (LUseO) then
+ call mpi_allreduce(tmp,global_tmp, 1, &
+ MPI_DOUBLE_PRECISION,MPI_SUM,MPI_COMM_WORLD,ierr)
+ global_tmp = dsqrt(global_tmp)
+ endif
+ if (LUseT) then
+ call mpi_allreduce(tmpt,global_tmpt, 1, &
+ MPI_DOUBLE_PRECISION,MPI_SUM,MPI_COMM_WORLD,ierr)
+ global_tmpt = dsqrt(global_tmpt)
+ end if
+ if (LUseO) then
+ l2norm_mnh = global_tmp
+ else
+ l2norm_mnh = global_tmpt
+ endif
+
+ end function l2norm_mnh
+!----------------------------------------------------------------------------
+ real(kind=rl) function l2norm(phi,phi_is_volumeintegral)
+ implicit none
+ type(scalar3d), intent(in) :: phi
+ logical, optional :: phi_is_volumeintegral
+ integer :: ix, iy, iz
+ real(kind=rl) :: tmp, global_tmp
+ integer :: ierr
+ integer :: nlocalx, nlocaly
+ real(kind=rl) :: vol_h, vol_r, h
+ logical :: divide_by_volume
+ real(kind=rl) :: volume_factor
+ if (present(phi_is_volumeintegral)) then
+ divide_by_volume = phi_is_volumeintegral
+ else
+ divide_by_volume = .false.
+ end if
+
+ nlocalx = phi%ix_max-phi%ix_min+1
+ nlocaly = phi%iy_max-phi%iy_min+1
+
+ tmp = 0.0_rl
+ if (phi%isactive) then
+ do ix=1,nlocalx
+ do iy=1,nlocaly
+#ifdef CARTESIANGEOMETRY
+ h = phi%grid_param%L/phi%grid_param%n
+ vol_h = h**2
+#else
+ vol_h = volume_of_element(ix+(phi%ix_min-1), &
+ iy+(phi%iy_min-1), &
+ phi%grid_param)
+#endif
+ do iz=1,phi%grid_param%nz
+#ifdef CARTESIANGEOMETRY
+ vol_r = r_grid(iz+1)-r_grid(iz)
+#else
+ vol_r = (r_grid(iz+1)**3 - r_grid(iz)**3)/3.0_rl
+#endif
+ if (divide_by_volume) then
+ volume_factor = 1.0_rl/(vol_h*vol_r)
+ else
+ volume_factor = vol_h*vol_r
+ end if
+ tmp = tmp + volume_factor*phi%s(iz,iy,ix)**2
+ end do
+ end do
+ end do
+ end if
+
+ call mpi_allreduce(tmp,global_tmp, 1, &
+ MPI_DOUBLE_PRECISION,MPI_SUM,MPI_COMM_WORLD,ierr)
+ l2norm = dsqrt(global_tmp)
+ end function l2norm
+
+!==================================================================
+! calculate phi <- phi + alpha*dphi
+!==================================================================
+ subroutine daxpy_scalar3d(alpha,dphi,phi)
+ implicit none
+ real(kind=rl), intent(in) :: alpha
+ type(scalar3d), intent(in) :: dphi
+ type(scalar3d), intent(inout) :: phi
+ integer :: nlin
+ integer :: nlocalx, nlocaly
+
+ nlocalx = phi%ix_max-phi%ix_min+1
+ nlocaly = phi%iy_max-phi%iy_min+1
+ nlin = (nlocalx+2*phi%halo_size) &
+ * (nlocaly+2*phi%halo_size) &
+ * (phi%grid_param%nz+2)
+
+ if (LUseO) call daxpy(nlin,alpha,dphi%s,1,phi%s,1)
+ if (LUseT) call daxpy(nlin,alpha,dphi%st,1,phi%st,1)
+
+
+ end subroutine daxpy_scalar3d
+
+!==================================================================
+! Save scalar field to file
+!==================================================================
+ subroutine save_scalar3d(comm_horiz,phi,filename)
+ implicit none
+ integer, intent(in) :: comm_horiz
+ type(scalar3d), intent(in) :: phi
+ character(*), intent(in) :: filename
+ integer :: file_id = 100
+ integer :: ix,iy,iz
+ integer :: nlocal
+ integer :: rank, nproc, ierr
+ character(len=21) :: s
+
+ nlocal = phi%ix_max-phi%ix_min+1
+
+ ! Get number of processes and rank
+ call mpi_comm_size(comm_horiz, nproc, ierr)
+ call mpi_comm_rank(comm_horiz, rank, ierr)
+
+ write(s,'(I10.10,"_",I10.10)') nproc, rank
+
+ open(unit=file_id,file=trim(filename)//"_"//trim(s)//".dat")
+ write(file_id,*) "# 3d scalar data file"
+ write(file_id,*) "# ==================="
+ write(file_id,*) "# Data is written as s(iz,iy,ix) "
+ write(file_id,*) "# with the leftmost index running fastest"
+ write(file_id,'(" n = ",I8)') phi%grid_param%n
+ write(file_id,'(" nz = ",I8)') phi%grid_param%nz
+ write(file_id,'(" L = ",F20.10)') phi%grid_param%L
+ write(file_id,'(" H = ",F20.10)') phi%grid_param%H
+ write(file_id,'(" ix_min = ",I10)') phi%ix_min
+ write(file_id,'(" ix_max = ",I10)') phi%ix_max
+ write(file_id,'(" iy_min = ",I10)') phi%iy_min
+ write(file_id,'(" iy_max = ",I10)') phi%iy_max
+ write(file_id,'(" icompx_min = ",I10)') phi%icompx_min
+ write(file_id,'(" icompx_max = ",I10)') phi%icompx_max
+ write(file_id,'(" icompy_min = ",I10)') phi%icompy_min
+ write(file_id,'(" icompy_max = ",I10)') phi%icompy_max
+ write(file_id,'(" halosize = ",I10)') phi%halo_size
+
+
+ do ix=1-phi%halo_size,nlocal+phi%halo_size
+ do iy=1-phi%halo_size,nlocal+phi%halo_size
+ do iz=0,phi%grid_param%nz+1
+ write(file_id,'(E24.15)') phi%s(iz,iy,ix)
+ end do
+ end do
+ end do
+ close(file_id)
+ end subroutine save_scalar3d
+
+end module datatypes
diff --git a/src/ZSOLVER/tensorproductmultigrid_Source/dblas.f90 b/src/ZSOLVER/tensorproductmultigrid_Source/dblas.f90
new file mode 100644
index 0000000000000000000000000000000000000000..48d5dcdce4f328566fd6e968cd8ba21311c5dd30
--- /dev/null
+++ b/src/ZSOLVER/tensorproductmultigrid_Source/dblas.f90
@@ -0,0 +1,241 @@
+subroutine dcopy(n,sx,incx,sy,incy)
+!
+! copies a vector, x, to a vector, y.
+! uses unrolled loops for increments equal to 1.
+! jack dongarra, linpack, 3/11/78.
+! modified 12/3/93, array(1) declarations changed to array(*)
+! modified 12/12/00 change name to avoid confusion with spline routine
+!
+ real sx(*),sy(*)
+ integer i,incx,incy,ix,iy,m,mp1,n
+!
+ if(n.le.0)return
+ if(incx.eq.1.and.incy.eq.1)go to 20
+!
+! code for unequal increments or equal increments
+! not equal to 1
+!
+ ix = 1
+ iy = 1
+ if(incx.lt.0)ix = (-n+1)*incx + 1
+ if(incy.lt.0)iy = (-n+1)*incy + 1
+ do 10 i = 1,n
+ sy(iy) = sx(ix)
+ ix = ix + incx
+ iy = iy + incy
+ 10 continue
+ return
+!
+! code for both increments equal to 1
+!
+!
+! clean-up loop
+!
+ 20 m = mod(n,7)
+ if( m .eq. 0 ) go to 40
+ do 30 i = 1,m
+ sy(i) = sx(i)
+ 30 continue
+ if( n .lt. 7 ) return
+ 40 mp1 = m + 1
+ !$acc kernels
+ do 50 i = mp1,n,7
+ sy(i) = sx(i)
+ sy(i + 1) = sx(i + 1)
+ sy(i + 2) = sx(i + 2)
+ sy(i + 3) = sx(i + 3)
+ sy(i + 4) = sx(i + 4)
+ sy(i + 5) = sx(i + 5)
+ sy(i + 6) = sx(i + 6)
+ 50 continue
+ !$acc end kernels
+ return
+
+end subroutine dcopy
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+SUBROUTINE DAXPY( N, SA, SX, INCX, SY, INCY )
+
+! Y = A*X + Y (X, Y = VECTORS, A = SCALAR)
+
+! --INPUT--
+! N NUMBER OF ELEMENTS IN INPUT VECTORS 'X' AND 'Y'
+! SA SINGLE PRECISION SCALAR MULTIPLIER 'A'
+! SX SING-PREC ARRAY CONTAINING VECTOR 'X'
+! INCX SPACING OF ELEMENTS OF VECTOR 'X' IN 'SX'
+! SY SING-PREC ARRAY CONTAINING VECTOR 'Y'
+! INCY SPACING OF ELEMENTS OF VECTOR 'Y' IN 'SY'
+
+! --OUTPUT--
+! SY FOR I = 0 TO N-1, OVERWRITE SY(LY+I*INCY) WITH
+! SA*SX(LX+I*INCX) + SY(LY+I*INCY),
+! WHERE LX = 1 IF INCX .GE. 0,
+! = (-INCX)*N IF INCX .LT. 0
+! AND LY IS DEFINED IN A SIMILAR WAY USING INCY.
+
+ REAL SX(*), SY(*), SA
+
+
+ IF( N.LE.0 .OR. SA.EQ.0.0 ) RETURN
+
+ IF ( INCX.EQ.INCY .AND. INCX.GT.1 ) THEN
+
+ DO 10 I = 1, 1+(N-1)*INCX, INCX
+ SY(I) = SY(I) + SA * SX(I)
+ 10 CONTINUE
+
+ ELSE IF ( INCX.EQ.INCY .AND. INCX.EQ.1 ) THEN
+
+! ** EQUAL, UNIT INCREMENTS
+ M = MOD(N,4)
+ IF( M .NE. 0 ) THEN
+! ** CLEAN-UP LOOP SO REMAINING VECTOR LENGTH
+! ** IS A MULTIPLE OF 4.
+ DO 20 I = 1, M
+ SY(I) = SY(I) + SA * SX(I)
+ 20 CONTINUE
+ ENDIF
+! ** UNROLL LOOP FOR SPEED
+ !$acc kernels
+ DO 30 I = M+1, N, 4
+ SY(I) = SY(I) + SA * SX(I)
+ SY(I+1) = SY(I+1) + SA * SX(I+1)
+ SY(I+2) = SY(I+2) + SA * SX(I+2)
+ SY(I+3) = SY(I+3) + SA * SX(I+3)
+ 30 CONTINUE
+ !$acc end kernels
+
+ ELSE
+! ** NONEQUAL OR NONPOSITIVE INCREMENTS.
+ IX = 1
+ IY = 1
+ IF( INCX.LT.0 ) IX = 1 + (N-1)*(-INCX)
+ IF( INCY.LT.0 ) IY = 1 + (N-1)*(-INCY)
+ DO 40 I = 1, N
+ SY(IY) = SY(IY) + SA*SX(IX)
+ IX = IX + INCX
+ IY = IY + INCY
+ 40 CONTINUE
+
+ ENDIF
+
+ RETURN
+END SUBROUTINE DAXPY
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+SUBROUTINE DSCAL( N, SA, SX, INCX )
+
+! CALCULATE X = A*X (X = VECTOR, A = SCALAR)
+
+! --INPUT-- N NUMBER OF ELEMENTS IN VECTOR
+! SA SINGLE PRECISION SCALE FACTOR
+! SX SING-PREC ARRAY, LENGTH 1+(N-1)*INCX, CONTAINING VECTOR
+! INCX SPACING OF VECTOR ELEMENTS IN 'SX'
+
+! --OUTPUT-- SX REPLACE SX(1+I*INCX) WITH SA * SX(1+I*INCX)
+! FOR I = 0 TO N-1
+
+ REAL SA, SX(*)
+
+
+ IF( N.LE.0 ) RETURN
+
+ IF( INCX.NE.1 ) THEN
+
+ DO 10 I = 1, 1+(N-1)*INCX, INCX
+ SX(I) = SA * SX(I)
+ 10 CONTINUE
+
+ ELSE
+
+ M = MOD(N,5)
+ IF( M.NE.0 ) THEN
+! ** CLEAN-UP LOOP SO REMAINING VECTOR LENGTH
+! ** IS A MULTIPLE OF 5.
+ DO 30 I = 1, M
+ SX(I) = SA * SX(I)
+ 30 CONTINUE
+ ENDIF
+! ** UNROLL LOOP FOR SPEED
+ DO 50 I = M+1, N, 5
+ SX(I) = SA * SX(I)
+ SX(I+1) = SA * SX(I+1)
+ SX(I+2) = SA * SX(I+2)
+ SX(I+3) = SA * SX(I+3)
+ SX(I+4) = SA * SX(I+4)
+ 50 CONTINUE
+
+ ENDIF
+
+ RETURN
+END SUBROUTINE DSCAL
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+FUNCTION DDOT( N, SX, INCX, SY, INCY )
+! ##############################
+
+! S.P. DOT PRODUCT OF VECTORS 'X' AND 'Y'
+
+! --INPUT--
+! N NUMBER OF ELEMENTS IN INPUT VECTORS 'X' AND 'Y'
+! SX SING-PREC ARRAY CONTAINING VECTOR 'X'
+! INCX SPACING OF ELEMENTS OF VECTOR 'X' IN 'SX'
+! SY SING-PREC ARRAY CONTAINING VECTOR 'Y'
+! INCY SPACING OF ELEMENTS OF VECTOR 'Y' IN 'SY'
+
+! --OUTPUT--
+! DDOT SUM FOR I = 0 TO N-1 OF SX(LX+I*INCX) * SY(LY+I*INCY),
+! WHERE LX = 1 IF INCX .GE. 0,
+! = (-INCX)*N IF INCX .LT. 0,
+! AND LY IS DEFINED IN A SIMILAR WAY USING INCY.
+
+ IMPLICIT NONE
+ INTEGER N,INCX,INCY
+ REAL SX(*), SY(*)
+ REAL DDOT
+ INTEGER I,M, IX, IY
+
+
+ DDOT = 0.0
+ IF( N.LE.0 ) RETURN
+
+ IF ( INCX.EQ.INCY .AND. INCX.GT.1 ) THEN
+
+ DO 10 I = 1, 1+(N-1)*INCX, INCX
+ DDOT = DDOT + SX(I) * SY(I)
+ 10 CONTINUE
+
+ ELSE IF ( INCX.EQ.INCY .AND. INCX.EQ.1 ) THEN
+
+! ** EQUAL, UNIT INCREMENTS
+ M = MOD(N,5)
+ IF( M .NE. 0 ) THEN
+! ** CLEAN-UP LOOP SO REMAINING VECTOR LENGTH
+! ** IS A MULTIPLE OF 4.
+ DO 20 I = 1, M
+ DDOT = DDOT + SX(I) * SY(I)
+ 20 CONTINUE
+ ENDIF
+! ** UNROLL LOOP FOR SPEED
+ DO 30 I = M+1, N, 5
+ DDOT = DDOT + SX(I)*SY(I) + SX(I+1)*SY(I+1) &
+ + SX(I+2)*SY(I+2) + SX(I+3)*SY(I+3) &
+ + SX(I+4)*SY(I+4)
+ 30 CONTINUE
+
+ ELSE
+! ** NONEQUAL OR NONPOSITIVE INCREMENTS.
+ IX = 1
+ IY = 1
+ IF( INCX.LT.0 ) IX = 1 + (N-1)*(-INCX)
+ IF( INCY.LT.0 ) IY = 1 + (N-1)*(-INCY)
+ DO 40 I = 1, N
+ DDOT = DDOT + SX(IX) * SY(IY)
+ IX = IX + INCX
+ IY = IY + INCY
+ 40 CONTINUE
+
+ ENDIF
+
+ RETURN
+END FUNCTION DDOT
diff --git a/src/ZSOLVER/tensorproductmultigrid_Source/discretisation.f90 b/src/ZSOLVER/tensorproductmultigrid_Source/discretisation.f90
new file mode 100644
index 0000000000000000000000000000000000000000..70d9063b2494dce63cf65cb43ce68cd9a379199b
--- /dev/null
+++ b/src/ZSOLVER/tensorproductmultigrid_Source/discretisation.f90
@@ -0,0 +1,2068 @@
+!=== COPYRIGHT AND LICENSE STATEMENT ===
+!
+! This file is part of the TensorProductMultigrid code.
+!
+! (c) The copyright relating to this work is owned jointly by the
+! Crown, Met Office and NERC [2014]. However, it has been created
+! with the help of the GungHo Consortium, whose members are identified
+! at https://puma.nerc.ac.uk/trac/GungHo/wiki .
+!
+! Main Developer: Eike Mueller
+!
+! TensorProductMultigrid is free software: you can redistribute it and/or
+! modify it under the terms of the GNU Lesser General Public License as
+! published by the Free Software Foundation, either version 3 of the
+! License, or (at your option) any later version.
+!
+! TensorProductMultigrid is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU Lesser General Public License for more details.
+!
+! You should have received a copy of the GNU Lesser General Public License
+! along with TensorProductMultigrid (see files COPYING and COPYING.LESSER).
+! If not, see <http://www.gnu.org/licenses/>.
+!
+!=== COPYRIGHT AND LICENSE STATEMENT ===
+
+
+!==================================================================
+!
+! Discretisation module of the model problem
+!
+!
+! -omega2 * (d^2/dx^2 + d^2/dy^2 + lambda2 * d^2/dz^2 ) u
+! + delta u = RHS
+! [Cartesian]
+!
+! or
+!
+! -omega2 * (laplace_{2d} + lambda2/r^2 d/dr (r^2 d/dr)) u
+! + delta u = RHS
+! [Spherical]
+!
+! We use a cell centered finite volume discretisation with
+! The equation is discretised either in a unit cube or on 1/6th
+! of a cubed sphere grid.
+!
+! The vertical grid spacing is not necessarily uniform and can
+! be chosen by specifying the vertical grid in a vector.
+!
+! The following boundary conditions are used:
+!
+! * Dirichlet in the horizontal
+! * Neumann in the vertical
+!
+! For delta = 0 the operator reduces to the Poisson operator.
+!
+! Eike Mueller, University of Bath, Feb 2012
+!
+!==================================================================
+
+module discretisation
+
+ use parameters
+ use messages
+ use datatypes
+ use communication
+#ifndef MNH
+ use mpi
+#else
+ use modd_mpif
+#endif
+
+ implicit none
+
+private
+
+ type model_parameters
+ real(kind=rl) :: omega2 ! omega^2
+ real(kind=rl) :: lambda2 ! lambda^2
+ real(kind=rl) :: delta ! delta
+ end type model_parameters
+
+! --- Stencil ---
+!
+
+! Grid traversal direction in SOR
+ integer, parameter :: DIRECTION_FORWARD = 1
+ integer, parameter :: DIRECTION_BACKWARD = 2
+
+! Ordering in SOR
+ ! Lexicographic ordering
+ integer, parameter :: ORDERING_LEX = 1
+ ! Red-black ordering
+ integer, parameter :: ORDERING_RB = 2
+
+ type smoother_parameters
+ ! smoother
+ integer :: smoother
+ ! relaxation parameter
+ real(kind=rl) :: rho
+ ! ordering of degrees of freedom
+ integer :: ordering
+ end type smoother_parameters
+
+ ! Allowed smoothers
+ integer, parameter :: SMOOTHER_LINE_SOR = 3
+ integer, parameter :: SMOOTHER_LINE_SSOR = 4
+ integer, parameter :: SMOOTHER_LINE_JAC = 6
+
+ ! Number of levels
+ integer :: nlev
+
+ ! Grid parameters
+ type(grid_parameters) :: grid_param
+
+ ! Model parameters
+ type(model_parameters) :: model_param
+
+ ! Smoother parameters
+ type(smoother_parameters) :: smoother_param
+
+ ! Arrays for measuring the residual reduction
+ real(kind=rl), allocatable :: log_resreduction(:)
+ integer, allocatable :: nsmooth_total(:)
+
+ ! Data structure for storing the vertical discretisation
+ type vertical_coefficients
+ real(kind=rl), pointer , contiguous :: a(:)
+ real(kind=rl), pointer , contiguous :: b(:)
+ real(kind=rl), pointer , contiguous :: c(:)
+ real(kind=rl), pointer , contiguous :: d(:)
+ end type vertical_coefficients
+
+ ! Stoarge for vertical coefficients
+ type(vertical_coefficients) :: vert_coeff
+
+public::discretisation_initialise_mnh
+public::discretisation_initialise
+public::discretisation_finalise
+public::smooth_mnh
+public::smooth
+public::line_SOR
+public::line_SSOR
+public::line_jacobi_mnh
+public::line_jacobi
+public::calculate_residual_mnh
+public::calculate_residual
+public::apply_mnh
+public::apply
+public::model_parameters
+public::smoother_parameters
+public::volume_of_element
+public::SMOOTHER_LINE_SOR
+public::SMOOTHER_LINE_SSOR
+public::SMOOTHER_LINE_JAC
+public::DIRECTION_FORWARD
+public::DIRECTION_BACKWARD
+public::ORDERING_LEX
+public::ORDERING_RB
+
+contains
+
+!==================================================================
+! Initialise module
+!==================================================================
+ subroutine discretisation_initialise_mnh(grid_param_in, &
+ model_param_in, &
+ smoother_param_in, &
+ nlev_in, &
+ PA_K,PB_K,PC_K,PD_K)
+ implicit none
+ type(grid_parameters), intent(in) :: grid_param_in
+ type(model_parameters), intent(in) :: model_param_in
+ type(smoother_parameters), intent(in) :: smoother_param_in
+ integer, intent(in) :: nlev_in
+ real(kind=rl) , optional , intent (in) :: PA_K(:),PB_K(:),PC_K(:),PD_K(:)
+
+ ! local var
+ integer :: k
+
+ grid_param = grid_param_in
+ model_param = model_param_in
+ smoother_param = smoother_param_in
+ nlev = nlev_in
+ allocate(log_resreduction(nlev))
+ allocate(nsmooth_total(nlev))
+ log_resreduction(:) = 0.0_rl
+ nsmooth_total(:) = 0
+ allocate(r_grid(grid_param%nz+1))
+ if (grid_param%graded) then
+ do k=1,grid_param%nz+1
+ r_grid(k) = grid_param%H*(1.0_rl*(k-1.0_rl)/grid_param%nz)**2
+ end do
+ else
+ do k=1,grid_param%nz+1
+ r_grid(k) = grid_param%H*(1.0_rl*(k-1.0_rl)/grid_param%nz)
+ end do
+ end if
+ ! Allocate arrays for vertical discretisation matrices
+ ! and calculate matrix entries
+ allocate(vert_coeff%a(grid_param%nz))
+ allocate(vert_coeff%b(grid_param%nz))
+ allocate(vert_coeff%c(grid_param%nz))
+ allocate(vert_coeff%d(grid_param%nz))
+ call construct_vertical_coeff_mnh(PA_K,PB_K,PC_K,PD_K)
+ end subroutine discretisation_initialise_mnh
+
+ subroutine discretisation_initialise(grid_param_in, &
+ model_param_in, &
+ smoother_param_in, &
+ nlev_in)
+ implicit none
+ type(grid_parameters), intent(in) :: grid_param_in
+ type(model_parameters), intent(in) :: model_param_in
+ type(smoother_parameters), intent(in) :: smoother_param_in
+ integer, intent(in) :: nlev_in
+ integer :: k
+ grid_param = grid_param_in
+ model_param = model_param_in
+ smoother_param = smoother_param_in
+ nlev = nlev_in
+ allocate(log_resreduction(nlev))
+ allocate(nsmooth_total(nlev))
+ log_resreduction(:) = 0.0_rl
+ nsmooth_total(:) = 0
+ allocate(r_grid(grid_param%nz+1))
+ if (grid_param%graded) then
+ do k=1,grid_param%nz+1
+ r_grid(k) = grid_param%H*(1.0_rl*(k-1.0_rl)/grid_param%nz)**2
+ end do
+ else
+ do k=1,grid_param%nz+1
+ r_grid(k) = grid_param%H*(1.0_rl*(k-1.0_rl)/grid_param%nz)
+ end do
+ end if
+#ifdef CARTESIANGEOMETRY
+#else
+ r_grid(:) = 1.0_rl + r_grid(:)
+#endif
+ ! Allocate arrays for vertical discretisation matrices
+ ! and calculate matrix entries
+ allocate(vert_coeff%a(grid_param%nz))
+ allocate(vert_coeff%b(grid_param%nz))
+ allocate(vert_coeff%c(grid_param%nz))
+ allocate(vert_coeff%d(grid_param%nz))
+ call construct_vertical_coeff()
+ end subroutine discretisation_initialise
+
+!==================================================================
+! Finalise module
+!==================================================================
+ subroutine discretisation_finalise()
+ implicit none
+ integer :: level
+ real(kind=rl) :: rho_avg
+#ifdef MEASURESMOOTHINGRATE
+ if (i_am_master_mpi) then
+ write(STDOUT,'("Average smoothing rates:")')
+ do level=nlev,1,-1
+ if (nsmooth_total(level) > 0) then
+ rho_avg = exp(log_resreduction(level)/nsmooth_total(level))
+ else
+ rho_avg = 1.0_rl
+ end if
+ write(STDOUT,'("rho_{avg}(",I3,") = ",E10.4," ( ",I5," x )")') &
+ level, rho_avg, nsmooth_total(level)
+ end do
+ end if
+#endif
+ deallocate(log_resreduction)
+ deallocate(nsmooth_total)
+ deallocate(r_grid)
+ ! Deallocate storage for vertical discretisation matrices
+ deallocate(vert_coeff%a)
+ deallocate(vert_coeff%b)
+ deallocate(vert_coeff%c)
+ deallocate(vert_coeff%d)
+ end subroutine discretisation_finalise
+
+!==================================================================
+! Construct alpha_{i',j'} and |T_{ij}| needed for the
+! horizontal stencil
+! ( alpha_{i+1,j},
+! alpha_{i-1,j},
+! alpha_{i,j+1},
+! alpha_{i,j-1},
+! alpha_{ij})
+! (ix,iy) are LOCAL indices of the grid boxes, which are
+! converted to global indices
+!==================================================================
+ subroutine construct_alpha_T_mnh(grid_param,ix,iy,alpha_T,Tij)
+ implicit none
+ type(grid_parameters), intent(in) :: grid_param
+ integer, intent(in) :: ix
+ integer, intent(in) :: iy
+ real(kind=rl), intent(inout), dimension(5) :: alpha_T
+ real(kind=rl), intent(out) :: Tij
+
+ !local var
+ real(kind=rl) :: h, rho_i, sigma_j
+ real(kind=rl) :: xcoef
+ logical :: l2nd
+
+ h = grid_param%L/grid_param%n
+ ! Cartesian coefficients
+ Tij = h**2
+ ! optimisation for newman MNH case = all coef constant
+ alpha_T(1:4) = 1.0_rl
+ alpha_T(5) = 4.0_rl
+ return
+ xcoef = 0.5_rl ! 0.0
+ l2nd = .false. ! .true. ! .false.
+ alpha_T(1) = 1.0
+ alpha_T(2) = 1.0
+ if (ix == grid_param%n) then
+ alpha_T(1) = xcoef * 2.0_rl
+ if (l2nd) alpha_T(2) = 2.0_rl
+ end if
+ if (ix == 1) then
+ alpha_T(2) = xcoef * 2.0_rl
+ if (l2nd) alpha_T(1) = 2.0_rl
+ end if
+ alpha_T(3) = 1.0
+ alpha_T(4) = 1.0
+ if (iy == grid_param%n) then
+ alpha_T(3) = xcoef * 2.0_rl
+ if (l2nd) alpha_T(4) = 2.0
+ end if
+ if (iy == 1) then
+ alpha_T(4) = xcoef * 2.0_rl
+ if (l2nd) alpha_T(3) = 2.0
+ end if
+
+ alpha_T(5) = alpha_T(1) + alpha_T(2) + alpha_T(3) + alpha_T(4)
+ end subroutine construct_alpha_T_mnh
+! constant coef for MNH
+ subroutine construct_alpha_T_cst_mnh(grid_param,alpha_T,Tij)
+ implicit none
+ type(grid_parameters), intent(in) :: grid_param
+ real(kind=rl), intent(inout), dimension(5) :: alpha_T
+ real(kind=rl), intent(out) :: Tij
+
+ !local var
+ real(kind=rl) :: h
+
+ h = grid_param%L/grid_param%n
+ ! Cartesian coefficients
+ Tij = h**2
+ ! optimisation for newman MNH case = all coef constant
+ alpha_T(1:4) = 1.0_rl
+ alpha_T(5) = 4.0_rl
+
+ end subroutine construct_alpha_T_cst_mnh
+!==================================================================
+ subroutine construct_alpha_T(grid_param,ix,iy,alpha_T,Tij)
+ implicit none
+ type(grid_parameters), intent(in) :: grid_param
+ integer, intent(in) :: ix
+ integer, intent(in) :: iy
+ real(kind=rl), intent(inout), dimension(5) :: alpha_T
+ real(kind=rl), intent(out) :: Tij
+ real(kind=rl) :: h, rho_i, sigma_j
+#ifdef CARTESIANGEOMETRY
+ h = grid_param%L/grid_param%n
+ ! Cartesian coefficients
+ Tij = h**2
+ if (ix == grid_param%n) then
+ alpha_T(1) = 2.0_rl
+ else
+ alpha_T(1) = 1.0_rl
+ end if
+ if (ix == 1) then
+ alpha_T(2) = 2.0_rl
+ else
+ alpha_T(2) = 1.0_rl
+ end if
+ if (iy == grid_param%n) then
+ alpha_T(3) = 2.0_rl
+ else
+ alpha_T(3) = 1.0_rl
+ end if
+ if (iy == 1) then
+ alpha_T(4) = 2.0_rl
+ else
+ alpha_T(4) = 1.0_rl
+ end if
+#else
+ ! Coefficients in cubed sphere geometry
+ ! (rho_i,sigma_j) \in [-1,1] x [-1,1] are the coordinates of the
+ ! cubed sphere segment
+ h = 2.0_rl/grid_param%n
+ Tij = volume_of_element(ix,iy,grid_param)
+ rho_i = 2.0_rl*(1.0_rl*ix-0.5_rl)/grid_param%n-1.0_rl
+ sigma_j = 2.0_rl*(1.0_rl*iy-0.5_rl)/grid_param%n-1.0_rl
+ ! alpha_{i+1,j}
+ if (ix == grid_param%n) then
+ alpha_T(1) = 2.0_rl*DSQRT((1.0_rl+(rho_i+0.25_rl*h)**2)/(1.0_rl+sigma_j**2))
+ else
+ alpha_T(1) = DSQRT((1.0_rl+(rho_i+0.5_rl*h)**2)/(1.0_rl+sigma_j**2))
+ end if
+ ! alpha_{i-1,j}
+ if (ix == 1) then
+ alpha_T(2) = 2.0_rl*DSQRT((1.0_rl+(rho_i-0.25_rl*h)**2)/(1.0_rl+sigma_j**2))
+ else
+ alpha_T(2) = DSQRT((1.0_rl+(rho_i-0.5_rl*h)**2)/(1.0_rl+sigma_j**2))
+ end if
+ ! alpha_{i,j+1}
+ if (iy == grid_param%n) then
+ alpha_T(3) = 2.0_rl*DSQRT((1.0_rl+(sigma_j+0.25_rl*h)**2)/(1.0_rl+rho_i**2))
+ else
+ alpha_T(3) = DSQRT((1.0_rl+(sigma_j+0.5_rl*h)**2)/(1.0_rl+rho_i**2))
+ end if
+ ! alpha_{i,j-1}
+ if (iy == 1) then
+ alpha_T(4) = 2.0_rl*DSQRT((1.0_rl+(sigma_j-0.25_rl*h)**2)/(1.0_rl+rho_i**2))
+ else
+ alpha_T(4) = DSQRT((1.0_rl+(sigma_j-0.5_rl*h)**2)/(1.0_rl+rho_i**2))
+ end if
+#endif
+ alpha_T(5) = alpha_T(1) + alpha_T(2) + alpha_T(3) + alpha_T(4)
+ end subroutine construct_alpha_T
+!==================================================================
+! Construct coefficients of tridiagonal matrix A_T
+! describing the coupling in the vertical direction and the
+! diagonal matrix diag(d)
+!==================================================================
+subroutine construct_vertical_coeff_mnh(PA_K,PB_K,PC_K,PD_K)
+ implicit none
+ real(kind=rl) , optional , intent (in) :: PA_K(:),PB_K(:),PC_K(:),PD_K(:)
+ !local var
+ real(kind=rl) :: a_k_tmp, b_k_tmp, c_k_tmp, d_k_tmp
+ real(kind=rl) :: omega2, lambda2, delta, vol_r, surface_k, surface_kp1
+ integer :: k
+
+ IF (.NOT. PRESENT(PA_K)) THEN
+ omega2 = model_param%omega2
+ lambda2 = model_param%lambda2
+ delta = model_param%delta
+ do k = 1, grid_param%nz
+
+ vol_r = r_grid(k+1)-r_grid(k)
+ surface_k = 1.0_rl
+ surface_kp1 = 1.0_rl
+
+ ! Diagonal element
+ a_k_tmp = delta*vol_r
+ ! off diagonal elements
+ ! Boundary conditions
+ ! Top
+ if (k == grid_param%nz) then
+ if (grid_param%vertbc == VERTBC_DIRICHLET) then
+ b_k_tmp = - 2.0_rl * omega2*lambda2 &
+ * surface_kp1/(r_grid(k+1)-r_grid(k))
+ else
+ b_k_tmp = 0.0_rl
+ end if
+ else
+ b_k_tmp = - 2.0_rl*omega2*lambda2 &
+ * surface_kp1/(r_grid(k+2)-r_grid(k))
+ end if
+ ! Bottom
+ if (k == 1) then
+ if (grid_param%vertbc == VERTBC_DIRICHLET) then
+ c_k_tmp = - 2.0_rl * omega2*lambda2 &
+ * surface_k/(r_grid(k+1)-r_grid(k))
+ else
+ c_k_tmp = 0.0_rl
+ end if
+ else
+ c_k_tmp = - 2.0_rl * omega2 * lambda2 &
+ * surface_k/(r_grid(k+1)-r_grid(k-1))
+ end if
+ ! Diagonal matrix d_k
+ d_k_tmp = - omega2 * (r_grid(k+1)-r_grid(k))
+ vert_coeff%a(k) = a_k_tmp/d_k_tmp
+ vert_coeff%b(k) = b_k_tmp/d_k_tmp
+ vert_coeff%c(k) = c_k_tmp/d_k_tmp
+ vert_coeff%d(k) = d_k_tmp
+ end do
+ ELSE
+ do k = 1, grid_param%nz
+ vert_coeff%a(k) = PA_K(k)
+ vert_coeff%b(k) = PB_K(k)
+ vert_coeff%c(k) = PC_K(k)
+ vert_coeff%d(k) = PD_K(k)
+ end do
+ ENDIF
+end subroutine construct_vertical_coeff_mnh
+
+subroutine construct_vertical_coeff()
+ implicit none
+ real(kind=rl) :: a_k_tmp, b_k_tmp, c_k_tmp, d_k_tmp
+ real(kind=rl) :: omega2, lambda2, delta, vol_r, surface_k, surface_kp1
+ integer :: k
+ omega2 = model_param%omega2
+ lambda2 = model_param%lambda2
+ delta = model_param%delta
+ do k = 1, grid_param%nz
+#ifdef CARTESIANGEOMETRY
+ vol_r = r_grid(k+1)-r_grid(k)
+ surface_k = 1.0_rl
+ surface_kp1 = 1.0_rl
+#else
+ vol_r = (r_grid(k+1)**3 - r_grid(k)**3)/3.0_rl
+ surface_k = r_grid(k)**2
+ surface_kp1 = r_grid(k+1)**2
+#endif
+ ! Diagonal element
+ a_k_tmp = delta*vol_r
+ ! off diagonal elements
+ ! Boundary conditions
+ ! Top
+ if (k == grid_param%nz) then
+ if (grid_param%vertbc == VERTBC_DIRICHLET) then
+ b_k_tmp = - 2.0_rl * omega2*lambda2 &
+ * surface_kp1/(r_grid(k+1)-r_grid(k))
+ else
+ b_k_tmp = 0.0_rl
+ end if
+ else
+ b_k_tmp = - 2.0_rl*omega2*lambda2 &
+ * surface_kp1/(r_grid(k+2)-r_grid(k))
+ end if
+ ! Bottom
+ if (k == 1) then
+ if (grid_param%vertbc == VERTBC_DIRICHLET) then
+ c_k_tmp = - 2.0_rl * omega2*lambda2 &
+ * surface_k/(r_grid(k+1)-r_grid(k))
+ else
+ c_k_tmp = 0.0_rl
+ end if
+ else
+ c_k_tmp = - 2.0_rl * omega2 * lambda2 &
+ * surface_k/(r_grid(k+1)-r_grid(k-1))
+ end if
+ ! Diagonal matrix d_k
+ d_k_tmp = - omega2 * (r_grid(k+1)-r_grid(k))
+ vert_coeff%a(k) = a_k_tmp/d_k_tmp
+ vert_coeff%b(k) = b_k_tmp/d_k_tmp
+ vert_coeff%c(k) = c_k_tmp/d_k_tmp
+ vert_coeff%d(k) = d_k_tmp
+ end do
+end subroutine construct_vertical_coeff
+
+!==================================================================
+! Calculate local residual r = b - A.u
+!==================================================================
+ subroutine calculate_residual_mnh(level,m,b,u,r)
+ implicit none
+ integer, intent(in) :: level
+ integer, intent(in) :: m
+ type(scalar3d), intent(in) :: b
+ type(scalar3d), intent(inout) :: u
+ type(scalar3d), intent(inout) :: r
+ integer :: ix,iy,iz
+ integer :: iib,iie,ijb,ije,ikb,ike
+
+ real , dimension(:,:,:) , pointer , contiguous :: zr_st , zb_st
+
+ ! r <- A.u
+ !call boundary_mnh(u)
+ call apply_mnh(u,r)
+ ! r <- b - r = b - A.u
+ if (LUseO) then
+ do ix=u%icompx_min,u%icompx_max
+ do iy=u%icompy_min,u%icompy_max
+ do iz=1,u%grid_param%nz
+ r%s(iz,iy,ix) = b%s(iz,iy,ix) - r%s(iz,iy,ix)
+ end do
+ end do
+ end do
+ endif
+ if (LUseT) then
+!!$ do iz=1,u%grid_param%nz
+!!$ do iy=u%icompy_min,u%icompy_max
+!!$ do ix=u%icompx_min,u%icompx_max
+!!$ r%st(ix,iy,iz) = b%st(ix,iy,iz) - r%st(ix,iy,iz)
+!!$ end do
+!!$ end do
+!!$ end do
+ !-----------------
+ iib=u%icompx_min
+ iie=u%icompx_max
+ ijb=u%icompy_min
+ ije=u%icompy_max
+ ikb=1
+ ike=u%grid_param%nz
+
+ zr_st => r%st
+ zb_st => b%st
+ !$acc kernels
+ zr_st(iib:iie,ijb:ije,ikb:ike) = zb_st(iib:iie,ijb:ije,ikb:ike) - zr_st(iib:iie,ijb:ije,ikb:ike)
+ !$acc end kernels
+ endif
+
+ end subroutine calculate_residual_mnh
+
+ subroutine calculate_residual(level,m,b,u,r)
+ implicit none
+ integer, intent(in) :: level
+ integer, intent(in) :: m
+ type(scalar3d), intent(in) :: b
+ type(scalar3d), intent(inout) :: u
+ type(scalar3d), intent(inout) :: r
+ integer :: ix,iy,iz
+
+
+ ! r <- A.u
+ call apply(u,r)
+ ! r <- b - r = b - A.u
+ do ix=u%icompx_min,u%icompx_max
+ do iy=u%icompy_min,u%icompy_max
+ do iz=1,u%grid_param%nz
+ r%s(iz,iy,ix) = b%s(iz,iy,ix) - r%s(iz,iy,ix)
+ end do
+ end do
+ end do
+ end subroutine calculate_residual
+
+!==================================================================
+! Apply operator v = A.u
+!==================================================================
+ subroutine apply_mnh(u,v)
+ implicit none
+ type(scalar3d), intent(inout) :: u
+ type(scalar3d), intent(inout) :: v
+
+ ! local var
+ real(kind=rl), dimension(5) :: alpha_T
+ real(kind=rl) :: Tij
+ real(kind=rl) :: a_k, b_k, c_k, d_k
+ integer :: ix,iy,iz
+ real(kind=rl) :: tmp
+ integer :: iib,iie,ijb,ije
+
+ real(kind=rl), dimension(:,:,:) , pointer , contiguous :: zv_st , zu_st
+ real(kind=rl), dimension(:) , pointer , contiguous :: za_k, zb_k, zc_k, zd_k
+ integer :: ii,ij
+ integer :: ize
+
+ call boundary_mnh(u)
+
+ if (LUseO) then
+ do ix=u%icompx_min,u%icompx_max
+ do iy=u%icompy_min,u%icompy_max
+ ! Construct horizontal part of stencil
+ call construct_alpha_T_mnh(u%grid_param, &
+ ix+u%ix_min-1, &
+ iy+u%iy_min-1, &
+ alpha_T,Tij)
+ do iz=1,u%grid_param%nz
+ a_k = vert_coeff%a(iz)
+ b_k = vert_coeff%b(iz)
+ c_k = vert_coeff%c(iz)
+ d_k = vert_coeff%d(iz)
+ tmp = ((a_k-b_k-c_k)*Tij ) * u%s(iz,iy,ix)
+ if (iz < grid_param%nz) then
+ tmp = tmp + b_k*Tij * u%s(iz+1,iy,ix)
+ end if
+ if (iz > 1) then
+ tmp = tmp + c_k*Tij * u%s(iz-1,iy,ix)
+ end if
+ if ((iz > 1) .and. (iz < grid_param%nz)) then
+ tmp = tmp - alpha_T(5) * u%s(iz, iy ,ix ) &
+ + alpha_T(1) * u%s(iz, iy ,ix+1) &
+ + alpha_T(2) * u%s(iz, iy ,ix-1) &
+ + alpha_T(3) * u%s(iz, iy+1,ix ) &
+ + alpha_T(4) * u%s(iz, iy-1,ix )
+ end if
+ v%s(iz,iy,ix) = d_k*tmp
+ end do
+ end do
+ end do
+ endif
+ if (LUseT) then
+ call construct_alpha_T_cst_mnh(u%grid_param,alpha_T,Tij)
+ !-----------------------------------------------------------
+ iib=u%icompx_min
+ iie=u%icompx_max
+ ijb=u%icompy_min
+ ije=u%icompy_max
+ ize=u%grid_param%nz
+ !
+ zv_st => v%st
+ zu_st => u%st
+ zb_k => vert_coeff%b
+ zc_k => vert_coeff%c
+ zd_k => vert_coeff%d
+
+ !$acc kernels
+ iz=1
+ !$acc loop independent collapse(2)
+ do ij=ijb,ije
+ do ii=iib,iie
+ zv_st(ii,ij,iz) = zd_k(iz)* ( (-zb_k(iz)-zc_k(iz))*Tij * zu_st(ii,ij,iz ) &
+ +zb_k(iz) *Tij * zu_st(ii,ij,iz+1) )
+ end do
+ end do
+ !
+ do iz=2,ize-1
+ !$acc loop independent collapse(2)
+ do ij=ijb,ije
+ do ii=iib,iie
+ zv_st(ii,ij,iz) = zd_k(iz)* ( ((-zb_k(iz)-zc_k(iz))*Tij - 4.0_rl ) * zu_st(ii,ij,iz) &
+ +zb_k(iz) *Tij * zu_st(ii,ij,iz+1) &
+ +zc_k(iz) *Tij * zu_st(ii,ij,iz-1) &
+ + zu_st(ii+1,ij,iz) &
+ + zu_st(ii-1,ij,iz) &
+ + zu_st(ii,ij+1,iz) &
+ + zu_st(ii,ij-1,iz) &
+ )
+ end do
+ end do
+ end do
+ !
+ iz=ize
+ !$acc loop independent collapse(2)
+ do ij=ijb,ije
+ do ii=iib,iie
+ zv_st(ii,ij,iz) = zd_k(iz)* ( (-zb_k(iz)-zc_k(iz))*Tij * zu_st(ii,ij,iz) &
+ +zc_k(iz) *Tij * zu_st(ii,ij,iz-1) )
+ end do
+ end do
+
+ !$acc end kernels
+ endif
+
+ end subroutine apply_mnh
+
+ subroutine apply(u,v)
+ implicit none
+ type(scalar3d), intent(in) :: u
+ type(scalar3d), intent(inout) :: v
+ real(kind=rl), dimension(5) :: alpha_T
+ real(kind=rl) :: Tij
+ real(kind=rl) :: a_k, b_k, c_k, d_k
+ integer :: ix,iy,iz
+ real(kind=rl) :: tmp
+
+ do ix=u%icompx_min,u%icompx_max
+ do iy=u%icompy_min,u%icompy_max
+ ! Construct horizontal part of stencil
+ call construct_alpha_T(u%grid_param, &
+ ix+u%ix_min-1, &
+ iy+u%iy_min-1, &
+ alpha_T,Tij)
+ do iz=1,u%grid_param%nz
+ a_k = vert_coeff%a(iz)
+ b_k = vert_coeff%b(iz)
+ c_k = vert_coeff%c(iz)
+ d_k = vert_coeff%d(iz)
+ tmp = ((a_k-b_k-c_k)*Tij - alpha_T(5)) * u%s(iz,iy,ix)
+ if (iz < grid_param%nz) then
+ tmp = tmp + b_k*Tij * u%s(iz+1,iy,ix)
+ end if
+ if (iz > 1) then
+ tmp = tmp + c_k*Tij * u%s(iz-1,iy,ix)
+ end if
+ tmp = tmp + alpha_T(1) * u%s(iz, iy ,ix+1) &
+ + alpha_T(2) * u%s(iz, iy ,ix-1) &
+ + alpha_T(3) * u%s(iz, iy+1,ix ) &
+ + alpha_T(4) * u%s(iz, iy-1,ix )
+ v%s(iz,iy,ix) = d_k*tmp
+ end do
+ end do
+ end do
+ end subroutine apply
+!==================================================================
+!==================================================================
+!
+! S M O O T H E R S
+!
+!==================================================================
+!==================================================================
+
+!==================================================================
+! Perform nsmooth smoother iterations
+!==================================================================
+ subroutine smooth_mnh(level,m,nsmooth,direction,b,u)
+ implicit none
+ integer, intent(in) :: level
+ integer, intent(in) :: m
+ integer, intent(in) :: nsmooth ! Number of smoothing steps
+ integer, intent(in) :: direction ! Direction
+ type(scalar3d), intent(inout) :: b ! RHS
+ type(scalar3d), intent(inout) :: u ! solution vector
+ integer :: i
+ real(kind=rl) :: log_res_initial, log_res_final
+ type(scalar3d) :: r
+ integer :: halo_size
+ integer :: nlocal, nz
+
+#ifdef MEASURESMOOTHINGRATE
+ r%ix_min = u%ix_min
+ r%ix_max = u%ix_max
+ r%iy_min = u%iy_min
+ r%iy_max = u%iy_max
+ r%icompx_min = u%icompx_min
+ r%icompx_max = u%icompx_max
+ r%icompy_min = u%icompy_min
+ r%icompy_max = u%icompy_max
+ r%halo_size = u%halo_size
+ r%isactive = u%isactive
+ r%grid_param = u%grid_param
+ nlocal = r%ix_max-r%ix_min+1
+ halo_size = r%halo_size
+ nz = r%grid_param%nz
+
+ if (LUseO) then
+ allocate(r%s(0:nz+1, &
+ 1-halo_size:nlocal+halo_size, &
+ 1-halo_size:nlocal+halo_size))
+ end if
+
+ if (LUseT) then
+ allocate(r%st(1-halo_size:nlocal+halo_size, &
+ 1-halo_size:nlocal+halo_size, &
+ 0:nz+1))
+ end if
+
+ call calculate_residual(level,m,b,u,r)
+ log_res_initial = log(l2norm(r))
+#endif
+ ! Carry out nsmooth iterations of the smoother
+ if (smoother_param%smoother == SMOOTHER_LINE_SOR) then
+ do i=1,nsmooth
+ call line_SOR_mnh(level,m,direction,b,u)
+ end do
+ else if (smoother_param%smoother == SMOOTHER_LINE_SSOR) then
+ do i=1,nsmooth
+ call line_SSOR_mnh(level,m,direction,b,u)
+ end do
+ else if (smoother_param%smoother == SMOOTHER_LINE_JAC) then
+ do i=1,nsmooth
+ call line_jacobi_mnh(level,m,b,u)
+ end do
+ end if
+#ifdef MEASURESMOOTHINGRATE
+ call calculate_residual_mnh(level,m,b,u,r)
+ log_res_final = log(l2norm(r))
+ log_resreduction(level) = log_resreduction(level) &
+ + (log_res_final - log_res_initial)
+ nsmooth_total(level) = nsmooth_total(level) + nsmooth
+ if (LUseO) deallocate(r%s)
+ if (LUseT) deallocate(r%st)
+#endif
+ end subroutine smooth_mnh
+!==================================================================
+! Perform nsmooth smoother iterations
+!==================================================================
+ subroutine smooth(level,m,nsmooth,direction,b,u)
+ implicit none
+ integer, intent(in) :: level
+ integer, intent(in) :: m
+ integer, intent(in) :: nsmooth ! Number of smoothing steps
+ integer, intent(in) :: direction ! Direction
+ type(scalar3d), intent(inout) :: b ! RHS
+ type(scalar3d), intent(inout) :: u ! solution vector
+ integer :: i
+ real(kind=rl) :: log_res_initial, log_res_final
+ type(scalar3d) :: r
+ integer :: halo_size
+ integer :: nlocal, nz
+
+#ifdef MEASURESMOOTHINGRATE
+ r%ix_min = u%ix_min
+ r%ix_max = u%ix_max
+ r%iy_min = u%iy_min
+ r%iy_max = u%iy_max
+ r%icompx_min = u%icompx_min
+ r%icompx_max = u%icompx_max
+ r%icompy_min = u%icompy_min
+ r%icompy_max = u%icompy_max
+ r%halo_size = u%halo_size
+ r%isactive = u%isactive
+ r%grid_param = u%grid_param
+ nlocal = r%ix_max-r%ix_min+1
+ halo_size = r%halo_size
+ nz = r%grid_param%nz
+ if (LUseO) then
+ allocate(r%s(0:nz+1, &
+ 1-halo_size:nlocal+halo_size, &
+ 1-halo_size:nlocal+halo_size))
+ call calculate_residual(level,m,b,u,r)
+ endif
+ if (LUseT) then
+ allocate(r%st(1-halo_size:nlocal+halo_size, &
+ 1-halo_size:nlocal+halo_size, &
+ 0:nz+1) )
+ endif
+ log_res_initial = log(l2norm(r))
+#endif
+ ! Carry out nsmooth iterations of the smoother
+ if (smoother_param%smoother == SMOOTHER_LINE_SOR) then
+ do i=1,nsmooth
+ call line_SOR(level,m,direction,b,u)
+ end do
+ else if (smoother_param%smoother == SMOOTHER_LINE_SSOR) then
+ do i=1,nsmooth
+ call line_SSOR(level,m,direction,b,u)
+ end do
+ else if (smoother_param%smoother == SMOOTHER_LINE_JAC) then
+ do i=1,nsmooth
+ call line_jacobi(level,m,b,u)
+ end do
+ end if
+#ifdef MEASURESMOOTHINGRATE
+ call calculate_residual(level,m,b,u,r)
+ log_res_final = log(l2norm(r))
+ log_resreduction(level) = log_resreduction(level) &
+ + (log_res_final - log_res_initial)
+ nsmooth_total(level) = nsmooth_total(level) + nsmooth
+ if (LUseO) deallocate(r%s)
+ if (LUseT) deallocate(r%st)
+#endif
+ end subroutine smooth
+!==================================================================
+! SOR line smoother mnh
+!==================================================================
+ subroutine line_SOR_mnh(level,m,direction,b,u)
+
+ implicit none
+
+ integer, intent(in) :: level
+ integer, intent(in) :: m
+ integer, intent(in) :: direction
+ type(scalar3d), intent(in) :: b
+ type(scalar3d), intent(inout) :: u
+
+ !local Var
+ real(kind=rl), allocatable :: r(:)
+ integer :: nz, nlocal
+ real(kind=rl), allocatable :: c(:), utmp(:)
+ integer :: ixmin(5), ixmax(5), dix
+ integer :: iymin(5), iymax(5), diy
+ integer :: color
+ integer :: nsweeps, isweep
+ integer :: ordering
+ real(kind=rl) :: rho
+ integer, dimension(4) :: send_requests, recv_requests
+ integer, dimension(4) :: send_requestsT, recv_requestsT
+ integer :: tmp, ierr
+ integer :: iblock
+ logical :: overlap_comms
+
+ call boundary_mnh(u)
+
+ ordering = smoother_param%ordering
+ rho = smoother_param%rho
+
+ nz = u%grid_param%nz
+
+ ! Create residual vector
+ allocate(r(nz))
+ ! Allocate memory for auxiliary vectors for Thomas algorithm
+ allocate(c(nz))
+ allocate(utmp(nz))
+ nlocal = u%ix_max-u%ix_min+1
+#ifdef OVERLAPCOMMS
+ overlap_comms = (nlocal > 2)
+#else
+ overlap_comms = .false.
+#endif
+ ! Block 1 (N)
+ ixmin(1) = 1
+ ixmax(1) = nlocal
+ iymin(1) = 1
+ iymax(1) = 1
+ ! Block 2 (S)
+ ixmin(2) = 1
+ ixmax(2) = nlocal
+ iymin(2) = nlocal
+ iymax(2) = nlocal
+ ! Block 3 (W)
+ ixmin(3) = 1
+ ixmax(3) = 1
+ iymin(3) = 2
+ iymax(3) = nlocal-1
+ ! Block 4 (E)
+ ixmin(4) = nlocal
+ ixmax(4) = nlocal
+ iymin(4) = 2
+ iymax(4) = nlocal-1
+ ! Block 5 (INTERIOR)
+ if (overlap_comms) then
+ ixmin(5) = 2
+ ixmax(5) = nlocal-1
+ iymin(5) = 2
+ iymax(5) = nlocal-1
+ else
+ ! If there are no interior cells, do not overlap
+ ! communications and calculations, just loop over interior cells
+ ixmin(5) = 1
+ ixmax(5) = nlocal
+ iymin(5) = 1
+ iymax(5) = nlocal
+ end if
+ dix = +1
+ diy = +1
+ color = 1
+ ! When iteration backwards over the grid, reverse the direction
+ if (direction == DIRECTION_BACKWARD) then
+ do iblock = 1, 5
+ tmp = ixmax(iblock)
+ ixmax(iblock) = ixmin(iblock)
+ ixmin(iblock) = tmp
+ tmp = iymax(iblock)
+ iymax(iblock) = iymin(iblock)
+ iymin(iblock) = tmp
+ end do
+ dix = -1
+ diy = -1
+ color = 0
+ end if
+ nsweeps = 1
+ if (ordering == ORDERING_LEX) then
+ nsweeps = 1
+ else if (ordering == ORDERING_RB) then
+ nsweeps = 2
+ end if
+ do isweep = 1, nsweeps
+ if (overlap_comms) then
+ ! Loop over cells next to boundary (iblock = 1,...,4)
+ do iblock = 1, 4
+ call loop_over_grid_mnh(iblock)
+ end do
+ ! Initiate halo exchange
+ call ihaloswap_mnh(level,m,u,send_requests,recv_requests,send_requestsT,recv_requestsT)
+ end if
+ ! Loop over INTERIOR cells
+ iblock = 5
+ call loop_over_grid_mnh(iblock)
+ if (overlap_comms) then
+ if (m > 0) then
+ if (LUseO) call mpi_waitall(4,recv_requests, MPI_STATUSES_IGNORE, ierr)
+ if (LUseO) call mpi_waitall(4,send_requests, MPI_STATUSES_IGNORE, ierr)
+ if (LUseT) call mpi_waitall(4,recv_requestsT, MPI_STATUSES_IGNORE, ierr)
+ if (LUseT) call mpi_waitall(4,send_requestsT, MPI_STATUSES_IGNORE, ierr)
+ end if
+ else
+ call haloswap_mnh(level,m,u)
+ end if
+ color = 1-color
+ end do
+
+ ! Free memory again
+ deallocate(r)
+ deallocate(c)
+ deallocate(utmp)
+
+ contains
+
+ !------------------------------------------------------------------
+ ! Loop over grid, for a given block
+ !------------------------------------------------------------------
+ subroutine loop_over_grid_mnh(iblock)
+ implicit none
+ integer, intent(in) :: iblock
+ integer :: ix,iy,iz
+
+ if (LUseO) then
+ do ix=ixmin(iblock),ixmax(iblock),dix
+ do iy=iymin(iblock),iymax(iblock),diy
+ if (ordering == ORDERING_RB) then
+ if (mod((ix+u%ix_min)+(iy+u%iy_min),2) .ne. color) cycle
+ end if
+ call apply_tridiag_solve_mnh(ix,iy,r,c,b, &
+ u%s(1:nz,iy ,ix+1), &
+ u%s(1:nz,iy ,ix-1), &
+ u%s(1:nz,iy+1,ix ), &
+ u%s(1:nz,iy-1,ix ), &
+ utmp)
+ ! Add to field with overrelaxation-factor
+ do iz=1,nz
+ u%s(iz,iy,ix) = (1.0_rl-rho)*u%s(iz,iy,ix) + rho*utmp(iz)
+ end do
+ end do
+ end do
+ end if
+ if (LUseT) then
+ do ix=ixmin(iblock),ixmax(iblock),dix
+ do iy=iymin(iblock),iymax(iblock),diy
+ if (ordering == ORDERING_RB) then
+ if (mod((ix+u%ix_min)+(iy+u%iy_min),2) .ne. color) cycle
+ end if
+ call apply_tridiag_solve_mnhT(ix,iy,r,c,b, &
+ u%st(ix+1,iy ,1:nz), &
+ u%st(ix-1,iy ,1:nz), &
+ u%st(ix ,iy+1,1:nz), &
+ u%st(ix ,iy-1,1:nz), &
+ utmp)
+ ! Add to field with overrelaxation-factor
+ do iz=1,nz
+ u%st(ix,iy,iz) = (1.0_rl-rho)*u%st(ix,iy,iz) + rho*utmp(iz)
+ end do
+ end do
+ end do
+ end if
+
+ end subroutine loop_over_grid_mnh
+
+ end subroutine line_SOR_mnh
+!==================================================================
+! SOR line smoother
+!==================================================================
+ subroutine line_SOR(level,m,direction,b,u)
+
+ implicit none
+
+ integer, intent(in) :: level
+ integer, intent(in) :: m
+ integer, intent(in) :: direction
+ type(scalar3d), intent(in) :: b
+ type(scalar3d), intent(inout) :: u
+ real(kind=rl), allocatable :: r(:)
+ integer :: nz, nlocal
+ real(kind=rl), allocatable :: c(:), utmp(:)
+ integer :: ixmin(5), ixmax(5), dix
+ integer :: iymin(5), iymax(5), diy
+ integer :: color
+ integer :: nsweeps, isweep
+ integer :: ordering
+ real(kind=rl) :: rho
+ integer, dimension(4) :: send_requests, recv_requests
+ integer :: tmp, ierr
+ integer :: iblock
+ logical :: overlap_comms
+
+ ordering = smoother_param%ordering
+ rho = smoother_param%rho
+
+ nz = u%grid_param%nz
+
+ ! Create residual vector
+ allocate(r(nz))
+ ! Allocate memory for auxiliary vectors for Thomas algorithm
+ allocate(c(nz))
+ allocate(utmp(nz))
+ nlocal = u%ix_max-u%ix_min+1
+#ifdef OVERLAPCOMMS
+ overlap_comms = (nlocal > 2)
+#else
+ overlap_comms = .false.
+#endif
+ ! Block 1 (N)
+ ixmin(1) = 1
+ ixmax(1) = nlocal
+ iymin(1) = 1
+ iymax(1) = 1
+ ! Block 2 (S)
+ ixmin(2) = 1
+ ixmax(2) = nlocal
+ iymin(2) = nlocal
+ iymax(2) = nlocal
+ ! Block 3 (W)
+ ixmin(3) = 1
+ ixmax(3) = 1
+ iymin(3) = 2
+ iymax(3) = nlocal-1
+ ! Block 4 (E)
+ ixmin(4) = nlocal
+ ixmax(4) = nlocal
+ iymin(4) = 2
+ iymax(4) = nlocal-1
+ ! Block 5 (INTERIOR)
+ if (overlap_comms) then
+ ixmin(5) = 2
+ ixmax(5) = nlocal-1
+ iymin(5) = 2
+ iymax(5) = nlocal-1
+ else
+ ! If there are no interior cells, do not overlap
+ ! communications and calculations, just loop over interior cells
+ ixmin(5) = 1
+ ixmax(5) = nlocal
+ iymin(5) = 1
+ iymax(5) = nlocal
+ end if
+ dix = +1
+ diy = +1
+ color = 1
+ ! When iteration backwards over the grid, reverse the direction
+ if (direction == DIRECTION_BACKWARD) then
+ do iblock = 1, 5
+ tmp = ixmax(iblock)
+ ixmax(iblock) = ixmin(iblock)
+ ixmin(iblock) = tmp
+ tmp = iymax(iblock)
+ iymax(iblock) = iymin(iblock)
+ iymin(iblock) = tmp
+ end do
+ dix = -1
+ diy = -1
+ color = 0
+ end if
+ nsweeps = 1
+ if (ordering == ORDERING_LEX) then
+ nsweeps = 1
+ else if (ordering == ORDERING_RB) then
+ nsweeps = 2
+ end if
+ do isweep = 1, nsweeps
+ if (overlap_comms) then
+ ! Loop over cells next to boundary (iblock = 1,...,4)
+ do iblock = 1, 4
+ call loop_over_grid(iblock)
+ end do
+ ! Initiate halo exchange
+ call ihaloswap(level,m,u,send_requests,recv_requests)
+ end if
+ ! Loop over INTERIOR cells
+ iblock = 5
+ call loop_over_grid(iblock)
+ if (overlap_comms) then
+ if (m > 0) then
+ call mpi_waitall(4,recv_requests, MPI_STATUSES_IGNORE, ierr)
+ end if
+ else
+ call haloswap(level,m,u)
+ end if
+ color = 1-color
+ end do
+
+ ! Free memory again
+ deallocate(r)
+ deallocate(c)
+ deallocate(utmp)
+
+ contains
+
+ !------------------------------------------------------------------
+ ! Loop over grid, for a given block
+ !------------------------------------------------------------------
+ subroutine loop_over_grid(iblock)
+ implicit none
+ integer, intent(in) :: iblock
+ integer :: ix,iy,iz
+ do ix=ixmin(iblock),ixmax(iblock),dix
+ do iy=iymin(iblock),iymax(iblock),diy
+ if (ordering == ORDERING_RB) then
+ if (mod((ix+u%ix_min)+(iy+u%iy_min),2) .ne. color) cycle
+ end if
+ call apply_tridiag_solve(ix,iy,r,c,b, &
+ u%s(1:nz,iy ,ix+1), &
+ u%s(1:nz,iy ,ix-1), &
+ u%s(1:nz,iy+1,ix ), &
+ u%s(1:nz,iy-1,ix ), &
+ utmp)
+ ! Add to field with overrelaxation-factor
+ do iz=1,nz
+ u%s(iz,iy,ix) = (1.0_rl-rho)*u%s(iz,iy,ix) + rho*utmp(iz)
+ end do
+ end do
+ end do
+ end subroutine loop_over_grid
+
+ end subroutine line_SOR
+
+!==================================================================
+! SSOR line smoother mnh
+!==================================================================
+ subroutine line_SSOR_mnh(level,m,direction,b,u)
+ implicit none
+ integer, intent(in) :: level
+ integer, intent(in) :: m
+ integer, intent(in) :: direction
+ type(scalar3d), intent(in) :: b
+ type(scalar3d), intent(inout) :: u
+ if (direction == DIRECTION_FORWARD) then
+ call line_SOR_mnh(level,m,DIRECTION_FORWARD,b,u)
+ call line_SOR_mnh(level,m,DIRECTION_BACKWARD,b,u)
+ else
+ call line_SOR_mnh(level,m,DIRECTION_BACKWARD,b,u)
+ call line_SOR_mnh(level,m,DIRECTION_FORWARD,b,u)
+ end if
+ end subroutine line_SSOR_mnh
+
+!==================================================================
+! SSOR line smoother
+!==================================================================
+ subroutine line_SSOR(level,m,direction,b,u)
+ implicit none
+ integer, intent(in) :: level
+ integer, intent(in) :: m
+ integer, intent(in) :: direction
+ type(scalar3d), intent(in) :: b
+ type(scalar3d), intent(inout) :: u
+ if (direction == DIRECTION_FORWARD) then
+ call line_SOR(level,m,DIRECTION_FORWARD,b,u)
+ call line_SOR(level,m,DIRECTION_BACKWARD,b,u)
+ else
+ call line_SOR(level,m,DIRECTION_BACKWARD,b,u)
+ call line_SOR(level,m,DIRECTION_FORWARD,b,u)
+ end if
+ end subroutine line_SSOR
+
+!==================================================================
+! Jacobi line smoother
+!==================================================================
+ subroutine line_Jacobi_mnh(level,m,b,u)
+ implicit none
+ integer, intent(in) :: level
+ integer, intent(in) :: m
+ type(scalar3d), intent(in) :: b
+ type(scalar3d), intent(inout) :: u
+ integer :: ix,iy,iz, nz
+ real(kind=rl), dimension(5) :: alpha_T
+ integer :: nlocal, halo_size
+ real(kind=rl) :: rho
+ logical :: overlap_comms
+ integer, dimension(4) :: send_requests, recv_requests
+ integer, dimension(4) :: send_requestsT, recv_requestsT
+ integer :: ixmin(5), ixmax(5)
+ integer :: iymin(5), iymax(5)
+ integer :: iblock, ierr
+
+ integer :: iib,iie,ijb,ije
+
+ real , dimension(:,:,:) , pointer , contiguous :: zSut0_st , zu_st
+
+ integer , parameter :: max_lev = 128
+ logical , save :: Ljacob_first_call = .true.
+ logical , save , dimension(max_lev) :: Ljacob_first_call_level = .true.
+
+ real(kind=rl), pointer , contiguous :: r(:)
+ real(kind=rl), pointer , contiguous :: c(:), utmp(:)
+ real(kind=rl), pointer , contiguous :: u0(:,:,:)
+ real(kind=rl), pointer , contiguous :: ut0(:,:,:)
+ type(scalar3d) , pointer :: Sr,Sc,Sut0,Sutmp
+
+ type Temp_jacobi
+ real(kind=rl), pointer , contiguous :: r(:)
+ real(kind=rl), pointer , contiguous :: c(:), utmp(:)
+ real(kind=rl), pointer , contiguous :: u0(:,:,:)
+ real(kind=rl), pointer , contiguous :: ut0(:,:,:)
+ type(scalar3d) , pointer :: Sr,Sc,Sut0,Sutmp
+ end type Temp_jacobi
+
+ type (Temp_jacobi) , save , dimension(max_lev) :: Tjacobi
+
+ !
+ ! init size , param
+ !
+ nz = u%grid_param%nz
+ nlocal = u%ix_max -u%ix_min + 1
+ halo_size = u%halo_size
+
+ ! Set optimal smoothing parameter on each level
+ !rho = 2.0_rl/(2.0_rl+4.0_rl*model_param%omega2*u%grid_param%n**2/(1.0_rl+4.0_rl*model_param%omega2*u%grid_param%n**2))
+ rho = smoother_param%rho
+
+ ! Allocate data one for all by level
+ if (Ljacob_first_call_level(level)) then
+ Ljacob_first_call_level(level) = .false.
+ if (LUseO) then
+ allocate(Tjacobi(level)%u0(0:u%grid_param%nz+1, &
+ 1-halo_size:nlocal+halo_size, &
+ 1-halo_size:nlocal+halo_size) )
+ !$acc enter data create(Tjacobi(level)%u0)
+ end if
+ if (LUseT) then
+ allocate(Tjacobi(level)%ut0(1-halo_size:nlocal+halo_size, &
+ 1-halo_size:nlocal+halo_size, &
+ 0:u%grid_param%nz+1) )
+ !$acc enter data create(Tjacobi(level)%ut0)
+ end if
+ ! Create residual vector
+ allocate(Tjacobi(level)%r(nz))
+ !$acc enter data create(Tjacobi(level)%r)
+ ! Allocate memory for auxiliary vectors for Thomas algorithm
+ allocate(Tjacobi(level)%c(nz))
+ !$acc enter data create(Tjacobi(level)%c)
+ allocate(Tjacobi(level)%utmp(nz))
+ !$acc enter data create(Tjacobi(level)%utmp)
+ if (LUseT) then
+ allocate(Tjacobi(level)%Sr)
+ allocate(Tjacobi(level)%Sr%st(1-halo_size:nlocal+halo_size, &
+ 1-halo_size:nlocal+halo_size, &
+ 0:u%grid_param%nz+1) )
+ !$acc enter data create(Tjacobi(level)%Sr%st)
+ allocate(Tjacobi(level)%Sut0)
+ allocate(Tjacobi(level)%Sut0%st(1-halo_size:nlocal+halo_size, &
+ 1-halo_size:nlocal+halo_size, &
+ 0:u%grid_param%nz+1) )
+ !$acc enter data create(Tjacobi(level)%Sut0%st)
+ allocate(Tjacobi(level)%Sutmp)
+ allocate(Tjacobi(level)%Sutmp%st(1-halo_size:nlocal+halo_size, &
+ 1-halo_size:nlocal+halo_size, &
+ 0:u%grid_param%nz+1) )
+ !$acc enter data create(Tjacobi(level)%Sutmp%st)
+ end if
+ end if
+
+ call boundary_mnh(u)
+
+
+
+#ifdef OVERLAPCOMMS
+ overlap_comms = (nlocal > 2)
+#else
+ overlap_comms = .false.
+#endif
+
+ ! Block 1 (N)
+ ixmin(1) = 1
+ ixmax(1) = nlocal
+ iymin(1) = 1
+ iymax(1) = 1
+ ! Block 2 (S)
+ ixmin(2) = 1
+ ixmax(2) = nlocal
+ iymin(2) = nlocal
+ iymax(2) = nlocal
+ ! Block 3 (W)
+ ixmin(3) = 1
+ ixmax(3) = 1
+ iymin(3) = 2
+ iymax(3) = nlocal-1
+ ! Block 4 (E)
+ ixmin(4) = nlocal
+ ixmax(4) = nlocal
+ iymin(4) = 2
+ iymax(4) = nlocal-1
+ ! Block 5 (INTERIOR)
+ if (overlap_comms) then
+ ixmin(5) = 2
+ ixmax(5) = nlocal-1
+ iymin(5) = 2
+ iymax(5) = nlocal-1
+ else
+ ! If there are no interior cells, do not overlap
+ ! communications and calculations, just loop over interior cells
+ ixmin(5) = 1
+ ixmax(5) = nlocal
+ iymin(5) = 1
+ iymax(5) = nlocal
+ end if
+
+ ! Temporary vector
+ if (LUseO) then
+!!$ allocate(u0(0:u%grid_param%nz+1, &
+!!$ 1-halo_size:nlocal+halo_size, &
+!!$ 1-halo_size:nlocal+halo_size) )
+ u0 => Tjacobi(level)%u0
+ end if
+ if (LUseT) then
+!!$ allocate(ut0(1-halo_size:nlocal+halo_size, &
+!!$ 1-halo_size:nlocal+halo_size, &
+!!$ 0:u%grid_param%nz+1) )
+ ut0 => Tjacobi(level)%ut0
+ end if
+ if (LUseO) u0(:,:,:) = u%s(:,:,:)
+ if (LUseT) then
+ zu_st => u%st
+ !$acc kernels
+ ut0(:,:,:) = zu_st(:,:,:)
+ !$acc end kernels
+ end if
+ ! Create residual vector
+!!$ allocate(r(nz))
+ r => Tjacobi(level)%r
+ ! Allocate memory for auxiliary vectors for Thomas algorithm
+!!$ allocate(c(nz))
+ c => Tjacobi(level)%c
+!!$ allocate(utmp(nz))
+ utmp => Tjacobi(level)%utmp
+ if (LUseT) then
+!!$ allocate(Sr%st(1-halo_size:nlocal+halo_size, &
+!!$ 1-halo_size:nlocal+halo_size, &
+!!$ 0:u%grid_param%nz+1) )
+ Sr => Tjacobi(level)%Sr
+!!$ allocate(Sut0%st(1-halo_size:nlocal+halo_size, &
+!!$ 1-halo_size:nlocal+halo_size, &
+!!$ 0:u%grid_param%nz+1) )
+ Sut0 => Tjacobi(level)%Sut0
+
+ zSut0_st => Sut0%st
+ zu_st => u%st
+
+ !$acc kernels
+ zSut0_st(:,:,:) = zu_st(:,:,:)
+ !$acc end kernels
+
+!!$ allocate(Sutmp%st(1-halo_size:nlocal+halo_size, &
+!!$ 1-halo_size:nlocal+halo_size, &
+!!$ 0:u%grid_param%nz+1) )
+ Sutmp => Tjacobi(level)%Sutmp
+
+ endif
+
+ ! Loop over grid
+ if (overlap_comms) then
+ ! Loop over cells next to boundary (iblock = 1,...,4)
+ do iblock = 1, 4
+ call loop_over_grid_jacobi_mnh(iblock)
+ end do
+ ! Initiate halo exchange
+ call ihaloswap_mnh(level,m,u,send_requests,recv_requests,send_requestsT,recv_requestsT)
+ end if
+ ! Loop over INTERIOR cells
+ iblock = 5
+ call loop_over_grid_jacobi_mnh(iblock)
+ if (overlap_comms) then
+ if (m > 0) then
+ if (LUseO) call mpi_waitall(4,recv_requests, MPI_STATUSES_IGNORE, ierr)
+ if (LUseO) call mpi_waitall(4,send_requests, MPI_STATUSES_IGNORE, ierr)
+ if (LUseT) call mpi_waitall(4,recv_requestsT, MPI_STATUSES_IGNORE, ierr)
+ if (LUseT) call mpi_waitall(4,send_requestsT, MPI_STATUSES_IGNORE, ierr)
+ end if
+ else
+ call haloswap_mnh(level,m,u)
+ end if
+
+ ! Free memory again
+!!$ deallocate(r)
+!!$ deallocate(c)
+!!$ if (LUseO) deallocate(u0)
+!!$ if (LUseT) deallocate(ut0)
+!!$ deallocate(utmp)
+!!$ if (LUseT) deallocate(Sr%st,Sut0%st,Sutmp%st)
+
+ contains
+
+ subroutine loop_over_grid_jacobi_mnh(iblock)
+ implicit none
+ integer, intent(in) :: iblock
+ integer :: ix,iy,iz
+
+ real , dimension(:,:,:) , pointer , contiguous :: zu_st , zSutmp_st , zSut0_st
+
+ if (LUseO) then
+ do ix=ixmin(iblock),ixmax(iblock)
+ do iy=iymin(iblock),iymax(iblock)
+ call apply_tridiag_solve_mnh(ix,iy,r,c,b, &
+ u0(1:nz,iy ,ix+1), &
+ u0(1:nz,iy ,ix-1), &
+ u0(1:nz,iy+1,ix ), &
+ u0(1:nz,iy-1,ix ), &
+ utmp)
+ ! Add correction
+ do iz=1,nz
+ u%s(iz,iy,ix) = rho*utmp(iz) + (1.0_rl-rho)*u0(iz,iy,ix)
+ end do
+ end do
+ end do
+ end if
+ if (LUseT) then
+ iib=ixmin(iblock)
+ iie=ixmax(iblock)
+ ijb=iymin(iblock)
+ ije=iymax(iblock)
+
+ zu_st => u%st
+ zSutmp_st => Sutmp%st
+ zSut0_st => Sut0%st
+
+ call apply_tridiag_solve_mnh_allT(iib,iie,ijb,ije,Sr,c,b, &
+ Sut0, &
+ Sutmp,level )
+ !$acc kernels
+ !$acc loop independent collapse(3)
+ do concurrent ( ix=iib:iie,iy=ijb:ije,iz=1:nz )
+ zu_st(ix,iy,iz) = &
+ rho*zSutmp_st(ix,iy,iz) &
+ + (1.0_rl-rho)*zSut0_st(ix,iy,iz)
+ end do ! concurrent
+ !$acc end kernels
+ end if
+
+ end subroutine loop_over_grid_jacobi_mnh
+
+end subroutine line_Jacobi_mnh
+!==================================================================
+! Jacobi line smoother
+!==================================================================
+ subroutine line_Jacobi(level,m,b,u)
+ implicit none
+ integer, intent(in) :: level
+ integer, intent(in) :: m
+ type(scalar3d), intent(in) :: b
+ type(scalar3d), intent(inout) :: u
+ real(kind=rl), allocatable :: r(:)
+ integer :: ix,iy,iz, nz
+ real(kind=rl), dimension(5) :: alpha_T
+ real(kind=rl), allocatable :: c(:), utmp(:)
+ real(kind=rl), allocatable :: u0(:,:,:)
+ integer :: nlocal, halo_size
+ real(kind=rl) :: rho
+ logical :: overlap_comms
+ integer, dimension(4) :: send_requests, recv_requests
+ integer :: ixmin(5), ixmax(5)
+ integer :: iymin(5), iymax(5)
+ integer :: iblock, ierr
+
+ ! Set optimal smoothing parameter on each level
+ rho = 2.0_rl/(2.0_rl+4.0_rl*model_param%omega2*u%grid_param%n**2/(1.0_rl+4.0_rl*model_param%omega2*u%grid_param%n**2))
+
+ nz = u%grid_param%nz
+ nlocal = u%ix_max -u%ix_min + 1
+ halo_size = u%halo_size
+
+#ifdef OVERLAPCOMMS
+ overlap_comms = (nlocal > 2)
+#else
+ overlap_comms = .false.
+#endif
+
+ ! Block 1 (N)
+ ixmin(1) = 1
+ ixmax(1) = nlocal
+ iymin(1) = 1
+ iymax(1) = 1
+ ! Block 2 (S)
+ ixmin(2) = 1
+ ixmax(2) = nlocal
+ iymin(2) = nlocal
+ iymax(2) = nlocal
+ ! Block 3 (W)
+ ixmin(3) = 1
+ ixmax(3) = 1
+ iymin(3) = 2
+ iymax(3) = nlocal-1
+ ! Block 4 (E)
+ ixmin(4) = nlocal
+ ixmax(4) = nlocal
+ iymin(4) = 2
+ iymax(4) = nlocal-1
+ ! Block 5 (INTERIOR)
+ if (overlap_comms) then
+ ixmin(5) = 2
+ ixmax(5) = nlocal-1
+ iymin(5) = 2
+ iymax(5) = nlocal-1
+ else
+ ! If there are no interior cells, do not overlap
+ ! communications and calculations, just loop over interior cells
+ ixmin(5) = 1
+ ixmax(5) = nlocal
+ iymin(5) = 1
+ iymax(5) = nlocal
+ end if
+
+ ! Temporary vector
+ allocate(u0(0:u%grid_param%nz+1, &
+ 1-halo_size:nlocal+halo_size, &
+ 1-halo_size:nlocal+halo_size) )
+ u0(:,:,:) = u%s(:,:,:)
+ ! Create residual vector
+ allocate(r(nz))
+ ! Allocate memory for auxiliary vectors for Thomas algorithm
+ allocate(c(nz))
+ allocate(utmp(nz))
+
+ ! Loop over grid
+ if (overlap_comms) then
+ ! Loop over cells next to boundary (iblock = 1,...,4)
+ do iblock = 1, 4
+ call loop_over_grid(iblock)
+ end do
+ ! Initiate halo exchange
+ call ihaloswap(level,m,u,send_requests,recv_requests)
+ end if
+ ! Loop over INTERIOR cells
+ iblock = 5
+ call loop_over_grid(iblock)
+ if (overlap_comms) then
+ if (m > 0) then
+ call mpi_waitall(4,recv_requests, MPI_STATUSES_IGNORE, ierr)
+ end if
+ else
+ call haloswap(level,m,u)
+ end if
+
+ ! Free memory again
+ deallocate(r)
+ deallocate(c)
+ deallocate(u0)
+ deallocate(utmp)
+
+ contains
+
+ subroutine loop_over_grid(iblock)
+ implicit none
+ integer, intent(in) :: iblock
+ integer :: ix,iy,iz
+ do ix=ixmin(iblock),ixmax(iblock)
+ do iy=iymin(iblock),iymax(iblock)
+ call apply_tridiag_solve(ix,iy,r,c,b, &
+ u0(1:nz,iy ,ix+1), &
+ u0(1:nz,iy ,ix-1), &
+ u0(1:nz,iy+1,ix ), &
+ u0(1:nz,iy-1,ix ), &
+ utmp)
+ ! Add correction
+ do iz=1,nz
+ u%s(iz,iy,ix) = rho*utmp(iz) + (1.0_rl-rho)*u0(iz,iy,ix)
+ end do
+ end do
+ end do
+ end subroutine loop_over_grid
+
+ end subroutine line_Jacobi
+!==================================================================
+! At a given horizontal position (ix,iy) (local coordinates),
+! calculate
+!
+! u_out = T(ix,iy)^{-1} (b_(ix,iy)
+! - sum_{ix',iy' != ix,iy} A_{(ix,iy),(ix',iy')}*u_in(ix',iy'))
+!
+!==================================================================
+ subroutine apply_tridiag_solve_mnh(ix,iy,r,c,b, &
+ u_in_1, &
+ u_in_2, &
+ u_in_3, &
+ u_in_4, &
+ u_out)
+
+ implicit none
+ integer, intent(in) :: ix
+ integer, intent(in) :: iy
+ real(kind=rl), intent(inout), dimension(:) :: r
+ real(kind=rl), intent(inout), dimension(:) :: c
+ type(scalar3d), intent(in) :: b
+ real(kind=rl), intent(in), dimension(:) :: u_in_1
+ real(kind=rl), intent(in), dimension(:) :: u_in_2
+ real(kind=rl), intent(in), dimension(:) :: u_in_3
+ real(kind=rl), intent(in), dimension(:) :: u_in_4
+ real(kind=rl), intent(inout), dimension(:) :: u_out
+ real(kind=rl), dimension(5) :: alpha_T
+ real(kind=rl) :: Tij
+ real(kind=rl) :: alpha_div_Tij, tmp, b_k_tmp, c_k_tmp
+ integer :: iz, nz
+
+ real(kind=rl) :: xctop_boot
+
+ nz = b%grid_param%nz
+ xctop_boot = 0.0
+
+ call construct_alpha_T_mnh(b%grid_param, &
+ ix+b%ix_min-1, &
+ iy+b%iy_min-1, &
+ alpha_T,Tij)
+ ! Calculate r_i = b_i - A_{ij} u_i
+ !alpha_T(5) = 4
+ if (LUseO) then
+ iz=1
+ r(iz) = b%s(iz,iy,ix)
+ do iz=2,nz-1
+ r(iz) = b%s(iz,iy,ix) - vert_coeff%d(iz) * ( &
+ alpha_T(1) * u_in_1(iz) + &
+ alpha_T(2) * u_in_2(iz) + &
+ alpha_T(3) * u_in_3(iz) + &
+ alpha_T(4) * u_in_4(iz) )
+ end do
+ iz=nz
+ r(iz) = b%s(iz,iy,ix)
+
+ ! Thomas algorithm
+ ! STEP 1: Create modified coefficients
+ iz = 1
+ alpha_div_Tij = alpha_T(5)/Tij
+ tmp = (vert_coeff%a(iz)-vert_coeff%b(iz)-vert_coeff%c(iz)) &
+ - xctop_boot*alpha_div_Tij
+ c(iz) = vert_coeff%b(iz)/tmp
+ u_out(iz) = r(iz) / (tmp*Tij*vert_coeff%d(iz))
+ do iz=2,nz-1
+ b_k_tmp = vert_coeff%b(iz)
+ c_k_tmp = vert_coeff%c(iz)
+ tmp = ((vert_coeff%a(iz)-b_k_tmp-c_k_tmp)-alpha_div_Tij) &
+ - c(iz-1)*c_k_tmp
+ c(iz) = b_k_tmp / tmp
+ u_out(iz) = (r(iz) / (Tij*vert_coeff%d(iz)) - u_out(iz-1)*c_k_tmp) / tmp
+ end do
+ iz=nz
+ b_k_tmp = vert_coeff%b(iz)
+ c_k_tmp = vert_coeff%c(iz)
+ tmp = ((vert_coeff%a(iz)-b_k_tmp-c_k_tmp)- xctop_boot*alpha_div_Tij) &
+ - c(iz-1)*c_k_tmp
+ c(iz) = b_k_tmp / tmp
+ u_out(iz) = (r(iz) / (Tij*vert_coeff%d(iz)) - u_out(iz-1)*c_k_tmp) / tmp
+
+ ! STEP 2: back substitution
+ do iz=nz-1,1,-1
+ u_out(iz) = u_out(iz) - c(iz) * u_out(iz+1)
+ end do
+ end if
+ !
+
+ end subroutine apply_tridiag_solve_mnh
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! tranpose version
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ subroutine apply_tridiag_solve_mnhT(ix,iy,r,c,b, &
+ u_in_1, &
+ u_in_2, &
+ u_in_3, &
+ u_in_4, &
+ u_out)
+
+ implicit none
+ integer, intent(in) :: ix
+ integer, intent(in) :: iy
+ real(kind=rl), intent(inout), dimension(:) :: r
+ real(kind=rl), intent(inout), dimension(:) :: c
+ type(scalar3d), intent(in) :: b
+ real(kind=rl), intent(in), dimension(:) :: u_in_1
+ real(kind=rl), intent(in), dimension(:) :: u_in_2
+ real(kind=rl), intent(in), dimension(:) :: u_in_3
+ real(kind=rl), intent(in), dimension(:) :: u_in_4
+ real(kind=rl), intent(inout), dimension(:) :: u_out
+ real(kind=rl), dimension(5) :: alpha_T
+ real(kind=rl) :: Tij
+ real(kind=rl) :: alpha_div_Tij, tmp, b_k_tmp, c_k_tmp
+ integer :: iz, nz
+
+ real(kind=rl) :: xctop_boot
+
+ nz = b%grid_param%nz
+ xctop_boot = 0.0
+
+ call construct_alpha_T_cst_mnh(b%grid_param,alpha_T,Tij)
+ ! Calculate r_i = b_i - A_{ij} u_i
+ if (LUseT ) then
+ iz=1
+ r(iz) = b%st(ix,iy,iz)
+ do iz=2,nz-1
+ r(iz) = b%st(ix,iy,iz) - vert_coeff%d(iz) * ( &
+ alpha_T(1) * u_in_1(iz) + &
+ alpha_T(2) * u_in_2(iz) + &
+ alpha_T(3) * u_in_3(iz) + &
+ alpha_T(4) * u_in_4(iz) )
+ end do
+ iz=nz
+ r(iz) = b%st(ix,iy,iz)
+
+ ! Thomas algorithm
+ ! STEP 1: Create modified coefficients
+ iz = 1
+ alpha_div_Tij = alpha_T(5)/Tij
+ tmp = (vert_coeff%a(iz)-vert_coeff%b(iz)-vert_coeff%c(iz)) &
+ - xctop_boot*alpha_div_Tij
+ c(iz) = vert_coeff%b(iz)/tmp
+ u_out(iz) = r(iz) / (tmp*Tij*vert_coeff%d(iz))
+ do iz=2,nz-1
+ b_k_tmp = vert_coeff%b(iz)
+ c_k_tmp = vert_coeff%c(iz)
+ tmp = ((vert_coeff%a(iz)-b_k_tmp-c_k_tmp)-alpha_div_Tij) &
+ - c(iz-1)*c_k_tmp
+ c(iz) = b_k_tmp / tmp
+ u_out(iz) = (r(iz) / (Tij*vert_coeff%d(iz)) - u_out(iz-1)*c_k_tmp) / tmp
+ end do
+ iz=nz
+ b_k_tmp = vert_coeff%b(iz)
+ c_k_tmp = vert_coeff%c(iz)
+ tmp = ((vert_coeff%a(iz)-b_k_tmp-c_k_tmp)- xctop_boot*alpha_div_Tij) &
+ - c(iz-1)*c_k_tmp
+ c(iz) = b_k_tmp / tmp
+ u_out(iz) = (r(iz) / (Tij*vert_coeff%d(iz)) - u_out(iz-1)*c_k_tmp) / tmp
+
+ ! STEP 2: back substitution
+ do iz=nz-1,1,-1
+ u_out(iz) = u_out(iz) - c(iz) * u_out(iz+1)
+ end do
+ end if
+
+ end subroutine apply_tridiag_solve_mnhT
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! tranpose version all xyz
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ subroutine apply_tridiag_solve_mnh_allT(iib,iie,ijb,ije, &
+ Sr,c,b,Su_in,Su_out,level)
+
+ implicit none
+ integer, intent(in) :: iib,iie,ijb,ije
+ type(scalar3d), intent(inout) :: Sr
+ real(kind=rl), intent(inout), dimension(:) :: c
+ type(scalar3d), intent(in) :: b
+ type(scalar3d), intent(in) :: Su_in
+ type(scalar3d), intent(inout) :: Su_out
+ integer, intent(in) :: level
+
+ !local
+ !real(kind=rl), dimension(5) :: alpha_T
+ real(kind=rl) :: Tij
+ real(kind=rl) :: alpha_div_Tij ! b_k_tmp, c_k_tmp
+ integer :: iz, nz
+
+ real, dimension(:,:,:) , pointer, contiguous :: zSr_st , zb_st , zSu_in_st , zSu_out_st
+ real, dimension(:) , pointer, contiguous :: za_k, zb_k, zc_k, zd_k
+ integer :: ii,ij
+
+ integer , parameter :: max_lev = 128
+ logical , save :: Lfirst_call_tridiag_mnhallT = .true.
+ logical , save , dimension(max_lev) :: Lfirst_call_level_tridiag_mnhallT = .true.
+
+ real, dimension(:), pointer, contiguous :: tmp_k,c_k
+
+ type Temp_tridiag_mnh
+ real, dimension(:), pointer, contiguous :: tmp_k,c_k
+ end type Temp_tridiag_mnh
+
+ type(Temp_tridiag_mnh) , save , dimension(max_lev) :: Ttridiag_mnh
+
+ if (LUseT ) then
+
+ nz = b%grid_param%nz
+
+ !call construct_alpha_T_cst_mnh(b%grid_param,alpha_T,Tij)
+ Tij = ( b%grid_param%L/b%grid_param%n ) ** 2
+ alpha_div_Tij = 4.0_rl / Tij
+ !print*,"level=",level," Tij=",Tij," alpha_div_Tij=",alpha_div_Tij
+ ! Calculate r_i = b_i - A_{ij} u_i
+
+ zSr_st => Sr%st
+ zb_st => b%st
+ zSu_in_st => Su_in%st
+ zSu_out_st => Su_out%st
+ za_k => vert_coeff%a
+ zb_k => vert_coeff%b
+ zc_k => vert_coeff%c
+ zd_k => vert_coeff%d
+
+ if ( Lfirst_call_level_tridiag_mnhallT(level) ) then
+ Lfirst_call_level_tridiag_mnhallT(level) = .false.
+ allocate(Ttridiag_mnh(level)%tmp_k(size(zb_k)))
+ allocate(Ttridiag_mnh(level)%c_k(size(zb_k)))
+
+ tmp_k => Ttridiag_mnh(level)%tmp_k
+ c_k => Ttridiag_mnh(level)%c_k
+ ! Thomas algorithm
+ ! STEP 1: Create modified coefficients
+ iz = 1
+ tmp_k(iz) = (za_k(iz)-zb_k(iz)-zc_k(iz))
+ c_k(iz) = zb_k(iz)/tmp_k(iz)
+ !
+ do iz=2,nz-1
+ tmp_k(iz) = ((za_k(iz)-zb_k(iz)-zc_k(iz))-alpha_div_Tij) &
+ - c_k(iz-1)*zc_k(iz)
+ c_k(iz) = zb_k(iz) / tmp_k(iz)
+ end do
+ !
+ iz=nz
+ tmp_k(iz) = ((za_k(iz)-zb_k(iz)-zc_k(iz))) &
+ - c_k(iz-1)*zc_k(iz)
+ c_k(iz) = zb_k(iz) / tmp_k(iz)
+
+ !$acc enter data copyin(tmp_k,c_k)
+
+ endif
+
+ tmp_k => Ttridiag_mnh(level)%tmp_k
+ c_k => Ttridiag_mnh(level)%c_k
+
+ !$acc kernels
+ iz=1
+ zSr_st(iib:iie,ijb:ije,iz) = zb_st(iib:iie,ijb:ije,iz)
+ do iz=2,nz-1
+ zSr_st(iib:iie,ijb:ije,iz) = zb_st(iib:iie,ijb:ije,iz) - zd_k(iz) * ( &
+ zSu_in_st(iib+1:iie+1,ijb:ije,iz) + &
+ zSu_in_st(iib-1:iie-1,ijb:ije,iz) + &
+ zSu_in_st(iib:iie,ijb+1:ije+1,iz) + &
+ zSu_in_st(iib:iie,ijb-1:ije-1,iz) )
+ end do
+ iz=nz
+ zSr_st(iib:iie,ijb:ije,iz) = zb_st(iib:iie,ijb:ije,iz)
+ !
+ ! Thomas algorithm
+ !
+ iz = 1
+ zSu_out_st(iib:iie,ijb:ije,iz) = zSr_st(iib:iie,ijb:ije,iz) / (tmp_k(iz)*Tij*zd_k(iz))
+ !
+ !$acc loop seq
+ do iz=2,nz-1
+ !$acc loop independent collapse(2)
+ do ij=ijb,ije
+ do ii=iib,iie
+ zSu_out_st(ii,ij,iz) = (zSr_st(ii,ij,iz) / (Tij*zd_k(iz)) &
+ - zSu_out_st(ii,ij,iz-1)*zc_k(iz)) / tmp_k(iz)
+ end do
+ end do
+ end do
+ !
+ iz=nz
+ zSu_out_st(iib:iie,ijb:ije,iz) = (zSr_st(iib:iie,ijb:ije,iz) / (Tij*zd_k(iz)) &
+ - zSu_out_st(iib:iie,ijb:ije,iz-1)*zc_k(iz)) / tmp_k(iz)
+
+ ! STEP 2: back substitution
+ !$acc loop seq
+ do iz=nz-1,1,-1
+ zSu_out_st(iib:iie,ijb:ije,iz) = zSu_out_st(iib:iie,ijb:ije,iz) &
+ - c_k(iz) * zSu_out_st(iib:iie,ijb:ije,iz+1)
+ end do
+ !$acc end kernels
+
+ end if
+
+ end subroutine apply_tridiag_solve_mnh_allT
+ !==================================================================
+! At a given horizontal position (ix,iy) (local coordinates),
+! calculate
+!
+! u_out = T(ix,iy)^{-1} (b_(ix,iy)
+! - sum_{ix',iy' != ix,iy} A_{(ix,iy),(ix',iy')}*u_in(ix',iy'))
+!
+!==================================================================
+ subroutine apply_tridiag_solve(ix,iy,r,c,b, &
+ u_in_1, &
+ u_in_2, &
+ u_in_3, &
+ u_in_4, &
+ u_out)
+
+ implicit none
+ integer, intent(in) :: ix
+ integer, intent(in) :: iy
+ real(kind=rl), intent(inout), dimension(:) :: r
+ real(kind=rl), intent(inout), dimension(:) :: c
+ type(scalar3d), intent(in) :: b
+ real(kind=rl), intent(in), dimension(:) :: u_in_1
+ real(kind=rl), intent(in), dimension(:) :: u_in_2
+ real(kind=rl), intent(in), dimension(:) :: u_in_3
+ real(kind=rl), intent(in), dimension(:) :: u_in_4
+ real(kind=rl), intent(inout), dimension(:) :: u_out
+ real(kind=rl), dimension(5) :: alpha_T
+ real(kind=rl) :: Tij
+ real(kind=rl) :: alpha_div_Tij, tmp, b_k_tmp, c_k_tmp
+ integer :: iz, nz
+
+ nz = b%grid_param%nz
+
+ call construct_alpha_T(b%grid_param, &
+ ix+b%ix_min-1, &
+ iy+b%iy_min-1, &
+ alpha_T,Tij)
+ ! Calculate r_i = b_i - A_{ij} u_i
+ !alpha_T(5) = 4.0
+ do iz=1,nz
+ r(iz) = b%s(iz,iy,ix) - vert_coeff%d(iz) * ( &
+ alpha_T(1) * u_in_1(iz) + &
+ alpha_T(2) * u_in_2(iz) + &
+ alpha_T(3) * u_in_3(iz) + &
+ alpha_T(4) * u_in_4(iz) )
+ end do
+ !r(1:nz) = b%s(1:nz,iy,ix)
+ ! Thomas algorithm
+ ! STEP 1: Create modified coefficients
+ iz = 1
+ alpha_div_Tij = alpha_T(5)/Tij
+ tmp = (vert_coeff%a(iz)-vert_coeff%b(iz)-vert_coeff%c(iz)) &
+ - alpha_div_Tij
+ c(iz) = vert_coeff%b(iz)/tmp
+ u_out(iz) = r(iz) / (tmp*Tij*vert_coeff%d(iz))
+ do iz=2,nz
+ b_k_tmp = vert_coeff%b(iz)
+ c_k_tmp = vert_coeff%c(iz)
+ tmp = ((vert_coeff%a(iz)-b_k_tmp-c_k_tmp)-alpha_div_Tij) &
+ - c(iz-1)*c_k_tmp
+ c(iz) = b_k_tmp / tmp
+ u_out(iz) = (r(iz) / (Tij*vert_coeff%d(iz)) - u_out(iz-1)*c_k_tmp) / tmp
+ end do
+ ! STEP 2: back substitution
+ do iz=nz-1,1,-1
+ u_out(iz) = u_out(iz) - c(iz) * u_out(iz+1)
+ end do
+ end subroutine apply_tridiag_solve
+
+end module discretisation
diff --git a/src/ZSOLVER/tensorproductmultigrid_Source/messages.f90 b/src/ZSOLVER/tensorproductmultigrid_Source/messages.f90
new file mode 100644
index 0000000000000000000000000000000000000000..7b4345777a92dcb235e12c456284ecc66b06c980
--- /dev/null
+++ b/src/ZSOLVER/tensorproductmultigrid_Source/messages.f90
@@ -0,0 +1,104 @@
+!=== COPYRIGHT AND LICENSE STATEMENT ===
+!
+! This file is part of the TensorProductMultigrid code.
+!
+! (c) The copyright relating to this work is owned jointly by the
+! Crown, Met Office and NERC [2014]. However, it has been created
+! with the help of the GungHo Consortium, whose members are identified
+! at https://puma.nerc.ac.uk/trac/GungHo/wiki .
+!
+! Main Developer: Eike Mueller
+!
+! TensorProductMultigrid is free software: you can redistribute it and/or
+! modify it under the terms of the GNU Lesser General Public License as
+! published by the Free Software Foundation, either version 3 of the
+! License, or (at your option) any later version.
+!
+! TensorProductMultigrid is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU Lesser General Public License for more details.
+!
+! You should have received a copy of the GNU Lesser General Public License
+! along with TensorProductMultigrid (see files COPYING and COPYING.LESSER).
+! If not, see <http://www.gnu.org/licenses/>.
+!
+!=== COPYRIGHT AND LICENSE STATEMENT ===
+
+
+!==================================================================
+!
+! Module for error/warning/info messages
+!
+! Eike Mueller, University of Bath, Feb 2012
+!
+!==================================================================
+module messages
+
+ use parameters
+#ifndef MNH
+ use mpi
+#else
+ use modd_mpif
+#endif
+
+ implicit none
+
+contains
+
+!==================================================================
+! Print error message and exit
+!==================================================================
+ subroutine fatalerror(message)
+ implicit none
+ character(len=*), intent(in) :: message
+ integer :: ierr, rank
+ integer, parameter :: errorcode = -1
+ call mpi_comm_rank(MPI_COMM_WORLD,rank,ierr)
+ if (rank == 0) then
+ write(STDERR,'("FATAL ERROR: ",A)') message
+ end if
+ call mpi_finalize(ierr)
+ STOP
+ end subroutine fatalerror
+
+!==================================================================
+! Print error message
+!==================================================================
+ subroutine error(message)
+ implicit none
+ character(len=*), intent(in) :: message
+ integer :: ierr, rank
+ call mpi_comm_rank(MPI_COMM_WORLD,rank,ierr)
+ if (rank == 0) then
+ write(STDERR,'("ERROR: ",A)') message
+ end if
+ end subroutine error
+
+!==================================================================
+! Print warning message
+!==================================================================
+ subroutine warning(message)
+ implicit none
+ character(len=*), intent(in) :: message
+ integer :: ierr, rank
+ call mpi_comm_rank(MPI_COMM_WORLD,rank,ierr)
+ if (rank == 0) then
+ write(STDERR,'("WARNING: ",A)') message
+ end if
+ end subroutine warning
+
+!==================================================================
+! Print info message
+!==================================================================
+ subroutine information(message)
+ implicit none
+ character(len=*), intent(in) :: message
+ integer :: ierr, rank
+ call mpi_comm_rank(MPI_COMM_WORLD,rank,ierr)
+ if (rank == 0) then
+ write(STDERR,'("INFO: ",A)') message
+ end if
+ end subroutine information
+
+end module messages
diff --git a/src/ZSOLVER/tensorproductmultigrid_Source/mg_main.f90 b/src/ZSOLVER/tensorproductmultigrid_Source/mg_main.f90
new file mode 100644
index 0000000000000000000000000000000000000000..a97d51b494603178c8f34336f074d49d4f8aa8ec
--- /dev/null
+++ b/src/ZSOLVER/tensorproductmultigrid_Source/mg_main.f90
@@ -0,0 +1,85 @@
+!=== COPYRIGHT AND LICENSE STATEMENT ===
+!
+! This file is part of the TensorProductMultigrid code.
+!
+! (c) The copyright relating to this work is owned jointly by the
+! Crown, Met Office and NERC [2014]. However, it has been created
+! with the help of the GungHo Consortium, whose members are identified
+! at https://puma.nerc.ac.uk/trac/GungHo/wiki .
+!
+! Main Developer: Eike Mueller
+!
+! TensorProductMultigrid is free software: you can redistribute it and/or
+! modify it under the terms of the GNU Lesser General Public License as
+! published by the Free Software Foundation, either version 3 of the
+! License, or (at your option) any later version.
+!
+! TensorProductMultigrid is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU Lesser General Public License for more details.
+!
+! You should have received a copy of the GNU Lesser General Public License
+! along with TensorProductMultigrid (see files COPYING and COPYING.LESSER).
+! If not, see <http://www.gnu.org/licenses/>.
+!
+!=== COPYRIGHT AND LICENSE STATEMENT ===
+
+
+!==================================================================
+!
+! Main program for multigrid solver code for Helmholtz/Poisson
+! equation, discretised in the cell centred finite volume scheme
+!
+! Eike Mueller, University of Bath, Feb 2012
+!
+!==================================================================
+
+!==================================================================
+! Main program
+!==================================================================
+
+program mg_main
+
+ use discretisation
+ use parameters
+ use datatypes
+ use multigrid
+ use conjugategradient
+ use solver
+ use profiles
+ use messages
+ use communication
+ use timer
+#ifndef MNH
+ use mpi
+#else
+ use modd_mpif
+#endif
+
+ use mode_mg_read_param
+ use mode_mg
+
+ implicit none
+
+ call mg_init()
+
+ ! Initialise ghosts in initial solution, as mg_solve assumes that they
+ ! are up-to-date
+ call haloswap(mg_param%n_lev,pproc,xu_fine)
+
+ ! Solve using multigrid
+ call initialise_timer(t_solve,"t_solve")
+ call start_timer(t_solve)
+ comm_measuretime = .True.
+#ifdef MEASUREHALOSWAP
+ call measurehaloswap()
+#else
+ call mg_solve(xb_fine,xu_fine,solver_param)
+#endif
+ comm_measuretime = .False.
+ call finish_timer(t_solve)
+
+call mg_finalize()
+
+end program mg_main
diff --git a/src/ZSOLVER/tensorproductmultigrid_Source/mg_main_mnh.f90 b/src/ZSOLVER/tensorproductmultigrid_Source/mg_main_mnh.f90
new file mode 100644
index 0000000000000000000000000000000000000000..21999316883d4dcffe25e5fa84fd544f2485a6b7
--- /dev/null
+++ b/src/ZSOLVER/tensorproductmultigrid_Source/mg_main_mnh.f90
@@ -0,0 +1,203 @@
+!=== COPYRIGHT AND LICENSE STATEMENT ===
+!
+! This file is part of the TensorProductMultigrid code.
+!
+! (c) The copyright relating to this work is owned jointly by the
+! Crown, Met Office and NERC [2014]. However, it has been created
+! with the help of the GungHo Consortium, whose members are identified
+! at https://puma.nerc.ac.uk/trac/GungHo/wiki .
+!
+! Main Developer: Eike Mueller
+!
+! TensorProductMultigrid is free software: you can redistribute it and/or
+! modify it under the terms of the GNU Lesser General Public License as
+! published by the Free Software Foundation, either version 3 of the
+! License, or (at your option) any later version.
+!
+! TensorProductMultigrid is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU Lesser General Public License for more details.
+!
+! You should have received a copy of the GNU Lesser General Public License
+! along with TensorProductMultigrid (see files COPYING and COPYING.LESSER).
+! If not, see <http://www.gnu.org/licenses/>.
+!
+!=== COPYRIGHT AND LICENSE STATEMENT ===
+
+
+!==================================================================
+!
+! Main program for multigrid solver code for Helmholtz/Poisson
+! equation, discretised in the cell centred finite volume scheme
+!
+! Eike Mueller, University of Bath, Feb 2012
+!
+!==================================================================
+
+!==================================================================
+! Main program
+!==================================================================
+
+module mode_mg_main_mnh
+
+ use discretisation
+ use parameters
+ use datatypes
+ use multigrid
+ use conjugategradient
+ use solver
+ use profiles
+ use messages
+ use communication
+ use timer
+#ifndef MNH
+ use mpi
+#else
+ use modd_mpif
+#endif
+
+ use mode_mg_read_param
+ use mode_mg
+
+contains
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ subroutine mg_main_mnh_init(KN,KNZ,PL,PH,PA_K,PB_K,PC_K,PD_K)
+
+ use parameters , only : LMean
+
+ implicit none
+
+ integer , optional , intent (in) :: KN,KNZ
+ real(kind=rl) , optional , intent (in) :: PL,PH
+ real(kind=rl) , optional , intent (in) :: PA_K(:),PB_K(:),PC_K(:),PD_K(:)
+
+ call mg_init_mnh(KN,KNZ,PL,PH,PA_K,PB_K,PC_K,PD_K)
+
+ ! Initialise ghosts in initial solution, as mg_solve assumes that they
+ ! are up-to-date
+ call haloswap_mnh(mg_param%n_lev,pproc,xu_fine)
+
+ if (.NOT. PRESENT(KN)) then
+ !
+ ! Force some parameter for Idealized StandAlone Newman Solver until convergence
+ !
+ ! -> Mean must by set to 0 for covergence with Newmann boundaries
+ LMean = .true.
+ ! -> converge up to 1e-10 in 50 iteration
+ solver_param%resreduction = 1.0d-10
+ solver_param%maxiter = 50
+
+ if (i_am_master_mpi) then
+ call flush(STDOUT)
+ write(STDOUT,*)
+ write(STDOUT,*) "!!!!! WARNING mg_main_mnh_init !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! "
+ write(STDOUT,*) "!!!!! FORCED PARAMETER FOR StandAlone Newman Solver until convergence !!!! "
+ write(STDOUT,*) "!!!!! LMean = " , LMean
+ write(STDOUT,*) "!!!!! solver_param%resreduction = " , solver_param%resreduction
+ write(STDOUT,*) "!!!!! solver_param%maxiter = " , solver_param%maxiter
+ write(STDOUT,*) "!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! "
+ write(STDOUT,*)
+ call flush(STDOUT)
+ end if
+ endif
+
+ end subroutine mg_main_mnh_init
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+subroutine mg_main_initialise_rhs_mnh(KIB,KIE,KIU,KJB,KJE,KJU,KKU,PY)
+
+implicit none
+
+integer , optional , intent(in) :: KIB,KIE,KIU,KJB,KJE,KJU,KKU
+real(kind=rl) , optional , intent(in) :: PY(:,:,:)
+
+ call initialise_rhs_mnh(grid_param,model_param,xb_fine,KIB,KIE,KIU,KJB,KJE,KJU,KKU,PY)
+ call haloswap_mnh(mg_param%n_lev,pproc,xb_fine)
+
+end subroutine mg_main_initialise_rhs_mnh
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+subroutine mg_main_initialise_u_mnh(KIB,KIE,KIU,KJB,KJE,KJU,KKU,PU)
+
+implicit none
+
+integer , optional , intent(in) :: KIB,KIE,KIU,KJB,KJE,KJU,KKU
+real(kind=rl) , optional , intent(in) :: PU(:,:,:)
+
+ call initialise_u_mnh(grid_param,model_param,xu_fine,KIB,KIE,KIU,KJB,KJE,KJU,KKU,PU)
+ call haloswap_mnh(mg_param%n_lev,pproc,xu_fine)
+
+end subroutine mg_main_initialise_u_mnh
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+subroutine mg_main_get_u_mnh(KIB,KIE,KIU,KJB,KJE,KJU,KKU,PU)
+
+implicit none
+
+integer , optional , intent(in) :: KIB,KIE,KIU,KJB,KJE,KJU,KKU
+real(kind=rl) , optional , intent(inout) :: PU(:,:,:)
+
+ call get_u_mnh(grid_param,model_param,xu_fine,KIB,KIE,KIU,KJB,KJE,KJU,KKU,PU)
+
+end subroutine mg_main_get_u_mnh
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ subroutine mg_main_mnh_solve()
+
+ implicit none
+
+ ! Solve using multigrid
+ call initialise_timer(t_solve,"t_solve")
+ call start_timer(t_solve)
+ comm_measuretime = .True.
+
+ call mg_solve_mnh(xb_fine,xu_fine,solver_param)
+
+ comm_measuretime = .False.
+ call finish_timer(t_solve)
+
+ end subroutine mg_main_mnh_solve
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ subroutine mg_main_mnh_finalize()
+
+
+ end subroutine mg_main_mnh_finalize
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ subroutine mg_main_mnh
+
+ implicit none
+
+ integer :: it
+
+ call mg_main_mnh_init()
+
+ DO it=1,1
+
+ call mg_main_initialise_rhs_mnh()
+ call mg_main_initialise_u_mnh()
+
+ if (i_am_master_mpi) then
+ write(STDOUT,*),'************************ IT=',it,' ***************************'
+ call flush(STDOUT)
+ end if
+
+ call mg_main_mnh_solve()
+
+ ENDDO
+
+ call mg_finalize()
+
+ end subroutine mg_main_mnh
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+end module mode_mg_main_mnh
+
+program mg_main_mnh_all
+
+ use mode_mg_main_mnh
+
+ call mg_main_mnh()
+
+end program mg_main_mnh_all
diff --git a/src/ZSOLVER/tensorproductmultigrid_Source/mode_mg.f90 b/src/ZSOLVER/tensorproductmultigrid_Source/mode_mg.f90
new file mode 100644
index 0000000000000000000000000000000000000000..11ade04e65232027b59ee864585f82ad81bc9a1b
--- /dev/null
+++ b/src/ZSOLVER/tensorproductmultigrid_Source/mode_mg.f90
@@ -0,0 +1,335 @@
+module mode_mg
+
+ use datatypes
+ use communication
+ use discretisation
+ use multigrid
+ use conjugategradient
+ use solver
+ use parameters
+ use timer
+#ifndef MNH
+ use mpi
+#else
+ use modd_mpif
+#endif
+ use profiles
+
+ use mode_mg_read_param
+
+implicit none
+
+ type(grid_parameters) :: grid_param
+ type(comm_parameters) :: comm_param
+ type(model_parameters) :: model_param
+ type(smoother_parameters) :: smoother_param
+ type(mg_parameters) :: mg_param
+ type(cg_parameters) :: cg_param
+ type(solver_parameters) :: solver_param
+
+ type(scalar3d) :: xu_fine
+ type(scalar3d) :: xb_fine
+ type(scalar3d) :: xr_fine
+#ifdef TESTCONVERGENCE
+ type(scalar3d) :: uerror
+ real(kind=rl) :: l2error
+#endif
+
+ ! --- Name of executable ---
+ character(len=256) :: executable
+
+ ! --- Parameter file ---
+ character(len=256) :: parameterfile
+
+ ! --- General parameters ---
+ logical :: savefields ! Save fields to disk?
+
+ integer :: i, int_size
+ integer :: i_arg
+ integer :: ierr
+
+ ! Timers
+ type(time) :: t_solve
+ type(time) :: t_readparam
+ type(time) :: t_initialise
+ type(time) :: t_finalise
+
+contains
+
+subroutine mg_init_mnh(KN,KNZ,PL,PH,PA_K,PB_K,PC_K,PD_K)
+
+use MODE_OPENACC_SET_DEVICE
+
+implicit none
+
+integer , optional , intent (in) :: KN,KNZ
+real(kind=rl) , optional , intent (in) :: PL,PH
+real(kind=rl) , optional , intent (in) :: PA_K(:),PB_K(:),PC_K(:),PD_K(:)
+
+! local var
+
+logical :: gisinit
+
+ ! Initialise MPI ...
+ call mpi_initialized(gisinit, ierr )
+ if (.not. gisinit ) then
+ call mpi_init(ierr)
+ end if
+ !
+ ! get default device type
+ call MNH_OPENACC_GET_DEVICE_AT_INIT()
+ ! ... and pre initialise communication module
+ call comm_preinitialise()
+
+ parameterfile="parameters_mg.nam"
+
+ if (i_am_master_mpi) then
+ write(STDOUT,*) ''
+ write(STDOUT,*) 'Compile time parameters:'
+ write(STDOUT,*) ''
+#ifdef CARTESIANGEOMETRY
+ write(STDOUT,*) ' Geometry: Cartesian'
+#else
+ write(STDOUT,*) ' Geometry: Spherical'
+#endif
+#ifdef USELAPACK
+ write(STDOUT,*) ' Use Lapack: Yes'
+#else
+ write(STDOUT,*) ' Use Lapack: No'
+#endif
+#ifdef OVERLAPCOMMS
+ write(STDOUT,*) ' Overlap communications and calculation: Yes'
+#else
+ write(STDOUT,*) ' Overlap communications and calculation: No'
+#endif
+ write(STDOUT,*) ''
+
+ end if
+
+ ! Initialise timing module
+ call initialise_timing("timing.txt")
+
+ ! Read parameter files
+ call initialise_timer(t_readparam,"t_readparam")
+ call start_timer(t_readparam)
+ if (i_am_master_mpi) then
+ write(STDOUT,*) "Reading parameters from file '" // &
+ trim(parameterfile) // "'"
+ end if
+ call read_general_parameters(parameterfile,savefields)
+ call read_solver_parameters(parameterfile,solver_param)
+ call read_grid_parameters_mnh(parameterfile,grid_param,KN,KNZ,PL,PH)
+ call read_comm_parameters(parameterfile,comm_param)
+ call read_model_parameters(parameterfile,model_param)
+ call read_smoother_parameters(parameterfile,smoother_param)
+ call read_multigrid_parameters(parameterfile,mg_param)
+ call read_conjugategradient_parameters(parameterfile,cg_param)
+ call finish_timer(t_readparam)
+
+ if (i_am_master_mpi) then
+ write(STDOUT,*) ''
+ end if
+
+ ! Initialise discretisation module
+ call discretisation_initialise_mnh(grid_param, &
+ model_param, &
+ smoother_param, &
+ mg_param%n_lev, &
+ PA_K,PB_K,PC_K,PD_K )
+
+ ! Initialise communication module
+ call initialise_timer(t_initialise,"t_initialise")
+ call start_timer(t_initialise)
+ call comm_initialise(mg_param%n_lev, &
+ mg_param%lev_split, &
+ grid_param, &
+ comm_param)
+
+ ! Initialise multigrid
+ call mg_initialise(grid_param, &
+ comm_param, &
+ model_param, &
+ smoother_param, &
+ mg_param, &
+ cg_param &
+ )
+
+ call create_scalar3d(MPI_COMM_HORIZ,grid_param,comm_param%halo_size,xu_fine)
+ call create_scalar3d(MPI_COMM_HORIZ,grid_param,comm_param%halo_size,xb_fine)
+ call create_scalar3d(MPI_COMM_HORIZ,grid_param,comm_param%halo_size,xr_fine)
+
+!!$ call mg_initialise_rhs_mnh()
+
+ call finish_timer(t_initialise)
+ if (i_am_master_mpi) then
+ write(STDOUT,*) ''
+ end if
+
+end subroutine mg_init_mnh
+
+subroutine mg_init()
+
+implicit none
+
+ ! Initialise MPI ...
+ call mpi_init(ierr)
+
+ ! ... and pre initialise communication module
+ call comm_preinitialise()
+
+ parameterfile="parameters_mg.nam"
+
+ if (i_am_master_mpi) then
+ write(STDOUT,*) ''
+ write(STDOUT,*) 'Compile time parameters:'
+ write(STDOUT,*) ''
+#ifdef CARTESIANGEOMETRY
+ write(STDOUT,*) ' Geometry: Cartesian'
+#else
+ write(STDOUT,*) ' Geometry: Spherical'
+#endif
+#ifdef USELAPACK
+ write(STDOUT,*) ' Use Lapack: Yes'
+#else
+ write(STDOUT,*) ' Use Lapack: No'
+#endif
+#ifdef OVERLAPCOMMS
+ write(STDOUT,*) ' Overlap communications and calculation: Yes'
+#else
+ write(STDOUT,*) ' Overlap communications and calculation: No'
+#endif
+ write(STDOUT,*) ''
+
+ end if
+
+ ! Initialise timing module
+ call initialise_timing("timing.txt")
+
+ ! Read parameter files
+ call initialise_timer(t_readparam,"t_readparam")
+ call start_timer(t_readparam)
+ if (i_am_master_mpi) then
+ write(STDOUT,*) "Reading parameters from file '" // &
+ trim(parameterfile) // "'"
+ end if
+ call read_general_parameters(parameterfile,savefields)
+ call read_solver_parameters(parameterfile,solver_param)
+ call read_grid_parameters(parameterfile,grid_param)
+ call read_comm_parameters(parameterfile,comm_param)
+ call read_model_parameters(parameterfile,model_param)
+ call read_smoother_parameters(parameterfile,smoother_param)
+ call read_multigrid_parameters(parameterfile,mg_param)
+ call read_conjugategradient_parameters(parameterfile,cg_param)
+ call finish_timer(t_readparam)
+
+ if (i_am_master_mpi) then
+ write(STDOUT,*) ''
+ end if
+
+ ! Initialise discretisation module
+ call discretisation_initialise(grid_param, &
+ model_param, &
+ smoother_param, &
+ mg_param%n_lev )
+
+ ! Initialise communication module
+ call initialise_timer(t_initialise,"t_initialise")
+ call start_timer(t_initialise)
+ call comm_initialise(mg_param%n_lev, &
+ mg_param%lev_split, &
+ grid_param, &
+ comm_param)
+
+ ! Initialise multigrid
+ call mg_initialise(grid_param, &
+ comm_param, &
+ model_param, &
+ smoother_param, &
+ mg_param, &
+ cg_param &
+ )
+
+ call create_scalar3d(MPI_COMM_HORIZ,grid_param,comm_param%halo_size,xu_fine)
+ call create_scalar3d(MPI_COMM_HORIZ,grid_param,comm_param%halo_size,xb_fine)
+ call create_scalar3d(MPI_COMM_HORIZ,grid_param,comm_param%halo_size,xr_fine)
+ call initialise_rhs(grid_param,model_param,xb_fine)
+#ifdef TESTCONVERGENCE
+ call create_scalar3d(MPI_COMM_HORIZ,grid_param,comm_param%halo_size,uerror)
+ call analytical_solution(grid_param,uerror)
+#endif
+ call finish_timer(t_initialise)
+ if (i_am_master_mpi) then
+ write(STDOUT,*) ''
+ end if
+
+end subroutine mg_init
+
+subroutine mg_finalize()
+
+implicit none
+
+#ifdef TESTCONVERGENCE
+ call daxpy_scalar3d(-1.0_rl,xu_fine,uerror)
+ call haloswap(mg_param%n_lev,pproc,uerror)
+ l2error = l2norm(uerror)
+ if (i_am_master_mpi) then
+ write(STDOUT,'("||error|| = ",E20.12," log_2(||error||) = ",E20.12)') &
+ l2error, log(l2error)/log(2.0_rl)
+ end if
+#endif
+
+#ifdef TESTCONVERGENCE
+ if (savefields) then
+ call save_scalar3d(MPI_COMM_HORIZ,uerror,"error")
+ end if
+#endif
+
+ ! Save fields to disk
+ if (savefields) then
+ call haloswap(mg_param%n_lev,pproc,xu_fine)
+ call save_scalar3d(MPI_COMM_HORIZ,xu_fine,"solution")
+ call volscale_scalar3d(xb_fine,1)
+ call calculate_residual(mg_param%n_lev,pproc,xb_fine,xu_fine,xr_fine)
+ call volscale_scalar3d(xb_fine,-1)
+ call volscale_scalar3d(xr_fine,-1)
+ call haloswap(mg_param%n_lev,pproc,xr_fine)
+ call save_scalar3d(MPI_COMM_HORIZ,xr_fine,"residual")
+ end if
+
+ if (i_am_master_mpi) then
+ write(STDOUT,*) ''
+ end if
+
+ call discretisation_finalise()
+
+ ! Finalise
+ call initialise_timer(t_finalise,"t_finalise")
+ call start_timer(t_finalise)
+ call mg_finalise()
+ call cg_finalise()
+ ! Deallocate memory
+ call destroy_scalar3d(xu_fine)
+ call destroy_scalar3d(xb_fine)
+ call destroy_scalar3d(xr_fine)
+#ifdef TESTCONVERGENCE
+ call destroy_scalar3d(uerror)
+#endif
+
+
+ ! Finalise communications ...
+ call comm_finalise(mg_param%n_lev,mg_param%lev_split,grid_param)
+ call finish_timer(t_finalise)
+ call print_timerinfo("# --- Main timing results ---")
+ call print_elapsed(t_readparam,.true.,1.0_rl)
+ call print_elapsed(t_initialise,.true.,1.0_rl)
+ call print_elapsed(t_solve,.true.,1.0_rl)
+ call print_elapsed(t_finalise,.true.,1.0_rl)
+ ! Finalise timing
+ call finalise_timing()
+ ! ... and MPI
+ call mpi_finalize(ierr)
+
+
+end subroutine mg_finalize
+
+end module mode_mg
diff --git a/src/ZSOLVER/tensorproductmultigrid_Source/mode_mg_read_param.f90 b/src/ZSOLVER/tensorproductmultigrid_Source/mode_mg_read_param.f90
new file mode 100644
index 0000000000000000000000000000000000000000..b0f0181c71deeea7fb1fd0c23c11406106de9870
--- /dev/null
+++ b/src/ZSOLVER/tensorproductmultigrid_Source/mode_mg_read_param.f90
@@ -0,0 +1,576 @@
+!=== COPYRIGHT AND LICENSE STATEMENT ===
+!
+! This file is part of the TensorProductMultigrid code.
+!
+! (c) The copyright relating to this work is owned jointly by the
+! Crown, Met Office and NERC [2014]. However, it has been created
+! with the help of the GungHo Consortium, whose members are identified
+! at https://puma.nerc.ac.uk/trac/GungHo/wiki .
+!
+! Main Developer: Eike Mueller
+!
+! TensorProductMultigrid is free software: you can redistribute it and/or
+! modify it under the terms of the GNU Lesser General Public License as
+! published by the Free Software Foundation, either version 3 of the
+! License, or (at your option) any later version.
+!
+! TensorProductMultigrid is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU Lesser General Public License for more details.
+!
+! You should have received a copy of the GNU Lesser General Public License
+! along with TensorProductMultigrid (see files COPYING and COPYING.LESSER).
+! If not, see <http://www.gnu.org/licenses/>.
+!
+!=== COPYRIGHT AND LICENSE STATEMENT ===
+
+module mode_mg_read_param
+
+contains
+
+!==================================================================
+! Read general parameters from namelist file
+!==================================================================
+subroutine read_general_parameters(filename,savefields_out)
+ use parameters
+ use communication
+ use messages
+#ifndef MNH
+ use mpi
+#else
+ use modd_mpif
+#endif
+ implicit none
+ character(*), intent(in) :: filename
+ logical, intent(out) :: savefields_out
+ integer, parameter :: file_id = 16
+ logical :: savefields
+ integer :: ierr
+ namelist /parameters_general/ savefields
+ if (i_am_master_mpi) then
+ open(file_id,file=filename)
+ read(file_id,NML=parameters_general)
+ close(file_id)
+ write(STDOUT,NML=parameters_general)
+ write(STDOUT,'("---------------------------------------------- ")')
+ write(STDOUT,'("General parameters")')
+ write(STDOUT,'(" Save fields = ",L6)') savefields
+ write(STDOUT,'("---------------------------------------------- ")')
+ write(STDOUT,'("")')
+ end if
+ call mpi_bcast(savefields,1,MPI_LOGICAL,master_rank,MPI_COMM_WORLD,ierr)
+ savefields_out = savefields
+end subroutine read_general_parameters
+
+!==================================================================
+! Read solver parameters from namelist file
+!==================================================================
+subroutine read_solver_parameters(filename,solver_param_out)
+ use solver
+ use parameters
+ use communication
+ use messages
+#ifndef MNH
+ use mpi
+#else
+ use modd_mpif
+#endif
+ implicit none
+ character(*), intent(in) :: filename
+ type(solver_parameters), intent(out) :: solver_param_out
+ integer :: solvertype
+ real(kind=rl) :: resreduction
+ integer :: maxiter
+ integer, parameter :: file_id = 16
+ integer :: ierr
+ namelist /parameters_solver/ solvertype,resreduction, maxiter &
+ , LUseO , LUseT , LMean
+ if (i_am_master_mpi) then
+ open(file_id,file=filename)
+ read(file_id,NML=parameters_solver)
+ close(file_id)
+ write(STDOUT,NML=parameters_solver)
+ write(STDOUT,'("---------------------------------------------- ")')
+ write(STDOUT,'(" LMean = ",L8)') LMean
+ write(STDOUT,'(" LUseO = ",L8)') LUseO
+ write(STDOUT,'(" LUseT = ",L8)') LUseT
+ write(STDOUT,'("Solver parameters ")')
+ if (solvertype == SOLVER_RICHARDSON) then
+ write(STDOUT,'(" solver = Richardson")')
+ else if (solvertype == SOLVER_CG) then
+ write(STDOUT,'(" solver = CG")')
+ else
+ call fatalerror("Unknown solver type")
+ end if
+ write(STDOUT,'(" maxiter = ",I8)') maxiter
+ write(STDOUT,'(" resreduction = ",E15.6)') resreduction
+ write(STDOUT,'("---------------------------------------------- ")')
+ write(*,'("")')
+ end if
+ call mpi_bcast(solvertype,1,MPI_INTEGER,master_rank,MPI_COMM_WORLD,ierr)
+ call mpi_bcast(maxiter,1,MPI_INTEGER,master_rank,MPI_COMM_WORLD,ierr)
+ call mpi_bcast(resreduction,1,MPI_DOUBLE_PRECISION,master_rank,MPI_COMM_WORLD,ierr)
+ call mpi_bcast(LMean,1,MPI_LOGICAL,master_rank,MPI_COMM_WORLD,ierr)
+ call mpi_bcast(LUseO,1,MPI_LOGICAL,master_rank,MPI_COMM_WORLD,ierr)
+ call mpi_bcast(LUseT,1,MPI_LOGICAL,master_rank,MPI_COMM_WORLD,ierr)
+ solver_param_out%solvertype = solvertype
+ solver_param_out%maxiter = maxiter
+ solver_param_out%resreduction = resreduction
+end subroutine read_solver_parameters
+
+!==================================================================
+! Read grid parameters from namelist file
+!==================================================================
+subroutine read_grid_parameters_mnh(filename,grid_param,KN,KNZ,PL,PH)
+ use parameters
+ use datatypes
+ use communication
+ use messages
+#ifndef MNH
+ use mpi
+#else
+ use modd_mpif
+#endif
+ implicit none
+ character(*), intent(in) :: filename
+ type(grid_parameters), intent(out) :: grid_param
+
+ integer , optional , intent (in) :: KN,KNZ
+ real(kind=rl) , optional , intent (in) :: PL,PH
+
+ ! Grid parameters
+ integer :: n, nz
+ real(kind=rl) :: L, H
+ integer :: vertbc
+ logical :: graded
+ integer, parameter :: file_id = 106
+ integer :: ierr
+ namelist /parameters_grid/ n, nz, L, H, vertbc, graded
+ if (i_am_master_mpi) then
+ open(file_id,file=filename)
+ read(file_id,NML=parameters_grid)
+ close(file_id)
+
+ if (vertbc == VERTBC_DIRICHLET) then
+ write(STDOUT,'(" vertbc = DIRICHLET")')
+ else if (vertbc == VERTBC_NEUMANN) then
+ write(STDOUT,'(" vertbc = NEUMANN")')
+ else
+ vertbc = -1
+ end if
+ write(STDOUT,'(" graded =",L3)') graded
+ write(STDOUT,'("---------------------------------------------- ")')
+ write(STDOUT,'("")')
+ end if
+ call mpi_bcast(n,1,MPI_INTEGER,master_rank,MPI_COMM_WORLD,ierr)
+ call mpi_bcast(nz,1,MPI_INTEGER,master_rank,MPI_COMM_WORLD,ierr)
+ call mpi_bcast(L,1,MPI_DOUBLE_PRECISION,master_rank,MPI_COMM_WORLD,ierr)
+ call mpi_bcast(H,1,MPI_DOUBLE_PRECISION,master_rank,MPI_COMM_WORLD,ierr)
+ call mpi_bcast(vertbc,1,MPI_INTEGER,master_rank,MPI_COMM_WORLD,ierr)
+ call mpi_bcast(graded,1,MPI_LOGICAL,master_rank,MPI_COMM_WORLD,ierr)
+ IF (PRESENT(KN)) THEN
+ n = KN
+ nz = KNZ
+ L = PL
+ H = PH
+ END IF
+ if (i_am_master_mpi) then
+ write(STDOUT,NML=parameters_grid)
+ write(STDOUT,'("---------------------------------------------- ")')
+ write(STDOUT,'("Grid parameters")')
+ write(STDOUT,'(" n = ",I15)') n
+ write(STDOUT,'(" nz = ",I15)') nz
+ write(STDOUT,'(" L = ",E15.6)') L
+ write(STDOUT,'(" H = ",E15.6)') H
+ end if
+ grid_param%n = n
+ grid_param%nz = nz
+ grid_param%L = L
+ grid_param%H = H
+ grid_param%vertbc = vertbc
+ grid_param%graded = graded
+ if (vertbc == -1) then
+ call fatalerror("vertbc has to be either 1 (Dirichlet) or 2 (Neumann)")
+ end if
+end subroutine read_grid_parameters_mnh
+!==================================================================
+! Read grid parameters from namelist file
+!==================================================================
+subroutine read_grid_parameters(filename,grid_param)
+ use parameters
+ use datatypes
+ use communication
+ use messages
+#ifndef MNH
+ use mpi
+#else
+ use modd_mpif
+#endif
+
+ implicit none
+ character(*), intent(in) :: filename
+ type(grid_parameters), intent(out) :: grid_param
+ ! Grid parameters
+ integer :: n, nz
+ real(kind=rl) :: L, H
+ integer :: vertbc
+ logical :: graded
+ integer, parameter :: file_id = 16
+ integer :: ierr
+ namelist /parameters_grid/ n, nz, L, H, vertbc, graded
+ if (i_am_master_mpi) then
+ open(file_id,file=filename)
+ read(file_id,NML=parameters_grid)
+ close(file_id)
+ write(STDOUT,NML=parameters_grid)
+ write(STDOUT,'("---------------------------------------------- ")')
+ write(STDOUT,'("Grid parameters")')
+ write(STDOUT,'(" n = ",I15)') n
+ write(STDOUT,'(" nz = ",I15)') nz
+ write(STDOUT,'(" L = ",E15.6)') L
+ write(STDOUT,'(" H = ",E15.6)') H
+ if (vertbc == VERTBC_DIRICHLET) then
+ write(STDOUT,'(" vertbc = DIRICHLET")')
+ else if (vertbc == VERTBC_NEUMANN) then
+ write(STDOUT,'(" vertbc = NEUMANN")')
+ else
+ vertbc = -1
+ end if
+ write(STDOUT,'(" graded =",L3)') graded
+ write(STDOUT,'("---------------------------------------------- ")')
+ write(STDOUT,'("")')
+ end if
+ call mpi_bcast(n,1,MPI_INTEGER,master_rank,MPI_COMM_WORLD,ierr)
+ call mpi_bcast(nz,1,MPI_INTEGER,master_rank,MPI_COMM_WORLD,ierr)
+ call mpi_bcast(L,1,MPI_DOUBLE_PRECISION,master_rank,MPI_COMM_WORLD,ierr)
+ call mpi_bcast(H,1,MPI_DOUBLE_PRECISION,master_rank,MPI_COMM_WORLD,ierr)
+ call mpi_bcast(vertbc,1,MPI_INTEGER,master_rank,MPI_COMM_WORLD,ierr)
+ call mpi_bcast(graded,1,MPI_LOGICAL,master_rank,MPI_COMM_WORLD,ierr)
+ grid_param%n = n
+ grid_param%nz = nz
+ grid_param%L = L
+ grid_param%H = H
+ grid_param%vertbc = vertbc
+ grid_param%graded = graded
+ if (vertbc == -1) then
+ call fatalerror("vertbc has to be either 1 (Dirichlet) or 2 (Neumann)")
+ end if
+end subroutine read_grid_parameters
+!==================================================================
+! Read parallel communication parameters from namelist file
+!==================================================================
+subroutine read_comm_parameters(filename,comm_param)
+ use parameters
+ use communication
+ use messages
+#ifndef MNH
+ use mpi
+#else
+ use modd_mpif
+#endif
+ implicit none
+ character(*), intent(in) :: filename
+ type(comm_parameters), intent(out) :: comm_param
+ ! Grid parameters
+ integer :: halo_size
+ integer, parameter :: file_id = 16
+ integer :: ierr
+ namelist /parameters_communication/ halo_size
+ if (i_am_master_mpi) then
+ open(file_id,file=filename)
+ read(file_id,NML=parameters_communication)
+ close(file_id)
+ write(STDOUT,NML=parameters_communication)
+ write(STDOUT,'("---------------------------------------------- ")')
+ write(STDOUT,'("Communication parameters")')
+ write(STDOUT,'(" halosize = ",I3)') halo_size
+ write(STDOUT,'("---------------------------------------------- ")')
+ write(STDOUT,'("")')
+ if ( (halo_size .ne. 1) ) then
+ halo_size = -1
+ end if
+ end if
+ call mpi_bcast(halo_size,1,MPI_INTEGER,master_rank,MPI_COMM_WORLD,ierr)
+ comm_param%halo_size = halo_size
+ if (halo_size == -1) then
+ call fatalerror("Halo size has to be 1.")
+ end if
+end subroutine read_comm_parameters
+
+!==================================================================
+! Read model parameters from namelist file
+!==================================================================
+subroutine read_model_parameters(filename,model_param)
+ use parameters
+ use discretisation
+ use communication
+ use messages
+#ifndef MNH
+ use mpi
+#else
+ use modd_mpif
+#endif
+ implicit none
+ character(*), intent(in) :: filename
+ type(model_parameters), intent(out) :: model_param
+ real(kind=rl) :: omega2, lambda2, delta
+ integer, parameter :: file_id = 16
+ integer :: ierr
+ namelist /parameters_model/ omega2, lambda2, delta
+ if (i_am_master_mpi) then
+ open(file_id,file=filename)
+ read(file_id,NML=parameters_model)
+ close(file_id)
+ write(STDOUT,NML=parameters_model)
+ write(STDOUT,'("---------------------------------------------- ")')
+ write(STDOUT,'("Model parameters")')
+ write(STDOUT,'(" omega2 = ",E15.6)') omega2
+ write(STDOUT,'(" lambda2 = ",E15.6)') lambda2
+ write(STDOUT,'(" delta = ",E15.6)') delta
+ write(STDOUT,'("---------------------------------------------- ")')
+ write(STDOUT,'("")')
+ end if
+ call mpi_bcast(omega2,1,MPI_DOUBLE_PRECISION,master_rank,MPI_COMM_WORLD,ierr)
+ call mpi_bcast(lambda2,1,MPI_DOUBLE_PRECISION,master_rank,MPI_COMM_WORLD,ierr)
+ call mpi_bcast(delta,1,MPI_DOUBLE_PRECISION,master_rank,MPI_COMM_WORLD,ierr)
+ model_param%omega2 = omega2
+ model_param%lambda2 = lambda2
+ model_param%delta = delta
+end subroutine read_model_parameters
+
+!==================================================================
+! Read smoother parameters from namelist file
+!==================================================================
+subroutine read_smoother_parameters(filename,smoother_param)
+ use parameters
+ use discretisation
+ use communication
+ use messages
+#ifndef MNH
+ use mpi
+#else
+ use modd_mpif
+#endif
+ implicit none
+ character(*), intent(in) :: filename
+ type(smoother_parameters), intent(out) :: smoother_param
+ integer, parameter :: file_id = 16
+ integer :: smoother, ordering
+ real(kind=rl) :: rho
+ integer :: ierr
+ namelist /parameters_smoother/ smoother, &
+ ordering, &
+ rho
+ if (i_am_master_mpi) then
+ open(file_id,file=filename)
+ read(file_id,NML=parameters_smoother)
+ close(file_id)
+ write(STDOUT,NML=parameters_smoother)
+
+ write(STDOUT,'("---------------------------------------------- ")')
+ write(STDOUT,'("Smoother parameters")')
+ ! Smoother
+ if (smoother == SMOOTHER_LINE_SOR) then
+ write(STDOUT,'(" smoother = LINE_SOR")')
+ else if (smoother == SMOOTHER_LINE_SSOR) then
+ write(STDOUT,'(" smoother = LINE_SSOR")')
+ else if (smoother == SMOOTHER_LINE_JAC) then
+ write(STDOUT,'(" smoother = LINE_JACOBI")')
+ else
+ smoother = -1
+ end if
+
+ if (ordering == ORDERING_LEX) then
+ write(STDOUT,'(" ordering = LEX")')
+ else if (ordering == ORDERING_RB) then
+ write(STDOUT,'(" ordering = RB")')
+ else
+ ordering = -1
+ end if
+ write(STDOUT,'(" rho = ",E15.6)') rho
+ write(STDOUT,'("---------------------------------------------- ")')
+ write(STDOUT,'("")')
+ end if
+ call mpi_bcast(smoother,1,MPI_INTEGER,master_rank,MPI_COMM_WORLD,ierr)
+ call mpi_bcast(ordering,1,MPI_INTEGER,master_rank,MPI_COMM_WORLD,ierr)
+ call mpi_bcast(rho,1,MPI_DOUBLE_PRECISION,master_rank,MPI_COMM_WORLD,ierr)
+ smoother_param%smoother = smoother
+ smoother_param%ordering = ordering
+ smoother_param%rho = rho
+ if (smoother == -1) then
+ call fatalerror('Unknown smoother.')
+ end if
+ if (ordering == -1) then
+ call fatalerror('Unknown ordering.')
+ end if
+
+end subroutine read_smoother_parameters
+
+!==================================================================
+! Read multigrid parameters from namelist file
+!==================================================================
+subroutine read_multigrid_parameters(filename,mg_param)
+ use parameters
+ use multigrid
+ use communication
+ use messages
+#ifndef MNH
+ use mpi
+#else
+ use modd_mpif
+#endif
+
+ use MODE_OPENACC_SET_DEVICE, only : iswitch_cpu_gpu
+
+ implicit none
+ character(*), intent(in) :: filename
+ type(mg_parameters), intent(out) :: mg_param
+ integer, parameter :: file_id = 16
+ integer :: verbose, n_lev, lev_split, n_presmooth, n_postsmooth, &
+ prolongation, restriction, n_coarsegridsmooth, &
+ coarsegridsolver
+ integer :: ierr
+ namelist /parameters_multigrid/ verbose, &
+ n_lev, &
+ lev_split, &
+ iswitch_cpu_gpu, &
+ n_presmooth, &
+ n_postsmooth, &
+ n_coarsegridsmooth, &
+ prolongation, &
+ restriction, &
+ coarsegridsolver
+ if (i_am_master_mpi) then
+ open(file_id,file=filename)
+ read(file_id,NML=parameters_multigrid)
+ close(file_id)
+ write(STDOUT,NML=parameters_multigrid)
+ write(STDOUT,'("---------------------------------------------- ")')
+ write(STDOUT,'("Multigrid parameters")')
+ write(STDOUT,'(" verbose = ",L6)') verbose
+ write(STDOUT,'(" levels = ",I3)') n_lev
+ write(STDOUT,'(" splitlevel = ",I3)') lev_split
+ !
+ ! switch lev_split from the top level to have constant lev_split
+ ! when changing n_lev
+ !
+ lev_split = n_lev - lev_split
+ write(STDOUT,'(" splitlevel/sw= ",I3)') lev_split
+ write(STDOUT,'(" iswitch_cpu_gpu = ",I3)') iswitch_cpu_gpu
+ iswitch_cpu_gpu = n_lev - iswitch_cpu_gpu
+ write(STDOUT,'("switch_cpu_gpu/s = ",I3)') iswitch_cpu_gpu
+ !
+ write(STDOUT,'(" n_presmooth = ",I6)') n_presmooth
+ write(STDOUT,'(" n_postsmooth = ",I6)') n_postsmooth
+ if (restriction == REST_CELLAVERAGE) then
+ write(STDOUT,'(" restriction = CELLAVERAGE")')
+ else if (restriction == REST_KHALIL) then
+ write(STDOUT,'(" restriction = KHALIL ")')
+ else
+ restriction = -1
+ endif
+ if (prolongation == PROL_CONSTANT) then
+ write(STDOUT,'(" prolongation = CONSTANT")')
+ else if (prolongation == PROL_TRILINEAR) then
+#ifdef PIECEWISELINEAR
+ write(STDOUT,'(" prolongation = TRILINEAR (piecewise linear)")')
+#else
+ write(STDOUT,'(" prolongation = TRILINEAR (regression plane)")')
+#endif
+ else
+ prolongation = -1
+ endif
+ if (coarsegridsolver == COARSEGRIDSOLVER_CG) then
+ write(STDOUT,'(" coarse solver = CG")')
+ else if (coarsegridsolver == COARSEGRIDSOLVER_SMOOTHER) then
+ write(STDOUT,'(" coarse solver = SMOOTHER (",I6," iterations)")') &
+ n_coarsegridsmooth
+ else
+ coarsegridsolver = -1
+ end if
+ write(STDOUT,'("---------------------------------------------- ")')
+ write(*,'("")')
+
+ end if
+ call mpi_bcast(verbose,1,MPI_INTEGER,master_rank,MPI_COMM_WORLD,ierr)
+ call mpi_bcast(n_lev,1,MPI_INTEGER,master_rank,MPI_COMM_WORLD,ierr)
+ call mpi_bcast(lev_split,1,MPI_INTEGER,master_rank,MPI_COMM_WORLD,ierr)
+ call mpi_bcast(iswitch_cpu_gpu,1,MPI_INTEGER,master_rank,MPI_COMM_WORLD,ierr)
+ call mpi_bcast(n_presmooth,1,MPI_INTEGER,master_rank,MPI_COMM_WORLD,ierr)
+ call mpi_bcast(n_postsmooth,1,MPI_INTEGER,master_rank,MPI_COMM_WORLD,ierr)
+ call mpi_bcast(n_coarsegridsmooth,1,MPI_INTEGER,master_rank,MPI_COMM_WORLD, &
+ ierr)
+ call mpi_bcast(prolongation,1,MPI_INTEGER,master_rank,MPI_COMM_WORLD,ierr)
+ call mpi_bcast(restriction,1,MPI_INTEGER,master_rank,MPI_COMM_WORLD,ierr)
+ call mpi_bcast(coarsegridsolver,1,MPI_Integer,master_rank,MPI_COMM_WORLD,ierr)
+ mg_param%verbose = verbose
+ mg_param%n_lev = n_lev
+ mg_param%lev_split = lev_split
+ mg_param%n_presmooth = n_presmooth
+ mg_param%n_postsmooth = n_postsmooth
+ mg_param%n_coarsegridsmooth = n_coarsegridsmooth
+ mg_param%prolongation = prolongation
+ mg_param%restriction = restriction
+ mg_param%coarsegridsolver = coarsegridsolver
+ if (restriction == -1) then
+ call fatalerror('Unknown restriction.')
+ end if
+ if (prolongation == -1) then
+ call fatalerror('Unknown prolongation.')
+ end if
+ if (coarsegridsolver == -1) then
+ call fatalerror('Unknown coarse grid solver.')
+ end if
+end subroutine read_multigrid_parameters
+
+!==================================================================
+! Read conjugate gradient parameters from namelist file
+!==================================================================
+subroutine read_conjugategradient_parameters(filename,cg_param)
+ use parameters
+ use communication
+ use conjugategradient
+ use communication
+ use messages
+#ifndef MNH
+ use mpi
+#else
+ use modd_mpif
+#endif
+ implicit none
+ character(*), intent(in) :: filename
+ type(cg_parameters), intent(out) :: cg_param
+ integer, parameter :: file_id = 16
+ integer :: verbose, maxiter, n_prec
+ real(kind=rl) :: resreduction
+ integer :: ierr
+ namelist /parameters_conjugategradient/ verbose, &
+ maxiter, &
+ resreduction, &
+ n_prec
+ if (i_am_master_mpi) then
+ open(file_id,file=filename)
+ read(file_id,NML=parameters_conjugategradient)
+ close(file_id)
+ write(STDOUT,NML=parameters_conjugategradient)
+ write(STDOUT,'("---------------------------------------------- ")')
+ write(STDOUT,'("Conjugate gradient parameters")')
+ write(STDOUT,'(" verbose = ",I6)') verbose
+ write(STDOUT,'(" maxiter = ",I6)') maxiter
+ write(STDOUT,'(" resreduction = ",E15.6)') resreduction
+ write(STDOUT,'(" n_prec = ",I6)') n_prec
+ write(STDOUT,'("---------------------------------------------- ")')
+ write(STDOUT,'("")')
+ end if
+ call mpi_bcast(verbose,1,MPI_INTEGER,master_rank,MPI_COMM_WORLD,ierr)
+ call mpi_bcast(maxiter,1,MPI_INTEGER,master_rank,MPI_COMM_WORLD,ierr)
+ call mpi_bcast(resreduction,1,MPI_DOUBLE_PRECISION,master_rank,MPI_COMM_WORLD,ierr)
+ call mpi_bcast(n_prec,1,MPI_INTEGER,master_rank,MPI_COMM_WORLD,ierr)
+ cg_param%verbose = verbose
+ cg_param%maxiter = maxiter
+ cg_param%resreduction = resreduction
+ cg_param%n_prec = n_prec
+end subroutine read_conjugategradient_parameters
+
+end module mode_mg_read_param
diff --git a/src/ZSOLVER/tensorproductmultigrid_Source/mode_mnh_allocate_mg_halo.f90 b/src/ZSOLVER/tensorproductmultigrid_Source/mode_mnh_allocate_mg_halo.f90
new file mode 100644
index 0000000000000000000000000000000000000000..7b41eaf44c6bcb823cb65dc6600c619dd86b75b3
--- /dev/null
+++ b/src/ZSOLVER/tensorproductmultigrid_Source/mode_mnh_allocate_mg_halo.f90
@@ -0,0 +1,16 @@
+module mode_mnh_allocate_mg_halo
+contains
+ subroutine mnh_allocate_mg_halo(ptab,nx,ny,nz)
+ implicit none
+ integer , intent(in) :: nx,ny,nz
+ real, dimension(:,:,:) , pointer , contiguous :: ptab
+
+ real, dimension(:,:,:) , pointer , contiguous :: ztab
+
+ allocate (ztab(nx,ny,nz))
+ !$acc enter data create (ztab)
+
+ ptab => ztab
+
+ end subroutine mnh_allocate_mg_halo
+end module mode_mnh_allocate_mg_halo
diff --git a/src/ZSOLVER/tensorproductmultigrid_Source/mode_openacc_set_device.f90 b/src/ZSOLVER/tensorproductmultigrid_Source/mode_openacc_set_device.f90
new file mode 120000
index 0000000000000000000000000000000000000000..3c68748c1ae2179857dc555ec579b2d6a60ff446
--- /dev/null
+++ b/src/ZSOLVER/tensorproductmultigrid_Source/mode_openacc_set_device.f90
@@ -0,0 +1 @@
+../../MNH/mode_openacc_set_device.f90
\ No newline at end of file
diff --git a/src/ZSOLVER/tensorproductmultigrid_Source/multigrid.f90 b/src/ZSOLVER/tensorproductmultigrid_Source/multigrid.f90
new file mode 100644
index 0000000000000000000000000000000000000000..bb1a7d3f7ea79fe25eba3090a39a93cf9d9415b9
--- /dev/null
+++ b/src/ZSOLVER/tensorproductmultigrid_Source/multigrid.f90
@@ -0,0 +1,1924 @@
+!=== COPYRIGHT AND LICENSE STATEMENT ===
+!
+! This file is part of the TensorProductMultigrid code.
+!
+! (c) The copyright relating to this work is owned jointly by the
+! Crown, Met Office and NERC [2014]. However, it has been created
+! with the help of the GungHo Consortium, whose members are identified
+! at https://puma.nerc.ac.uk/trac/GungHo/wiki .
+!
+! Main Developer: Eike Mueller
+!
+! TensorProductMultigrid is free software: you can redistribute it and/or
+! modify it under the terms of the GNU Lesser General Public License as
+! published by the Free Software Foundation, either version 3 of the
+! License, or (at your option) any later version.
+!
+! TensorProductMultigrid is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU Lesser General Public License for more details.
+!
+! You should have received a copy of the GNU Lesser General Public License
+! along with TensorProductMultigrid (see files COPYING and COPYING.LESSER).
+! If not, see <http://www.gnu.org/licenses/>.
+!
+!=== COPYRIGHT AND LICENSE STATEMENT ===
+
+
+!==================================================================
+!
+! Geometric multigrid module for cell centred finite volume
+! discretisation.
+!
+! Eike Mueller, University of Bath, Feb 2012
+!
+!==================================================================
+module multigrid
+
+#ifndef MNH
+ use mpi
+#else
+ use modd_mpif
+#endif
+ use parameters
+ use datatypes
+ use discretisation
+ use messages
+ use solver
+ use conjugategradient
+ use communication
+ use timer
+
+ implicit none
+
+public::mg_parameters
+public::mg_initialise
+public::mg_finalise
+public::mg_solve_mnh
+public::mg_solve
+public::measurehaloswap
+public::REST_CELLAVERAGE
+public::REST_KHALIL
+public::PROL_CONSTANT
+public::PROL_TRILINEAR
+public::COARSEGRIDSOLVER_SMOOTHER
+public::COARSEGRIDSOLVER_CG
+
+private
+
+ ! --- multigrid parameter constants ---
+ ! restriction
+ integer, parameter :: REST_CELLAVERAGE = 1
+ integer, parameter :: REST_KHALIL = 2
+ ! prolongation method
+ integer, parameter :: PROL_CONSTANT = 1
+ integer, parameter :: PROL_TRILINEAR = 2
+ ! Coarse grid solver
+ integer, parameter :: COARSEGRIDSOLVER_SMOOTHER = 1
+ integer, parameter :: COARSEGRIDSOLVER_CG = 2
+
+ ! --- Multigrid parameters type ---
+ type mg_parameters
+ ! Verbosity level
+ integer :: verbose
+ ! Number of MG levels
+ integer :: n_lev
+ ! First level where data is pulled together
+ integer :: lev_split
+ ! Number of presmoothing steps
+ integer :: n_presmooth
+ ! Number of postsmoothing steps
+ integer :: n_postsmooth
+ ! Number of smoothing steps on coarsest level
+ integer :: n_coarsegridsmooth
+ ! Prolongation (see PROL_... for allowed values)
+ integer :: prolongation
+ ! Restriction (see RESTR_... for allowed values)
+ integer :: restriction
+ ! Smoother (see SMOOTHER_... for allowed values)
+ integer :: smoother
+ ! Relaxation factor
+ real(kind=rl) :: omega
+ ! Smoother on coarse grid
+ integer :: coarsegridsolver
+ ! ordering of grid points for smoother
+ integer :: ordering
+ end type mg_parameters
+
+! --- Parameters ---
+ type(mg_parameters) :: mg_param
+ type(model_parameters) :: model_param
+ type(smoother_parameters) :: smoother_param
+ type(grid_parameters) :: grid_param
+ type(comm_parameters) :: comm_param
+ type(cg_parameters) :: cg_param
+
+
+! --- Gridded and scalar data structures ---
+ ! Solution vector
+ type(scalar3d), allocatable :: xu_mg(:,:)
+ ! RHS vector
+ type(scalar3d), allocatable :: xb_mg(:,:)
+ ! residual
+ type(scalar3d), allocatable :: xr_mg(:,:)
+
+! --- Timer ---
+ type(time), allocatable, dimension(:,:) :: t_restrict
+ type(time), allocatable, dimension(:,:) :: t_prolongate
+ type(time), allocatable, dimension(:,:) :: t_residual
+ type(time), allocatable, dimension(:,:) :: t_addcorr
+ type(time), allocatable, dimension(:,:) :: t_smooth
+ type(time), allocatable, dimension(:,:) :: t_coarsesolve
+ type(time), allocatable, dimension(:,:) :: t_total
+
+contains
+
+!==================================================================
+! Initialise multigrid module, check and print out out parameters
+!==================================================================
+ subroutine mg_initialise(grid_param_in, & ! Grid parameters
+ comm_param_in, & ! Comm parameters
+ model_param_in, & ! Model parameters
+ smoother_param_in, & ! Smoother parameters
+ mg_param_in, & ! Multigrid parameters
+ cg_param_in & ! CG parameters
+ )
+ implicit none
+ type(grid_parameters), intent(in) :: grid_param_in
+ type(comm_parameters), intent(in) :: comm_param_in
+ type(model_parameters), intent(in) :: model_param_in
+ type(smoother_parameters), intent(in) :: smoother_param_in
+ type(mg_parameters), intent(in) :: mg_param_in
+ type(cg_parameters), intent(in) :: cg_param_in
+ real(kind=rl) :: L, H
+ integer :: n, nz, m, nlocal
+ logical :: reduced_m
+ integer :: level
+ integer :: rank, ierr
+ integer, dimension(2) :: p_horiz
+ integer, parameter :: dim_horiz = 2
+ logical :: grid_active
+ integer :: ix_min, ix_max, iy_min, iy_max
+ integer :: icompx_min, icompx_max, &
+ icompy_min, icompy_max
+ integer :: halo_size
+ integer :: vertbc
+ character(len=32) :: t_label
+
+ real , dimension(:,:,:) , pointer , contiguous :: zxu_mg_st,zxb_mg_st,zxr_mg_st
+
+ if (i_am_master_mpi) &
+ write(STDOUT,*) '*** Initialising multigrid ***'
+ ! Check that cell counts are valid
+ grid_param = grid_param_in
+ comm_param = comm_param_in
+ mg_param = mg_param_in
+ model_param = model_param_in
+ smoother_param = smoother_param_in
+ cg_param = cg_param_in
+ halo_size = comm_param%halo_size
+ vertbc = grid_param%vertbc
+
+ ! Check parameters
+ if (grid_param%n < 2**(mg_param%n_lev-1) ) then
+ call fatalerror('Number of cells in x-/y- direction has to be at least 2^{n_lev-1}.')
+ endif
+
+ if (mod(grid_param%n,2**(mg_param%n_lev-1)) .ne. 0 ) then
+ call fatalerror('Number of cells in x-/y- direction is not a multiple of 2^{n_lev-1}.')
+ end if
+ if (i_am_master_mpi) &
+ write(STDOUT,*) ''
+
+ ! Allocate memory for timers
+ allocate(t_smooth(mg_param%n_lev,0:pproc))
+ allocate(t_total(mg_param%n_lev,0:pproc))
+ allocate(t_restrict(mg_param%n_lev,0:pproc))
+ allocate(t_residual(mg_param%n_lev,0:pproc))
+ allocate(t_prolongate(mg_param%n_lev,0:pproc))
+ allocate(t_addcorr(mg_param%n_lev,0:pproc))
+ allocate(t_coarsesolve(mg_param%n_lev,0:pproc))
+
+ ! Allocate memory for all levels and initialise fields
+ allocate(xu_mg(mg_param%n_lev,0:pproc))
+ allocate(xb_mg(mg_param%n_lev,0:pproc))
+ allocate(xr_mg(mg_param%n_lev,0:pproc))
+ n = grid_param%n
+ nlocal = n/(2**pproc)
+ nz = grid_param%nz
+ L = grid_param%L
+ H = grid_param%H
+ level = mg_param%n_lev
+ m = pproc
+ reduced_m = .false.
+ ! Work out local processor coordinates (this is necessary to identify
+ ! global coordinates)
+ call mpi_comm_rank(MPI_COMM_HORIZ,rank,ierr)
+ call mpi_cart_coords(MPI_COMM_HORIZ,rank,dim_horiz,p_horiz,ierr)
+ if (i_am_master_mpi) then
+ write(STDOUT, &
+ '(" Global gridsize (x,y,z) (pproc = ",I4," ) : ",I8," x ",I8," x ",I8)') &
+ pproc, n, n, nz
+ end if
+ do while (level > 0)
+ if (i_am_master_mpi) &
+ write(STDOUT, &
+ '(" Local gridsize (x,y,z) on level ",I3," m = ",I4," : ",I8," x ",I8," x ",I8)') &
+ level, m, nlocal, nlocal, nz
+ if (nlocal < 1) then
+ call fatalerror('Number of grid points < 1')
+ end if
+
+ ! Set sizes of computational grid (take care at boundaries)
+ if (p_horiz(1) == 0) then
+ icompy_min = 1
+ else
+ icompy_min = 1 - (halo_size - 1)
+ end if
+
+ if (p_horiz(2) == 0) then
+ icompx_min = 1
+ else
+ icompx_min = 1 - (halo_size - 1)
+ end if
+
+ if (p_horiz(1) == 2**pproc-1) then
+ icompy_max = nlocal
+ else
+ icompy_max = nlocal + (halo_size - 1)
+ end if
+
+ if (p_horiz(2) == 2**pproc-1) then
+ icompx_max = nlocal
+ else
+ icompx_max = nlocal + (halo_size - 1)
+ end if
+
+ ! Allocate data
+ if (LUseO) then
+ allocate(xu_mg(level,m)%s(0:nz+1, &
+ 1-halo_size:nlocal+halo_size, &
+ 1-halo_size:nlocal+halo_size))
+ allocate(xb_mg(level,m)%s(0:nz+1, &
+ 1-halo_size:nlocal+halo_size, &
+ 1-halo_size:nlocal+halo_size))
+ allocate(xr_mg(level,m)%s(0:nz+1, &
+ 1-halo_size:nlocal+halo_size, &
+ 1-halo_size:nlocal+halo_size))
+ xu_mg(level,m)%s(:,:,:) = 0.0_rl
+ xb_mg(level,m)%s(:,:,:) = 0.0_rl
+ xr_mg(level,m)%s(:,:,:) = 0.0_rl
+ endif
+
+ if (LUseT) then
+ allocate(zxu_mg_st(1-halo_size:nlocal+halo_size, &
+ 1-halo_size:nlocal+halo_size, &
+ 0:nz+1))
+ xu_mg(level,m)%st => zxu_mg_st
+
+ allocate(zxb_mg_st(1-halo_size:nlocal+halo_size, &
+ 1-halo_size:nlocal+halo_size, &
+ 0:nz+1))
+ xb_mg(level,m)%st => zxb_mg_st
+
+ allocate(zxr_mg_st(1-halo_size:nlocal+halo_size, &
+ 1-halo_size:nlocal+halo_size, &
+ 0:nz+1))
+ xr_mg(level,m)%st => zxr_mg_st
+
+
+ !$acc kernels
+ zxu_mg_st(:,:,:) = 0.0_rl
+ zxb_mg_st(:,:,:) = 0.0_rl
+ zxr_mg_st(:,:,:) = 0.0_rl
+ !$acc end kernels
+ endif
+
+ ! NB: 1st coordinate is in the y-direction of the processor grid,
+ ! second coordinate is in the x-direction (see comments in
+ ! communication module)
+ iy_min = (p_horiz(1)/2**(pproc-m))*nlocal+1
+ iy_max = (p_horiz(1)/2**(pproc-m)+1)*nlocal
+ ix_min = p_horiz(2)/2**(pproc-m)*nlocal+1
+ ix_max = (p_horiz(2)/2**(pproc-m)+1)*nlocal
+ ! Set grid parameters and local data ranges
+ ! Note that only n (and possibly nz) change as we
+ ! move down the levels
+ xu_mg(level,m)%grid_param%L = L
+ xu_mg(level,m)%grid_param%H = H
+ xu_mg(level,m)%grid_param%n = n
+ xu_mg(level,m)%grid_param%nz = nz
+ xu_mg(level,m)%grid_param%vertbc = vertbc
+ xu_mg(level,m)%ix_min = ix_min
+ xu_mg(level,m)%ix_max = ix_max
+ xu_mg(level,m)%iy_min = iy_min
+ xu_mg(level,m)%iy_max = iy_max
+ xu_mg(level,m)%icompx_min = icompx_min
+ xu_mg(level,m)%icompx_max = icompx_max
+ xu_mg(level,m)%icompy_min = icompy_min
+ xu_mg(level,m)%icompy_max = icompy_max
+ xu_mg(level,m)%halo_size = halo_size
+
+ xb_mg(level,m)%grid_param%L = L
+ xb_mg(level,m)%grid_param%H = H
+ xb_mg(level,m)%grid_param%n = n
+ xb_mg(level,m)%grid_param%nz = nz
+ xb_mg(level,m)%grid_param%vertbc = vertbc
+ xb_mg(level,m)%ix_min = ix_min
+ xb_mg(level,m)%ix_max = ix_max
+ xb_mg(level,m)%iy_min = iy_min
+ xb_mg(level,m)%iy_max = iy_max
+ xb_mg(level,m)%icompx_min = icompx_min
+ xb_mg(level,m)%icompx_max = icompx_max
+ xb_mg(level,m)%icompy_min = icompy_min
+ xb_mg(level,m)%icompy_max = icompy_max
+ xb_mg(level,m)%halo_size = halo_size
+
+ xr_mg(level,m)%grid_param%L = L
+ xr_mg(level,m)%grid_param%H = H
+ xr_mg(level,m)%grid_param%n = n
+ xr_mg(level,m)%grid_param%nz = nz
+ xr_mg(level,m)%grid_param%vertbc = vertbc
+ xr_mg(level,m)%ix_min = ix_min
+ xr_mg(level,m)%ix_max = ix_max
+ xr_mg(level,m)%iy_min = iy_min
+ xr_mg(level,m)%iy_max = iy_max
+ xr_mg(level,m)%icompx_min = icompx_min
+ xr_mg(level,m)%icompx_max = icompx_max
+ xr_mg(level,m)%icompy_min = icompy_min
+ xr_mg(level,m)%icompy_max = icompy_max
+ xr_mg(level,m)%halo_size = halo_size
+
+ ! Are these grids active?
+ if ( (m == pproc) .or. &
+ ( (mod(p_horiz(1),2**(pproc-m)) == 0) .and. &
+ (mod(p_horiz(2),2**(pproc-m)) == 0) ) ) then
+ grid_active = .true.
+ else
+ grid_active = .false.
+ end if
+ xu_mg(level,m)%isactive = grid_active
+ xb_mg(level,m)%isactive = grid_active
+ xr_mg(level,m)%isactive = grid_active
+ write(t_label,'("t_total(",I3,",",I3,")")') level, m
+ call initialise_timer(t_total(level,m),t_label)
+ write(t_label,'("t_smooth(",I3,",",I3,")")') level, m
+ call initialise_timer(t_smooth(level,m),t_label)
+ write(t_label,'("t_restrict(",I3,",",I3,")")') level, m
+ call initialise_timer(t_restrict(level,m),t_label)
+ write(t_label,'("t_residual(",I3,",",I3,")")') level, m
+ call initialise_timer(t_residual(level,m),t_label)
+ write(t_label,'("t_prolongate(",I3,",",I3,")")') level, m
+ call initialise_timer(t_prolongate(level,m),t_label)
+ write(t_label,'("t_addcorrection(",I3,",",I3,")")') level, m
+ call initialise_timer(t_addcorr(level,m),t_label)
+ write(t_label,'("t_coarsegridsolver(",I3,",",I3,")")') level, m
+ call initialise_timer(t_coarsesolve(level,m),t_label)
+
+ ! If we are below L_split, split data
+ if ( (level .le. mg_param%lev_split) .and. &
+ (m > 0) .and. (.not. reduced_m) ) then
+ reduced_m = .true.
+ m = m-1
+ nlocal = 2*nlocal
+ cycle
+ end if
+ reduced_m = .false.
+ level = level-1
+ n = n/2
+ nlocal = nlocal/2
+ end do
+ if (i_am_master_mpi) &
+ write(STDOUT,*) ''
+ call cg_initialise(cg_param)
+ end subroutine mg_initialise
+
+!==================================================================
+! Finalise, free memory for all data structures
+!==================================================================
+ subroutine mg_finalise()
+ implicit none
+ integer :: level, m
+ logical :: reduced_m
+ character(len=80) :: s
+ integer :: ierr
+
+ if (i_am_master_mpi) &
+ write(STDOUT,*) '*** Finalising multigrid ***'
+ ! Deallocate memory
+ level = mg_param%n_lev
+ m = pproc
+ reduced_m = .false.
+ call print_timerinfo("--- V-cycle timing results ---")
+ do while (level > 0)
+ write(s,'("level = ",I3,", m = ",I3)') level,m
+ call print_timerinfo(s)
+ call print_elapsed(t_smooth(level,m),.True.,1.0_rl)
+ call print_elapsed(t_restrict(level,m),.True.,1.0_rl)
+ call print_elapsed(t_prolongate(level,m),.True.,1.0_rl)
+ call print_elapsed(t_residual(level,m),.True.,1.0_rl)
+ call print_elapsed(t_addcorr(level,m),.True.,1.0_rl)
+ call print_elapsed(t_coarsesolve(level,m),.True.,1.0_rl)
+ call print_elapsed(t_total(level,m),.True.,1.0_rl)
+
+ if (LUseO) then
+ deallocate(xu_mg(level,m)%s)
+ deallocate(xb_mg(level,m)%s)
+ deallocate(xr_mg(level,m)%s)
+ endif
+
+ if (LUseT) then
+ deallocate(xu_mg(level,m)%st)
+ deallocate(xb_mg(level,m)%st)
+ deallocate(xr_mg(level,m)%st)
+ endif
+
+ ! If we are below L_split, split data
+ if ( (level .le. mg_param%lev_split) .and. &
+ (m > 0) .and. (.not. reduced_m) ) then
+ reduced_m = .true.
+ m = m-1
+ cycle
+ end if
+ reduced_m = .false.
+ level = level-1
+ end do
+ deallocate(xu_mg)
+ deallocate(xb_mg)
+ deallocate(xr_mg)
+ deallocate(t_total)
+ deallocate(t_smooth)
+ deallocate(t_restrict)
+ deallocate(t_prolongate)
+ deallocate(t_residual)
+ deallocate(t_addcorr)
+ deallocate(t_coarsesolve)
+ if (i_am_master_mpi) write(STDOUT,'("")')
+ end subroutine mg_finalise
+
+!==================================================================
+! Restrict from fine -> coarse
+!==================================================================
+ subroutine restrict_mnh(phifine,phicoarse)
+ implicit none
+ type(scalar3d), intent(in) :: phifine
+ type(scalar3d), intent(inout) :: phicoarse
+ ! local var
+ integer :: ix,iy,iz
+ integer :: ix_min, ix_max, iy_min, iy_max, n
+ real(kind=rl) :: xn,xs,xw,xe
+
+ real , dimension(:,:,:) , pointer , contiguous :: zphifine_st , zphicoarse_st
+
+ n = phicoarse%grid_param%n
+ ix_min = phicoarse%icompx_min
+ ix_max = phicoarse%icompx_max
+ iy_min = phicoarse%icompy_min
+ iy_max = phicoarse%icompy_max
+ ! three dimensional cell average
+ if (mg_param%restriction == REST_CELLAVERAGE) then
+ ! Do not coarsen in z-direction
+ if (LUseO) then
+ do ix=ix_min,ix_max
+ do iy=iy_min,iy_max
+ do iz=1,phicoarse%grid_param%nz
+ phicoarse%s(iz,iy,ix) = &
+ phifine%s(iz ,2*iy ,2*ix ) + &
+ phifine%s(iz ,2*iy-1,2*ix ) + &
+ phifine%s(iz ,2*iy ,2*ix-1) + &
+ phifine%s(iz ,2*iy-1,2*ix-1)
+ end do
+ end do
+ end do
+ endif
+ if (LUseT) then
+ zphifine_st => phifine%st
+ zphicoarse_st => phicoarse%st
+ !$acc kernels loop independent collapse(3)
+ do iz=1,phicoarse%grid_param%nz
+ do iy=iy_min,iy_max
+ do ix=ix_min,ix_max
+ zphicoarse_st(ix,iy,iz) = &
+ zphifine_st(2*ix ,2*iy ,iz) + &
+ zphifine_st(2*ix ,2*iy-1,iz) + &
+ zphifine_st(2*ix-1,2*iy ,iz) + &
+ zphifine_st(2*ix-1,2*iy-1,iz)
+ end do
+ end do
+ end do
+ !$acc end kernels
+ endif
+
+ elseif(mg_param%restriction == REST_KHALIL) then
+ if (LUseO) then
+ do ix=ix_min,ix_max
+ xw=1.0
+ xe=1.0
+ if (ix==1) xw=0.0
+ if (ix==n) xe=0.0
+ do iy=iy_min,iy_max
+ xs=1.0
+ xn=1.0
+ if (iy==1) xs=0.0
+ if (iy==n) xn=0.0
+ do iz=1,phicoarse%grid_param%nz
+ phicoarse%s(iz,iy,ix) = 0.25_rl * ( &
+ phifine%s(iz,2*iy+1,2*ix-1) * xn + &
+ phifine%s(iz,2*iy+1,2*ix ) * xn + &
+ phifine%s(iz,2*iy ,2*ix-2) * xw + &
+ phifine%s(iz,2*iy ,2*ix-1) * (4-xw-xn) + &
+ phifine%s(iz,2*iy ,2*ix ) * (4-xe-xn) + &
+ phifine%s(iz,2*iy ,2*ix+1) * xe + &
+ phifine%s(iz,2*iy-1,2*ix-2) * xw + &
+ phifine%s(iz,2*iy-1,2*ix-1) * (4-xw-xs) + &
+ phifine%s(iz,2*iy-1,2*ix ) * (4-xe-xs) + &
+ phifine%s(iz,2*iy-2,2*ix-1) * xs + &
+ phifine%s(iz,2*iy-2,2*ix ) * xs &
+ & )
+ end do
+ end do
+ end do
+ end if
+ if (LUseT) then
+ do iz=1,phicoarse%grid_param%nz
+ do iy=iy_min,iy_max
+ xs=1.0
+ xn=1.0
+ if (iy==1) xs=0.0
+ if (iy==n) xn=0.0
+ do ix=ix_min,ix_max
+ xw=1.0
+ xe=1.0
+ if (ix==1) xw=0.0
+ if (ix==n) xe=0.0
+ phicoarse%st(ix,iy,iz) = 0.25_rl * ( &
+ phifine%s(2*ix-1,2*iy+1,iz) * xn + &
+ phifine%s(2*ix ,2*iy+1,iz) * xn + &
+ phifine%s(2*ix-2,2*iy ,iz) * xw + &
+ phifine%s(2*ix-1,2*iy ,iz) * (4-xw-xn) + &
+ phifine%s(2*ix ,2*iy ,iz) * (4-xe-xn) + &
+ phifine%s(2*ix+1,2*iy ,iz) * xe + &
+ phifine%s(2*ix-2,2*iy-1,iz) * xw + &
+ phifine%s(2*ix-1,2*iy-1,iz) * (4-xw-xs) + &
+ phifine%s(2*ix ,2*iy-1,iz) * (4-xe-xs) + &
+ phifine%s(2*ix-1,2*iy-2,iz) * xs + &
+ phifine%s(2*ix ,2*iy-2,iz) * xs &
+ & )
+ end do
+ end do
+ end do
+ end if
+
+ end if
+ end subroutine restrict_mnh
+!==================================================================
+! Restrict from fine -> coarse
+!==================================================================
+ subroutine restrict(phifine,phicoarse)
+ implicit none
+ type(scalar3d), intent(in) :: phifine
+ type(scalar3d), intent(inout) :: phicoarse
+ integer :: ix,iy,iz
+ integer :: ix_min, ix_max, iy_min, iy_max
+
+ ix_min = phicoarse%icompx_min
+ ix_max = phicoarse%icompx_max
+ iy_min = phicoarse%icompy_min
+ iy_max = phicoarse%icompy_max
+ ! three dimensional cell average
+ if (mg_param%restriction == REST_CELLAVERAGE) then
+ ! Do not coarsen in z-direction
+ if (LUseO) then
+ do ix=ix_min,ix_max
+ do iy=iy_min,iy_max
+ do iz=1,phicoarse%grid_param%nz
+ phicoarse%s(iz,iy,ix) = &
+ phifine%s(iz ,2*iy ,2*ix ) + &
+ phifine%s(iz ,2*iy-1,2*ix ) + &
+ phifine%s(iz ,2*iy ,2*ix-1) + &
+ phifine%s(iz ,2*iy-1,2*ix-1)
+ end do
+ end do
+ end do
+ end if
+ if (LUseT) then
+ do iz=1,phicoarse%grid_param%nz
+ do iy=iy_min,iy_max
+ do ix=ix_min,ix_max
+ phicoarse%st(ix,iy,iz) = &
+ phifine%st(2*ix ,2*iy ,iz) + &
+ phifine%st(2*ix ,2*iy-1,iz) + &
+ phifine%st(2*ix-1,2*iy ,iz) + &
+ phifine%st(2*ix-1,2*iy-1,iz)
+ end do
+ end do
+ end do
+ endif
+ end if
+ end subroutine restrict
+!==================================================================
+! Prolongate from coarse -> fine
+! level, m is the correspong to the fine grid level
+!==================================================================
+ subroutine prolongate_mnh(level,m,phicoarse,phifine)
+ implicit none
+ integer, intent(in) :: level
+ integer, intent(in) :: m
+ type(scalar3d), intent(in) :: phicoarse
+ type(scalar3d), intent(inout) :: phifine
+ real(kind=rl) :: tmp
+ integer :: nlocal
+ integer, dimension(5) :: ixmin, ixmax, iymin, iymax
+ integer :: n, nz
+ integer :: ix, iy, iz
+ integer :: dix, diy, diz
+ real(kind=rl) :: rhox, rhoy, rhoz
+ real(kind=rl) :: rho_i, sigma_j, h, c1, c2
+ logical :: overlap_comms
+ integer, dimension(4) :: send_requests, recv_requests
+ integer, dimension(4) :: send_requestsT, recv_requestsT
+ integer :: ierr
+ integer :: iblock
+
+ ! Needed for interpolation matrix
+#ifdef PIECEWISELINEAR
+#else
+ real(kind=rl) :: dx(4,3), A(3,3), dx_fine(4,2)
+ integer :: i,j,k
+ real(kind=rl) :: dxu(2), grad(2)
+ dx(1,3) = 1.0_rl
+ dx(2,3) = 1.0_rl
+ dx(3,3) = 1.0_rl
+ dx(4,3) = 1.0_rl
+#endif
+
+ nlocal = phicoarse%ix_max-phicoarse%ix_min+1
+ n = phicoarse%grid_param%n
+ nz = phicoarse%grid_param%nz
+
+#ifdef OVERLAPCOMMS
+ overlap_comms = (nlocal > 2)
+#else
+ overlap_comms = .false.
+#endif
+ ! Block 1 (N)
+ ixmin(1) = 1
+ ixmax(1) = nlocal
+ iymin(1) = 1
+ iymax(1) = 1
+ ! Block 2 (S)
+ ixmin(2) = 1
+ ixmax(2) = nlocal
+ iymin(2) = nlocal
+ iymax(2) = nlocal
+ ! Block 3 (W)
+ ixmin(3) = 1
+ ixmax(3) = 1
+ iymin(3) = 2
+ iymax(3) = nlocal-1
+ ! Block 4 (E)
+ ixmin(4) = nlocal
+ ixmax(4) = nlocal
+ iymin(4) = 2
+ iymax(4) = nlocal-1
+ ! Block 5 (INTERIOR)
+ if (overlap_comms) then
+ ixmin(5) = 2
+ ixmax(5) = nlocal-1
+ iymin(5) = 2
+ iymax(5) = nlocal-1
+ else
+ ! If there are no interior cells, do not overlap
+ ! communications and calculations, just loop over interior cells
+ ixmin(5) = 1
+ ixmax(5) = nlocal
+ iymin(5) = 1
+ iymax(5) = nlocal
+ end if
+
+ ! *** Constant prolongation or (tri-) linear prolongation ***
+ if ( (mg_param%prolongation == PROL_CONSTANT) .or. &
+ (mg_param%prolongation == PROL_TRILINEAR) ) then
+ if (overlap_comms) then
+ ! Loop over cells next to boundary (iblock = 1,...,4)
+ do iblock = 1, 4
+ if (mg_param%prolongation == PROL_CONSTANT) then
+ call loop_over_grid_constant_mnh(iblock)
+ end if
+ if (mg_param%prolongation == PROL_TRILINEAR) then
+ call loop_over_grid_linear_mnh(iblock)
+ end if
+ end do
+ ! Initiate halo exchange
+ call ihaloswap_mnh(level,m,phifine,send_requests,recv_requests,send_requestsT,recv_requestsT)
+ end if
+ ! Loop over INTERIOR cells
+ iblock = 5
+ if (mg_param%prolongation == PROL_CONSTANT) then
+ call loop_over_grid_constant_mnh(iblock)
+ end if
+ if (mg_param%prolongation == PROL_TRILINEAR) then
+ call loop_over_grid_linear_mnh(iblock)
+ end if
+ if (overlap_comms) then
+ if (m > 0) then
+ if (LUseO) call mpi_waitall(4,recv_requests, MPI_STATUSES_IGNORE, ierr)
+ if (LUseO) call mpi_waitall(4,send_requests, MPI_STATUSES_IGNORE, ierr)
+ if (LUseT) call mpi_waitall(4,recv_requestsT, MPI_STATUSES_IGNORE, ierr)
+ if (LUseT) call mpi_waitall(4,send_requestsT, MPI_STATUSES_IGNORE, ierr)
+ end if
+ else
+ call haloswap_mnh(level,m,phifine)
+ end if
+ else
+ call fatalerror("Unsupported prolongation.")
+ end if
+
+ contains
+
+ !------------------------------------------------------------------
+ ! The actual loops over the grid for the individual blocks,
+ ! when overlapping calculation and communication
+ !------------------------------------------------------------------
+
+ !------------------------------------------------------------------
+ ! (1) Constant interpolation
+ !------------------------------------------------------------------
+ subroutine loop_over_grid_constant_mnh(iblock)
+ implicit none
+ integer, intent(in) :: iblock
+ integer :: ix,iy,iz
+
+ if (LUseO) then
+ do ix=ixmin(iblock),ixmax(iblock)
+ do iy=iymin(iblock),iymax(iblock)
+ do dix = -1,0
+ do diy = -1,0
+ do iz=1,phicoarse%grid_param%nz
+ phifine%s(iz,2*iy+diy,2*ix+dix) = phicoarse%s(iz,iy,ix)
+ end do
+ end do
+ end do
+ end do
+ end do
+ end if
+ if (LUseT) then
+ do ix=ixmin(iblock),ixmax(iblock)
+ do iy=iymin(iblock),iymax(iblock)
+ do dix = -1,0
+ do diy = -1,0
+ do iz=1,phicoarse%grid_param%nz
+ phifine%st(2*ix+dix,2*iy+diy,iz) = phicoarse%st(ix,iy,iz)
+ end do
+ end do
+ end do
+ end do
+ end do
+ end if
+
+ end subroutine loop_over_grid_constant_mnh
+
+ !------------------------------------------------------------------
+ ! (2) Linear interpolation
+ !------------------------------------------------------------------
+ subroutine loop_over_grid_linear_mnh(iblock)
+ implicit none
+ integer, intent(in) :: iblock
+ !local var
+ integer :: ix,iy,iz
+
+ real , dimension(:,:,:) , pointer , contiguous :: zphifine_st , zphicoarse_st
+
+ ! optimisation for newman MNH case : all coef constant
+ rhox = 0.25_rl
+ rhoy = 0.25_rl
+
+ if (LUseO) then
+ do ix=ixmin(iblock),ixmax(iblock)
+ do iy=iymin(iblock),iymax(iblock)
+ ! Piecewise linear interpolation
+ do iz=1,phicoarse%grid_param%nz
+ do dix = -1,0
+ do diy = -1,0
+ phifine%s(iz,2*iy+diy,2*ix+dix) = &
+ phicoarse%s(iz,iy,ix) + &
+ rhox*(phicoarse%s(iz,iy,ix+(2*dix+1)) &
+ - phicoarse%s(iz,iy,ix)) + &
+ rhoy*(phicoarse%s(iz,iy+(2*diy+1),ix) &
+ - phicoarse%s(iz,iy,ix))
+ end do
+ end do
+ end do
+ end do
+ end do
+ end if
+ if (LUseT) then
+ ! Piecewise linear interpolation
+
+ zphifine_st => phifine%st
+ zphicoarse_st => phicoarse%st
+
+ !$acc kernels loop independent collapse(5)
+ do iz=1,phicoarse%grid_param%nz
+ do diy = -1,0
+ do dix = -1,0
+ do iy=iymin(iblock),iymax(iblock)
+ do ix=ixmin(iblock),ixmax(iblock)
+ zphifine_st(2*ix+dix,2*iy+diy,iz) = &
+ zphicoarse_st(ix,iy,iz) + &
+ rhox*(zphicoarse_st(ix+(2*dix+1),iy,iz) &
+ - zphicoarse_st(ix,iy,iz)) + &
+ rhoy*(zphicoarse_st(ix,iy+(2*diy+1),iz) &
+ - zphicoarse_st(ix,iy,iz))
+ end do
+ end do
+ end do
+ end do
+ end do
+ !$acc end kernels
+ end if
+
+ end subroutine loop_over_grid_linear_mnh
+
+ end subroutine prolongate_mnh
+!==================================================================
+! Prolongate from coarse -> fine
+! level, m is the correspong to the fine grid level
+!==================================================================
+ subroutine prolongate(level,m,phicoarse,phifine)
+ implicit none
+ integer, intent(in) :: level
+ integer, intent(in) :: m
+ type(scalar3d), intent(in) :: phicoarse
+ type(scalar3d), intent(inout) :: phifine
+ real(kind=rl) :: tmp
+ integer :: nlocal
+ integer, dimension(5) :: ixmin, ixmax, iymin, iymax
+ integer :: n, nz
+ integer :: ix, iy, iz
+ integer :: dix, diy, diz
+ real(kind=rl) :: rhox, rhoy, rhoz
+ real(kind=rl) :: rho_i, sigma_j, h, c1, c2
+ logical :: overlap_comms
+ integer, dimension(4) :: send_requests, recv_requests
+ integer :: ierr
+ integer :: iblock
+
+ ! Needed for interpolation matrix
+#ifdef PIECEWISELINEAR
+#else
+ real(kind=rl) :: dx(4,3), A(3,3), dx_fine(4,2)
+ integer :: i,j,k
+ real(kind=rl) :: dxu(2), grad(2)
+ dx(1,3) = 1.0_rl
+ dx(2,3) = 1.0_rl
+ dx(3,3) = 1.0_rl
+ dx(4,3) = 1.0_rl
+#endif
+
+ nlocal = phicoarse%ix_max-phicoarse%ix_min+1
+ n = phicoarse%grid_param%n
+ nz = phicoarse%grid_param%nz
+
+#ifdef OVERLAPCOMMS
+ overlap_comms = (nlocal > 2)
+#else
+ overlap_comms = .false.
+#endif
+ ! Block 1 (N)
+ ixmin(1) = 1
+ ixmax(1) = nlocal
+ iymin(1) = 1
+ iymax(1) = 1
+ ! Block 2 (S)
+ ixmin(2) = 1
+ ixmax(2) = nlocal
+ iymin(2) = nlocal
+ iymax(2) = nlocal
+ ! Block 3 (W)
+ ixmin(3) = 1
+ ixmax(3) = 1
+ iymin(3) = 2
+ iymax(3) = nlocal-1
+ ! Block 4 (E)
+ ixmin(4) = nlocal
+ ixmax(4) = nlocal
+ iymin(4) = 2
+ iymax(4) = nlocal-1
+ ! Block 5 (INTERIOR)
+ if (overlap_comms) then
+ ixmin(5) = 2
+ ixmax(5) = nlocal-1
+ iymin(5) = 2
+ iymax(5) = nlocal-1
+ else
+ ! If there are no interior cells, do not overlap
+ ! communications and calculations, just loop over interior cells
+ ixmin(5) = 1
+ ixmax(5) = nlocal
+ iymin(5) = 1
+ iymax(5) = nlocal
+ end if
+
+ ! *** Constant prolongation or (tri-) linear prolongation ***
+ if ( (mg_param%prolongation == PROL_CONSTANT) .or. &
+ (mg_param%prolongation == PROL_TRILINEAR) ) then
+ if (overlap_comms) then
+ ! Loop over cells next to boundary (iblock = 1,...,4)
+ do iblock = 1, 4
+ if (mg_param%prolongation == PROL_CONSTANT) then
+ call loop_over_grid_constant(iblock)
+ end if
+ if (mg_param%prolongation == PROL_TRILINEAR) then
+ call loop_over_grid_linear(iblock)
+ end if
+ end do
+ ! Initiate halo exchange
+ call ihaloswap(level,m,phifine,send_requests,recv_requests)
+ end if
+ ! Loop over INTERIOR cells
+ iblock = 5
+ if (mg_param%prolongation == PROL_CONSTANT) then
+ call loop_over_grid_constant(iblock)
+ end if
+ if (mg_param%prolongation == PROL_TRILINEAR) then
+ call loop_over_grid_linear(iblock)
+ end if
+ if (overlap_comms) then
+ if (m > 0) then
+ call mpi_waitall(4,recv_requests, MPI_STATUSES_IGNORE, ierr)
+ end if
+ else
+ call haloswap(level,m,phifine)
+ end if
+ else
+ call fatalerror("Unsupported prolongation.")
+ end if
+
+ contains
+
+ !------------------------------------------------------------------
+ ! The actual loops over the grid for the individual blocks,
+ ! when overlapping calculation and communication
+ !------------------------------------------------------------------
+
+ !------------------------------------------------------------------
+ ! (1) Constant interpolation
+ !------------------------------------------------------------------
+ subroutine loop_over_grid_constant(iblock)
+ implicit none
+ integer, intent(in) :: iblock
+ integer :: ix,iy,iz
+ do ix=ixmin(iblock),ixmax(iblock)
+ do iy=iymin(iblock),iymax(iblock)
+ do dix = -1,0
+ do diy = -1,0
+ do iz=1,phicoarse%grid_param%nz
+ phifine%s(iz,2*iy+diy,2*ix+dix) = phicoarse%s(iz,iy,ix)
+ end do
+ end do
+ end do
+ end do
+ end do
+ end subroutine loop_over_grid_constant
+
+ !------------------------------------------------------------------
+ ! (2) Linear interpolation
+ !------------------------------------------------------------------
+ subroutine loop_over_grid_linear(iblock)
+ implicit none
+ integer, intent(in) :: iblock
+ integer :: ix,iy,iz
+ do ix=ixmin(iblock),ixmax(iblock)
+ do iy=iymin(iblock),iymax(iblock)
+#ifdef PIECEWISELINEAR
+ ! Piecewise linear interpolation
+ do iz=1,phicoarse%grid_param%nz
+ do dix = -1,0
+ do diy = -1,0
+ if ( (ix+(2*dix+1)+phicoarse%ix_min-1 < 1 ) .or. &
+ (ix+(2*dix+1)+phicoarse%ix_min-1 > n ) ) then
+ rhox = 0.5_rl
+ else
+ rhox = 0.25_rl
+ end if
+ if ( (iy+(2*diy+1)+phicoarse%iy_min-1 < 1 ) .or. &
+ (iy+(2*diy+1)+phicoarse%iy_min-1 > n ) ) then
+ rhoy = 0.5_rl
+ else
+ rhoy = 0.25_rl
+ end if
+ phifine%s(iz,2*iy+diy,2*ix+dix) = &
+ phicoarse%s(iz,iy,ix) + &
+ rhox*(phicoarse%s(iz,iy,ix+(2*dix+1)) &
+ - phicoarse%s(iz,iy,ix)) + &
+ rhoy*(phicoarse%s(iz,iy+(2*diy+1),ix) &
+ - phicoarse%s(iz,iy,ix))
+ end do
+ end do
+ end do
+#else
+ ! Fit a plane through the four neighbours of each
+ ! coarse grid point. Use the gradient of this plane and
+ ! the value of the field on the coarse grid point for
+ ! the linear interpolation
+ ! Calculate the displacement vectors
+#ifdef CARTESIANGEOMETRY
+ ! (ix-1, iy)
+ dx(1,1) = -1.0_rl
+ dx(1,2) = 0.0_rl
+ ! (ix+1, iy)
+ dx(2,1) = +1.0_rl
+ dx(2,2) = 0.0_rl
+ ! (ix, iy-1)
+ dx(3,1) = 0.0_rl
+ dx(3,2) = -1.0_rl
+ ! (ix, iy+1)
+ dx(4,1) = 0.0_rl
+ dx(4,2) = +1.0_rl
+#else
+ rho_i = 2.0_rl*(ix+(phicoarse%ix_min-1)-0.5_rl)/n-1.0_rl
+ sigma_j = 2.0_rl*(iy+(phicoarse%iy_min-1)-0.5_rl)/n-1.0_rl
+ if (abs(rho_i**2+sigma_j**2) > 1.0E-12) then
+ c1 = (1.0_rl+rho_i**2+sigma_j**2)/sqrt(rho_i**2+sigma_j**2)
+ c2 = sqrt(1.0_rl+rho_i**2+sigma_j**2)/sqrt(rho_i**2+sigma_j**2)
+ else
+ rho_i = 1.0_rl
+ sigma_j = 1.0_rl
+ c1 = sqrt(0.5_rl)
+ c2 = sqrt(0.5_rl)
+ end if
+ ! (ix-1, iy)
+ dx(1,1) = -c1*rho_i
+ dx(1,2) = +c2*sigma_j
+ ! (ix+1, iy)
+ dx(2,1) = +c1*rho_i
+ dx(2,2) = -c2*sigma_j
+ ! (ix, iy-1)
+ dx(3,1) = -c1*sigma_j
+ dx(3,2) = -c2*rho_i
+ ! (ix, iy+1)
+ dx(4,1) = +c1*sigma_j
+ dx(4,2) = +c2*rho_i
+ dx_fine(1,1) = 0.25_rl*(dx(1,1)+dx(3,1))
+ dx_fine(1,2) = 0.25_rl*(dx(1,2)+dx(3,2))
+ dx_fine(2,1) = 0.25_rl*(dx(2,1)+dx(3,1))
+ dx_fine(2,2) = 0.25_rl*(dx(2,2)+dx(3,2))
+ dx_fine(3,1) = 0.25_rl*(dx(1,1)+dx(4,1))
+ dx_fine(3,2) = 0.25_rl*(dx(1,2)+dx(4,2))
+ dx_fine(4,1) = 0.25_rl*(dx(2,1)+dx(4,1))
+ dx_fine(4,2) = 0.25_rl*(dx(2,2)+dx(4,2))
+#endif
+ ! Boundaries
+ if (ix-1+phicoarse%ix_min-1 < 1 ) then
+ dx(1,1) = 0.5_rl*dx(1,1)
+ dx(1,2) = 0.5_rl*dx(1,2)
+ end if
+ if (ix+1+phicoarse%ix_min-1 > n ) then
+ dx(2,1) = 0.5_rl*dx(2,1)
+ dx(2,2) = 0.5_rl*dx(2,2)
+ end if
+ if (iy-1+phicoarse%iy_min-1 < 1 ) then
+ dx(3,1) = 0.5_rl*dx(3,1)
+ dx(3,2) = 0.5_rl*dx(3,2)
+ end if
+ if (iy+1+phicoarse%iy_min-1 > n ) then
+ dx(4,1) = 0.5_rl*dx(4,1)
+ dx(4,2) = 0.5_rl*dx(4,2)
+ end if
+ ! Calculate matrix used for least squares linear fit
+ A(:,:) = 0.0_rl
+ do i = 1,4
+ do j=1,3
+ do k=1,3
+ A(j,k) = A(j,k) + dx(i,j)*dx(i,k)
+ end do
+ end do
+ end do
+ ! invert A
+ call invertA(A)
+ do iz=1,phicoarse%grid_param%nz
+ ! Calculate gradient on each level
+ dxu(1:2) = dx(1,1:2)*phicoarse%s(iz,iy ,ix-1) &
+ + dx(2,1:2)*phicoarse%s(iz,iy ,ix+1) &
+ + dx(3,1:2)*phicoarse%s(iz,iy-1,ix ) &
+ + dx(4,1:2)*phicoarse%s(iz,iy+1,ix )
+ grad(:) = 0.0_rl
+ do j=1,2
+ do k=1,2
+ grad(j) = grad(j) + A(j,k)*dxu(k)
+ end do
+ end do
+ ! Use the gradient and the field value in the centre of
+ ! the coarse grid cell to interpolate to the fine grid
+ ! cells
+#ifdef CARTESIANGEOMETRY
+ do dix=-1,0
+ do diy=-1,0
+ phifine%s(iz,2*iy+diy,2*ix+dix) = &
+ phicoarse%s(iz,iy,ix) &
+ + 0.25_rl*( grad(1)*(2.0*dix+1) &
+ + grad(2)*(2.0*diy+1))
+ end do
+ end do
+#else
+ phifine%s(iz,2*iy-1, 2*ix-1) = phicoarse%s(iz,iy,ix) + &
+ ( grad(1)*dx_fine(1,1) + &
+ grad(2)*dx_fine(1,2) )
+ phifine%s(iz,2*iy-1, 2*ix ) = phicoarse%s(iz,iy,ix) + &
+ ( grad(1)*dx_fine(2,1) + &
+ grad(2)*dx_fine(2,2) )
+ phifine%s(iz,2*iy , 2*ix-1) = phicoarse%s(iz,iy,ix) + &
+ ( grad(1)*dx_fine(3,1) + &
+ grad(2)*dx_fine(3,2) )
+ phifine%s(iz,2*iy , 2*ix ) = phicoarse%s(iz,iy,ix) + &
+ ( grad(1)*dx_fine(4,1) + &
+ grad(2)*dx_fine(4,2) )
+#endif
+ end do
+#endif
+ end do
+ end do
+ end subroutine loop_over_grid_linear
+
+ end subroutine prolongate
+ !------------------------------------------------------------------
+ ! Invert the 3x3 matrix A either using LaPack or the explicit
+ ! formula
+ !------------------------------------------------------------------
+ subroutine invertA(A)
+ implicit none
+ real(kind=rl), intent(inout), dimension(3,3) :: A
+ real(kind=rl), dimension(3,3) :: Anew
+ real(kind=rl) :: invdetA
+ integer :: ipiv(3), info
+ real(kind=rl) :: work(3)
+#ifdef USELAPACK
+ call DGETRF( 3, 3, A, 3, ipiv, info )
+ call DGETRI( 3, A, 3, ipiv, work, 3, info )
+#else
+ invdetA = 1.0_rl / ( A(1,1) * (A(3,3)*A(2,2) - A(3,2)*A(2,3)) &
+ - A(2,1) * (A(3,3)*A(1,2) - A(3,2)*A(1,3)) &
+ + A(3,1) * (A(2,3)*A(1,2) - A(2,2)*A(1,3)) )
+ Anew(1,1) = A(3,3)*A(2,2) - A(3,2)*A(2,3)
+ Anew(1,2) = - ( A(3,3)*A(1,2) - A(3,2)*A(1,3) )
+ Anew(1,3) = A(2,3)*A(1,2) - A(2,2)*A(1,3)
+ Anew(2,1) = - ( A(3,3)*A(2,1) - A(3,1)*A(2,3) )
+ Anew(2,2) = A(3,3)*A(1,1) - A(3,1)*A(1,3)
+ Anew(2,3) = - ( A(2,3)*A(1,1) - A(2,1)*A(1,3) )
+ Anew(3,1) = A(3,2)*A(2,1) - A(3,1)*A(2,2)
+ Anew(3,2) = - ( A(3,2)*A(1,1) - A(3,1)*A(1,2) )
+ Anew(3,3) = A(2,2)*A(1,1) - A(2,1)*A(1,2)
+ A(:,:) = invdetA*Anew(:,:)
+#endif
+ end subroutine invertA
+
+!==================================================================
+! Multigrid V-cycle
+!==================================================================
+ recursive subroutine mg_vcycle_mnh(b,u,r,finelevel,splitlevel,level,m)
+ use MODE_OPENACC_SET_DEVICE
+ implicit none
+ integer, intent(in) :: finelevel
+ type(scalar3d), intent(inout), dimension(finelevel,0:pproc) :: b
+ type(scalar3d), intent(inout), dimension(finelevel,0:pproc) :: u
+ type(scalar3d), intent(inout), dimension(finelevel,0:pproc) :: r
+ integer, intent(in) :: splitlevel
+ integer, intent(in) :: level
+ integer, intent(in) :: m
+ !local var
+ integer :: n_gridpoints
+ integer :: nlocalx, nlocaly
+ integer :: halo_size
+
+ real , dimension(:,:,:) , pointer , contiguous :: zu_level_1_m_st,zu_level_1_m_1_st
+
+ nlocalx = u(level,m)%ix_max-u(level,m)%ix_min+1
+ nlocaly = u(level,m)%iy_max-u(level,m)%iy_min+1
+ halo_size = u(level,m)%halo_size
+ n_gridpoints = (nlocalx+2*halo_size) &
+ * (nlocaly+2*halo_size) &
+ * (u(level,m)%grid_param%nz+2)
+
+ if (level > 1) then
+ ! Perform n_presmooth smoothing steps
+ call start_timer(t_smooth(level,m))
+ call start_timer(t_total(level,m))
+ call smooth_mnh(level,m,mg_param%n_presmooth, &
+ DIRECTION_FORWARD, &
+ b(level,m),u(level,m))
+ call finish_timer(t_total(level,m))
+ call finish_timer(t_smooth(level,m))
+ ! Calculate residual
+ call start_timer(t_residual(level,m))
+ call start_timer(t_total(level,m))
+ call calculate_residual_mnh(level,m,b(level,m),u(level,m),r(level,m))
+ call finish_timer(t_total(level,m))
+ call finish_timer(t_residual(level,m))
+ ! Restrict residual
+ call start_timer(t_restrict(level,m))
+ call start_timer(t_total(level,m))
+ call restrict_mnh(r(level,m),b(level-1,m))
+ call finish_timer(t_total(level,m))
+ call finish_timer(t_restrict(level,m))
+ if ( ((level-1) .le. splitlevel) .and. (m > 0) ) then
+ ! Collect data on coarser level
+ call start_timer(t_total(level,m))
+ call collect(level-1,m,b(level-1,m),b(level-1,m-1))
+!!$ call print_scalaprod2(level-1, m , b(level-1,m) , "After collect b(level-1,m )=" )
+!!$ call print_scalaprod2(level-1, m-1, b(level-1,m-1), "After collect b(level-1,m-1)=" )
+ call finish_timer(t_total(level,m))
+ ! Set initial solution on coarser level to zero (incl. halos!)
+ if (LUseO) u(level-1,m-1)%s(:,:,:) = 0.0_rl
+ if (LUseT) then
+ zu_level_1_m_1_st => u(level-1,m-1)%st(:,:,:)
+ !$acc kernels
+ zu_level_1_m_1_st(:,:,:) = 0.0_rl
+ !$acc end kernels
+ end if
+ ! solve on coarser grid
+ call mg_vcycle_mnh(b,u,r,finelevel,splitlevel,level-1,m-1)
+ ! Distribute data on coarser grid
+ call start_timer(t_total(level,m))
+ call distribute(level-1,m,u(level-1,m-1),u(level-1,m))
+!!$ call print_scalaprod2(level-1, m , u(level-1,m) , "After distribute u(level-1,m )=" )
+!!$ call print_scalaprod2(level-1, m-1, u(level-1,m-1), "After distribute u(level-1,m-1)=" )
+ call finish_timer(t_total(level,m))
+ else
+ ! Set initial solution on coarser level to zero (incl. halos!)
+ if (LUseO) u(level-1,m)%s(:,:,:) = 0.0_rl
+ if (LUseT) then
+ zu_level_1_m_st => u(level-1,m)%st(:,:,:)
+ !$acc kernels
+ zu_level_1_m_st(:,:,:) = 0.0_rl
+ !$acc end kernels
+ end if
+ ! solve on coarser grid
+ ! switch from GPU to CPU if level == iswitch_cpu_gpu
+ if (level .EQ. iswitch_cpu_gpu ) then
+ !print*,' enter mg_vcycle_mnh level=', iswitch_cpu_gpu
+ !call MNH_OPENACC_GET_DEVICE()
+ call MNH_OPENACC_SET_DEVICE_HOST()
+ !call MNH_OPENACC_GET_DEVICE()
+ end if
+ call mg_vcycle_mnh(b,u,r,finelevel,splitlevel,level-1,m)
+ if (level .EQ. iswitch_cpu_gpu) then
+ !print*,' exit mg_vcycle_mnh level=', iswitch_cpu_gpu
+ !call MNH_OPENACC_GET_DEVICE()
+ call MNH_OPENACC_SET_DEVICE_DEFAULT()
+ !call MNH_OPENACC_GET_DEVICE()
+ end if
+ end if
+ ! Prolongate error
+ call start_timer(t_prolongate(level,m))
+ call start_timer(t_total(level,m))
+ call haloswap_mnh(level-1,m,u(level-1,m))
+ call boundary_mnh(u(level-1,m))
+!!$ call print_scalaprod2(level-1 , m , u(level-1,m) , "Befor prolongate_mnh u(level-1,m )=" )
+!!$ call print_scalaprod2(level , m , r(level ,m) , "Befor prolongate_mnh r(level ,m )=" )
+ call prolongate_mnh(level,m,u(level-1,m),r(level,m))
+!!$ call print_scalaprod2(level-1 , m , u(level-1,m) , "After prolongate_mnh u(level-1,m )=" )
+!!$ call print_scalaprod2(level , m , r(level ,m) , "After prolongate_mnh r(level ,m )=" )
+ call finish_timer(t_total(level,m))
+ call finish_timer(t_prolongate(level,m))
+ ! Add error to fine grid solution
+ call start_timer(t_addcorr(level,m))
+ call start_timer(t_total(level,m))
+ if (LUseO) call daxpy(n_gridpoints,1.0_rl,r(level,m)%s,1,u(level,m)%s,1)
+ if (LUseT) call daxpy(n_gridpoints,1.0_rl,r(level,m)%st,1,u(level,m)%st,1)
+ call finish_timer(t_total(level,m))
+ call finish_timer(t_addcorr(level,m))
+ ! Perform n_postsmooth smoothing steps
+ call start_timer(t_smooth(level,m))
+ call start_timer(t_total(level,m))
+ call smooth_mnh(level,m, &
+ mg_param%n_postsmooth, &
+ DIRECTION_BACKWARD, &
+ b(level,m),u(level,m))
+ call finish_timer(t_total(level,m))
+ call finish_timer(t_smooth(level,m))
+ else
+ call start_timer(t_coarsesolve(level,m))
+ call start_timer(t_total(level,m))
+ if (mg_param%coarsegridsolver == COARSEGRIDSOLVER_CG) then
+ call cg_solve_mnh(level,m,b(level,m),u(level,m))
+!!$ call print_scalaprod2(level, m , u(level,m), "After cg_solve_mnh u=(level,m)" )
+ else if (mg_param%coarsegridsolver == COARSEGRIDSOLVER_SMOOTHER) then
+ ! Smooth on coarsest level
+ call smooth_mnh(level,m, &
+ mg_param%n_coarsegridsmooth, &
+ DIRECTION_FORWARD, &
+ b(level,m),u(level,m))
+ end if
+ call finish_timer(t_total(level,m))
+ call finish_timer(t_coarsesolve(level,m))
+ end if
+
+ end subroutine mg_vcycle_mnh
+!==================================================================
+! Multigrid V-cycle
+!==================================================================
+ recursive subroutine mg_vcycle(b,u,r,finelevel,splitlevel,level,m)
+ implicit none
+ integer, intent(in) :: finelevel
+ type(scalar3d), intent(inout), dimension(finelevel,0:pproc) :: b
+ type(scalar3d), intent(inout), dimension(finelevel,0:pproc) :: u
+ type(scalar3d), intent(inout), dimension(finelevel,0:pproc) :: r
+ integer, intent(in) :: splitlevel
+ integer, intent(in) :: level
+ integer, intent(in) :: m
+ integer :: n_gridpoints
+ integer :: nlocalx, nlocaly
+ integer :: halo_size
+
+ nlocalx = u(level,m)%ix_max-u(level,m)%ix_min+1
+ nlocaly = u(level,m)%iy_max-u(level,m)%iy_min+1
+ halo_size = u(level,m)%halo_size
+ n_gridpoints = (nlocalx+2*halo_size) &
+ * (nlocaly+2*halo_size) &
+ * (u(level,m)%grid_param%nz+2)
+
+ if (level > 1) then
+ ! Perform n_presmooth smoothing steps
+ call start_timer(t_smooth(level,m))
+ call start_timer(t_total(level,m))
+ call smooth(level,m,mg_param%n_presmooth, &
+ DIRECTION_FORWARD, &
+ b(level,m),u(level,m))
+ call finish_timer(t_total(level,m))
+ call finish_timer(t_smooth(level,m))
+ ! Calculate residual
+ call start_timer(t_residual(level,m))
+ call start_timer(t_total(level,m))
+ call calculate_residual(level,m,b(level,m),u(level,m),r(level,m))
+ call finish_timer(t_total(level,m))
+ call finish_timer(t_residual(level,m))
+ ! Restrict residual
+ call start_timer(t_restrict(level,m))
+ call start_timer(t_total(level,m))
+ call restrict(r(level,m),b(level-1,m))
+ call finish_timer(t_total(level,m))
+ call finish_timer(t_restrict(level,m))
+ if ( ((level-1) .le. splitlevel) .and. (m > 0) ) then
+ ! Collect data on coarser level
+ call start_timer(t_total(level,m))
+ call collect(level-1,m,b(level-1,m),b(level-1,m-1))
+ call haloswap_mnh(level-1,m-1,b(level-1,m-1))
+ call finish_timer(t_total(level,m))
+ ! Set initial solution on coarser level to zero (incl. halos!)
+ if (LUseO) u(level-1,m-1)%s(:,:,:) = 0.0_rl
+ if (LUseT) u(level-1,m-1)%st(:,:,:) = 0.0_rl
+ ! solve on coarser grid
+ call mg_vcycle(b,u,r,finelevel,splitlevel,level-1,m-1)
+ ! Distribute data on coarser grid
+ call start_timer(t_total(level,m))
+ call distribute(level-1,m,u(level-1,m-1),u(level-1,m))
+ call haloswap(level-1,m,u(level-1,m))
+ call finish_timer(t_total(level,m))
+ else
+ ! Set initial solution on coarser level to zero (incl. halos!)
+ if (LUseO) u(level-1,m)%s(:,:,:) = 0.0_rl
+ if (LUseT) u(level-1,m)%st(:,:,:) = 0.0_rl
+ ! solve on coarser grid
+ call mg_vcycle(b,u,r,finelevel,splitlevel,level-1,m)
+ end if
+ ! Prolongate error
+ call start_timer(t_prolongate(level,m))
+ call start_timer(t_total(level,m))
+ call prolongate(level,m,u(level-1,m),r(level,m))
+ call finish_timer(t_total(level,m))
+ call finish_timer(t_prolongate(level,m))
+ ! Add error to fine grid solution
+ call start_timer(t_addcorr(level,m))
+ call start_timer(t_total(level,m))
+ if (LUseO) call daxpy(n_gridpoints,1.0_rl,r(level,m)%s,1,u(level,m)%s,1)
+ if (LUseT) call daxpy(n_gridpoints,1.0_rl,r(level,m)%st,1,u(level,m)%st,1)
+ call finish_timer(t_total(level,m))
+ call finish_timer(t_addcorr(level,m))
+ ! Perform n_postsmooth smoothing steps
+ call start_timer(t_smooth(level,m))
+ call start_timer(t_total(level,m))
+ call smooth(level,m, &
+ mg_param%n_postsmooth, &
+ DIRECTION_BACKWARD, &
+ b(level,m),u(level,m))
+ call finish_timer(t_total(level,m))
+ call finish_timer(t_smooth(level,m))
+ else
+ call start_timer(t_coarsesolve(level,m))
+ call start_timer(t_total(level,m))
+ if (mg_param%coarsegridsolver == COARSEGRIDSOLVER_CG) then
+ call cg_solve(level,m,b(level,m),u(level,m))
+ else if (mg_param%coarsegridsolver == COARSEGRIDSOLVER_SMOOTHER) then
+ ! Smooth on coarsest level
+ call smooth(level,m, &
+ mg_param%n_coarsegridsmooth, &
+ DIRECTION_FORWARD, &
+ b(level,m),u(level,m))
+ end if
+ call finish_timer(t_total(level,m))
+ call finish_timer(t_coarsesolve(level,m))
+ end if
+
+ end subroutine mg_vcycle
+
+!==================================================================
+! Test halo exchanges
+!==================================================================
+ recursive subroutine mg_vcyclehaloswaponly(b,u,r,finelevel,splitlevel,level,m)
+ implicit none
+ integer, intent(in) :: finelevel
+ type(scalar3d), intent(inout), dimension(finelevel,0:pproc) :: b
+ type(scalar3d), intent(inout), dimension(finelevel,0:pproc) :: u
+ type(scalar3d), intent(inout), dimension(finelevel,0:pproc) :: r
+ integer, intent(in) :: splitlevel
+ integer, intent(in) :: level
+ integer, intent(in) :: m
+ integer, parameter :: nhaloswap = 100
+ integer :: i
+ integer :: ierr
+
+ if (level > 1) then
+ call mpi_barrier(MPI_COMM_HORIZ,ierr)
+ do i=1,nhaloswap
+ call haloswap(level,m,u(level,m))
+ end do
+ call mpi_barrier(MPI_COMM_HORIZ,ierr)
+ if ( ((level-1) .le. splitlevel) .and. (m > 0) ) then
+ call mpi_barrier(MPI_COMM_HORIZ,ierr)
+ do i=1,nhaloswap
+ call haloswap(level-1,m,u(level-1,m))
+ end do
+ call mpi_barrier(MPI_COMM_HORIZ,ierr)
+ call mg_vcyclehaloswaponly(b,u,r,finelevel,splitlevel,level-1,m-1)
+ else
+ call mg_vcyclehaloswaponly(b,u,r,finelevel,splitlevel,level-1,m)
+ end if
+ else
+ ! Haloswap on coarsest level
+ call mpi_barrier(MPI_COMM_HORIZ,ierr)
+ do i=1,nhaloswap
+ call haloswap(level,m,u(level,m))
+ end do
+ call mpi_barrier(MPI_COMM_HORIZ,ierr)
+ end if
+
+ end subroutine mg_vcyclehaloswaponly
+
+!==================================================================
+! Multigrid solve
+! Assumes that ghosts in initial solution are up-to-date
+!==================================================================
+ subroutine mg_solve_mnh(bRHS,usolution,solver_param)
+ implicit none
+ type(scalar3d), intent(in) :: bRHS
+ type(scalar3d), intent(inout) :: usolution
+ type(solver_parameters), intent(in) :: solver_param
+ integer :: solvertype
+ real(kind=rl) :: resreduction
+ integer :: maxiter
+ integer :: n_gridpoints
+ integer :: iter, level, finelevel, splitlevel
+ real(kind=rl) :: res_old, res_new, res_initial , mean_initial , norm_initial
+ logical :: solverconverged = .false.
+ integer :: nlocalx, nlocaly
+ integer :: halo_size
+ type(time) :: t_prec, t_res, t_apply, t_l2norm, t_scalprod, t_mainloop
+ type(scalar3d) :: pp
+ type(scalar3d) :: q
+ type(scalar3d) :: z_one
+ real(kind=rl) :: alpha, beta, pq, rz, rz_old
+ integer :: ierr
+ real(kind=rl) , pointer , contiguous , dimension(:,:,:) :: z_one_st
+
+ solvertype = solver_param%solvertype
+ resreduction = solver_param%resreduction
+ maxiter = solver_param%maxiter
+ nlocalx = usolution%ix_max - usolution%ix_min+1
+ nlocaly = usolution%iy_max - usolution%iy_min+1
+ halo_size = usolution%halo_size
+
+ level = mg_param%n_lev
+ finelevel = level
+ splitlevel = mg_param%lev_split
+
+ ! Initialise timers
+ call initialise_timer(t_prec,"t_prec")
+ call initialise_timer(t_apply,"t_apply")
+ call initialise_timer(t_l2norm,"t_l2norm")
+ call initialise_timer(t_scalprod,"t_scalarprod")
+ call initialise_timer(t_res,"t_residual")
+ call initialise_timer(t_mainloop,"t_mainloop")
+
+ n_gridpoints = (nlocalx+2*halo_size) &
+ * (nlocaly+2*halo_size) &
+ * (usolution%grid_param%nz+2)
+ !
+ ! Init 1 vector = z_one
+ call create_scalar3d(MPI_COMM_HORIZ,bRHS%grid_param,halo_size,z_one)
+ if (LUseO) then
+ z_one%s(:,:,:) = 0.0_rl
+ z_one%s(1:z_one%grid_param%nz,1:z_one%icompy_max,1:z_one%icompx_max) = 1.0_rl
+ end if
+ if (LUseT) then
+ z_one_st => z_one%st
+ !$acc kernels
+ z_one_st(:,:,:) = 0.0_rl
+ z_one_st(1:z_one%icompx_max,1:z_one%icompy_max,1:z_one%grid_param%nz) = 1.0_rl
+ !$acc end kernels
+ end if
+ ! Mean / Norm of B
+ call scalarprod_mnh(pproc,z_one,z_one, mean_initial )
+ call scalarprod_mnh(pproc,z_one,bRHS, mean_initial )
+ norm_initial = l2norm_mnh(bRHS,.true.)
+ mean_initial = mean_initial / (( z_one%grid_param%nz ) * ( z_one%grid_param%n )**2)
+ norm_initial = mean_initial / norm_initial
+ if (LMean) then
+ ! b <- b -mean_initial * z_one
+ if (LUseO) call daxpy(n_gridpoints,-mean_initial,z_one%s,1,bRHS%s,1)
+ if (LUseT) call daxpy(n_gridpoints,-mean_initial,z_one%st,1,bRHS%st,1)
+ call scalarprod_mnh(pproc,z_one,bRHS, mean_initial )
+ endif
+ !
+ ! Copy b to b(1)
+ ! Copy usolution to u(1)
+ if (LUseO) call dcopy(n_gridpoints,bRHS%s,1,xb_mg(level,pproc)%s,1)
+ if (LUseT) call dcopy(n_gridpoints,bRHS%st,1,xb_mg(level,pproc)%st,1)
+ if (LUseO) call dcopy(n_gridpoints,usolution%s,1,xu_mg(level,pproc)%s,1)
+ if (LUseT) call dcopy(n_gridpoints,usolution%st,1,xu_mg(level,pproc)%st,1)
+
+! Scale with volume of grid cells
+ call volscale_scalar3d_mnh(xb_mg(level,pproc),1)
+ call scalarprod_mnh(pproc,z_one,xb_mg(level,pproc), mean_initial )
+
+ call start_timer(t_res)
+ call calculate_residual_mnh(level, pproc, &
+ xb_mg(level,pproc),xu_mg(level,pproc),xr_mg(level,pproc))
+ call finish_timer(t_res)
+ call start_timer(t_l2norm)
+ res_initial = l2norm_mnh(xr_mg(level,pproc),.true.)
+ call finish_timer(t_l2norm)
+ res_old = res_initial
+ if (mg_param%verbose > 0) then
+ if (i_am_master_mpi) then
+ write(STDOUT,'(" *** Multigrid solver ***")')
+ write(STDOUT,'(" <MG> Initial residual : ",E10.5)') res_initial
+ end if
+ end if
+ if (mg_param%verbose > 0) then
+ if (i_am_master_mpi) then
+ write(STDOUT,'(" <MG> iter : residual rho")')
+ write(STDOUT,'(" <MG> --------------------------------")')
+ end if
+ end if
+
+ call mpi_barrier(MPI_COMM_WORLD,ierr)
+ call start_timer(t_mainloop)
+ if (solvertype == SOLVER_CG) then
+ ! NB: b(level,pproc) will be used as r in the following
+ call create_scalar3d(MPI_COMM_HORIZ,bRHS%grid_param,halo_size,pp)
+ call create_scalar3d(MPI_COMM_HORIZ,bRHS%grid_param,halo_size,q)
+ ! Apply preconditioner: Calculate p = M^{-1} r
+ ! (1) copy b <- r
+ if (LUseO) call dcopy(n_gridpoints,xr_mg(level,pproc)%s,1,xb_mg(level,pproc)%s,1)
+ if (LUseT) call dcopy(n_gridpoints,xr_mg(level,pproc)%st,1,xb_mg(level,pproc)%st,1)
+ ! (2) set u <- 0
+ if (LUseO) xu_mg(level,pproc)%s(:,:,:) = 0.0_rl
+ if (LUseT) xu_mg(level,pproc)%st(:,:,:) = 0.0_rl
+ ! (3) Call MG Vcycle
+ call start_timer(t_prec)
+ call mg_vcycle_mnh(xb_mg,xu_mg,xr_mg,finelevel,splitlevel,level,pproc)
+ call finish_timer(t_prec)
+ ! (4) copy pp <- u (=solution from MG Vcycle)
+ if (LUseO) call dcopy(n_gridpoints,xu_mg(level,pproc)%s,1,pp%s,1)
+ if (LUseT) call dcopy(n_gridpoints,xu_mg(level,pproc)%st,1,pp%st,1)
+ ! Calculate rz_old = <pp,b>
+ call start_timer(t_scalprod)
+ call scalarprod_mnh(pproc,pp,xb_mg(level,pproc),rz_old)
+ call finish_timer(t_scalprod)
+ do iter = 1, maxiter
+ ! Apply matrix q <- A.pp
+ call start_timer(t_apply)
+ call apply_mnh(pp,q)
+ call finish_timer(t_apply)
+ ! Calculate pq <- <pp,q>
+ call start_timer(t_scalprod)
+ call scalarprod_mnh(pproc,pp,q,pq)
+ call finish_timer(t_scalprod)
+ alpha = rz_old/pq
+ ! x <- x + alpha*p
+ if (LUseO) call daxpy(n_gridpoints,alpha,pp%s,1,usolution%s,1)
+ if (LUseT) call daxpy(n_gridpoints,alpha,pp%st,1,usolution%st,1)
+ ! b <- b - alpha*q
+ if (LUseO) call daxpy(n_gridpoints,-alpha,q%s,1,xb_mg(level,pproc)%s,1)
+ if (LUseT) call daxpy(n_gridpoints,-alpha,q%st,1,xb_mg(level,pproc)%st,1)
+ ! Calculate norm of residual and exit if it has been
+ ! reduced sufficiently
+ call start_timer(t_l2norm)
+ res_new = l2norm_mnh(xb_mg(level,pproc),.true.)
+ call finish_timer(t_l2norm)
+ if (mg_param%verbose > 1) then
+ if (i_am_master_mpi) then
+ write(STDOUT,'(" <MG> ",I7," : ",E10.5," ",F10.5)') iter, res_new, res_new/res_old
+ end if
+ end if
+ if (res_new/res_initial < resreduction) then
+ solverconverged = .true.
+ exit
+ end if
+ res_old = res_new
+ ! Apply preconditioner q <- M^{-1} b
+ ! (1) Initialise solution u <- 0
+ if (LUseO) xu_mg(level,pproc)%s(:,:,:) = 0.0_rl
+ if (LUseT) xu_mg(level,pproc)%st(:,:,:) = 0.0_rl
+ ! (2) Call MG Vcycle
+ call start_timer(t_prec)
+ call mg_vcycle_mnh(xb_mg,xu_mg,xr_mg,finelevel,splitlevel,level,pproc)
+ call finish_timer(t_prec)
+ ! (3) copy q <- u (solution from MG Vcycle)
+ if (LUseO) call dcopy(n_gridpoints,xu_mg(level,pproc)%s,1,q%s,1)
+ if (LUseT) call dcopy(n_gridpoints,xu_mg(level,pproc)%st,1,q%st,1)
+ call start_timer(t_scalprod)
+ call scalarprod_mnh(pproc,q,xb_mg(level,pproc),rz)
+ call finish_timer(t_scalprod)
+ beta = rz/rz_old
+ ! p <- beta*p
+ if (LUseO) call dscal(n_gridpoints,beta,pp%s,1)
+ if (LUseT) call dscal(n_gridpoints,beta,pp%st,1)
+ ! p <- p+q
+ if (LUseO) call daxpy(n_gridpoints,1.0_rl,q%s,1,pp%s,1)
+ if (LUseT) call daxpy(n_gridpoints,1.0_rl,q%st,1,pp%st,1)
+ rz_old = rz
+ end do
+ call destroy_scalar3d(pp)
+ call destroy_scalar3d(q)
+ else if (solvertype == SOLVER_RICHARDSON) then
+ ! Iterate until convergence
+ do iter=1,maxiter
+ call start_timer(t_prec)
+ call mg_vcycle_mnh(xb_mg,xu_mg,xr_mg,finelevel,splitlevel,level,pproc)
+ call finish_timer(t_prec)
+ call start_timer(t_res)
+ ! Ghosts are up-to-date here, so no need for halo exchange
+ call calculate_residual_mnh(level, pproc, &
+ xb_mg(level,pproc),xu_mg(level,pproc),xr_mg(level,pproc))
+ call finish_timer(t_res)
+ call start_timer(t_l2norm)
+ res_new = l2norm_mnh(xr_mg(level,pproc),.true.)
+ call finish_timer(t_l2norm)
+ if (mg_param%verbose > 1) then
+ if (i_am_master_mpi) then
+ write(STDOUT,'(" <MG> ",I7," : ",E10.5," ",F10.5)') iter, res_new, res_new/res_old
+ end if
+ end if
+ if (res_new/res_initial < resreduction) then
+ solverconverged = .true.
+ exit
+ end if
+ res_old = res_new
+ end do
+ ! Copy u(1) to usolution
+ if (LUseO) call dcopy(n_gridpoints,xu_mg(level,pproc)%s,1,usolution%s,1)
+ if (LUseT) call dcopy(n_gridpoints,xu_mg(level,pproc)%st,1,usolution%st,1)
+ end if
+
+ call destroy_scalar3d(z_one)
+
+ call finish_timer(t_mainloop)
+
+ ! Print out solver information
+ if (mg_param%verbose > 0) then
+ if (solverconverged) then
+ if (i_am_master_mpi) then
+ write(STDOUT,'(" <MG> Final residual ||r|| = ",E12.6)') res_new
+ write(STDOUT,'(" <MG> Solver converged in ",I7," iterations rho_{avg} = ",F10.5)') &
+ iter, (res_new/res_initial)**(1./(iter))
+ end if
+ else
+ if (i_am_master_mpi) then
+ write(STDOUT,'(" <MG> Solver failed to converge after ",I7," iterations rho_{avg} = ",F10.5)') &
+ maxiter, (res_new/res_initial)**(1./(iter))
+ end if
+ end if
+ end if
+ call print_timerinfo("--- Main iteration timing results ---")
+ call print_elapsed(t_apply,.True.,1.0_rl)
+ call print_elapsed(t_res,.True.,1.0_rl)
+ call print_elapsed(t_prec,.True.,1.0_rl)
+ call print_elapsed(t_l2norm,.True.,1.0_rl)
+ call print_elapsed(t_scalprod,.True.,1.0_rl)
+ call print_elapsed(t_mainloop,.True.,1.0_rl)
+ if (i_am_master_mpi) write(STDOUT,'("")')
+ end subroutine mg_solve_mnh
+
+ subroutine mg_solve(bRHS,usolution,solver_param)
+ implicit none
+ type(scalar3d), intent(in) :: bRHS
+ type(scalar3d), intent(inout) :: usolution
+ type(solver_parameters), intent(in) :: solver_param
+ integer :: solvertype
+ real(kind=rl) :: resreduction
+ integer :: maxiter
+ integer :: n_gridpoints
+ integer :: iter, level, finelevel, splitlevel
+ real(kind=rl) :: res_old, res_new, res_initial
+ logical :: solverconverged = .false.
+ integer :: nlocalx, nlocaly
+ integer :: halo_size
+ type(time) :: t_prec, t_res, t_apply, t_l2norm, t_scalprod, t_mainloop
+ type(scalar3d) :: pp
+ type(scalar3d) :: q
+ real(kind=rl) :: alpha, beta, pq, rz, rz_old
+ integer :: ierr
+
+ solvertype = solver_param%solvertype
+ resreduction = solver_param%resreduction
+ maxiter = solver_param%maxiter
+ nlocalx = usolution%ix_max - usolution%ix_min+1
+ nlocaly = usolution%iy_max - usolution%iy_min+1
+ halo_size = usolution%halo_size
+
+ level = mg_param%n_lev
+ finelevel = level
+ splitlevel = mg_param%lev_split
+
+ ! Initialise timers
+ call initialise_timer(t_prec,"t_prec")
+ call initialise_timer(t_apply,"t_apply")
+ call initialise_timer(t_l2norm,"t_l2norm")
+ call initialise_timer(t_scalprod,"t_scalarprod")
+ call initialise_timer(t_res,"t_residual")
+ call initialise_timer(t_mainloop,"t_mainloop")
+
+ ! Copy b to b(1)
+ ! Copy usolution to u(1)
+ n_gridpoints = (nlocalx+2*halo_size) &
+ * (nlocaly+2*halo_size) &
+ * (usolution%grid_param%nz+2)
+ call dcopy(n_gridpoints,bRHS%s,1,xb_mg(level,pproc)%s,1)
+ call dcopy(n_gridpoints,usolution%s,1,xu_mg(level,pproc)%s,1)
+! Scale with volume of grid cells
+ call volscale_scalar3d(xb_mg(level,pproc),1)
+ call start_timer(t_res)
+ call calculate_residual(level, pproc, &
+ xb_mg(level,pproc),xu_mg(level,pproc),xr_mg(level,pproc))
+ call finish_timer(t_res)
+ call start_timer(t_l2norm)
+ res_initial = l2norm(xr_mg(level,pproc),.true.)
+ call finish_timer(t_l2norm)
+ res_old = res_initial
+ if (mg_param%verbose > 0) then
+ if (i_am_master_mpi) then
+ write(STDOUT,'(" *** Multigrid solver ***")')
+ write(STDOUT,'(" <MG> Initial residual : ",E10.5)') res_initial
+ end if
+ end if
+ if (mg_param%verbose > 0) then
+ if (i_am_master_mpi) then
+ write(STDOUT,'(" <MG> iter : residual rho")')
+ write(STDOUT,'(" <MG> --------------------------------")')
+ end if
+ end if
+
+ call mpi_barrier(MPI_COMM_WORLD,ierr)
+ call start_timer(t_mainloop)
+ if (solvertype == SOLVER_CG) then
+ ! NB: b(level,pproc) will be used as r in the following
+ call create_scalar3d(MPI_COMM_HORIZ,bRHS%grid_param,halo_size,pp)
+ call create_scalar3d(MPI_COMM_HORIZ,bRHS%grid_param,halo_size,q)
+ ! Apply preconditioner: Calculate p = M^{-1} r
+ ! (1) copy b <- r
+ call dcopy(n_gridpoints,xr_mg(level,pproc)%s,1,xb_mg(level,pproc)%s,1)
+ ! (2) set u <- 0
+ xu_mg(level,pproc)%s(:,:,:) = 0.0_rl
+ ! (3) Call MG Vcycle
+ call start_timer(t_prec)
+ call mg_vcycle(xb_mg,xu_mg,xr_mg,finelevel,splitlevel,level,pproc)
+ call finish_timer(t_prec)
+ ! (4) copy pp <- u (=solution from MG Vcycle)
+ call dcopy(n_gridpoints,xu_mg(level,pproc)%s,1,pp%s,1)
+ ! Calculate rz_old = <pp,b>
+ call start_timer(t_scalprod)
+ call scalarprod(pproc,pp,xb_mg(level,pproc),rz_old)
+ call finish_timer(t_scalprod)
+ do iter = 1, maxiter
+ ! Apply matrix q <- A.pp
+ call start_timer(t_apply)
+ call apply(pp,q)
+ call finish_timer(t_apply)
+ ! Calculate pq <- <pp,q>
+ call start_timer(t_scalprod)
+ call scalarprod(pproc,pp,q,pq)
+ call finish_timer(t_scalprod)
+ alpha = rz_old/pq
+ ! x <- x + alpha*p
+ call daxpy(n_gridpoints,alpha,pp%s,1,usolution%s,1)
+ ! b <- b - alpha*q
+ call daxpy(n_gridpoints,-alpha,q%s,1,xb_mg(level,pproc)%s,1)
+ ! Calculate norm of residual and exit if it has been
+ ! reduced sufficiently
+ call start_timer(t_l2norm)
+ res_new = l2norm(xb_mg(level,pproc),.true.)
+ call finish_timer(t_l2norm)
+ if (mg_param%verbose > 1) then
+ if (i_am_master_mpi) then
+ write(STDOUT,'(" <MG> ",I7," : ",E10.5," ",F10.5)') iter, res_new, res_new/res_old
+ end if
+ end if
+ if (res_new/res_initial < resreduction) then
+ solverconverged = .true.
+ exit
+ end if
+ res_old = res_new
+ ! Apply preconditioner q <- M^{-1} b
+ ! (1) Initialise solution u <- 0
+ xu_mg(level,pproc)%s(:,:,:) = 0.0_rl
+ ! (2) Call MG Vcycle
+ call start_timer(t_prec)
+ call mg_vcycle(xb_mg,xu_mg,xr_mg,finelevel,splitlevel,level,pproc)
+ call finish_timer(t_prec)
+ ! (3) copy q <- u (solution from MG Vcycle)
+ call dcopy(n_gridpoints,xu_mg(level,pproc)%s,1,q%s,1)
+ call start_timer(t_scalprod)
+ call scalarprod(pproc,q,xb_mg(level,pproc),rz)
+ call finish_timer(t_scalprod)
+ beta = rz/rz_old
+ ! p <- beta*p
+ call dscal(n_gridpoints,beta,pp%s,1)
+ ! p <- p+q
+ call daxpy(n_gridpoints,1.0_rl,q%s,1,pp%s,1)
+ rz_old = rz
+ end do
+ call destroy_scalar3d(pp)
+ call destroy_scalar3d(q)
+ else if (solvertype == SOLVER_RICHARDSON) then
+ ! Iterate until convergence
+ do iter=1,maxiter
+ call start_timer(t_prec)
+ call mg_vcycle(xb_mg,xu_mg,xr_mg,finelevel,splitlevel,level,pproc)
+ call finish_timer(t_prec)
+ call start_timer(t_res)
+ ! Ghosts are up-to-date here, so no need for halo exchange
+ call calculate_residual(level, pproc, &
+ xb_mg(level,pproc),xu_mg(level,pproc),xr_mg(level,pproc))
+ call finish_timer(t_res)
+ call start_timer(t_l2norm)
+ res_new = l2norm(xr_mg(level,pproc),.true.)
+ call finish_timer(t_l2norm)
+ if (mg_param%verbose > 1) then
+ if (i_am_master_mpi) then
+ write(STDOUT,'(" <MG> ",I7," : ",E10.5," ",F10.5)') iter, res_new, res_new/res_old
+ end if
+ end if
+ if (res_new/res_initial < resreduction) then
+ solverconverged = .true.
+ exit
+ end if
+ res_old = res_new
+ end do
+ ! Copy u(1) to usolution
+ call dcopy(n_gridpoints,xu_mg(level,pproc)%s,1,usolution%s,1)
+ end if
+ call finish_timer(t_mainloop)
+
+ ! Print out solver information
+ if (mg_param%verbose > 0) then
+ if (solverconverged) then
+ if (i_am_master_mpi) then
+ write(STDOUT,'(" <MG> Final residual ||r|| = ",E12.6)') res_new
+ write(STDOUT,'(" <MG> Solver converged in ",I7," iterations rho_{avg} = ",F10.5)') &
+ iter, (res_new/res_initial)**(1./(iter))
+ end if
+ else
+ if (i_am_master_mpi) then
+ write(STDOUT,'(" <MG> Solver failed to converge after ",I7," iterations rho_{avg} = ",F10.5)') &
+ maxiter, (res_new/res_initial)**(1./(iter))
+ end if
+ end if
+ end if
+ call print_timerinfo("--- Main iteration timing results ---")
+ call print_elapsed(t_apply,.True.,1.0_rl)
+ call print_elapsed(t_res,.True.,1.0_rl)
+ call print_elapsed(t_prec,.True.,1.0_rl)
+ call print_elapsed(t_l2norm,.True.,1.0_rl)
+ call print_elapsed(t_scalprod,.True.,1.0_rl)
+ call print_elapsed(t_mainloop,.True.,1.0_rl)
+ if (i_am_master_mpi) write(STDOUT,'("")')
+ end subroutine mg_solve
+
+!==================================================================
+! Test haloswap on all levels
+!==================================================================
+ subroutine measurehaloswap()
+ implicit none
+ integer :: iter, level, finelevel, splitlevel
+
+ level = mg_param%n_lev
+ finelevel = level
+ splitlevel = mg_param%lev_split
+ call mg_vcyclehaloswaponly(xb_mg,xu_mg,xr_mg,finelevel,splitlevel,level,pproc)
+ end subroutine measurehaloswap
+
+end module multigrid
+
diff --git a/src/ZSOLVER/tensorproductmultigrid_Source/parameters.f90 b/src/ZSOLVER/tensorproductmultigrid_Source/parameters.f90
new file mode 100644
index 0000000000000000000000000000000000000000..5195982fdeffc44390f2a2fa9fd116f6e0d76660
--- /dev/null
+++ b/src/ZSOLVER/tensorproductmultigrid_Source/parameters.f90
@@ -0,0 +1,64 @@
+!=== COPYRIGHT AND LICENSE STATEMENT ===
+!
+! This file is part of the TensorProductMultigrid code.
+!
+! (c) The copyright relating to this work is owned jointly by the
+! Crown, Met Office and NERC [2014]. However, it has been created
+! with the help of the GungHo Consortium, whose members are identified
+! at https://puma.nerc.ac.uk/trac/GungHo/wiki .
+!
+! Main Developer: Eike Mueller
+!
+! TensorProductMultigrid is free software: you can redistribute it and/or
+! modify it under the terms of the GNU Lesser General Public License as
+! published by the Free Software Foundation, either version 3 of the
+! License, or (at your option) any later version.
+!
+! TensorProductMultigrid is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU Lesser General Public License for more details.
+!
+! You should have received a copy of the GNU Lesser General Public License
+! along with TensorProductMultigrid (see files COPYING and COPYING.LESSER).
+! If not, see <http://www.gnu.org/licenses/>.
+!
+!=== COPYRIGHT AND LICENSE STATEMENT ===
+
+
+!==================================================================
+!
+! General parameters
+!
+! Eike Mueller, University of Bath, Feb 2012
+!
+!==================================================================
+
+module parameters
+
+ implicit none
+
+! floating point precision. Always use rl_kind in code
+ integer, parameter :: single_precision=4 ! single precision
+ integer, parameter :: double_precision=8 ! double precision
+ integer, parameter :: rl=double_precision ! global switch between
+ ! single/double precision
+! NOTE: As we still use BLAS subroutines, these need to be
+! replaced as well when switching between double and
+! single precision!
+ real(kind=rl), parameter :: Tolerance = 1.0e-15
+
+! Output units
+ integer, parameter :: STDOUT = 6
+ integer, parameter :: STDERR = 0
+
+! Numerical constants
+ real(kind=rl), parameter :: two_pi = 6.2831853071795862_rl
+
+! Use Original (K,J,I) or Transposed (I,J,K) array
+ logical :: LUseO = .false.
+ logical :: LUseT = .true. ! .false. ! .true.
+! Remove mean to B = Right Hand side
+ logical :: LMean = .false.
+
+end module parameters
diff --git a/src/ZSOLVER/tensorproductmultigrid_Source/profiles.f90 b/src/ZSOLVER/tensorproductmultigrid_Source/profiles.f90
new file mode 100644
index 0000000000000000000000000000000000000000..72338e703e1ab7a938de88d82c72d8b43c2ac763
--- /dev/null
+++ b/src/ZSOLVER/tensorproductmultigrid_Source/profiles.f90
@@ -0,0 +1,392 @@
+!=== COPYRIGHT AND LICENSE STATEMENT ===
+!
+! This file is part of the TensorProductMultigrid code.
+!
+! (c) The copyright relating to this work is owned jointly by the
+! Crown, Met Office and NERC [2014]. However, it has been created
+! with the help of the GungHo Consortium, whose members are identified
+! at https://puma.nerc.ac.uk/trac/GungHo/wiki .
+!
+! Main Developer: Eike Mueller
+!
+! TensorProductMultigrid is free software: you can redistribute it and/or
+! modify it under the terms of the GNU Lesser General Public License as
+! published by the Free Software Foundation, either version 3 of the
+! License, or (at your option) any later version.
+!
+! TensorProductMultigrid is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU Lesser General Public License for more details.
+!
+! You should have received a copy of the GNU Lesser General Public License
+! along with TensorProductMultigrid (see files COPYING and COPYING.LESSER).
+! If not, see <http://www.gnu.org/licenses/>.
+!
+!=== COPYRIGHT AND LICENSE STATEMENT ===
+
+
+!==================================================================
+!
+! Analytical forms of RHS vectors
+!
+! Eike Mueller, University of Bath, Feb 2012
+!
+!==================================================================
+module profiles
+
+ use communication
+ use parameters
+ use datatypes
+ use discretisation
+
+ implicit none
+
+ public::initialise_u_mnh
+ public::get_u_mnh
+ public::initialise_rhs_mnh
+ public::initialise_rhs
+ public::analytical_solution
+
+private
+ contains
+!==================================================================
+! Initialise U vector
+!==================================================================
+ subroutine initialise_u_mnh(grid_param,model_param,u,KIB,KIE,KIU,KJB,KJE,KJU,KKU,PU)
+ implicit none
+ type(grid_parameters), intent(in) :: grid_param
+ type(model_parameters), intent(in) :: model_param
+ type(scalar3d), intent(inout) :: u
+ integer :: ix, iy, iz, ix_min, ix_max, iy_min, iy_max
+ real(kind=rl) :: x, y, z
+ real(kind=rl) :: rho, sigma, theta, phi, r, b_low, b_up, pi
+
+ integer , optional, intent(in) :: KIB,KIE,KIU,KJB,KJE,KJU,KKU
+ real(kind=rl) , optional, intent(in) :: PU(:,:,:)
+
+ real , dimension(:,:,:) , pointer , contiguous :: zu_st
+
+ ix_min = u%ix_min
+ ix_max = u%ix_max
+ iy_min = u%iy_min
+ iy_max = u%iy_max
+ IF (.NOT. PRESENT(KIB) ) THEN
+ ! Initialise RHS
+ if (LUseO) then
+ do ix=ix_min, ix_max
+ do iy=iy_min, iy_max
+ do iz=1,u%grid_param%nz
+
+ u%s(iz,iy-iy_min+1,ix-ix_min+1) = 0.0_rl
+
+ end do
+ end do
+ end do
+ end if
+ if (LUseT) then
+ zu_st => u%st
+ !$acc kernels loop independent collapse(3)
+ do iz=1,u%grid_param%nz
+ do iy=iy_min, iy_max
+ do ix=ix_min, ix_max
+
+ zu_st(ix-ix_min+1,iy-iy_min+1,iz) = 0.0_rl
+
+ end do
+ end do
+ end do
+ !$acc end kernels
+ end if
+ ELSE
+ ! Initialise RHS
+ if (LUseO) then
+ do ix=ix_min, ix_max
+ do iy=iy_min, iy_max
+ do iz=1,u%grid_param%nz
+ u%s(iz,iy-iy_min+1,ix-ix_min+1) = PU(IX-ix_min+KIB,IY-iy_min+KJB,IZ)
+ end do
+ end do
+ end do
+ end if
+ if (LUseT) then
+ zu_st => u%st
+ !$acc kernels loop independent collapse(3)
+ do iz=1,u%grid_param%nz
+ do iy=iy_min, iy_max
+ do ix=ix_min, ix_max
+ zu_st(ix-ix_min+1,iy-iy_min+1,iz) = PU(IX-ix_min+KIB,IY-iy_min+KJB,IZ)
+ end do
+ end do
+ end do
+ !$acc end kernels
+ end if
+ END IF
+ end subroutine initialise_u_mnh
+!==================================================================
+! Get U vector
+!==================================================================
+ subroutine get_u_mnh(grid_param,model_param,u,KIB,KIE,KIU,KJB,KJE,KJU,KKU,PU)
+ implicit none
+ type(grid_parameters), intent(in) :: grid_param
+ type(model_parameters), intent(in) :: model_param
+ type(scalar3d), intent(inout) :: u
+ integer :: ix, iy, iz, ix_min, ix_max, iy_min, iy_max
+ real(kind=rl) :: x, y, z
+ real(kind=rl) :: rho, sigma, theta, phi, r, b_low, b_up, pi
+
+ integer , optional, intent(in) :: KIB,KIE,KIU,KJB,KJE,KJU,KKU
+ real(kind=rl) , optional, intent(inout) :: PU(:,:,:)
+
+ real , dimension(:,:,:) , pointer , contiguous :: zu_st
+
+ ix_min = u%ix_min
+ ix_max = u%ix_max
+ iy_min = u%iy_min
+ iy_max = u%iy_max
+ IF (.NOT. PRESENT(KIB) ) THEN
+ !
+ ELSE
+ ! Get PU
+ if (LUseO) then
+ do ix=ix_min, ix_max
+ do iy=iy_min, iy_max
+ do iz=1,u%grid_param%nz
+ PU(IX-ix_min+KIB,IY-iy_min+KJB,IZ) = u%s(iz,iy-iy_min+1,ix-ix_min+1)
+ end do
+ end do
+ end do
+ else
+ zu_st => u%st
+ !$acc kernels loop independent collapse(3)
+ do iz=1,u%grid_param%nz
+ do iy=iy_min, iy_max
+ do ix=ix_min, ix_max
+ PU(IX-ix_min+KIB,IY-iy_min+KJB,IZ) = zu_st(ix-ix_min+1,iy-iy_min+1,iz)
+ end do
+ end do
+ end do
+ !$acc end kernels
+ end if
+ END IF
+ end subroutine get_u_mnh
+!==================================================================
+! Initialise RHS vector
+!==================================================================
+ subroutine initialise_rhs_mnh(grid_param,model_param,b,KIB,KIE,KIU,KJB,KJE,KJU,KKU,PY)
+ implicit none
+ type(grid_parameters), intent(in) :: grid_param
+ type(model_parameters), intent(in) :: model_param
+ type(scalar3d), intent(inout) :: b
+ integer :: ix, iy, iz, ix_min, ix_max, iy_min, iy_max
+ real(kind=rl) :: x, y, z
+ real(kind=rl) :: rho, sigma, theta, phi, r, b_low, b_up, pi
+
+ integer , optional, intent(in) :: KIB,KIE,KIU,KJB,KJE,KJU,KKU
+ real(kind=rl) , optional, intent(in) :: PY(:,:,:)
+
+ real , dimension(:,:,:) , pointer , contiguous :: zb_st
+
+ ix_min = b%ix_min
+ ix_max = b%ix_max
+ iy_min = b%iy_min
+ iy_max = b%iy_max
+ IF (.NOT. PRESENT(KIB) ) THEN
+ ! Initialise RHS
+ if (LUseO) then
+ do ix=ix_min, ix_max
+ do iy=iy_min, iy_max
+ do iz=1,b%grid_param%nz
+ x = 1.0_rl*((ix-0.5_rl)/(1.0_rl*b%grid_param%n))
+ y = 1.0_rl*((iy-0.5_rl)/(1.0_rl*b%grid_param%n))
+ z = 1.0_rl*((iz-0.5_rl)/(1.0_rl*b%grid_param%nz))
+
+ b%s(iz,iy-iy_min+1,ix-ix_min+1) = 0.0_rl
+
+ if ( ( x .ge. 0.1_rl ) .and. ( x .le. 0.4_rl ) &
+ .and. (y .ge. 0.3_rl ) .and. ( y .le. 0.6_rl ) &
+ .and. (z .ge. 0.2_rl ) .and. ( z .le. 0.7_rl ) ) &
+ then
+
+ b%s(iz,iy-iy_min+1,ix-ix_min+1) = 1.0_rl
+
+ end if
+
+ end do
+ end do
+ end do
+ endif
+ if (LUseT) then
+ zb_st => b%st
+ !$acc kernels loop independent collapse(3)
+ do iz=1,b%grid_param%nz
+ do iy=iy_min, iy_max
+ do ix=ix_min, ix_max
+ x = 1.0_rl*((ix-0.5_rl)/(1.0_rl*b%grid_param%n))
+ y = 1.0_rl*((iy-0.5_rl)/(1.0_rl*b%grid_param%n))
+ z = 1.0_rl*((iz-0.5_rl)/(1.0_rl*b%grid_param%nz))
+
+ zb_st(ix-ix_min+1,iy-iy_min+1,iz) = 0.0_rl
+
+ if ( ( x .ge. 0.1_rl ) .and. ( x .le. 0.4_rl ) &
+ .and. (y .ge. 0.3_rl ) .and. ( y .le. 0.6_rl ) &
+ .and. (z .ge. 0.2_rl ) .and. ( z .le. 0.7_rl ) ) &
+ then
+
+ zb_st(ix-ix_min+1,iy-iy_min+1,iz) = 1.0_rl
+
+ end if
+
+ end do
+ end do
+ end do
+ !$acc end kernels
+ end if
+ ELSE
+ ! Initialise RHS
+ if (LUseO) then
+ do ix=ix_min, ix_max
+ do iy=iy_min, iy_max
+ do iz=1,b%grid_param%nz
+ b%s(iz,iy-iy_min+1,ix-ix_min+1) = PY(IX-ix_min+KIB,IY-iy_min+KJB,IZ)
+ end do
+ end do
+ end do
+ end if
+ if (LUseT) then
+ zb_st => b%st
+ !$acc kernels loop independent collapse(3)
+ do iz=1,b%grid_param%nz
+ do iy=iy_min, iy_max
+ do ix=ix_min, ix_max
+ zb_st(ix-ix_min+1,iy-iy_min+1,iz) = PY(IX-ix_min+KIB,IY-iy_min+KJB,IZ)
+ end do
+ end do
+ end do
+ !$acc end kernels
+ end if
+ END IF
+ end subroutine initialise_rhs_mnh
+!==================================================================
+! Initialise RHS vector
+!==================================================================
+ subroutine initialise_rhs(grid_param,model_param,b)
+ implicit none
+ type(grid_parameters), intent(in) :: grid_param
+ type(model_parameters), intent(in) :: model_param
+ type(scalar3d), intent(inout) :: b
+ integer :: ix, iy, iz, ix_min, ix_max, iy_min, iy_max
+ real(kind=rl) :: x, y, z
+ real(kind=rl) :: rho, sigma, theta, phi, r, b_low, b_up, pi
+
+#ifdef TESTCONVERGENCE
+ real(kind=rl) :: px,py,pz
+#endif
+
+ ix_min = b%ix_min
+ ix_max = b%ix_max
+ iy_min = b%iy_min
+ iy_max = b%iy_max
+ b_low = 1.0_rl+0.25*b%grid_param%H
+ b_up = 1.0_rl+0.75*b%grid_param%H
+ pi = 4.0_rl*atan2(1.0_rl,1.0_rl)
+ ! Initialise RHS
+ do ix=ix_min, ix_max
+ do iy=iy_min, iy_max
+ do iz=1,b%grid_param%nz
+ x = 1.0_rl*((ix-0.5_rl)/(1.0_rl*b%grid_param%n))
+ y = 1.0_rl*((iy-0.5_rl)/(1.0_rl*b%grid_param%n))
+ z = 1.0_rl*((iz-0.5_rl)/(1.0_rl*b%grid_param%nz))
+#ifdef TESTCONVERGENCE
+ ! RHS for analytical solution x*(1-x)*y*(1-y)*z*(1-z)
+ if (grid_param%vertbc == VERTBC_DIRICHLET) then
+ px = x*(1.0_rl-x)
+ py = y*(1.0_rl-y)
+ pz = z*(1.0_rl-z)
+ b%s(iz,iy-iy_min+1,ix-ix_min+1) = &
+ ( 2.0_rl*model_param%omega2*((px+py)*pz &
+ + model_param%lambda2*px*py)+model_param%delta*px*py*pz)
+ else
+ px = x*(1.0_rl-x)
+ py = y*(1.0_rl-y)
+ pz = 1.0_rl
+ b%s(iz,iy-iy_min+1,ix-ix_min+1) = &
+ ( 2.0_rl*model_param%omega2*((px+py)*pz)+model_param%delta*px*py*pz)
+ end if
+#else
+ b%s(iz,iy-iy_min+1,ix-ix_min+1) = 0.0_rl
+#ifdef CARTESIANGEOMETRY
+ if ( ( x .ge. 0.1_rl ) .and. ( x .le. 0.4_rl ) &
+ .and. (y .ge. 0.3_rl ) .and. ( y .le. 0.6_rl ) &
+ .and. (z .ge. 0.2_rl ) .and. ( z .le. 0.7_rl ) ) &
+ then
+ b%s(iz,iy-iy_min+1,ix-ix_min+1) = 1.0_rl
+ end if
+#else
+ rho = 2.0_rl*(1.0_rl*ix-0.5_rl)/grid_param%n-1.0_rl
+ sigma = 2.0_rl*(1.0_rl*iy-0.5_rl)/grid_param%n-1.0_rl
+ phi = atan(sigma)
+ theta = atan(rho/sqrt(1.0_rl+sigma**2))
+ x = sin(theta)
+ y = cos(theta)*sin(phi)
+ z = cos(theta)*cos(phi)
+ phi = atan2(x,y)
+ theta = atan2(sqrt(x**2+y**2),z)
+ r = 0.5_rl*(r_grid(iz)+r_grid(iz+1))
+ if (( (r > b_low) .and. (r < b_up) ) .and. &
+ (((theta>pi/10.0_rl) .and. (theta<pi/5.0_rl )) .or. &
+ ((theta>3.0_rl*pi/8.0_rl) .and. (theta<5.0_rl*pi/8.0_rl )) .or. &
+ ((theta>4.0_rl*pi/5.0_rl) .and. (theta<9.0_rl*pi/10.0_rl)))) then
+ b%s(iz,iy-iy_min+1,ix-ix_min+1) = 1.0_rl
+ end if
+! RHS used in GPU code:
+! if ( (r > b_low) .and. (r < b_up) .and. &
+! (rho > -0.5) .and. (rho < 0.5) .and. &
+! (sigma > -0.5).and. (sigma < 0.5) ) then
+! b%s(iz,iy-iy_min+1,ix-ix_min+1) = 1.0_rl
+! end if
+#endif
+#endif
+ end do
+ end do
+ end do
+ end subroutine initialise_rhs
+!==================================================================
+! Exact solution for test problem
+! u(x,y,z) = x*(1-x)*y*(1-y)*z*(1-z)
+!==================================================================
+ subroutine analytical_solution(grid_param,u)
+ implicit none
+ type(grid_parameters), intent(in) :: grid_param
+ type(scalar3d), intent(inout) :: u
+ integer :: ix, iy, iz, ix_min, ix_max, iy_min, iy_max
+ real(kind=rl) :: x, y, z
+
+ ix_min = u%ix_min
+ ix_max = u%ix_max
+ iy_min = u%iy_min
+ iy_max = u%iy_max
+
+ ! Initialise RHS
+ do ix=ix_min, ix_max
+ do iy=iy_min, iy_max
+ do iz=1,u%grid_param%nz
+ x = u%grid_param%L*((ix-0.5_rl)/(1.0_rl*u%grid_param%n))
+ y = u%grid_param%L*((iy-0.5_rl)/(1.0_rl*u%grid_param%n))
+ z = u%grid_param%H*((iz-0.5_rl)/(1.0_rl*u%grid_param%nz))
+ if (grid_param%vertbc == VERTBC_DIRICHLET) then
+ u%s(iz,iy-iy_min+1,ix-ix_min+1) &
+ = x*(1.0_rl-x) &
+ * y*(1.0_rl-y) &
+ * z*(1.0_rl-z)
+ else
+ u%s(iz,iy-iy_min+1,ix-ix_min+1) &
+ = x*(1.0_rl-x) &
+ * y*(1.0_rl-y)
+ end if
+ end do
+ end do
+ end do
+ end subroutine analytical_solution
+
+end module profiles
diff --git a/src/ZSOLVER/tensorproductmultigrid_Source/solver.f90 b/src/ZSOLVER/tensorproductmultigrid_Source/solver.f90
new file mode 100644
index 0000000000000000000000000000000000000000..97f5a7b840cc0030902eaf39b55bb1d9c0460041
--- /dev/null
+++ b/src/ZSOLVER/tensorproductmultigrid_Source/solver.f90
@@ -0,0 +1,61 @@
+!=== COPYRIGHT AND LICENSE STATEMENT ===
+!
+! This file is part of the TensorProductMultigrid code.
+!
+! (c) The copyright relating to this work is owned jointly by the
+! Crown, Met Office and NERC [2014]. However, it has been created
+! with the help of the GungHo Consortium, whose members are identified
+! at https://puma.nerc.ac.uk/trac/GungHo/wiki .
+!
+! Main Developer: Eike Mueller
+!
+! TensorProductMultigrid is free software: you can redistribute it and/or
+! modify it under the terms of the GNU Lesser General Public License as
+! published by the Free Software Foundation, either version 3 of the
+! License, or (at your option) any later version.
+!
+! TensorProductMultigrid is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU Lesser General Public License for more details.
+!
+! You should have received a copy of the GNU Lesser General Public License
+! along with TensorProductMultigrid (see files COPYING and COPYING.LESSER).
+! If not, see <http://www.gnu.org/licenses/>.
+!
+!=== COPYRIGHT AND LICENSE STATEMENT ===
+
+
+!==================================================================
+!
+! Solver parameters
+!
+! Eike Mueller, University of Bath, May 2012
+!
+!==================================================================
+module solver
+
+ use parameters
+ use datatypes
+
+ implicit none
+
+public::solver_parameters
+public::SOLVER_RICHARDSON
+public::SOLVER_CG
+
+private
+
+ integer, parameter :: SOLVER_RICHARDSON = 1
+ integer, parameter :: SOLVER_CG = 2
+
+
+ ! --- Solver parameters ---
+ type solver_parameters
+ integer :: solvertype ! Type of solver
+ real(kind=rl) :: resreduction ! Required relative residual reduction
+ integer :: maxiter ! Maximal number of iterations
+ end type solver_parameters
+
+end module solver
+
diff --git a/src/ZSOLVER/tensorproductmultigrid_Source/timer.f90 b/src/ZSOLVER/tensorproductmultigrid_Source/timer.f90
new file mode 100644
index 0000000000000000000000000000000000000000..da0f17907a28016c0aad1fee4b78d348cf72ecfd
--- /dev/null
+++ b/src/ZSOLVER/tensorproductmultigrid_Source/timer.f90
@@ -0,0 +1,193 @@
+!=== COPYRIGHT AND LICENSE STATEMENT ===
+!
+! This file is part of the TensorProductMultigrid code.
+!
+! (c) The copyright relating to this work is owned jointly by the
+! Crown, Met Office and NERC [2014]. However, it has been created
+! with the help of the GungHo Consortium, whose members are identified
+! at https://puma.nerc.ac.uk/trac/GungHo/wiki .
+!
+! Main Developer: Eike Mueller
+!
+! TensorProductMultigrid is free software: you can redistribute it and/or
+! modify it under the terms of the GNU Lesser General Public License as
+! published by the Free Software Foundation, either version 3 of the
+! License, or (at your option) any later version.
+!
+! TensorProductMultigrid is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU Lesser General Public License for more details.
+!
+! You should have received a copy of the GNU Lesser General Public License
+! along with TensorProductMultigrid (see files COPYING and COPYING.LESSER).
+! If not, see <http://www.gnu.org/licenses/>.
+!
+!=== COPYRIGHT AND LICENSE STATEMENT ===
+
+
+!==================================================================
+!
+! Timer module
+!
+! Eike Mueller, University of Bath, Feb 2012
+!
+!==================================================================
+
+module timer
+
+#ifndef MNH
+ use mpi
+#else
+ use modd_mpif
+#endif
+ use parameters
+
+ implicit none
+
+public::initialise_timing
+public::finalise_timing
+public::time
+public::initialise_timer
+public::start_timer
+public::finish_timer
+public::print_timerinfo
+public::print_elapsed
+
+private
+
+! Timer type
+ type time
+ character(len=32) :: label
+ real(kind=rl) :: start
+ real(kind=rl) :: finish
+ integer :: ncall
+ real(kind=rl) :: elapsed
+ end type time
+
+ ! id of timer output file
+ integer, parameter :: TIMEROUT = 9
+
+ ! used my MPI
+ integer :: rank, ierr
+
+contains
+
+!==================================================================
+! Initialise timer module
+!==================================================================
+ subroutine initialise_timing(filename)
+ implicit none
+ character(len=*), intent(in) :: filename
+ call mpi_comm_rank(MPI_COMM_WORLD,rank,ierr)
+ if (rank==0) then
+ open(UNIT=TIMEROUT,FILE=trim(filename))
+ write(STDOUT,'("Writing timer information to file ",A40)') filename
+ write(TIMEROUT,'("# ----------------------------------------------")')
+ write(TIMEROUT,'("# Timer information for geometric multigrid code")')
+ write(TIMEROUT,'("# ----------------------------------------------")')
+ end if
+ end subroutine initialise_timing
+
+!==================================================================
+! Finalise timer module
+!==================================================================
+ subroutine finalise_timing()
+ implicit none
+ if (rank==0) then
+ close(TIMEROUT)
+ end if
+ end subroutine finalise_timing
+
+!==================================================================
+! Initialise timer
+!==================================================================
+ subroutine initialise_timer(t,label)
+ implicit none
+ type(time), intent(inout) :: t
+ character(len=*), intent(in) :: label
+ t%label = label
+ t%start = 0.0_rl
+ t%ncall = 0
+ t%finish = 0.0_rl
+ t%elapsed = 0.0_rl
+ end subroutine initialise_timer
+
+!==================================================================
+! Start timer
+!==================================================================
+ subroutine start_timer(t)
+ implicit none
+ type(time), intent(inout) :: t
+ t%start = mpi_wtime()
+ end subroutine start_timer
+
+!==================================================================
+! Finish timer
+!==================================================================
+ subroutine finish_timer(t)
+ implicit none
+ type(time), intent(inout) :: t
+ t%finish = mpi_wtime()
+ t%elapsed = t%elapsed + (t%finish-t%start)
+ t%ncall = t%ncall + 1
+ end subroutine finish_timer
+
+!==================================================================
+! Print to timer file
+!==================================================================
+ subroutine print_timerinfo(msg)
+ implicit none
+ character(len=*), intent(in) :: msg
+ if (rank == 0) then
+ write(TIMEROUT,*) "# " // trim(msg)
+ end if
+ end subroutine print_timerinfo
+
+!==================================================================
+! Print timer information
+!==================================================================
+ subroutine print_elapsed(t,summaryonly,factor)
+ implicit none
+ type(time), intent(in) :: t
+ logical, intent(in) :: summaryonly
+ real(kind=rl), intent(in) :: factor
+ real(kind=rl) :: elapsedtime
+ real(kind=rl) :: t_min
+ real(kind=rl) :: t_max
+ real(kind=rl) :: t_avg
+ integer :: rank, nprocs, ierr
+ integer :: nc
+
+ t_min = 0.0_rl
+ t_max = 0.0_rl
+ t_avg = 0.0_rl
+
+
+ elapsedtime = (t%elapsed) * factor
+ call mpi_reduce(elapsedtime,t_min,1,MPI_DOUBLE_PRECISION, &
+ MPI_MIN, 0, MPI_COMM_WORLD,ierr)
+ call mpi_reduce(elapsedtime,t_avg,1,MPI_DOUBLE_PRECISION, &
+ MPI_SUM, 0, MPI_COMM_WORLD,ierr)
+ call mpi_reduce(elapsedtime,t_max,1,MPI_DOUBLE_PRECISION, &
+ MPI_MAX, 0, MPI_COMM_WORLD,ierr)
+ call mpi_comm_size(MPI_COMM_WORLD,nprocs,ierr)
+ call mpi_comm_rank(MPI_COMM_WORLD,rank,ierr)
+ t_avg = t_avg/nprocs
+ nc = t%ncall
+ if (nc == 0) nc = 1
+ if (summaryonly) then
+ if (rank == 0) then
+ write(TIMEROUT,'(A32," [",I7,"]: ",E10.4," / ",E10.4," / ",E10.4," (min/avg/max)")') &
+ t%label,t%ncall,t_min,t_avg,t_max
+ write(TIMEROUT,'(A32," t/call: ",E10.4," / ",E10.4," / ",E10.4," (min/avg/max)")') &
+ t%label,t_min/nc,t_avg/nc,t_max/nc
+ end if
+ else
+ write(TIMEROUT,'(A32," : ",I8," calls ",E10.4," (rank ",I8,")")') &
+ t%label,elapsedtime, rank
+ end if
+ write(TIMEROUT,'("")')
+ end subroutine print_elapsed
+
+end module timer
diff --git a/src/ZSOLVER/tridz.f90 b/src/ZSOLVER/tridz.f90
new file mode 100644
index 0000000000000000000000000000000000000000..203c413f8251bcfb5bd4d6e242198a7923efd16d
--- /dev/null
+++ b/src/ZSOLVER/tridz.f90
@@ -0,0 +1,848 @@
+!MNH_LIC Copyright 1994-2019 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.
+!-----------------------------------------------------------------
+! ################
+ MODULE MODI_TRIDZ
+! ################
+!
+INTERFACE
+!
+ SUBROUTINE TRIDZ(HLBCX,HLBCY, &
+ PMAP,PDXHAT,PDYHAT,HPRESOPT, &
+ PDXHATM,PDYHATM,PRHOM, &
+ PAF,PCF,PTRIGSX,PTRIGSY,KIFAXX,KIFAXY, &
+ PRHODJ,PTHVREF,PZZ,PBFY,PBFB, &
+ PBF_SXP2_YP1_Z, &
+ PAF_ZS,PBF_ZS,PCF_ZS, &
+ PDXATH_ZS,PDYATH_ZS,PRHO_ZS, &
+ A_K,B_K,C_K,D_K) !JUAN FULL ZSOLVER
+!
+IMPLICIT NONE
+!
+CHARACTER (LEN=4), DIMENSION(2), INTENT(IN) :: HLBCX ! x-direction LBC type
+CHARACTER (LEN=4), DIMENSION(2), INTENT(IN) :: HLBCY ! y-direction LBC type
+!
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODJ ! density of reference * J
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PTHVREF ! Virtual Potential
+ ! Temperature of the reference state
+!
+REAL, DIMENSION(:,:), INTENT(IN) :: PMAP ! scale factor
+!
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PZZ ! height z
+!
+REAL, DIMENSION(:), INTENT(IN) :: PDXHAT ! Stretching in x direction
+REAL, DIMENSION(:), INTENT(IN) :: PDYHAT ! Stretching in y direction
+CHARACTER (LEN=5), INTENT(IN) :: HPRESOPT ! choice of the pressure solver
+!
+REAL, INTENT(OUT) :: PDXHATM ! mean grid increment in the x
+ ! direction
+REAL, INTENT(OUT) :: PDYHATM ! mean grid increment in the y
+ ! direction
+!
+REAL, DIMENSION (:), INTENT(OUT) :: PRHOM ! mean of XRHODJ on the plane
+ ! x y localized at a mass
+ ! level
+!
+REAL, DIMENSION(:), INTENT(OUT) :: PAF,PCF ! vectors giving the nonvanishing
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PBFY ! elements (yslice) of the tri-diag.
+ ! matrix in the pressure eq.
+!JUAN
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PBFB ! elements (bsplit slide) of the tri-diag.
+ ! matrix in the pressure eq.
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PBF_SXP2_YP1_Z ! elements of the tri-diag. SXP2_YP1_Z-slide
+ ! matrix in the pressure eq
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PAF_ZS,PBF_ZS,PCF_ZS
+REAL, DIMENSION(:,:) , INTENT(OUT) :: PDXATH_ZS,PDYATH_ZS
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PRHO_ZS
+REAL, DIMENSION(:) , INTENT(OUT) :: A_K,B_K,C_K,D_K
+!JUAN
+!
+ ! arrays of sin or cos values
+ ! for the FFT :
+REAL, DIMENSION(:), INTENT(OUT) :: PTRIGSX ! - along x
+REAL, DIMENSION(:), INTENT(OUT) :: PTRIGSY ! - along y
+!
+ ! decomposition in prime
+ ! numbers for the FFT:
+INTEGER, DIMENSION(19), INTENT(OUT) :: KIFAXX ! - along x
+INTEGER, DIMENSION(19), INTENT(OUT) :: KIFAXY ! - along y
+
+!
+END SUBROUTINE TRIDZ
+!
+END INTERFACE
+!
+END MODULE MODI_TRIDZ
+!
+! ###################################################################
+ SUBROUTINE TRIDZ(HLBCX,HLBCY, &
+ PMAP,PDXHAT,PDYHAT,HPRESOPT, &
+ PDXHATM,PDYHATM,PRHOM, &
+ PAF,PCF,PTRIGSX,PTRIGSY,KIFAXX,KIFAXY, &
+ PRHODJ,PTHVREF,PZZ,PBFY,PBFB, &
+ PBF_SXP2_YP1_Z, &
+ PAF_ZS,PBF_ZS,PCF_ZS, &
+ PDXATH_ZS,PDYATH_ZS,PRHO_ZS, &
+ A_K,B_K,C_K,D_K) !JUAN FULL ZSOLVER
+! ####################################################################
+!
+!!**** *TRIDZ * - Compute coefficients for the flat operator
+!!
+!! PURPOSE
+!! -------
+! The purpose of this routine is to compute the vertical time independent
+! coefficients a(k), b(k), c(k) required for the calculation of the "flat"
+! (i.e. neglecting the orography) operator Laplacian. RHOJ is averaged on
+! the whole horizontal domain. The form of the eigenvalues of the flat
+! operator depends on the lateral boundary conditions. Furthermore, this
+! routine initializes TRIGS and IFAX arrays required for the FFT transform
+! used in the routine PRECOND.
+!
+!!** METHOD
+!! ------
+!! The forms of the eigenvalues of the horizontal Laplacian are given by:
+!! Cyclic conditions:
+!! -----------------
+!! <rhoj> 2 ( pi ) <rhoj> 2 ( pi )
+!! b(m,n) = -4 ----------- sin (----- m ) -4 ----------- sin (----- n )
+!! <dxx> <dxx> ( imax ) <dyy> <dyy> ( jmax )
+!!
+!! Open conditions:
+!! -----------------
+!! <rhoj> 2 ( pi ) <rhoj> 2 ( pi )
+!! b(m,n) = -4 ----------- sin (----- m ) -4 ----------- sin (----- n )
+!! <dxx> <dxx> ( 2imax ) <dyy> <dyy> ( 2jmax )
+!!
+!! Cyclic condition along x and open condition along y:
+!! ------------------------------------------------------
+!! <rhoj> 2 ( pi ) <rhoj> 2 ( pi )
+!! b(m,n) = -4 ----------- sin (----- m ) -4 ----------- sin (----- n )
+!! <dxx> <dxx> ( imax ) <dyy> <dyy> ( 2jmax )
+!!
+!! Open condition along x and cyclic condition along y:
+!! ------------------------------------------------------
+!! <rhoj> 2 ( pi ) <rhoj> 2 ( pi )
+!! b(m,n) = -4 ----------- sin (----- m ) -4 ----------- sin (----- n )
+!! <dxx> <dxx> ( 2imax ) <dyy> <dyy> ( jmax )
+!!
+!! where m = 0,1,2....imax-1, n = 0,1,2....jmax-1
+!! Note that rhoj contains the Jacobian J = Deltax*Deltay*Deltaz = volume of
+!! an elementary mesh.
+
+!!
+!! EXTERNAL
+!! --------
+!! Function FFTFAX: initialization of TRIGSX,IFAXX,TRIGSY,IFAXY for
+!! the FFT transform
+!! GET_DIM_EXT_ll : get extended sub-domain sizes
+!! GET_INDICE_ll : get physical sub-domain bounds
+!! GET_DIM_PHYS_ll : get physical sub-domain sizes
+!! GET_GLOBALDIMS_ll : get physical global domain sizes
+!! GET_OR_ll : get origine coordonates of the physical sub-domain in global indices
+!! REDUCESUM_ll : sum into a scalar variable
+!! GET_SLICE_ll : get a slice of the global domain
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module MODD_CST : define constants
+!! XPI : pi
+!! XCPD
+!! Module MODD_PARAMETERS: declaration of parameter variables
+!! JPHEXT, JPVEXT: define the number of marginal points out of the
+!! physical domain along horizontal and vertical directions respectively
+!! Module MODD_CONF: model configurations
+!! LCARTESIAN: logical for CARTESIAN geometry
+!! .TRUE. = Cartesian geometry used
+!! L2D: logical for 2D model version
+!!
+!! REFERENCE
+!! ---------
+!! Book2 of documentation (routine TRIDZ)
+!!
+!! AUTHOR
+!! ------
+!! P. HÃ…reil and J. Stein * Meteo France *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 25/07/94
+!! 14/04/95 (J. Stein) bug in the ZDZM computation
+!! ( stretched case)
+!! 8/07/96 (P. Jabouille) change the FFT initialization
+!! which now works for odd number.
+!! 14/01/97 Durran anelastic equation (Stein,Lafore)
+!! 15/06/98 (D.Lugato, R.Guivarch) Parallelisation
+!! 10/08/98 (N. Asencio) add parallel code
+!! use PDXHAT, PDYHAT and not PXHAT,PYHAT
+!! PBFY is initialized
+!! 20/08/00 (J. Stein, J. Escobar) optimisation of the solver
+!! PBFY transposition
+!! 14/03/02 (P. Jabouille) set values for meaningless spectral coefficients
+!! (to avoid problem in bouissinesq configuration)
+!! J.Escobar : 15/09/2015 : WENO5 & JPHEXT <> 1
+!! Philippe Wautelet: 05/2016-04/2018: new data structures and calls for I/O
+!------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+USE MODD_CST
+USE MODD_CONF
+USE MODD_LUNIT_n, ONLY: TLUOUT
+USE MODD_PARAMETERS
+!
+USE MODE_ll
+USE MODE_MSG
+!JUAN P1/P2 SPLITTING
+USE MODE_SPLITTINGZ_ll , ONLY : GET_DIM_EXTZ_ll,GET_ORZ_ll,LWESTZ_ll,LSOUTHZ_ll
+!JUAN
+!
+!JUAN
+USE MODE_REPRO_SUM
+!JUAN
+USE MODE_MPPDB
+!
+USE mode_mg_main_mnh
+!
+IMPLICIT NONE
+!
+!
+!* 0.1 declarations of arguments
+!
+!
+!
+CHARACTER (LEN=4), DIMENSION(2), INTENT(IN) :: HLBCX ! x-direction LBC type
+CHARACTER (LEN=4), DIMENSION(2), INTENT(IN) :: HLBCY ! y-direction LBC type
+!
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODJ ! density of reference * J
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PTHVREF ! Virtual Potential
+ ! Temperature of the reference state
+!
+REAL, DIMENSION(:,:), INTENT(IN) :: PMAP ! scale factor
+!
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PZZ ! height z
+!
+REAL, DIMENSION(:), INTENT(IN) :: PDXHAT ! Stretching in x direction
+REAL, DIMENSION(:), INTENT(IN) :: PDYHAT ! Stretching in y direction
+CHARACTER (LEN=5), INTENT(IN) :: HPRESOPT ! choice of the pressure solver
+!
+REAL, INTENT(OUT) :: PDXHATM ! mean grid increment in the x
+ ! direction
+REAL, INTENT(OUT) :: PDYHATM ! mean grid increment in the y
+ ! direction
+!
+REAL, DIMENSION (:), INTENT(OUT) :: PRHOM ! mean of XRHODJ on the plane
+ ! x y localized at a mass
+ ! level
+!
+REAL, DIMENSION(:), INTENT(OUT) :: PAF,PCF ! vectors giving the nonvanishing
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PBFY ! elements (yslice) of the tri-diag.
+! matrix in the pressure eq. which is transposed. PBFY is a y-slices structure
+!JUAN
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PBFB ! elements (bsplit slide) of the tri-diag.
+ ! matrix in the pressure eq.
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PBF_SXP2_YP1_Z ! elements of the tri-diag. SXP2_YP1_Z-slide
+ ! matrix in the pressure eq.
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PAF_ZS,PBF_ZS,PCF_ZS
+REAL, DIMENSION(:,:) , INTENT(OUT) :: PDXATH_ZS,PDYATH_ZS
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PRHO_ZS
+REAL, DIMENSION(:) , INTENT(OUT) :: A_K,B_K,C_K,D_K
+!JUAN
+!
+ ! arrays of sin or cos values
+ ! for the FFT :
+REAL, DIMENSION(:), INTENT(OUT) :: PTRIGSX ! - along x
+REAL, DIMENSION(:), INTENT(OUT) :: PTRIGSY ! - along y
+!
+ ! decomposition in prime
+ ! numbers for the FFT:
+INTEGER, DIMENSION(19), INTENT(OUT) :: KIFAXX ! - along x
+INTEGER, DIMENSION(19), INTENT(OUT) :: KIFAXY ! - along y
+
+!
+!* 0.2 declarations of local variables
+!
+INTEGER :: IRESP ! FM return code
+INTEGER :: ILUOUT ! Logical unit number for
+ ! output-listing
+INTEGER :: IIB,IIE,IJB,IJE,IKB,IKE ! indice values of the physical subdomain
+INTEGER :: IKU , IKBE ! size of the arrays along z
+INTEGER :: IIB_ll,IIE_ll,IJB_ll,IJE_ll ! indice values of the physical global domain
+INTEGER :: IIMAX,IJMAX ! Number of points of the physical subdomain
+INTEGER :: IIMAX_ll,IJMAX_ll ! Number of points of Global physical domain
+!
+INTEGER :: JI,JJ,JK ! loop indexes
+!
+INTEGER :: INN ! temporary result for the computation of array TRIGS
+!
+REAL, DIMENSION (:,:), ALLOCATABLE :: ZEIGEN_ll ! eigenvalues b(m,n) in global representation
+REAL, DIMENSION (:), ALLOCATABLE :: ZEIGENX_ll ! used for the computation of ZEIGEN_ll
+!
+REAL, DIMENSION( SIZE(PDXHAT)) :: ZWORKX ! work array to compute PDXHATM
+REAL, DIMENSION( SIZE(PDYHAT)) :: ZWORKY ! work array to compute PDYHATM
+!
+REAL :: ZGWNX,ZGWNY ! greater wave numbers allowed by the model
+ ! configuration in x and y directions respectively
+!
+REAL, DIMENSION (SIZE(PZZ,3)) :: ZDZM ! mean of deltaz on the plane x y
+ ! localized at a w-level
+!
+REAL :: ZANGLE,ZDEL ! needed for the initialization of the arrays used by the FFT
+!
+REAL :: ZINVMEAN ! inverse of inner points number in an horizontal grid
+!
+INTEGER :: IINFO_ll ! return code of parallel routine
+REAL, DIMENSION (SIZE(PMAP,1)) :: ZXMAP ! extraction of PMAP array along x
+REAL, DIMENSION (SIZE(PMAP,2)) :: ZYMAP ! extraction of PMAP array along y
+INTEGER :: IORXY_ll,IORYY_ll ! origin's coordinates of the y-slices subdomain
+INTEGER :: IIUY_ll,IJUY_ll ! dimensions of the y-slices subdomain
+INTEGER :: IXMODE_ll,IYMODE_ll ! number of modes in the x and y direction for global point of view
+INTEGER :: IXMODEY_ll,IYMODEY_ll ! number of modes in the x and y direction for y_slice point of view
+!JUAN Z_SPLITTING
+INTEGER :: IORXB_ll,IORYB_ll ! origin's coordinates of the b-slices subdomain
+INTEGER :: IIUB_ll,IJUB_ll ! dimensions of the b-slices subdomain
+INTEGER :: IXMODEB_ll,IYMODEB_ll ! number of modes in the x and y direction for b_slice point of view
+!
+INTEGER :: IORX_SXP2_YP1_Z_ll,IORY_SXP2_YP1_Z_ll ! origin's coordinates of the b-slices subdomain
+INTEGER :: IIU_SXP2_YP1_Z_ll,IJU_SXP2_YP1_Z_ll,IKU_SXP2_YP1_Z_ll ! dimensions of the b-slices subdomain
+INTEGER :: IXMODE_SXP2_YP1_Z_ll,IYMODE_SXP2_YP1_Z_ll ! number of modes in the x and y direction for b_slice point of view
+!JUAN Z_SPLITTING
+!JUAN16
+!TYPE(DOUBLE_DOUBLE) , DIMENSION (SIZE(PZZ,3)) :: ZRHOM_ll , ZDZM_ll
+REAL, ALLOCATABLE, DIMENSION(:,:) :: ZRHOM_2D , ZDZM_2D
+REAL, ALLOCATABLE, DIMENSION(:,:,:) :: ZDZM_ZS
+!JUAN16
+!
+!
+!
+!
+!
+!------------------------------------------------------------------------------
+!
+!* 1. INITIALIZATION
+! --------------
+!
+!* 1.1 retrieve a logical unit number
+! ------------------------------
+!
+ILUOUT = TLUOUT%NLU
+!
+!* 1.2 compute loop bounds
+! -------------------
+!
+! extended sub-domain
+CALL GET_DIM_EXT_ll ('Y',IIUY_ll,IJUY_ll)
+!JUAN Z_SPLITTING
+CALL GET_DIM_EXT_ll ('B',IIUB_ll,IJUB_ll)
+! P1/P2 splitting
+CALL GET_DIM_EXTZ_ll('SXP2_YP1_Z',IIU_SXP2_YP1_Z_ll,IJU_SXP2_YP1_Z_ll,IKU_SXP2_YP1_Z_ll)
+!JUAN Z_SPLITTING
+IKU=SIZE(PRHODJ,3)
+!
+CALL GET_INDICE_ll (IIB,IJB,IIE,IJE)
+IKB=1 +JPVEXT
+IKE=IKU -JPVEXT
+! physical sub-domain
+CALL GET_DIM_PHYS_ll ( 'B',IIMAX,IJMAX)
+!
+! global physical domain limits
+CALL GET_GLOBALDIMS_ll ( IIMAX_ll, IJMAX_ll)
+IIB_ll = 1 + JPHEXT
+IIE_ll = IIMAX_ll + JPHEXT
+IJB_ll = 1 + JPHEXT
+IJE_ll = IJMAX_ll + JPHEXT
+!
+! the use of local array ZEIGENX and ZEIGEN would require some technical modifications
+!
+ALLOCATE (ZEIGENX_ll(IIMAX_ll+2*JPHEXT))
+ALLOCATE (ZEIGEN_ll(IIMAX_ll+2*JPHEXT,IJMAX_ll+2*JPHEXT))
+
+ZEIGEN_ll = 0.0
+! Get the origin coordinates of the extended sub-domain in global landmarks
+CALL GET_OR_ll('Y',IORXY_ll,IORYY_ll)
+!JUAN Z_SPLITING
+CALL GET_OR_ll('B',IORXB_ll,IORYB_ll)
+! P1/P2 Splitting
+CALL GET_ORZ_ll('SXP2_YP1_Z',IORX_SXP2_YP1_Z_ll,IORY_SXP2_YP1_Z_ll)
+!JUAN Z_SPLITING
+!
+!* 1.3 allocate x-slice array
+
+!
+!* 1.4 variables for the eigenvalues computation
+!
+ZGWNX = XPI/REAL(IIMAX_ll)
+ZGWNY = XPI/REAL(IJMAX_ll)
+!
+!------------------------------------------------------------------------------
+!
+!* 2. COMPUTE THE AVERAGE OF RHOJ*CPD*THETAVREF ALONG XY
+! --------------------------------------------------
+!
+ZINVMEAN = 1./REAL(IIMAX_ll*IJMAX_ll)
+!JUAN16
+ALLOCATE(ZRHOM_2D(IIB:IIE, IJB:IJE))
+PRHO_ZS = 1.0
+!
+DO JK = 1,SIZE(PZZ,3)
+ IF ( CEQNSYS == 'DUR' .OR. CEQNSYS == 'MAE' ) THEN
+ DO JJ = IJB,IJE
+ DO JI = IIB,IIE
+ ZRHOM_2D(JI,JJ) = PRHODJ(JI,JJ,JK)*XCPD*PTHVREF(JI,JJ,JK)
+ PRHO_ZS(JI,JJ,JK) = ZRHOM_2D(JI,JJ)
+ END DO
+ END DO
+ ELSEIF ( CEQNSYS == 'LHE' ) THEN
+ DO JJ = IJB,IJE
+ DO JI = IIB,IIE
+ ZRHOM_2D(JI,JJ) = PRHODJ(JI,JJ,JK)
+ PRHO_ZS(JI,JJ,JK) = ZRHOM_2D(JI,JJ)
+ END DO
+ END DO
+ END IF
+ ! global sum
+ PRHOM(JK) = SUM_DD_R2_ll(ZRHOM_2D) * ZINVMEAN
+END DO
+
+!
+!------------------------------------------------------------------------------
+!
+!* 3. COMPUTE THE MEAN INCREMENT BETWEEN Z LEVELS
+! -------------------------------------------
+!
+ALLOCATE(ZDZM_2D(IIB:IIE, IJB:IJE))
+ALLOCATE(ZDZM_ZS(IIB:IIE, IJB:IJE,IKU))
+ZDZM_ZS = 1.0
+!
+DO JK = IKB-1,IKE
+ DO JJ = IJB,IJE
+ DO JI = IIB,IIE
+ ZDZM_2D(JI,JJ) = (PZZ(JI,JJ,JK+1)-PZZ(JI,JJ,JK))
+ ZDZM_ZS(JI,JJ,JK) = ZDZM_2D(JI,JJ)
+ END DO
+ END DO
+ ZDZM(JK) = SUM_DD_R2_ll(ZDZM_2D) * ZINVMEAN
+END DO
+ZDZM(IKE+1) = ZDZM(IKE)
+ZDZM_ZS(:,:,IKE+1) = ZDZM_ZS(:,:,IKE)
+!
+! vertical average to arrive at a w-level
+DO JK = IKE+1,IKB,-1
+ ZDZM(JK) = (ZDZM(JK) + ZDZM(JK-1))*0.5
+ ZDZM_ZS(IIB:IIE,IJB:IJE,JK) = (ZDZM_ZS(IIB:IIE,IJB:IJE,JK) + ZDZM_ZS(IIB:IIE,IJB:IJE,JK-1)) * 0.5
+END DO
+!
+ZDZM(IKB-1) = -999.
+ZDZM_ZS(IIB:IIE,IJB:IJE,IKB-1) = -999.
+!
+!------------------------------------------------------------------------------
+!
+!* 4. COMPUTE THE MEAN INCREMENT BETWEEN X LEVELS
+! -------------------------------------------
+!
+PDXHATM =0.
+! . local sum
+IF (LCARTESIAN) THEN
+ PDXHATM = SUM_1DFIELD_ll ( PDXHAT,'X',IIB_ll,IIE_ll,IINFO_ll)
+ DO JJ=1,SIZE(PDXATH_ZS,2)
+ PDXATH_ZS(:,JJ) = PDXHAT(:)
+ END DO
+ELSE
+ ! Extraction of x-slice PMAP at j=(IJB_ll+IJE_ll)/2
+ CALL GET_SLICE_ll (PMAP,'X',(IJB_ll+IJE_ll)/2,ZXMAP(IIB:IIE) &
+ ,IIB,IIE,IINFO_ll)
+ ! initialize the work array = PDXHAT/ZXMAP
+ ZWORKX(IIB:IIE) = PDXHAT(IIB:IIE)/ ZXMAP (IIB:IIE)
+ PDXHATM = SUM_1DFIELD_ll ( ZWORKX,'X',IIB_ll,IIE_ll,IINFO_ll)
+ DO JJ=1,SIZE(PDXATH_ZS,2)
+ PDXATH_ZS(:,JJ) = PDXHAT(:) / PMAP(:,JJ)
+ END DO
+END IF
+! . division to complete sum
+PDXHATM = PDXHATM / REAL(IIMAX_ll)
+!
+!------------------------------------------------------------------------------
+!
+!* 5. COMPUTE THE MEAN INCREMENT BETWEEN Y LEVELS
+! -------------------------------------------
+!
+PDYHATM = 0.
+IF (LCARTESIAN) THEN
+ PDYHATM = SUM_1DFIELD_ll ( PDYHAT,'Y',IJB_ll,IJE_ll,IINFO_ll)
+ DO JI=1,SIZE(PDYATH_ZS,1)
+ PDYATH_ZS(JI,:) = PDYHAT(:)
+ END DO
+ELSE
+ ! Extraction of y-slice PMAP at i=IIB_ll+IIE_ll/2
+ CALL GET_SLICE_ll (PMAP,'Y',(IIB_ll+IIE_ll)/2,ZYMAP(IJB:IJE) &
+ ,IJB,IJE,IINFO_ll)
+ ! initialize the work array = PDYHAT / ZYMAP
+ ZWORKY(IJB:IJE) = PDYHAT(IJB:IJE) / ZYMAP (IJB:IJE)
+ PDYHATM = SUM_1DFIELD_ll ( ZWORKY,'Y',IJB_ll,IJE_ll,IINFO_ll)
+ DO JI=1,SIZE(PDYATH_ZS,1)
+ PDYATH_ZS(JI,:) = PDYHAT(:) / PMAP(JI,:)
+ END DO
+END IF
+! . division to complete sum
+PDYHATM= PDYHATM / REAL(IJMAX_ll)
+!
+!------------------------------------------------------------------------------
+!
+!* 6. COMPUTE THE OUT-DIAGONAL ELEMENTS A AND C OF THE MATRIX
+! -------------------------------------------------------
+!
+PAF_ZS = 1.0
+PCF_ZS = 1.0
+A_K = 0.0
+B_K = 0.0
+C_K = 0.0
+DO JK = IKB,IKE
+ PAF(JK) = 0.5 * ( PRHOM(JK-1) + PRHOM(JK) ) / ZDZM(JK) **2
+ PCF(JK) = 0.5 * ( PRHOM(JK) + PRHOM(JK+1) ) / ZDZM(JK+1) **2
+
+ PAF_ZS(IIB:IIE,IJB:IJE,JK) = 0.5 * ( PRHO_ZS(IIB:IIE,IJB:IJE,JK-1) + PRHO_ZS(IIB:IIE,IJB:IJE,JK) ) &
+ / ZDZM_ZS(IIB:IIE,IJB:IJE,JK) **2
+ PCF_ZS(IIB:IIE,IJB:IJE,JK) = 0.5 * ( PRHO_ZS(IIB:IIE,IJB:IJE,JK) + PRHO_ZS(IIB:IIE,IJB:IJE,JK+1) ) &
+ / ZDZM_ZS(IIB:IIE,IJB:IJE,JK+1) **2
+
+ D_K(JK) = PRHOM(JK) ! / ZDZM(JK)
+ B_K(JK) = PCF(JK) / D_K(JK)
+ C_K(JK) = PAF(JK) / D_K(JK)
+
+END DO
+
+!
+! at the upper and lower levels PAF and PCF are computed using the Neumann
+! conditions applying on the vertical component of the gradient
+!
+PAF(IKE+1) = -0.5 * ( PRHOM(IKE) + PRHOM(IKE+1) ) / ZDZM(IKE+1) **2
+D_K(IKE+1) = PRHOM(IKE+1) ! / ZDZM(IKE+1)
+C_K(IKE+1) = PAF(IKE+1) / D_K(IKE+1)
+
+PCF(IKB-1) = 0.5 * ( PRHOM(IKB-1) + PRHOM(IKB) ) / ZDZM(IKB) **2
+D_K(IKB-1) = PRHOM(IKB-1) ! / ZDZM(IKB-1)
+B_K(IKB-1) = PCF(IKB-1) / D_K(IKB-1)
+
+!
+PAF(IKB-1) = 0.0 ! 0.5 * ( PRHOM(IKB-1) + PRHOM(IKB) ) / ZDZM(IKB) **2
+C_K(IKB-1) = 0.0
+
+PCF(IKE+1) = 0.0 ! 0.5 * ( PRHOM(IKE) + PRHOM(IKE+1) ) / ZDZM(IKE+1) **2
+B_K(IKE+1) = 0.0
+
+PAF_ZS(IIB:IIE,IJB:IJE,IKE+1) = -0.5 * ( PRHO_ZS(IIB:IIE,IJB:IJE,IKE) + PRHO_ZS(IIB:IIE,IJB:IJE,IKE+1) ) &
+ / ZDZM_ZS(IIB:IIE,IJB:IJE,IKE+1) **2
+PCF_ZS(IIB:IIE,IJB:IJE,IKB-1) = 0.5 * ( PRHO_ZS(IIB:IIE,IJB:IJE,IKB-1) + PRHO_ZS(IIB:IIE,IJB:IJE,IKB) ) &
+ / ZDZM_ZS(IIB:IIE,IJB:IJE,IKB) **2
+
+PAF_ZS(IIB:IIE,IJB:IJE,IKB-1) = 0.0
+PCF_ZS(IIB:IIE,IJB:IJE,IKE+1) = 0.0
+
+IKBE = IKU
+
+IF ( HPRESOPT == 'ZSOLV' ) THEN
+ call mg_main_mnh_init(IIMAX_ll,IKBE,PDXHATM*IIMAX_ll,ZDZM(IKB)*IKBE,&
+ A_K,B_K,C_K,D_K)
+END IF
+
+!------------------------------------------------------------------------------
+!* 7. COMPUTE THE DIAGONAL ELEMENTS B OF THE MATRIX
+! ---------------------------------------------
+!
+!* 7.1 compute the horizontal eigenvalues
+!
+!
+!* 7.1.1 compute the eigenvalues along the x direction
+!
+SELECT CASE (HLBCX(1))
+! in the cyclic case, the eigenvalues are the same for two following JM values:
+! it corresponds to the real and complex parts of the FFT
+ CASE('CYCL') ! cyclic case
+ IXMODE_ll = IIMAX_ll+2*JPHEXT ! +2
+ IXMODEY_ll = IIUY_ll
+ IXMODEB_ll = IIUB_ll !JUAN Z_SPLITTING
+!
+ DO JI = 1,IXMODE_ll
+ ZEIGENX_ll(JI) = - ( 2. * SIN ( (JI-1)/2*ZGWNX ) / PDXHATM )**2
+ END DO
+ CASE DEFAULT ! other cases
+ IXMODE_ll = IIMAX_ll
+!
+!
+ IF (LEAST_ll(HSPLITTING='Y')) THEN
+ IXMODEY_ll = IIUY_ll - 2*JPHEXT ! -2
+ ELSE
+ IXMODEY_ll = IIUY_ll
+ END IF
+!JUAN Z_SPLITTING
+ IF (LEAST_ll(HSPLITTING='B')) THEN
+ IXMODEB_ll = IIUB_ll - 2*JPHEXT ! -2
+ ELSE
+ IXMODEB_ll = IIUB_ll
+ END IF
+!JUAN Z_SPLITTING
+!
+!
+ DO JI = 1,IXMODE_ll
+ ZEIGENX_ll(JI) = - ( 2. *SIN (0.5*REAL(JI-1)*ZGWNX ) / PDXHATM )**2
+ END DO
+END SELECT
+!
+!* 7.1.2 compute the eventual eigenvalues along the y direction
+!
+IF (.NOT. L2D) THEN
+!
+! y lateral boundary conditions for three-dimensional cases
+!
+ SELECT CASE (HLBCY(1))
+! in the cyclic case, the eigenvalues are the same for two following JN values:
+! it corresponds to the real and complex parts of the FFT result
+!
+ CASE('CYCL') ! 3D cyclic case
+ IYMODE_ll = IJMAX_ll+2*JPHEXT ! +2
+ IYMODEY_ll = IJUY_ll
+ IYMODEB_ll = IJUB_ll !JUAN Z_SPLITTING
+!
+ DO JJ = 1,IYMODE_ll
+ DO JI = 1,IXMODE_ll
+ ZEIGEN_ll(JI,JJ) = ZEIGENX_ll(JI) - &
+ ( 2.* SIN ( (JJ-1)/2*ZGWNY ) / PDYHATM )**2
+ END DO
+ END DO
+!
+ CASE DEFAULT ! 3D non-cyclic cases
+ IYMODE_ll = IJMAX_ll
+ IYMODEY_ll = IJUY_ll - 2*JPHEXT ! -2
+ IYMODEB_ll = IJUB_ll - 2*JPHEXT ! -2 JUAN Z_SPLITTING
+!
+ DO JJ = 1,IYMODE_ll
+ DO JI = 1,IXMODE_ll
+ ZEIGEN_ll(JI,JJ) = ZEIGENX_ll(JI) - ( 2.* SIN (0.5*REAL(JJ-1)*ZGWNY ) / &
+ PDYHATM )**2
+ END DO
+ END DO
+!
+ END SELECT
+ELSE
+!
+! copy the x eigenvalue array in a 2D array for a 2D case
+!
+ IYMODE_ll = 1
+ IYMODEY_ll = 1
+ ZEIGEN_ll(1:IXMODE_ll,1)=ZEIGENX_ll(1:IXMODE_ll)
+!
+END IF
+!
+DEALLOCATE(ZEIGENX_ll)
+!
+!CALL MPPDB_CHECK2D(ZEIGEN_ll,"TRIDZ::ZEIGEN_ll",PRECISION)
+!
+!
+!* 7.2 compute the matrix diagonal elements
+!
+!
+PBFY = 1.
+PBFB = 1. ! JUAN Z_SLIDE
+PBF_SXP2_YP1_Z = 1. ! JUAN Z_SLIDE
+!
+IF (L2D) THEN
+ DO JK= IKB,IKE
+ DO JJ= 1, IYMODEY_ll
+ DO JI= 1, IXMODEY_ll
+ PBFY(JI,JJ,JK) = PRHOM(JK)* ZEIGEN_ll(JI+IORXY_ll-1,JJ+IORYY_ll-1) - 0.5 * &
+ ( ( PRHOM(JK-1) + PRHOM(JK) ) / ZDZM(JK) **2 &
+ +( PRHOM(JK) + PRHOM(JK+1) ) / ZDZM(JK+1)**2 )
+ END DO
+ END DO
+ END DO
+! at the upper and lower levels PBFY is computed using the Neumann
+! condition
+!
+ PBFY(1:IXMODEY_ll,1:IYMODEY_ll,IKB-1) = -0.5 * ( PRHOM(IKB-1) + PRHOM(IKB) ) / &
+ ZDZM(IKB) **2
+ !
+ PBFY(1:IXMODEY_ll,1:IYMODEY_ll,IKE+1) = 0.5 * ( PRHOM(IKE) + PRHOM(IKE+1) ) / &
+ ZDZM(IKE+1) **2
+ !
+ELSE
+ DO JK= IKB,IKE
+ DO JJ= 1, IYMODEY_ll
+ DO JI= 1, IXMODEY_ll
+ PBFY(JJ,JI,JK) = PRHOM(JK)* ZEIGEN_ll(JI+IORXY_ll-1,JJ+IORYY_ll-1) - 0.5 * &
+ ( ( PRHOM(JK-1) + PRHOM(JK) ) / ZDZM(JK) **2 &
+ +( PRHOM(JK) + PRHOM(JK+1) ) / ZDZM(JK+1)**2 )
+ END DO
+ END DO
+ END DO
+! at the upper and lower levels PBFY is computed using the Neumann
+! condition
+!
+ PBFY(1:IYMODEY_ll,1:IXMODEY_ll,IKB-1) = -0.5 * ( PRHOM(IKB-1) + PRHOM(IKB) ) / &
+ ZDZM(IKB) **2
+ !
+ PBFY(1:IYMODEY_ll,1:IXMODEY_ll,IKE+1) = 0.5 * ( PRHOM(IKE) + PRHOM(IKE+1) ) / &
+ ZDZM(IKE+1) **2
+ !
+
+!JUAN Z_SPLITTING
+!JUAN for Z splitting we need to do the vertical substitution
+!JUAN in Bsplitting slides so need PBFB
+PBF_ZS = 1.0
+ DO JK= IKB,IKE
+ DO JJ= IJB,IJE
+ DO JI= IIB,IIE
+
+ PBFB(JI,JJ,JK) = PRHOM(JK)* ( -2.0 / PDXHATM**2 -2.0 /PDYHATM**2 ) - 0.5 * &
+ ( ( PRHOM(JK-1) + PRHOM(JK) ) / ZDZM(JK) **2 &
+ +( PRHOM(JK) + PRHOM(JK+1) ) / ZDZM(JK+1)**2 )
+
+ PBF_ZS(JI,JJ,JK) = PRHO_ZS(JI,JJ,JK)* ( -2.0 / PDXATH_ZS(JI,JJ)**2 -2.0 /PDYATH_ZS(JI,JJ)**2 ) - 0.5 * &
+ ( ( PRHO_ZS(JI,JJ,JK-1) + PRHO_ZS(JI,JJ,JK) ) / ZDZM_ZS(JI,JJ,JK) **2 &
+ +( PRHO_ZS(JI,JJ,JK) + PRHO_ZS(JI,JJ,JK+1) ) / ZDZM_ZS(JI,JJ,JK+1)**2 )
+
+ END DO
+ END DO
+ END DO
+! at the upper and lower levels PBFB is computed using the Neumann
+! condition
+!
+ PBFB(IIB:IIE,IJB:IJE,IKB-1) = - 0.5 * ( PRHOM(IKB-1) + PRHOM(IKB) ) / ZDZM(IKB) **2
+ !
+ PBFB(IIB:IIE,IJB:IJE,IKE+1) = + 0.5 * ( PRHOM(IKE) + PRHOM(IKE+1) ) / ZDZM(IKE+1) **2
+
+ PBF_ZS(IIB:IIE,IJB:IJE,IKB-1) = - 0.5 * ( PRHO_ZS(IIB:IIE,IJB:IJE,IKB-1) + PRHO_ZS(IIB:IIE,IJB:IJE,IKB) ) &
+ / ZDZM_ZS(IIB:IIE,IJB:IJE,IKB)**2
+
+ PBF_ZS(IIB:IIE,IJB:IJE,IKE+1) = 0.5 * ( PRHO_ZS(IIB:IIE,IJB:IJE,IKE) + PRHO_ZS(IIB:IIE,IJB:IJE,IKE+1) ) &
+ / ZDZM_ZS(IIB:IIE,IJB:IJE,IKE+1)**2
+!
+IF (HLBCX(1) == 'CYCL' .AND. .NOT.(L2D) ) THEN
+ !JUAN
+ ! fil unused 2 coef with NI+1 coef (lost in Z transposition elsewhere )
+ JI = IXMODE_ll -1
+ ZEIGEN_ll(2,:) = ZEIGEN_ll(JI,:)
+END IF
+IF (HLBCY(1) == 'CYCL' .AND. .NOT.(L2D) ) THEN
+ !JUAN
+ ! fill unused (:,2,:) coef with NJ+1 coef (lost in Z transposition elsewhere )
+ JJ = IYMODE_ll -1
+ ZEIGEN_ll(:,2) = ZEIGEN_ll(:,JJ)
+END IF
+ !
+!JUAN Z_SPLITTING
+!JUAN Z_SPLITTING
+!JUAN for Z splitting we need to do the vertical substitution
+!JUAN in _SXP2_YP1_Zsplitting slides so need PBF_SXP2_YP1_Z
+ DO JK=IKB,IKE
+ DO JJ= 1, IJU_SXP2_YP1_Z_ll
+ DO JI= 1, IIU_SXP2_YP1_Z_ll
+ PBF_SXP2_YP1_Z(JI,JJ,JK) = PRHOM(JK)* ZEIGEN_ll(JI+IORX_SXP2_YP1_Z_ll-IIB_ll,JJ+IORY_SXP2_YP1_Z_ll-IJB_ll) - 0.5 * &
+ ( ( PRHOM(JK-1) + PRHOM(JK) ) / ZDZM(JK) **2 &
+ +( PRHOM(JK) + PRHOM(JK+1) ) / ZDZM(JK+1)**2 )
+ END DO
+ END DO
+ END DO
+! at the upper and lower levels PBFB is computed using the Neumann
+! condition
+!
+ PBF_SXP2_YP1_Z(1:IIU_SXP2_YP1_Z_ll,1:IJU_SXP2_YP1_Z_ll,IKB-1) = -0.5 * ( PRHOM(IKB-1) + PRHOM(IKB) ) / &
+ ZDZM(IKB) **2
+ !
+ PBF_SXP2_YP1_Z(1:IIU_SXP2_YP1_Z_ll,1:IJU_SXP2_YP1_Z_ll,IKE+1) = 0.5 * ( PRHOM(IKE) + PRHOM(IKE+1) ) / &
+ ZDZM(IKE+1) **2
+ !
+!JUAN Z_SPLITTING
+END IF
+!
+! second coefficent is meaningless in cyclic case
+IF (HLBCX(1) == 'CYCL' .AND. L2D .AND. SIZE(PBFY,1) .GE. 2 ) PBFY(2,:,:)=1.
+IF (HLBCX(1) == 'CYCL' .AND. .NOT.(L2D) .AND. LWEST_ll(HSPLITTING='Y') .AND. SIZE(PBFY,2) .GE.2 ) &
+ PBFY(:,2,:)=1.
+IF (HLBCY(1) == 'CYCL' .AND. .NOT.(L2D) .AND. SIZE(PBFY,1) .GE. 2 ) PBFY(2,:,:)=1.
+!JUAN Z_SPLITTING
+! second coefficent is meaningless in cyclic case
+!IF (HLBCX(1) == 'CYCL' .AND. L2D .AND. SIZE(PBFB,1) .GE. 2 ) PBFB(2,:,:)=1.
+!IF (HLBCX(1) == 'CYCL' .AND. .NOT.(L2D) .AND. LWEST_ll(HSPLITTING='B') .AND. SIZE(PBFB,2) .GE.2 ) &
+! PBFB(:,2,:)=1.
+!IF (HLBCY(1) == 'CYCL' .AND. .NOT.(L2D) .AND. SIZE(PBFB,1) .GE. 2 ) PBFB(2,:,:)=1.
+!JUAN Z_SPLITTING
+!
+DEALLOCATE(ZEIGEN_ll)
+!
+!
+!------------------------------------------------------------------------------
+!* 8. INITIALIZATION OF THE TRIGS AND IFAX ARRAYS FOR THE FFT
+! -------------------------------------------------------
+!
+! 8.1 x lateral boundary conditions
+!
+CALL SET99(PTRIGSX,KIFAXX,IIMAX_ll)
+!
+! test on the value of KIMAX: KIMAX must be factorizable as a product
+! of powers of 2,3 and 5. KIFAXX(10) is equal to IIMAX if the decomposition
+! is correct, then KIFAXX(1) contains the number of decomposition factors
+! of KIMAX.
+!
+IF (KIFAXX(10) /= IIMAX_ll) THEN
+ WRITE(UNIT=ILUOUT,FMT="(' ERROR',/, &
+ &' : THE FORM OF THE FFT USED FOR THE INVERSION OF THE FLAT ',/,&
+ &' OPERATOR REQUIRES THAT KIMAX MUST BE FACTORIZABLE' ,/,&
+ & ' AS A PRODUCT OF POWERS OF 2, 3 AND 5.')")
+ !callabortstop
+ CALL PRINT_MSG(NVERB_FATAL,'GEN','TRIDZ','')
+END IF
+!
+IF (HLBCX(1) /= 'CYCL') THEN
+!
+! extra trigs for shifted (co) sine transform (FFT55)
+!
+ INN=2*(IIMAX_ll)
+ ZDEL=ASIN(1.0)/REAL(IIMAX_ll)
+ DO JI=1,IIMAX_ll
+ ZANGLE=REAL(JI)*ZDEL
+ PTRIGSX(INN+JI)=SIN(ZANGLE)
+ END DO
+!
+ENDIF
+!
+! 8.2 y lateral boundary conditions
+!
+IF (.NOT. L2D) THEN
+ CALL SET99(PTRIGSY,KIFAXY,IJMAX_ll)
+ !
+ ! test on the value of KJMAX: KJMAX must be factorizable as a product
+ ! of powers of 2,3 and 5. KIFAXY(10) is equal to IJMAX_ll if the decomposition
+ ! is correct, then KIFAXX(1) contains the number of decomposition factors
+ ! of IIMAX_ll.
+ !
+ IF (KIFAXY(10) /= IJMAX_ll) THEN
+ WRITE(UNIT=ILUOUT,FMT="(' ERROR',/, &
+ &' : THE FORM OF THE FFT USED FOR THE INVERSION OF THE FLAT ',/,&
+ &' OPERATOR REQUIRES THAT KJMAX MUST BE FACTORIZABLE' ,/,&
+ & ' AS A PRODUCT OF POWERS OF 2, 3 AND 5.')")
+ !callabortstop
+ CALL PRINT_MSG(NVERB_FATAL,'GEN','TRIDZ','')
+ END IF
+ !
+ !
+ ! other cases
+ !
+ IF (HLBCY(1) /= 'CYCL') THEN
+ !
+ ! extra trigs for shifted (co) sine transform
+ !
+ INN=2*(IJMAX_ll)
+ ZDEL=ASIN(1.0)/REAL(IJMAX_ll)
+ DO JJ=1,IJMAX_ll
+ ZANGLE=REAL(JJ)*ZDEL
+ PTRIGSY(INN+JJ)=SIN(ZANGLE)
+ END DO
+ !
+ ENDIF
+ !
+ENDIF
+!
+!------------------------------------------------------------------------------
+!
+END SUBROUTINE TRIDZ
diff --git a/src/ZSOLVER/zconjgrad.f90 b/src/ZSOLVER/zconjgrad.f90
new file mode 100644
index 0000000000000000000000000000000000000000..35d82862f990a91586103de8401beed89b72f1a0
--- /dev/null
+++ b/src/ZSOLVER/zconjgrad.f90
@@ -0,0 +1,292 @@
+!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 solver 2006/05/18 13:07:25
+!-----------------------------------------------------------------
+! ####################
+ MODULE MODI_ZCONJGRAD
+! ####################
+!
+INTERFACE
+!
+ SUBROUTINE ZCONJGRAD(HLBCX,HLBCY,PDXX,PDYY,PDZX,PDZY,PDZZ,PRHODJ,PTHETAV, &
+ PDXHATM,PDYHATM,PRHOM,PAF,PBF,PCF,PTRIGSX,PTRIGSY,KIFAXX,KIFAXY, &
+ KITR,PY,PPHI)
+!
+IMPLICIT NONE
+!
+CHARACTER (LEN=4), DIMENSION(2), INTENT(IN) :: HLBCX ! x-direction LBC type
+CHARACTER (LEN=4), DIMENSION(2), INTENT(IN) :: HLBCY ! y-direction LBC type
+!
+ ! Metric coefficients:
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDXX ! d*xx
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDYY ! d*yy
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDZX ! d*zx
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDZY ! d*zy
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDZZ ! d*zz
+!
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODJ ! density of reference * J
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PTHETAV ! virtual potential temp. at time t
+!
+REAL, INTENT(IN) :: PDXHATM ! mean grid increment in the x
+ ! direction
+REAL, INTENT(IN) :: PDYHATM ! mean grid increment in the y
+ ! direction
+!
+REAL, DIMENSION (:), INTENT(IN) :: PRHOM ! mean of XRHODJ on the plane x y
+ ! localized at a mass level
+!
+REAL, DIMENSION(:), INTENT(IN) :: PAF,PCF ! vectors giving the nonvanishing
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PBF ! elements of the tri-diag.
+ ! matrix in the pressure eq.
+!
+ ! arrays of sin or cos values
+ ! for the FFT :
+REAL, DIMENSION(:), INTENT(IN) :: PTRIGSX ! - along x
+REAL, DIMENSION(:), INTENT(IN) :: PTRIGSY ! - along y
+!
+ ! decomposition in prime
+ ! numbers for the FFT:
+INTEGER, DIMENSION(19), INTENT(IN) :: KIFAXX ! - along x
+INTEGER, DIMENSION(19), INTENT(IN) :: KIFAXY ! - along y
+!
+INTEGER, INTENT(IN) :: KITR ! number of iterations for the
+ ! pressure solver
+!
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PY ! RHS of the equation
+!
+REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PPHI ! solution of the equation
+!
+END SUBROUTINE ZCONJGRAD
+!
+END INTERFACE
+!
+END MODULE MODI_ZCONJGRAD
+!
+!
+!
+! #########################################################################
+ SUBROUTINE ZCONJGRAD(HLBCX,HLBCY,PDXX,PDYY,PDZX,PDZY,PDZZ,PRHODJ,PTHETAV, &
+ PDXHATM,PDYHATM,PRHOM,PAF,PBF,PCF,PTRIGSX,PTRIGSY,KIFAXX,KIFAXY, &
+ KITR,PY,PPHI)
+! #########################################################################
+!
+!!**** *CONJGRAD * - solve an elliptic equation by the conjugate gradient
+!! method
+!!
+!! PURPOSE
+!! -------
+! The purpose of this routine is to solve an elliptic equation using
+! the preditioned conjugate gradient (CG) method. This is a version of the
+! CG called ORTHOMIN (Young and Jea 1980).
+!
+!!** METHOD
+!! ------
+!! The equation to be solved reads:
+!!
+!! Q (PHI) = Y
+!!
+!! where Q is the quasi-Laplacian ( subroutine QLAP ) and PHI the pressure
+!! function.
+!! We precondition the problem by the operator F :
+!! -1 -1
+!! F * Q (PHI) = F (Y)
+!! F represents the flat Laplacian ie. without orography. Its inversion is
+!! realized in the routine FLAT_INV. This equation is solved with a Conjugate
+!! Gradient method.
+!! The initial guess is given by the pressure at the previous time step.
+!! The resolution stops after ITR iterations of the solver.
+!!
+!! EXTERNAL
+!! --------
+!! Subroutine GDIV: compute J times the divergence of 1/J times a vector
+!! Function QLAP: compute the complete quasi-Laplacian Q
+!! Subroutine FLAT_INV : invert the flat quasi-laplacien F
+!! Function DOTPROD: compute the dot product of 2 vectors
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module MODI_GDIV: interface for the subroutine GDIV
+!! Module MODI_QLAP: interface for the function QLAP
+!! Module MODI_FLAT_INV: interface for the subroutine FLAT_INV
+!! Module MODI_DOTPROD: interface for the function DOTPROD
+!!
+!! REFERENCE
+!! ---------
+!! Book2 of documentation (routine CONJGRAD)
+!! Kapitza and Eppel (1992) Beit. Physik ...
+!! Young and Jea (1980) ....
+!!
+!! AUTHOR
+!! ------
+!! P. HÅreil and J. Stein * Meteo France *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 25/07/94
+!!
+!! 14/01/97 Durran anelastic equation (Stein,Lafore)
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODI_GDIV
+USE MODI_QLAP
+USE MODI_FLAT_INV
+USE MODI_DOTPROD
+USE MODI_ZSOLVER_INV
+!
+IMPLICIT NONE
+!
+!* 0.1 declarations of arguments
+!
+!
+CHARACTER (LEN=4), DIMENSION(2), INTENT(IN) :: HLBCX ! x-direction LBC type
+CHARACTER (LEN=4), DIMENSION(2), INTENT(IN) :: HLBCY ! y-direction LBC type
+!
+ ! Metric coefficients:
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDXX ! d*xx
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDYY ! d*yy
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDZX ! d*zx
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDZY ! d*zy
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDZZ ! d*zz
+!
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODJ ! density of reference * J
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PTHETAV ! virtual potential temp. at time t
+!
+REAL, INTENT(IN) :: PDXHATM ! mean grid increment in the x
+ ! direction
+REAL, INTENT(IN) :: PDYHATM ! mean grid increment in the y
+ ! direction
+!
+REAL, DIMENSION (:), INTENT(IN) :: PRHOM ! mean of XRHODJ on the plane x y
+ ! localized at a mass level
+!
+REAL, DIMENSION(:), INTENT(IN) :: PAF,PCF ! vectors giving the nonvanishing
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PBF ! elements of the tri-diag.
+ ! matrix in the pressure eq.
+!
+ ! arrays of sin or cos values
+ ! for the FFT :
+REAL, DIMENSION(:), INTENT(IN) :: PTRIGSX ! - along x
+REAL, DIMENSION(:), INTENT(IN) :: PTRIGSY ! - along y
+!
+ ! decomposition in prime
+ ! numbers for the FFT:
+INTEGER, DIMENSION(19), INTENT(IN) :: KIFAXX ! - along x
+INTEGER, DIMENSION(19), INTENT(IN) :: KIFAXY ! - along y
+!
+INTEGER, INTENT(IN) :: KITR ! number of iterations for the
+ ! pressure solver
+!
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PY ! RHS of the equation
+!
+REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PPHI ! solution of the equation
+!
+!* 0.2 declarations of local variables
+!
+INTEGER :: JM ! loop index
+!
+REAL, DIMENSION(SIZE(PPHI,1),SIZE(PPHI,2),SIZE(PPHI,3)) :: ZDELTA
+ ! array containing the auxilary field DELTA of the CG method
+!
+REAL, DIMENSION(SIZE(PPHI,1),SIZE(PPHI,2),SIZE(PPHI,3)) :: ZP
+ ! array containing the auxilary field P of the CG method
+!
+REAL, DIMENSION(SIZE(PPHI,1),SIZE(PPHI,2),SIZE(PPHI,3)) :: ZWORK ! work
+ ! array containing the source term to be multiplied by the F inverse
+!
+REAL, DIMENSION(SIZE(PPHI,1),SIZE(PPHI,2),SIZE(PPHI,3)) :: ZWORKD ! work
+ ! array containing the result of the F inversion * Q (DELTA)
+!
+REAL, DIMENSION(SIZE(PPHI,1),SIZE(PPHI,2),SIZE(PPHI,3)) :: ZWORKP ! work
+ ! array containing the result of the F inversion * Q (P)
+!
+REAL :: ZALPHA, ZLAMBDA ! amplitude of the descent in the Conjugate
+ ! directions
+REAL :: ZDOTPP ! dot product of ZWORKP by itself
+!
+!-------------------------------------------------------------------------------
+!
+!* 1. INITIALIZATIONS
+! ---------------
+!
+ZLAMBDA = 0.
+ZP = 0.
+!
+!-------------------------------------------------------------------------------
+!
+!* 2. ITERATIVE LOOP
+! --------------
+!
+DO JM = 1,KITR
+!
+!* 2.1 compute the new pressure function
+!
+ PPHI = PPHI + ZLAMBDA * ZP ! the case JM =0 is special because
+ ! PPHI is not changed
+!
+!* 2.2 compute the auxiliary field DELTA
+!
+! -1
+! compute the vector DELTA = F * ( Y - Q ( PHI ) )
+!
+ ZWORK = QLAP(HLBCX,HLBCY,PDXX,PDYY,PDZX,PDZY,PDZZ,PRHODJ,PTHETAV,PPHI)
+ ! Q (PHI)
+!
+ ZWORK = PY - ZWORK ! Y - Q (PHI)
+!
+ CALL FLAT_INV(HLBCX,HLBCY,PDXHATM,PDYHATM,PRHOM,PAF,PBF,PCF, &! -1
+ PTRIGSX,PTRIGSY,KIFAXX,KIFAXY,ZWORK,ZDELTA) ! F (Y - Q (PHI)))
+!
+!* 2.3 compute the auxiliary field P
+!
+! -1
+! compute the vector P = DELTA + alpha F * Q ( DELTA )
+!
+ IF (JM == 1) THEN
+ ZP = ZDELTA ! P = DELTA at the first solver iteration
+ ELSE
+ ZWORK = QLAP(HLBCX,HLBCY,PDXX,PDYY,PDZX,PDZY, &
+ PDZZ,PRHODJ,PTHETAV,ZDELTA) ! Q ( DELTA )
+ CALL FLAT_INV(HLBCX,HLBCY,PDXHATM,PDYHATM,PRHOM,PAF,PBF,PCF, & ! -1
+ PTRIGSX,PTRIGSY,KIFAXX,KIFAXY,ZWORK,ZWORKD) ! F * Q ( DELTA )
+!
+ ZALPHA = - DOTPROD(ZWORKD,ZWORKP,HLBCX,HLBCY)/ZDOTPP ! ZWORKP,ZDOTPP come
+ ! from the previous solver iteration (section 2.4)
+ ZP = ZDELTA + ZALPHA * ZP ! new vector P
+!
+ END IF
+!
+!* 2.4 compute LAMBDA
+!
+!
+ ZWORK = QLAP(HLBCX,HLBCY,PDXX,PDYY,PDZX,PDZY,&
+ PDZZ,PRHODJ,PTHETAV,ZP) ! Q ( P )
+ CALL FLAT_INV(HLBCX,HLBCY,PDXHATM,PDYHATM,PRHOM,PAF,PBF,PCF,& ! -1
+ PTRIGSX,PTRIGSY,KIFAXX,KIFAXY,ZWORK,ZWORKP) ! F * Q ( P )
+!
+! store the scalar product to compute lambda and next P
+ ZDOTPP = DOTPROD(ZWORKP,ZWORKP,HLBCX,HLBCY)
+!
+ ZLAMBDA = DOTPROD(ZDELTA,ZWORKP,HLBCX,HLBCY) / ZDOTPP ! lambda
+!
+!
+END DO ! end of the loop for the iterative solver
+!
+!-------------------------------------------------------------------------------
+!
+!* 3. COMPUTE THE FINAL PRESSURE FUNCTION
+! -----------------------------------
+!
+PPHI = PPHI + ZLAMBDA * ZP
+!
+!-------------------------------------------------------------------------------
+!
+END SUBROUTINE ZCONJGRAD
diff --git a/src/ZSOLVER/zsolver.f90 b/src/ZSOLVER/zsolver.f90
new file mode 100644
index 0000000000000000000000000000000000000000..779a6b5685912b69249552d79b93337d17edd1bf
--- /dev/null
+++ b/src/ZSOLVER/zsolver.f90
@@ -0,0 +1,314 @@
+!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 solver 2006/05/18 13:07:25
+!-----------------------------------------------------------------
+! ####################
+ MODULE MODI_ZSOLVER
+! ####################
+!
+INTERFACE
+!
+ SUBROUTINE ZSOLVER(HLBCX,HLBCY,PDXX,PDYY,PDZX,PDZY,PDZZ,PRHODJ,PTHETAV, &
+ PDXHATM,PDYHATM,PRHOM,PAF,PBF,PCF,PTRIGSX,PTRIGSY,KIFAXX,KIFAXY, &
+ KITR,PY,PPHI, &
+ PAF_ZS,PBF_ZS,PCF_ZS, &
+ PDXATH_ZS,PDYATH_ZS,PRHO_ZS,PBFB, &
+ A_K,B_K,C_K,D_K) !JUAN FULL ZSOLVER
+!
+IMPLICIT NONE
+!
+CHARACTER (LEN=4), DIMENSION(2), INTENT(IN) :: HLBCX ! x-direction LBC type
+CHARACTER (LEN=4), DIMENSION(2), INTENT(IN) :: HLBCY ! y-direction LBC type
+!
+ ! Metric coefficients:
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDXX ! d*xx
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDYY ! d*yy
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDZX ! d*zx
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDZY ! d*zy
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDZZ ! d*zz
+!
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODJ ! density of reference * J
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PTHETAV ! virtual pot. temp. at time t
+!
+REAL, INTENT(IN) :: PDXHATM ! mean grid increment in the x
+ ! direction
+REAL, INTENT(IN) :: PDYHATM ! mean grid increment in the y
+ ! direction
+!
+REAL, DIMENSION (:), INTENT(IN) :: PRHOM ! XRHODJ mean on the X Y plane
+ ! localized at a mass level
+!
+REAL, DIMENSION(:), INTENT(IN) :: PAF,PCF ! vectors giving the nonvanishing
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PBF ! elements of the tri-diag.
+ ! matrix in the pressure eq.
+!
+ ! arrays of sin or cos values
+ ! for the FFT :
+REAL, DIMENSION(:), INTENT(IN) :: PTRIGSX ! - along x
+REAL, DIMENSION(:), INTENT(IN) :: PTRIGSY ! - along y
+!
+ ! decomposition in prime
+ ! numbers for the FFT:
+INTEGER, DIMENSION(19), INTENT(IN) :: KIFAXX ! - along x
+INTEGER, DIMENSION(19), INTENT(IN) :: KIFAXY ! - along y
+!
+INTEGER, INTENT(IN) :: KITR ! number of iterations for the
+ ! pressure solver
+!
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PY ! RHS of the equation
+!
+REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PPHI ! solution of the equation
+
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PAF_ZS,PBF_ZS,PCF_ZS
+REAL, DIMENSION(:,:) , INTENT(IN) :: PDXATH_ZS,PDYATH_ZS
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHO_ZS,PBFB
+REAL, DIMENSION(:) , INTENT(IN) :: A_K,B_K,C_K,D_K
+!
+END SUBROUTINE ZSOLVER
+!
+END INTERFACE
+!
+END MODULE MODI_ZSOLVER
+!
+!
+!
+! #########################################################################
+ SUBROUTINE ZSOLVER(HLBCX,HLBCY,PDXX,PDYY,PDZX,PDZY,PDZZ,PRHODJ,PTHETAV, &
+ PDXHATM,PDYHATM,PRHOM,PAF,PBF,PCF,PTRIGSX,PTRIGSY,KIFAXX,KIFAXY, &
+ KITR,PY,PPHI, &
+ PAF_ZS,PBF_ZS,PCF_ZS, &
+ PDXATH_ZS,PDYATH_ZS,PRHO_ZS,PBFB, &
+ A_K,B_K,C_K,D_K)
+! #########################################################################
+!
+!!**** *CONRESOL * - solve an elliptic equation by the conjugate residual
+!! method
+!!
+!! PURPOSE
+!! -------
+! The purpose of this routine is to solve an elliptic equation using
+! the preconditioned conjugate residual (CR) method. This is a version
+! of the scheme proposed by Skamarock, Smolarkiewicz and Klemp (MWR, 1997).
+!
+!!** METHOD
+!! ------
+!! The equation to be solved reads:
+!!
+!! Q (PHI) = Y
+!!
+!! where Q is the quasi-Laplacian ( subroutine QLAP ) and PHI the pressure
+!! function.
+!! We precondition the problem by the operator F :
+!! -1 -1
+!! F * Q (PHI) = F (Y)
+!! F represents the flat Laplacian ie. without orography. Its inversion is
+!! realized in the routine FLAT_INV. This equation is solved with a Conjugate
+!! Residual method.
+!! The initial guess is given by the pressure at the previous time step.
+!! The resolution stops after ITR iterations of the solver.
+!!
+!! EXTERNAL
+!! --------
+!! Subroutine GDIV: compute J times the divergence of 1/J times a vector
+!! Function QLAP: compute the complete quasi-Laplacian Q
+!! Subroutine FLAT_INV : invert the flat quasi-laplacien F
+!! Function DOTPROD: compute the dot product of 2 vectors
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module MODI_GDIV: interface for the subroutine GDIV
+!! Module MODI_QLAP: interface for the function QLAP
+!! Module MODI_FLAT_INV: interface for the subroutine FLAT_INV
+!! Module MODI_DOTPROD: interface for the function DOTPROD
+!!
+!! REFERENCE
+!! ---------
+!! Book2 of documentation (routine CONRESOL)
+!! Skamarock, Smolarkiewicz and Klemp (1997) MWR
+!!
+!! AUTHOR
+!! ------
+!! J.-P. Pinty *Laboratoire d'Aerologie*
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 25/08/99
+!! J.-P. Pinty & P. Jabouille
+!! 11/07/00 bug in ZALPHA
+!!
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODI_GDIV
+USE MODI_QLAP
+USE MODI_FLAT_INV
+USE MODI_ZSOLVER_INV
+USE MODI_DOTPROD
+!
+IMPLICIT NONE
+!
+!* 0.1 declarations of arguments
+!
+!
+CHARACTER (LEN=4), DIMENSION(2), INTENT(IN) :: HLBCX ! x-direction LBC type
+CHARACTER (LEN=4), DIMENSION(2), INTENT(IN) :: HLBCY ! y-direction LBC type
+!
+ ! Metric coefficients:
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDXX ! d*xx
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDYY ! d*yy
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDZX ! d*zx
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDZY ! d*zy
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDZZ ! d*zz
+!
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODJ ! density of reference * J
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PTHETAV ! virtual pot. temp. at time t
+!
+REAL, INTENT(IN) :: PDXHATM ! mean grid increment in the x
+ ! direction
+REAL, INTENT(IN) :: PDYHATM ! mean grid increment in the y
+ ! direction
+!
+REAL, DIMENSION (:), INTENT(IN) :: PRHOM ! mean of XRHODJ on the plane x y
+ ! localized at a mass level
+!
+REAL, DIMENSION(:), INTENT(IN) :: PAF,PCF ! vectors giving the nonvanishing
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PBF ! elements of the tri-diag.
+ ! matrix in the pressure eq.
+!
+ ! arrays of sin or cos values
+ ! for the FFT :
+REAL, DIMENSION(:), INTENT(IN) :: PTRIGSX ! - along x
+REAL, DIMENSION(:), INTENT(IN) :: PTRIGSY ! - along y
+!
+ ! decomposition in prime
+ ! numbers for the FFT:
+INTEGER, DIMENSION(19), INTENT(IN) :: KIFAXX ! - along x
+INTEGER, DIMENSION(19), INTENT(IN) :: KIFAXY ! - along y
+!
+INTEGER, INTENT(IN) :: KITR ! number of iterations for the
+ ! pressure solver
+!
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PY ! RHS of the equation
+!
+REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PPHI ! solution of the equation
+
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PAF_ZS,PBF_ZS,PCF_ZS
+REAL, DIMENSION(:,:) , INTENT(IN) :: PDXATH_ZS,PDYATH_ZS
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHO_ZS,PBFB
+REAL, DIMENSION(:) , INTENT(IN) :: A_K,B_K,C_K,D_K
+!
+!* 0.2 declarations of local variables
+!
+INTEGER :: JM ! loop index
+!
+REAL, DIMENSION(SIZE(PPHI,1),SIZE(PPHI,2),SIZE(PPHI,3)) :: ZDELTA, ZKSI
+ ! array containing the auxilary fields DELTA and KSI of the CR method
+REAL, DIMENSION(SIZE(PPHI,1),SIZE(PPHI,2),SIZE(PPHI,3)) :: ZP, ZQ
+ ! array containing the auxilary fields P and Q of the CR method
+REAL, DIMENSION(SIZE(PPHI,1),SIZE(PPHI,2),SIZE(PPHI,3)) :: ZRESIDUE
+ ! array containing the error field at each iteration Q(PHI) - Y
+!
+REAL :: ZALPHA, ZLAMBDA ! amplitude of the descent in the Conjugate
+ ! directions
+REAL :: ZDOT_DELTA ! dot product of ZDELTA by itself
+!
+!-------------------------------------------------------------------------------
+!
+!* 1. INITIALIZATIONS
+! ---------------
+!
+!
+!* 1.1 compute the vector: r^(0) = Q(PHI) - Y
+!
+#ifndef MNH_OPENACC
+ZRESIDUE = QLAP(HLBCX,HLBCY,PDXX,PDYY,PDZX,PDZY,PDZZ,PRHODJ,PTHETAV,PPHI) - PY
+#else
+CALL QLAP_DEVICE(ZRESIDUE,HLBCX,HLBCY,PDXX,PDYY,PDZX,PDZY,PDZZ,PRHODJ,PTHETAV,PPHI)
+ZRESIDUE = ZRESIDUE - PY
+#endif
+!
+!* 1.2 compute the vector: p^(0) = F^(-1)*( Q(PHI) - Y )
+!
+CALL ZSOLVER_INV(HLBCX,HLBCY,PDXHATM,PDYHATM,PRHOM,PAF,PBF,PCF, &
+ PTRIGSX,PTRIGSY,KIFAXX,KIFAXY,ZRESIDUE,ZP, &
+ PAF_ZS,PBF_ZS,PCF_ZS, &
+ PDXATH_ZS,PDYATH_ZS,PRHO_ZS,PBFB, &
+ A_K,B_K,C_K,D_K)
+!
+!* 1.3 compute the vector: delta^(0) = Q ( p^(0) )
+!
+#ifndef MNH_OPENACC
+ZDELTA = QLAP(HLBCX,HLBCY,PDXX,PDYY,PDZX,PDZY,PDZZ,PRHODJ,PTHETAV,ZP)
+#else
+CALL QLAP_DEVICE(ZDELTA,HLBCX,HLBCY,PDXX,PDYY,PDZX,PDZY,PDZZ,PRHODJ,PTHETAV,ZP)
+#endif
+!
+!-------------------------------------------------------------------------------
+!
+!* 2. ITERATIVE LOOP
+! --------------
+!
+DO JM = 1,KITR
+!
+!* 2.1 compute the step LAMBDA
+!
+ ZDOT_DELTA = DOTPROD(ZDELTA, ZDELTA,HLBCX,HLBCY) ! norm of DELTA
+ ZLAMBDA = - DOTPROD(ZRESIDUE,ZDELTA,HLBCX,HLBCY) / ZDOT_DELTA
+!
+!* 2.2 update the pressure function PHI
+!
+ !$acc kernels
+ PPHI = PPHI + ZLAMBDA * ZP
+ !$acc end kernels
+!
+!
+ IF( JM == KITR ) EXIT
+!
+!
+!* 2.3 update the residual error: r
+ !
+ !$acc kernels
+ ZRESIDUE = ZRESIDUE + ZLAMBDA * ZDELTA
+ !$acc end kernels
+!
+!* 2.4 compute the vector: q = F^(-1)*( Q(PHI) - Y )
+!
+ CALL ZSOLVER_INV(HLBCX,HLBCY,PDXHATM,PDYHATM,PRHOM,PAF,PBF,PCF, &
+ PTRIGSX,PTRIGSY,KIFAXX,KIFAXY,ZRESIDUE,ZQ, &
+ PAF_ZS,PBF_ZS,PCF_ZS, &
+ PDXATH_ZS,PDYATH_ZS,PRHO_ZS,PBFB, &
+ A_K,B_K,C_K,D_K)
+!
+!* 2.5 compute the auxiliary field: ksi = Q ( q )
+!
+#ifndef MNH_OPENACC
+ ZKSI= QLAP(HLBCX,HLBCY,PDXX,PDYY,PDZX,PDZY,PDZZ,PRHODJ,PTHETAV,ZQ)
+#else
+ CALL QLAP_DEVICE(ZKSI,HLBCX,HLBCY,PDXX,PDYY,PDZX,PDZY,PDZZ,PRHODJ,PTHETAV,ZQ)
+#endif
+! -1
+!* 2.6 compute the step ALPHA
+!
+ ZALPHA = - DOTPROD(ZKSI,ZDELTA,HLBCX,HLBCY) / ZDOT_DELTA ! lambda
+!
+!* 2.7 update p and DELTA
+!
+ !$acc kernels
+ ZP = ZQ + ZALPHA * ZP
+ ZDELTA = ZKSI + ZALPHA * ZDELTA
+ !$acc end kernels
+!
+END DO ! end of the loop for the iterative solver
+!
+!
+!-------------------------------------------------------------------------------
+!
+END SUBROUTINE ZSOLVER
diff --git a/src/ZSOLVER/zsolver_inv.f90 b/src/ZSOLVER/zsolver_inv.f90
new file mode 100644
index 0000000000000000000000000000000000000000..e6cfc214eef4a48d8064037fd25c42d35fee1078
--- /dev/null
+++ b/src/ZSOLVER/zsolver_inv.f90
@@ -0,0 +1,478 @@
+!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 solver 2006/05/18 13:07:25
+!-----------------------------------------------------------------
+! ####################
+ MODULE MODI_ZSOLVER_INV
+! ####################
+!
+INTERFACE
+!
+ SUBROUTINE ZSOLVER_INV(HLBCX,HLBCY,PDXHATM,PDYHATM,PRHOM,PAF,PBF,PCF, &
+ PTRIGSX,PTRIGSY,KIFAXX,KIFAXY,PY,PF_1_Y, &
+ PAF_ZS,PBF_ZS,PCF_ZS, &
+ PDXATH_ZS,PDYATH_ZS,PRHO_ZS,PBFB, &
+ A_K,B_K,C_K,D_K)
+!
+!
+IMPLICIT NONE
+!
+CHARACTER (LEN=4), DIMENSION(2), INTENT(IN) :: HLBCX ! x-direction LBC type
+CHARACTER (LEN=4), DIMENSION(2), INTENT(IN) :: HLBCY ! y-direction LBC type
+!
+REAL, INTENT(IN) :: PDXHATM ! mean grid increment in the x
+ ! direction
+REAL, INTENT(IN) :: PDYHATM ! mean grid increment in the y
+ ! direction
+!
+REAL, DIMENSION (:), INTENT(IN) :: PRHOM ! mean of XRHODJ on the plane x y
+ ! localized at a mass level
+!
+REAL, DIMENSION(:), INTENT(IN) :: PAF,PCF ! vectors giving the nonvanishing
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PBF ! elements of the tri-diag.
+ ! matrix in the pressure eq.
+!
+ ! arrays of sin or cos values
+ ! for the FFT :
+REAL, DIMENSION(:), INTENT(IN) :: PTRIGSX ! - along x
+REAL, DIMENSION(:), INTENT(IN) :: PTRIGSY ! - along y
+!
+ ! decomposition in prime
+ ! numbers for the FFT:
+INTEGER, DIMENSION(19), INTENT(IN) :: KIFAXX ! - along x
+INTEGER, DIMENSION(19), INTENT(IN) :: KIFAXY ! - along y
+!
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PY ! RHS of the equation
+!
+REAL, DIMENSION(:,:,:), INTENT(OUT):: PF_1_Y ! solution of the equation
+!
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PAF_ZS,PBF_ZS,PCF_ZS
+REAL, DIMENSION(:,:) , INTENT(IN) :: PDXATH_ZS,PDYATH_ZS
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHO_ZS,PBFB
+REAL, DIMENSION(:) , INTENT(IN) :: A_K,B_K,C_K,D_K
+!
+!
+END SUBROUTINE ZSOLVER_INV
+!
+END INTERFACE
+!
+END MODULE MODI_ZSOLVER_INV
+! ######################################################################
+SUBROUTINE ZSOLVER_INV(HLBCX,HLBCY,PDXHATM,PDYHATM,PRHOM,PAF,PBF,PCF, &
+ PTRIGSX,PTRIGSY,KIFAXX,KIFAXY,PY,PF_1_Y, &
+ PAF_ZS,PBF_ZS,PCF_ZS, &
+ PDXATH_ZS,PDYATH_ZS,PRHO_ZS,PBFB, &
+ A_K,B_K,C_K,D_K)
+ ! ######################################################################
+ !
+ !!**** *FLAT_INV * - Invert the flat quasi-laplacian operator
+ !!
+ !! PURPOSE
+ !! -------
+ ! This routine solves the following equation:
+ ! F ( F_1_Y ) = Y
+ ! where F represents the quasi-laplacian without orography. The solution is
+ ! F_1_Y.
+ !
+ !!** METHOD
+ !! ------
+ !! The horizontal part of F is inverted with a FFT transform. For each
+ !! horizontal direction, the FFT form depends on the lateral boundary
+ !! conditions :
+ !! - CRAY intrinsic function RFFTMLT in the cyclic case
+ !! - fast cosine transform called FFT55 for all other boundary condtions.
+ !! Then, in the wavenumber space, we invert for each
+ !! horizontal mode i,j a tridiagonal matrix by a classical double sweep
+ !! method. The singular mean mode (i,j)=(0,0) corresponds to the
+ !! undetermination of the pressure to within a constant and is treated apart.
+ !! To fix this degree of freedom, we set the horizontal mean value of the
+ !! pressure perturbation to 0 at the upper level of the model.
+ !!
+ !! EXTERNAL
+ !! --------
+ !! Subroutine FFT55 : aplly multiple fast real staggered (shifted)
+ !! cosine transform
+ !! Subroutine RFFTMLT : apply real-to-complex or complex-to-real Fast
+ !! Fourier Transform (FFT) on multiple input vectors.
+ !! Subroutine FFT991 : equivalent to RFFTMLT
+ !!
+ !! IMPLICIT ARGUMENTS
+ !! ------------------
+ !! Module MODD_PARAMETERS: declaration of parameter variables
+ !! JPHEXT, JPVEXT: define the number of marginal points out of the
+ !! physical domain along horizontal and vertical directions respectively
+ !! Module MODD_CONF: model configurations
+ !! L2D: logical for 2D model version
+ !!
+ !! REFERENCE
+ !! ---------
+ !! Book2 of documentation (subroutine FLAT_INV)
+ !!
+ !! AUTHOR
+ !! ------
+ !! P. Hereil and J. Stein * Meteo France *
+ !!
+ !! MODIFICATIONS
+ !! -------------
+ !! Original 20/07/94
+ !! Revision Jabouille (juillet 96) replace the CRAY intrinsic function
+ !! RFFTMLT by the arpege routine FFT991
+ !! 17/07/97 ( J. Stein and V. Masson) initialize the corner
+ !! verticals
+ !! 17/07/97 ( J. Stein and V. Masson) initialize the corner
+ !! verticals
+ !! Revision Jabouille (septembre 97) suppress the particular case for
+ !! tridiagonal inversion
+ !! Stein ( January 98 ) faster computation for the unused
+ !! points under the ground and out of the domain
+ !! Modification Lugato, Guivarch (June 1998) Parallelisation
+ !! Escobar, Stein (July 2000) optimisation
+ !-------------------------------------------------------------------------------
+ !
+ !* 0. DECLARATIONS
+ ! ------------
+ !
+ USE MODD_PARAMETERS
+ USE MODD_CONF
+ !
+ USE MODE_ll
+ USE MODD_ARGSLIST_ll, ONLY : LIST_ll
+ !
+ USE MODI_FFT55
+ USE MODI_GET_HALO
+ USE MODI_FLAT_INV
+ USE MODI_DOTPROD
+ !
+ USE mode_mg_main_mnh
+ !
+ IMPLICIT NONE
+ !
+ !* 0.1 declarations of arguments
+ !
+ CHARACTER (LEN=4), DIMENSION(2), INTENT(IN) :: HLBCX ! x-direction LBC type
+ CHARACTER (LEN=4), DIMENSION(2), INTENT(IN) :: HLBCY ! y-direction LBC type
+ !
+ REAL, INTENT(IN) :: PDXHATM ! mean grid increment in the x
+ ! direction
+ REAL, INTENT(IN) :: PDYHATM ! mean grid increment in the y
+ ! direction
+ !
+ REAL, DIMENSION (:), INTENT(IN) :: PRHOM ! mean of XRHODJ on the plane x y
+ ! localized at a mass level
+ !
+ REAL, DIMENSION(:), INTENT(IN) :: PAF,PCF ! vectors giving the nonvanishing
+ REAL, DIMENSION(:,:,:), INTENT(IN) :: PBF ! elements of the tri-diag.
+ ! matrix in the pressure eq.
+ !
+ ! arrays of sin or cos values
+ ! for the FFT :
+ REAL, DIMENSION(:), INTENT(IN) :: PTRIGSX ! - along x
+ REAL, DIMENSION(:), INTENT(IN) :: PTRIGSY ! - along y
+ !
+ ! decomposition in prime
+ ! numbers for the FFT:
+ INTEGER, DIMENSION(19), INTENT(IN) :: KIFAXX ! - along x
+ INTEGER, DIMENSION(19), INTENT(IN) :: KIFAXY ! - along y
+ !
+ REAL, DIMENSION(:,:,:), INTENT(IN) :: PY ! RHS of the equation
+ !
+ REAL, DIMENSION(:,:,:), INTENT(OUT):: PF_1_Y ! solution of the equation
+ !
+ REAL, DIMENSION(:,:,:), INTENT(IN) :: PAF_ZS,PBF_ZS,PCF_ZS
+ REAL, DIMENSION(:,:) , INTENT(IN) :: PDXATH_ZS,PDYATH_ZS
+ REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHO_ZS,PBFB
+ REAL, DIMENSION(:) , INTENT(IN) :: A_K,B_K,C_K,D_K
+ !
+ !* 0.2 declaration of local variables
+ !
+ REAL, DIMENSION(SIZE(PY,1),SIZE(PY,2),SIZE(PY,3)) :: ZY ! work array to store
+ ! the RHS of the equation
+ !
+ !REAL, DIMENSION(SIZE(PY,1),SIZE(PY,2),SIZE(PY,3)) :: ZWORK ! work array used by
+ ! the FFT. It has been enlarged in order to be sufficient for 2D and 3D cases
+ !
+ REAL, DIMENSION(SIZE(PBF,1),SIZE(PBF,2),SIZE(PBF,3)) :: ZAF ! work array to
+ ! ! expand PAF
+ INTEGER :: IIB ! indice I for the first inner mass point along x
+ INTEGER :: IIE ! indice I for the last inner mass point along x
+ INTEGER :: IJB ! indice J for the first inner mass point along y
+ INTEGER :: IJE ! indice J for the last inner mass point along y
+ INTEGER :: IKB ! indice K for the first inner mass point along z
+ INTEGER :: IKE ! indice K for the last inner mass point along z
+ INTEGER :: IKU ! size of the arrays along z
+ !
+ INTEGER :: JI,JJ,JK ! loop indexes along x, y, z respectively
+ INTEGER :: IIU,IJU
+ !-------------------------------------------------------------------------------
+ !
+ !* 1. COMPUTE LOOP BOUNDS
+ ! -------------------
+ !
+ !CALL GET_PHYSICAL_ll(IIB,IJB,IIE,IJE)
+ CALL GET_INDICE_ll(IIB,IJB,IIE,IJE)
+ CALL GET_DIM_EXT_ll('B',IIU,IJU)
+ !
+ IKU=SIZE(PY,3)
+ IKB=1+JPVEXT
+ IKE=IKU - JPVEXT
+ !
+ !
+ !-------------------------------------------------------------------------------
+ !
+ !* 3. FORM HOMOGENEOUS BOUNDARY CONDITIONS FOR A NONCYCLIC CASE
+ ! ---------------------------------------------------------
+ !
+ !
+ !* 3.1 copy the RHS in a local array REMAP functions will shift the indices for the FFT
+ !
+ !$acc kernels
+ PF_1_Y = 0.
+ ZY = PY
+ !$acc end kernels
+ !
+ !* 3.2 form homogeneous boundary condition used by the FFT for non-periodic
+ ! cases
+ !
+ ! modify the RHS in the x direction
+ !
+ IF (HLBCX(1) /= 'CYCL') THEN
+ !
+ IF (LWEST_ll(HSPLITTING='B')) THEN
+ !$acc kernels async
+ DO JK=IKB,IKE
+ DO JJ = IJB, IJE
+ ZY(IIB,JJ,JK) = ZY(IIB,JJ,JK) + PY(IIB-1,JJ,JK)
+ END DO
+ END DO
+ !$acc end kernels
+ END IF
+ !
+ IF (LEAST_ll(HSPLITTING='B')) THEN
+ !$acc kernels async
+ DO JK=IKB,IKE
+ DO JJ = IJB, IJE
+ ZY(IIE,JJ,JK) = ZY(IIE,JJ,JK) - PY(IIE+1,JJ,JK)
+ END DO
+ END DO
+ !$acc end kernels
+ END IF
+ END IF
+ !
+ ! modify the RHS in the same way along y
+ !
+ IF (HLBCY(1) /= 'CYCL'.AND. (.NOT. L2D)) THEN
+ IF (LSOUTH_ll(HSPLITTING='B')) THEN
+ !$acc kernels async
+ DO JK=IKB,IKE
+ DO JI = IIB, IIE
+ ZY(JI,IJB,JK) = ZY(JI,IJB,JK) + PY(JI,IJB-1,JK)
+ END DO
+ END DO
+ !$acc end kernels
+ END IF
+ !
+ IF (LNORTH_ll(HSPLITTING='B')) THEN
+ !$acc kernels async
+ DO JK=IKB,IKE
+ DO JI = IIB, IIE
+ ZY(JI,IJE,JK) = ZY(JI,IJE,JK) - PY(JI,IJE+1,JK)
+ END DO
+ END DO
+ !$acc end kernels
+ END IF
+ END IF
+ !$acc wait
+ !
+ !-------------------------------------------------------------------------------
+ !
+ !* 5. MATRIX INVERSION FOR THE FLAT OPERATOR
+ ! --------------------------------------
+ !
+ IF (L2D) THEN
+ STOP ' NO 2D MULTIGRID YET '
+ END IF
+
+ call mg_main_initialise_rhs_mnh(IIB,IIE,IIU,IJB,IJE,IJU,IKU,ZY)
+ call mg_main_initialise_u_mnh(IIB,IIE,IIU,IJB,IJE,IJU,IKU,PF_1_Y)
+
+ !print*,'************************ mg_main_mnh_solve ***************************'
+
+ call mg_main_mnh_solve()
+ call mg_main_get_u_mnh(IIB,IIE,IIU,IJB,IJE,IJU,IKU,PF_1_Y)
+ !
+ ! WARNING WITH GET_HALO_D not BITREPROD !!!
+ !
+ CALL GET_HALO(PF_1_Y)
+ !
+ CALL PF_1_Y_BOUND(PF_1_Y)
+ !-------------------------------------------------------------------------------
+ !
+CONTAINS
+
+SUBROUTINE PF_1_Y_BOUND(PF_1_Y)
+
+IMPLICIT NONE
+
+REAL , DIMENSION (:,:,:) :: PF_1_Y
+
+INTEGER :: ZDXM2, ZDYM2
+
+ !-------------------------------------------------------------------------------
+ !
+ !* 7. RETURN TO A NON HOMOGENEOUS NEUMAN CONDITION FOR NON-CYCLIC CASES
+ ! -----------------------------------------------------------------
+ !
+ !* 7.2 complete the lateral boundaries
+ !
+ IF (HLBCX(1) /= 'CYCL') THEN
+ !
+ !* 7.2.1 return to a non-homogeneous case in the x direction
+ !
+ ZDXM2 = PDXHATM*PDXHATM
+ !
+ IF (LWEST_ll(HSPLITTING='B')) THEN
+ !$acc kernels loop independent collapse(2) async
+ DO JK=IKB,IKE
+ DO JJ = IJB,IJE
+ PF_1_Y(IIB-1,JJ,JK) = PF_1_Y(IIB,JJ,JK) - PY(IIB-1,JJ,JK)*ZDXM2/PRHOM(JK)
+ END DO
+ END DO
+ !$acc end kernels
+ END IF
+ !
+ IF (LEAST_ll(HSPLITTING='B')) THEN
+ !$acc kernels loop independent collapse(2) async
+ DO JK=IKB,IKE
+ DO JJ = IJB,IJE
+ PF_1_Y(IIE+1,JJ,JK) = PF_1_Y(IIE,JJ,JK) + PY(IIE+1,JJ,JK)*ZDXM2/PRHOM(JK)
+ END DO
+ END DO
+ !$acc end kernels
+ END IF
+ !$acc wait
+ !
+ ! we set the solution at the corner point by the condition:
+ ! dxm ( P ) = 0
+ IF (LWEST_ll(HSPLITTING='B')) THEN
+ !$acc kernels loop independent async
+ DO JJ = IJB,IJE
+ PF_1_Y(IIB-1,JJ,IKB-1) = PF_1_Y(IIB,JJ,IKB-1)
+ PF_1_Y(IIB-1,JJ,IKE+1) = PF_1_Y(IIB,JJ,IKE+1)
+ END DO
+ !$acc end kernels
+ END IF
+ IF (LEAST_ll(HSPLITTING='B')) THEN
+ !$acc kernels loop independent async
+ DO JJ = IJB,IJE
+ PF_1_Y(IIE+1,JJ,IKB-1) = PF_1_Y(IIE,JJ,IKB-1)
+ PF_1_Y(IIE+1,JJ,IKE+1) = PF_1_Y(IIE,JJ,IKE+1)
+ END DO
+ !$acc end kernels
+ END IF
+ !$acc wait
+ !
+ ELSE
+ !
+ !* 7.2.2 periodize the pressure function field along the x direction
+ !
+ ! in fact this part is useless because it is done in the routine
+ ! REMAP_X_2WAY.
+ !
+ END IF
+!!$!
+ IF (.NOT.L2D) THEN
+ IF (HLBCY(1) /= 'CYCL') THEN
+ !
+ !* 7.2.3 return to a non-homogeneous case in the y direction
+ !
+ ZDYM2 = PDYHATM*PDYHATM
+ !
+ IF (LSOUTH_ll(HSPLITTING='B')) THEN
+ !$acc kernels loop independent collapse(2) async
+ DO JK=IKB,IKE
+ DO JI = IIB,IIE
+ PF_1_Y(JI,IJB-1,JK) = PF_1_Y(JI,IJB,JK) - PY(JI,IJB-1,JK)*ZDYM2/PRHOM(JK)
+ END DO
+ END DO
+ !$acc end kernels
+ END IF
+ !
+ IF (LNORTH_ll(HSPLITTING='B')) THEN
+ !$acc kernels loop independent collapse(2) async
+ DO JK=IKB,IKE
+ DO JI = IIB,IIE
+ PF_1_Y(JI,IJE+1,JK) = PF_1_Y(JI,IJE,JK) + PY(JI,IJE+1,JK)*ZDYM2/PRHOM(JK)
+ END DO
+ END DO
+ !$acc end kernels
+ END IF
+ !$acc wait
+ ! we set the solution at the corner point by the condition:
+ ! dym ( P ) = 0
+ !
+ IF (LSOUTH_ll(HSPLITTING='B')) THEN
+ !$acc kernels loop independent async
+ DO JI = IIB,IIE
+ PF_1_Y(JI,IJB-1,IKB-1) = PF_1_Y(JI,IJB,IKB-1)
+ PF_1_Y(JI,IJB-1,IKE+1) = PF_1_Y(JI,IJB,IKE+1)
+ END DO
+ !$acc end kernels
+ END IF
+ !
+ IF (LNORTH_ll(HSPLITTING='B')) THEN
+ !$acc kernels loop independent async
+ DO JI = IIB,IIE
+ PF_1_Y(JI,IJE+1,IKB-1) = PF_1_Y(JI,IJE,IKB-1)
+ PF_1_Y(JI,IJE+1,IKE+1) = PF_1_Y(JI,IJE,IKE+1)
+ END DO
+ !$acc end kernels
+ END IF
+ !$acc wait
+ ELSE
+ !
+ !* 7.2.4 periodize the pressure function field along the y direction
+ !
+ !
+ ! in fact this part is useless because it is done in the routine
+ ! REMAP_X_2WAY.
+ !
+ END IF
+ !
+ END IF
+ !
+ IF (.NOT. L2D .AND. HLBCX(1)/='CYCL' .AND. HLBCY(1)/='CYCL') THEN
+ ! the following verticals are not used
+ IF ( (LWEST_ll(HSPLITTING='B')).AND.(LSOUTH_ll(HSPLITTING='B')) ) THEN
+ !$acc kernels async
+ PF_1_Y(IIB-1,IJB-1,:)= PF_1_Y(IIB,IJB,:) ! 0.0
+ !$acc end kernels
+ END IF
+ !
+ IF ( (LWEST_ll(HSPLITTING='B')).AND.(LNORTH_ll(HSPLITTING='B')) ) THEN
+ !$acc kernels async
+ PF_1_Y(IIB-1,IJE+1,:)= PF_1_Y(IIB,IJE,:) ! 0.0
+ !$acc end kernels
+ END IF
+ !
+ IF ( (LEAST_ll(HSPLITTING='B')).AND.(LSOUTH_ll(HSPLITTING='B')) ) THEN
+ !$acc kernels async
+ PF_1_Y(IIE+1,IJB-1,:)= PF_1_Y(IIE,IJB,:) ! 0.0
+ !$acc end kernels
+ END IF
+ !
+ IF ( (LEAST_ll(HSPLITTING='B')).AND.(LNORTH_ll(HSPLITTING='B')) ) THEN
+ !$acc kernels async
+ PF_1_Y(IIE+1,IJE+1,:)= PF_1_Y(IIE,IJE,:) ! 0.0
+ !$acc end kernels
+ END IF
+ !$acc wait
+ END IF
+END SUBROUTINE PF_1_Y_BOUND
+ !------------------------------------------------------------------------------
+END SUBROUTINE ZSOLVER_INV