diff --git a/arch/CNRS/arch-X64_IRENE_GCC.fcm b/arch/CNRS/arch-X64_IRENE_GCC.fcm
index 99dffdfbefe76486365f86c46e1a7f23590c0382..f3c63fa392f047a5d5c802ef7cc61c5b62dfbeda 100644
--- a/arch/CNRS/arch-X64_IRENE_GCC.fcm
+++ b/arch/CNRS/arch-X64_IRENE_GCC.fcm
@@ -5,9 +5,9 @@
# module purge
# module load gnu/8.3.0
# module load flavor/buildcompiler/gcc/8
-# module load flavor/buildmpi/openmpi/2.0
+# module load flavor/buildmpi/openmpi/4.0
# module load flavor/hdf5/parallel
-# module load mpi/openmpi/2.0.4
+# module load mpi/openmpi/4.0.5.3
# module load hdf5/1.8.20
# module load netcdf-c/4.6.0
# module load netcdf-fortran/4.4.4
@@ -30,7 +30,7 @@
%CPP cpp -Dkey_nosignedzero
%FC mpif90
%PROD_FCFLAGS -fdefault-real-8 -O3 -funroll-all-loops -fcray-pointer -ffree-line-length-none -Wno-missing-include-dirs
-%DEBUG_FCFLAGS -fdefault-real-8 -O0 -g -fbacktrace -funroll-all-loops -fcray-pointer -ffree-line-length-none -fcheck=all -finit-real=nan
+%DEBUG_FCFLAGS -fdefault-real-8 -O0 -g -fbacktrace -funroll-all-loops -fcray-pointer -ffree-line-length-none -Wno-missing-include-dirs -fcheck=all -finit-real=nan
%FFLAGS %FCFLAGS
%LD mpif90
%LDFLAGS
diff --git a/arch/CNRS/arch-X64_JEANZAY_GCC.fcm b/arch/CNRS/arch-X64_JEANZAY_GCC.fcm
new file mode 100644
index 0000000000000000000000000000000000000000..12051bec23ed8e1736dd7bb151c7a01bd62464c4
--- /dev/null
+++ b/arch/CNRS/arch-X64_JEANZAY_GCC.fcm
@@ -0,0 +1,74 @@
+# Jean-Zay HPE at IDRIS, http://www.idris.fr/jean-zay
+#
+# XIOS_HOME root directory containing lib for XIOS
+# OASIS_HOME root directory containing lib for OASIS
+#
+# NCDF_INC netcdf4 include file
+# NCDF_LIB netcdf4 library
+# XIOS_INC xios include file (taken into accound only if key_xios is activated)
+# XIOS_LIB xios library (taken into accound only if key_xios is activated)
+# OASIS_INC oasis include file (taken into accound only if key_oasis3 is activated)
+# OASIS_LIB oasis library (taken into accound only if key_oasis3 is activated)
+#
+# FC Fortran compiler command
+# FCFLAGS Fortran compiler flags
+# FFLAGS Fortran 77 compiler flags
+# LD linker
+# LDFLAGS linker flags, e.g. -L<lib dir> if you have libraries
+# FPPFLAGS pre-processing flags
+# AR assembler
+# ARFLAGS assembler flags
+# MK make
+# USER_INC complete list of include files
+# USER_LIB complete list of libraries to pass to the linker
+# CC C compiler used to compile conv for AGRIF
+# CFLAGS compiler flags used with CC
+#
+# Note that:
+# - unix variables "$..." are accpeted and will be evaluated before calling fcm.
+# - fcm variables are starting with a % (and not a $)
+#
+# Module we used:
+# module purge
+# module load gcc/8.3.1
+# module load openmpi/4.1.1
+# module load hdf5/1.12.0-mpi
+# module load netcdf-c/4.7.4-mpi
+# module load netcdf-fortran/4.5.3-mpi
+#
+#---------------------------------------------------------------------------------------------
+#---------------------------------------------------------------------------------------------
+# All NETCDF and HDF paths are empty as they are automatically defined through environment
+# variables by the load of modules
+#---------------------------------------------------------------------------------------------
+#---------------------------------------------------------------------------------------------
+#
+#
+%XIOS_HOME $WORK/xios-trunk_gcc
+%OASIS_HOME
+%NETCDF_C_HOME $( echo $PATH | xargs -d ':' -n 1 | grep netcdf-c )/..
+%NETCDF_F_HOME $( echo $PATH | xargs -d ':' -n 1 | grep netcdf-fortran )/..
+
+%NCDF_INC -I%NETCDF_F_HOME/include -I%NETCDF_C_HOME/include
+%NCDF_LIB -L%NETCDF_F_HOME/lib -lnetcdff -L%NETCDF_C_HOME/lib -lnetcdf
+%XIOS_INC -I%XIOS_HOME/inc
+%XIOS_LIB -L%XIOS_HOME/lib -lxios -lstdc++
+%OASIS_INC -I%OASIS_HOME/build/lib/mct -I%OASIS_HOME/build/lib/psmile.MPI1
+%OASIS_LIB -L%OASIS_HOME/lib -lpsmile.MPI1 -lmct -lmpeu -lscrip
+
+%CPP cpp -Dkey_nosignedzero
+%FC mpif90
+%PROD_FCFLAGS -fdefault-real-8 -O3 -funroll-all-loops -fcray-pointer -ffree-line-length-none -Wno-missing-include-dirs
+%DEBUG_FCFLAGS -fdefault-real-8 -O0 -g -fbacktrace -funroll-all-loops -fcray-pointer -ffree-line-length-none -Wno-missing-include-dirs -fcheck=all -finit-real=nan
+%FFLAGS %FCFLAGS
+%LD mpif90
+%LDFLAGS
+%FPPFLAGS -P -traditional
+%AR ar
+%ARFLAGS rs
+%MK gmake
+%USER_INC %XIOS_INC %OASIS_INC %NCDF_INC
+%USER_LIB %XIOS_LIB %OASIS_LIB %NCDF_LIB
+
+%CC cc
+%CFLAGS -O0
diff --git a/arch/arch-osx_gfortran.fcm b/arch/arch-osx_gfortran.fcm
index 3ce12293a13ecbb091d1f5a058dbd52369ea4576..ece845b947a53e4e57d1057e8c11ef30488d1809 100644
--- a/arch/arch-osx_gfortran.fcm
+++ b/arch/arch-osx_gfortran.fcm
@@ -35,8 +35,8 @@
%CPP cpp -Dkey_nosignedzero
%FC mpif90
-%PROD_FCFLAGS -fdefault-real-8 -O3 -funroll-all-loops -fcray-pointer -ffree-line-length-none -fallow-argument-mismatch
-%DEBUG_FCFLAGS -fdefault-real-8 -O0 -g -fbacktrace -funroll-all-loops -fcray-pointer -ffree-line-length-none -fcheck=all -finit-real=nan
+%PROD_FCFLAGS -fdefault-real-8 -O3 -funroll-all-loops -fcray-pointer -ffree-line-length-none -fallow-argument-mismatch
+%DEBUG_FCFLAGS -fdefault-real-8 -O0 -g -fbacktrace -funroll-all-loops -fcray-pointer -ffree-line-length-none -fcheck=all -finit-real=nan -fallow-argument-mismatch
%FFLAGS %FCFLAGS
%LD %FC
%LDFLAGS
diff --git a/cfgs/AGRIF_DEMO/EXPREF/file_def_nemo-oce.xml b/cfgs/AGRIF_DEMO/EXPREF/file_def_nemo-oce.xml
index 0d0368d72066347fcc66532477e50d40941ecf95..6cb04ff08edd17dbda063ce517c65ec3582c7805 100644
--- a/cfgs/AGRIF_DEMO/EXPREF/file_def_nemo-oce.xml
+++ b/cfgs/AGRIF_DEMO/EXPREF/file_def_nemo-oce.xml
@@ -34,6 +34,8 @@
<field field_ref="qt_oce" name="qt_oce" />
<field field_ref="saltflx" name="sfx" />
<field field_ref="taum" name="taum" />
+ <field field_ref="utau" name="tauuo" />
+ <field field_ref="vtau" name="tauvo" />
<field field_ref="wspd" name="windsp" />
<field field_ref="precip" name="precip" />
<!-- ice and snow -->
@@ -44,7 +46,6 @@
<field field_ref="e3u" />
<field field_ref="ssu" name="uos" />
<field field_ref="uoce" name="uo" operation="instant" freq_op="5d" > @uoce_e3u / @e3u </field>
- <field field_ref="utau" name="tauuo" />
<field field_ref="uocetr_eff" name="uocetr_eff" />
<!-- available with diaar5 -->
<field field_ref="u_masstr" name="vozomatr" />
@@ -56,7 +57,6 @@
<field field_ref="e3v" />
<field field_ref="ssv" name="vos" />
<field field_ref="voce" name="vo" operation="instant" freq_op="5d" > @voce_e3v / @e3v </field>
- <field field_ref="vtau" name="tauvo" />
<field field_ref="vocetr_eff" name="vocetr_eff" />
<!-- available with diaar5 -->
<field field_ref="v_masstr" name="vomematr" />
diff --git a/cfgs/AGRIF_DEMO/cpp_AGRIF_DEMO.fcm b/cfgs/AGRIF_DEMO/cpp_AGRIF_DEMO.fcm
index c601304c02b7222e13ec1c3f5fffab37e3dbc88d..0e63a0c88c5a15ff518eba03d436c3b64111a310 100644
--- a/cfgs/AGRIF_DEMO/cpp_AGRIF_DEMO.fcm
+++ b/cfgs/AGRIF_DEMO/cpp_AGRIF_DEMO.fcm
@@ -1 +1 @@
-bld::tool::fppkeys key_si3 key_top key_xios key_agrif key_qco
+bld::tool::fppkeys key_si3 key_top key_xios key_agrif key_qco key_vco_1d3d
diff --git a/cfgs/AMM12/EXPREF/file_def_nemo-oce.xml b/cfgs/AMM12/EXPREF/file_def_nemo-oce.xml
index 776def802a18a6cc9f7ee4e9dd83f95132c4f5c7..d8c7291419b3cf1e34be1995cfffc2b50512c4eb 100644
--- a/cfgs/AMM12/EXPREF/file_def_nemo-oce.xml
+++ b/cfgs/AMM12/EXPREF/file_def_nemo-oce.xml
@@ -100,6 +100,8 @@
<field field_ref="qsr" name="rsntds" />
<field field_ref="qt" name="tohfls" />
<field field_ref="taum" />
+ <field field_ref="utau" name="tauuo" />
+ <field field_ref="vtau" name="tauvo" />
<field field_ref="mldkz5" />
<field field_ref="mldr10_1" />
</file>
@@ -107,13 +109,11 @@
<file id="file5" name_suffix="_grid_U" description="ocean U grid variables" >
<field field_ref="uoce" name="uo" />
<field field_ref="ssu" name="uos" />
- <field field_ref="utau" name="tauuo" />
</file>
<file id="file6" name_suffix="_grid_V" description="ocean V grid variables" >
<field field_ref="voce" name="vo" />
<field field_ref="ssv" name="vos" />
- <field field_ref="vtau" name="tauvo" />
</file>
<file id="file7" name_suffix="_grid_W" description="ocean W grid variables" >
diff --git a/cfgs/AMM12/cpp_AMM12.fcm b/cfgs/AMM12/cpp_AMM12.fcm
index f336c66632ebbddf8e67515e6df8b179ac0bb10f..da62ce79c7a9450404270cab61832b7a74267159 100644
--- a/cfgs/AMM12/cpp_AMM12.fcm
+++ b/cfgs/AMM12/cpp_AMM12.fcm
@@ -1 +1 @@
- bld::tool::fppkeys key_diainstant key_xios key_qco
+ bld::tool::fppkeys key_diainstant key_xios key_qco key_vco_3d
diff --git a/cfgs/GYRE_PISCES/EXPREF/file_def_nemo.xml b/cfgs/GYRE_PISCES/EXPREF/file_def_nemo.xml
index e24e2271a290446e9abcd4371329e210b83e0ad5..57144055d7774e652660e39313bf7036a4573a88 100644
--- a/cfgs/GYRE_PISCES/EXPREF/file_def_nemo.xml
+++ b/cfgs/GYRE_PISCES/EXPREF/file_def_nemo.xml
@@ -32,16 +32,16 @@
<field field_ref="qt" name="sohefldo" />
<field field_ref="mldr10_1" name="somxl010" />
<field field_ref="mldkz5" name="somixhgt" />
+ <field field_ref="utau" name="sozotaux" />
+ <field field_ref="vtau" name="sometauy" />
</file>
<file id="file2" name_suffix="_grid_U" description="ocean U grid variables" >
<field field_ref="uoce" name="vozocrtx" />
- <field field_ref="utau" name="sozotaux" />
</file>
<file id="file3" name_suffix="_grid_V" description="ocean V grid variables" >
<field field_ref="voce" name="vomecrty" />
- <field field_ref="vtau" name="sometauy" />
</file>
<file id="file4" name_suffix="_grid_W" description="ocean W grid variables" >
diff --git a/cfgs/GYRE_PISCES/cpp_GYRE_PISCES.fcm b/cfgs/GYRE_PISCES/cpp_GYRE_PISCES.fcm
index c1b9eb39aba4411355d686b08f5964e22d27f2a7..e9e766e9e7e97f43fbbae300be8d62a9b69130e5 100644
--- a/cfgs/GYRE_PISCES/cpp_GYRE_PISCES.fcm
+++ b/cfgs/GYRE_PISCES/cpp_GYRE_PISCES.fcm
@@ -1 +1 @@
-bld::tool::fppkeys key_top key_linssh key_xios
+bld::tool::fppkeys key_top key_linssh key_vco_1d key_xios
diff --git a/cfgs/ORCA2_ICE_ABL/EXPREF/file_def_nemo-oce.xml b/cfgs/ORCA2_ICE_ABL/EXPREF/file_def_nemo-oce.xml
index 6d6df82d2902518fb8e6e7e45a9e1d182726462d..9ba0c304fe37810dc0178058ac87ca15dff327df 100644
--- a/cfgs/ORCA2_ICE_ABL/EXPREF/file_def_nemo-oce.xml
+++ b/cfgs/ORCA2_ICE_ABL/EXPREF/file_def_nemo-oce.xml
@@ -30,6 +30,8 @@
<field field_ref="qt_oce" name="qt_oce" />
<field field_ref="saltflx" name="sfx" />
<field field_ref="taum" name="taum" />
+ <field field_ref="utau" name="tauuo" />
+ <field field_ref="vtau" name="tauvo" />
<field field_ref="wspd" name="windsp" />
<field field_ref="precip" name="precip" />
<!-- ice and snow -->
@@ -40,14 +42,12 @@
<field field_ref="e3u" />
<field field_ref="ssu" name="uos" />
<field field_ref="uoce" name="uo" />
- <field field_ref="utau" name="tauuo" />
</file>
<file id="file13" name_suffix="_grid_V" description="ocean V grid variables" >
<field field_ref="e3v" />
<field field_ref="ssv" name="vos" />
<field field_ref="voce" name="vo" />
- <field field_ref="vtau" name="tauvo" />
</file>
<file id="file14" name_suffix="_grid_ABL" description="ABL grid variables" >
diff --git a/cfgs/ORCA2_ICE_PISCES/EXPREF/file_def_nemo-oce.xml b/cfgs/ORCA2_ICE_PISCES/EXPREF/file_def_nemo-oce.xml
index c043f56fe5e9ae6fc252ae34d78b6c2660381ec9..04590b55f29789842576a1dff286ad9ec572d172 100644
--- a/cfgs/ORCA2_ICE_PISCES/EXPREF/file_def_nemo-oce.xml
+++ b/cfgs/ORCA2_ICE_PISCES/EXPREF/file_def_nemo-oce.xml
@@ -34,6 +34,8 @@
<field field_ref="qt_oce" name="qt_oce" />
<field field_ref="saltflx" name="sfx" />
<field field_ref="taum" name="taum" />
+ <field field_ref="utau" name="tauuo" />
+ <field field_ref="vtau" name="tauvo" />
<field field_ref="wspd" name="windsp" />
<field field_ref="precip" name="precip" />
<!-- ice and snow -->
@@ -44,7 +46,6 @@
<field field_ref="e3u" />
<field field_ref="ssu" name="uos" />
<field field_ref="uoce" name="uo" operation="instant" freq_op="5d" > @uoce_e3u / @e3u </field>
- <field field_ref="utau" name="tauuo" />
<field field_ref="uocetr_eff" name="uocetr_eff" />
<!-- available with diaar5 -->
<field field_ref="u_masstr" name="vozomatr" />
@@ -56,7 +57,6 @@
<field field_ref="e3v" />
<field field_ref="ssv" name="vos" />
<field field_ref="voce" name="vo" operation="instant" freq_op="5d" > @voce_e3v / @e3v </field>
- <field field_ref="vtau" name="tauvo" />
<field field_ref="vocetr_eff" name="vocetr_eff" />
<!-- available with diaar5 -->
<field field_ref="v_masstr" name="vomematr" />
diff --git a/cfgs/ORCA2_ICE_PISCES/EXPREF/namelist_cfg b/cfgs/ORCA2_ICE_PISCES/EXPREF/namelist_cfg
index 4b17c10299ec87c10936d1ed936390a783d0f3e3..c6e94339d09e11830e49e55ebf1aafcd7761c391 100644
--- a/cfgs/ORCA2_ICE_PISCES/EXPREF/namelist_cfg
+++ b/cfgs/ORCA2_ICE_PISCES/EXPREF/namelist_cfg
@@ -118,6 +118,17 @@
&namsbc_abl ! Atmospheric Boundary Layer formulation (ln_abl = T)
!-----------------------------------------------------------------------
cn_dom = 'dom_cfg_abl_L25Z10'
+
+ nn_dyn_restore = 2 ! restoring option for dynamical ABL variables: = 0 no restoring
+ ! = 1 equatorial restoring
+ ! = 2 global restoring
+ ! = 1 equatorial restoring
+ ! = 2 global restoring
+ rn_ldyn_min = 24. ! dynamics nudging magnitude inside the ABL [hour] (~3 rn_Dt)
+ rn_ldyn_max = 6. ! dynamics nudging magnitude above the ABL [hour] (~1 rn_Dt)
+ rn_ltra_min = 24. ! tracers nudging magnitude inside the ABL [hour] (~3 rn_Dt)
+ rn_ltra_max = 6. ! tracers nudging magnitude above the ABL [hour] (~1 rn_Dt)
+ rn_vfac = 1.
/
!-----------------------------------------------------------------------
&namtra_qsr ! penetrative solar radiation (ln_traqsr =T)
diff --git a/cfgs/ORCA2_ICE_PISCES/cpp_ORCA2_ICE_PISCES.fcm b/cfgs/ORCA2_ICE_PISCES/cpp_ORCA2_ICE_PISCES.fcm
index 267381634b107358e45a9bab4f1b598fca70097e..6a78b61f58accc90ea53e435a5d63fd27b4b740c 100644
--- a/cfgs/ORCA2_ICE_PISCES/cpp_ORCA2_ICE_PISCES.fcm
+++ b/cfgs/ORCA2_ICE_PISCES/cpp_ORCA2_ICE_PISCES.fcm
@@ -1 +1 @@
-bld::tool::fppkeys key_si3 key_top key_xios key_qco
+bld::tool::fppkeys key_si3 key_top key_xios key_qco key_vco_1d3d
diff --git a/cfgs/ORCA2_OFF_PISCES/EXPREF/namelist_cfg b/cfgs/ORCA2_OFF_PISCES/EXPREF/namelist_cfg
index 8e1b5a14cbd2cc8341fbf8c982e5f71f30495457..31af4cd1171848e621f1a1ee60371649f3298ac2 100644
--- a/cfgs/ORCA2_OFF_PISCES/EXPREF/namelist_cfg
+++ b/cfgs/ORCA2_OFF_PISCES/EXPREF/namelist_cfg
@@ -325,7 +325,7 @@
sn_sal = 'dyna_grid_T' , 120. , 'vosaline' , .true. , .true. , 'yearly' , '' , '' , ''
sn_mld = 'dyna_grid_T' , 120. , 'somixhgt' , .true. , .true. , 'yearly' , '' , '' , ''
sn_emp = 'dyna_grid_T' , 120. , 'sowaflcd' , .true. , .true. , 'yearly' , '' , '' , ''
- sn_fmf = 'dyna_grid_T' , 120. , 'iowaflup' , .true. , .true. , 'yearly' , '' , '' , ''
+ sn_fwf = 'dyna_grid_T' , 120. , 'iowaflup' , .true. , .true. , 'yearly' , '' , '' , ''
sn_ice = 'dyna_grid_T' , 120. , 'soicecov' , .true. , .true. , 'yearly' , '' , '' , ''
sn_qsr = 'dyna_grid_T' , 120. , 'soshfldo' , .true. , .true. , 'yearly' , '' , '' , ''
sn_wnd = 'dyna_grid_T' , 120. , 'sowindsp' , .true. , .true. , 'yearly' , '' , '' , ''
diff --git a/cfgs/ORCA2_OFF_PISCES/cpp_ORCA2_OFF_PISCES.fcm b/cfgs/ORCA2_OFF_PISCES/cpp_ORCA2_OFF_PISCES.fcm
index 4f4c1500a1384facf7e1236996532f4cdf1c5eac..306244c685d7a218e6c251af3c0da34b27359528 100644
--- a/cfgs/ORCA2_OFF_PISCES/cpp_ORCA2_OFF_PISCES.fcm
+++ b/cfgs/ORCA2_OFF_PISCES/cpp_ORCA2_OFF_PISCES.fcm
@@ -1 +1 @@
-bld::tool::fppkeys key_top key_xios
+bld::tool::fppkeys key_top key_xios key_linssh key_vco_1d3d
diff --git a/cfgs/ORCA2_OFF_TRC/EXPREF/file_def_nemo-innerttrc.xml b/cfgs/ORCA2_OFF_TRC/EXPREF/file_def_nemo-innerttrc.xml
index 747e6cd31de566188e305adab97ded2242f55108..d1d25f865840fe17302211b34338375cd44bafc6 100644
--- a/cfgs/ORCA2_OFF_TRC/EXPREF/file_def_nemo-innerttrc.xml
+++ b/cfgs/ORCA2_OFF_TRC/EXPREF/file_def_nemo-innerttrc.xml
@@ -36,12 +36,23 @@
<field field_ref="ssh" name="zos" />
</file>
- <file id="file1" name_suffix="_trc" description="passive tracers variables" >
+ <file id="file2" name_suffix="_trc" description="passive tracers variables" >
<field field_ref="Age" name="Age" operation="average" freq_op="1y" > @Age_e3t / @e3t </field>
<field field_ref="CFC11" name="CFC11" operation="average" freq_op="1y" > @CFC11_e3t / @e3t </field>
<field field_ref="CFC12" name="CFC12" operation="average" freq_op="1y" > @CFC12_e3t / @e3t </field>
<field field_ref="SF6" name="SF6" operation="average" freq_op="1y" > @SF6_e3t / @e3t </field>
- <field field_ref="RC14" name="RC14" operation="average" freq_op="1y" > @RC14_e3t / @e3t </field>
+ <field field_ref="RC14" name="RC14" operation="average" freq_op="1y" > @RC14_e3t / @e3t </field>
+ <field field_ref="qtr_CFC11" />
+ <field field_ref="qint_CFC11" />
+ <field field_ref="qtr_CFC12" />
+ <field field_ref="qint_CFC12" />
+ <field field_ref="qtr_SF6" />
+ <field field_ref="qint_SF6" />
+ <field field_ref="qtr_c14" />
+ <field field_ref="qint_c14" />
+ <field field_ref="DeltaC14" />
+ <field field_ref="C14Age" />
+ <field field_ref="RAge" />
</file>
</file_group>
diff --git a/cfgs/ORCA2_OFF_TRC/EXPREF/namelist_cfg b/cfgs/ORCA2_OFF_TRC/EXPREF/namelist_cfg
index e365edaa458129637a1d1f2a466f7cebc526a0b4..380fbc570eb6f76dce449b9fce4cb66f630a51ab 100644
--- a/cfgs/ORCA2_OFF_TRC/EXPREF/namelist_cfg
+++ b/cfgs/ORCA2_OFF_TRC/EXPREF/namelist_cfg
@@ -324,7 +324,7 @@
sn_mld = 'dyna_grid_T' , 120. , 'mldr10_1' , .true. , .true. , 'yearly' , '' , '' , ''
sn_emp = 'dyna_grid_T' , 120. , 'wfo' , .true. , .true. , 'yearly' , '' , '' , ''
sn_empb = 'dyna_grid_T' , 120. , 'wfob' , .true. , .true. , 'yearly' , '' , '' , ''
- sn_fmf = 'dyna_grid_T' , 120. , 'fmmflx' , .true. , .true. , 'yearly' , '' , '' , ''
+ sn_fwf = 'dyna_grid_T' , 120. , 'iowaflup' , .true. , .true. , 'yearly' , '' , '' , ''
sn_rnf = 'dyna_grid_T' , 120. , 'runoffs' , .true. , .true. , 'yearly' , '' , '' , ''
sn_ice = 'dyna_grid_T' , 120. , 'siconc' , .true. , .true. , 'yearly' , '' , '' , ''
sn_qsr = 'dyna_grid_T' , 120. , 'rsntds' , .true. , .true. , 'yearly' , '' , '' , ''
diff --git a/cfgs/ORCA2_SAS_ICE/EXPREF/file_def_nemo-oce.xml b/cfgs/ORCA2_SAS_ICE/EXPREF/file_def_nemo-oce.xml
index 5c75b89204e6b01528a9f6d0310d71949f58b0b4..2cdea4e2397740c0b0d8933093314a70e98891ef 100644
--- a/cfgs/ORCA2_SAS_ICE/EXPREF/file_def_nemo-oce.xml
+++ b/cfgs/ORCA2_SAS_ICE/EXPREF/file_def_nemo-oce.xml
@@ -34,6 +34,8 @@
<field field_ref="qt_oce" name="qt_oce" />
<field field_ref="saltflx" name="sfx" />
<field field_ref="taum" name="taum" />
+ <field field_ref="utau" name="tauuo" />
+ <field field_ref="vtau" name="tauvo" />
<field field_ref="wspd" name="windsp" />
<field field_ref="precip" name="precip" />
<!-- ice and snow -->
@@ -44,7 +46,6 @@
<field field_ref="e3u" />
<field field_ref="ssu" name="uos" />
<field field_ref="uoce" name="uo" operation="instant" freq_op="5d" > @uoce_e3u / @e3u </field>
- <field field_ref="utau" name="tauuo" />
<field field_ref="uocetr_eff" name="uocetr_eff" />
<!-- available with diaar5 -->
<field field_ref="u_masstr" name="vozomatr" />
@@ -56,7 +57,6 @@
<field field_ref="e3v" />
<field field_ref="ssv" name="vos" />
<field field_ref="voce" name="vo" operation="instant" freq_op="5d" > @voce_e3v / @e3v </field>
- <field field_ref="vtau" name="tauvo" />
<field field_ref="vocetr_eff" name="vocetr_eff" />
<!-- available with diaar5 -->
<field field_ref="v_masstr" name="vomematr" />
diff --git a/cfgs/ORCA2_SAS_ICE/cpp_ORCA2_SAS_ICE.fcm b/cfgs/ORCA2_SAS_ICE/cpp_ORCA2_SAS_ICE.fcm
index 9f59e30a24624bdfdc05f669a701e3d5cceacf9c..361bb033e48b8c45a42220547d9c69fb12a95c79 100644
--- a/cfgs/ORCA2_SAS_ICE/cpp_ORCA2_SAS_ICE.fcm
+++ b/cfgs/ORCA2_SAS_ICE/cpp_ORCA2_SAS_ICE.fcm
@@ -1 +1 @@
- bld::tool::fppkeys key_si3 key_linssh key_xios
+ bld::tool::fppkeys key_si3 key_linssh key_vco_1d3d key_xios
diff --git a/cfgs/SHARED/field_def_nemo-ice.xml b/cfgs/SHARED/field_def_nemo-ice.xml
index 6f444b4563f398c3b44021512551548252a10bf7..2768a8905a5f6ba1d13a688444aa1268a03d89b5 100644
--- a/cfgs/SHARED/field_def_nemo-ice.xml
+++ b/cfgs/SHARED/field_def_nemo-ice.xml
@@ -18,7 +18,7 @@
<field_group id="SBC" > <!-- time step automaticaly defined based on nn_fsbc -->
<!-- 2D variables -->
- <field_group id="SBC_2D" grid_ref="grid_T_2D" >
+ <field_group id="SBC_2D" grid_ref="grid_T_2D_inner" >
<!-- =================== -->
<!-- standard ice fields -->
@@ -69,8 +69,8 @@
<field id="icesalm" long_name="Mass of salt in sea ice per area" standard_name="sea_ice_salt_mass" unit="kg/m2" />
<!-- momentum (rheology) -->
- <field id="uice" long_name="X-component of sea ice velocity" standard_name="sea_ice_x_velocity" unit="m/s" />
- <field id="vice" long_name="Y-component of sea ice velocity" standard_name="sea_ice_y_velocity" unit="m/s" />
+ <field id="uice" long_name="X-component of sea ice velocity" standard_name="sea_ice_x_velocity" unit="m/s" grid_ref="grid_T_2D" />
+ <field id="vice" long_name="Y-component of sea ice velocity" standard_name="sea_ice_y_velocity" unit="m/s" grid_ref="grid_T_2D" />
<field id="icevel" long_name="Sea-ice speed" standard_name="sea_ice_speed" unit="m/s" />
<field id="utau_ai" long_name="X-component of atmospheric stress on sea ice" standard_name="surface_downward_x_stress" unit="N/m2" />
<field id="vtau_ai" long_name="Y-component of atmospheric stress on sea ice" standard_name="surface_downward_y_stress" unit="N/m2" />
@@ -93,7 +93,7 @@
<field id="yield11" long_name="yield surface tensor component 11" standard_name="yield11" unit="N/m" />
<field id="yield22" long_name="yield surface tensor component 22" standard_name="yield22" unit="N/m" />
<field id="yield12" long_name="yield surface tensor component 12" standard_name="yield12" unit="N/m" />
- <field id="beta_evp" long_name="Relaxation parameter of ice rheology (beta)" standard_name="relaxation_parameter_of_ice_rheology" unit="" />
+ <field id="beta_evp" long_name="Relaxation parameter of ice rheology (beta)" standard_name="relaxation_parameter_of_ice_rheology" unit="" grid_ref="grid_T_2D" />
<!-- surface heat fluxes -->
<field id="qt_ice" long_name="total heat flux at ice surface" standard_name="surface_downward_heat_flux_in_air" unit="W/m2" />
@@ -311,7 +311,7 @@
</field_group> <!-- SBC_2D -->
<!-- categories -->
- <field_group id="SBC_3D" grid_ref="grid_T_ncatice" >
+ <field_group id="SBC_3D" grid_ref="grid_T_ncatice_inner" >
<!-- standard ice fields -->
<field id="iceconc_cat" long_name="Sea-ice concentration per category" unit="" />
@@ -386,7 +386,7 @@
-->
<!-- output variables for my configuration (example) -->
- <field_group id="myvarICE" grid_ref="grid_T_2D" >
+ <field_group id="myvarICE" >
<!-- ice mask -->
<field field_ref="icemask" name="simsk" />
<field field_ref="icemask05" name="simsk05" />
@@ -495,7 +495,7 @@
</field_group>
- <field_group id="myvarICE_cat" grid_ref="grid_T_ncatice" >
+ <field_group id="myvarICE_cat" >
<!-- categories -->
<field field_ref="icemask_cat" name="simskcat"/>
@@ -524,7 +524,7 @@
<field field_ref="ilbgvol_tot" name="ilbgvol_tot" />
</field_group>
- <field_group id="ICE_budget" grid_ref="grid_T_2D" >
+ <field_group id="ICE_budget" >
<!-- general -->
<field field_ref="icemask" name="simsk" />
<field field_ref="iceconc" name="siconc" />
@@ -579,7 +579,7 @@
</field_group>
<!-- SIMIP daily fields -->
- <field_group id="SIday_fields" grid_ref="grid_T_2D" >
+ <field_group id="SIday_fields" >
<field field_ref="icepres" name="sitimefrac" />
<field field_ref="iceconc_pct" name="siconc" />
<field field_ref="icethic_cmip" name="sithick" />
@@ -591,7 +591,7 @@
</field_group>
<!-- SIMIP monthly fields -->
- <field_group id="SImon_fields" grid_ref="grid_T_2D" >
+ <field_group id="SImon_fields" >
<!-- Sea-ice state variables -->
<field field_ref="icepres" name="sitimefrac" />
<field field_ref="iceconc_pct" name="siconc" />
diff --git a/cfgs/SHARED/field_def_nemo-innerttrc.xml b/cfgs/SHARED/field_def_nemo-innerttrc.xml
index d54a667b23c34113463a49218fcfb8aa24c6e3dc..ccf4b8b587fb91ce660f84c3719b9ff543d9ecca 100644
--- a/cfgs/SHARED/field_def_nemo-innerttrc.xml
+++ b/cfgs/SHARED/field_def_nemo-innerttrc.xml
@@ -16,7 +16,7 @@
-->
- <field_group id="inerttrc" grid_ref="grid_T_2D">
+ <field_group id="inerttrc" grid_ref="grid_T_2D_inner">
<!-- CFC11 : variables available with ln_cfc11 -->
<field id="CFC11" long_name="Chlorofluoro carbon11 Concentration" unit="umol/m3" grid_ref="grid_T_3D" />
@@ -39,8 +39,8 @@
<!-- C14 : variables available with ln_c14 -->
<field id="RC14" long_name="Radiocarbon ratio" unit="-" grid_ref="grid_T_3D" />
<field id="RC14_e3t" long_name="RC14 * e3t" unit="m" grid_ref="grid_T_3D" > RC14 * e3t </field >
- <field id="DeltaC14" long_name="Delta C14" unit="permil" grid_ref="grid_T_3D" />
- <field id="C14Age" long_name="Radiocarbon age" unit="yr" grid_ref="grid_T_3D" />
+ <field id="DeltaC14" long_name="Delta C14" unit="permil" grid_ref="grid_T_3D_inner" />
+ <field id="C14Age" long_name="Radiocarbon age" unit="yr" grid_ref="grid_T_3D_inner" />
<field id="RAge" long_name="Reservoir Age" unit="yr" />
<field id="qtr_c14" long_name="Air-sea flux of C14" unit="1/m2/s" />
<field id="qint_c14" long_name="Cumulative air-sea flux of C14" unit="1/m2" />
@@ -52,7 +52,7 @@
<!-- AGE : variables available with ln_age -->
<field id="Age" long_name="Sea water age since surface contact" unit="yr" grid_ref="grid_T_3D" />
- <field id="Age_e3t" long_name="Age * e3t" unit="yr * m" grid_ref="grid_T_3D" > Age * e3t </field >
+ <field id="Age_e3t" long_name="Age * e3t" unit="yr * m" grid_ref="grid_T_3D" > Age * e3t </field >
</field_group>
diff --git a/cfgs/SHARED/field_def_nemo-oce.xml b/cfgs/SHARED/field_def_nemo-oce.xml
index 8c6362f30e2177c69d9db0a82e0fc0d486eac802..750a3f93b7febc3ed0cac89ff86405f615874f15 100644
--- a/cfgs/SHARED/field_def_nemo-oce.xml
+++ b/cfgs/SHARED/field_def_nemo-oce.xml
@@ -25,7 +25,7 @@ that are available in the tidal-forcing implementation (see
-->
<!-- Time -->
- <field id="diamlr_time" grid_ref="diamlr_grid_T_2D" prec="8" />
+ <field id="diamlr_time" grid_ref="diamlr_grid_T_2D_inner" prec="8" />
<!-- Regressors for tidal harmonic analysis -->
<field id="diamlr_r001" field_ref="diamlr_time" expr="sin( __TDE_M2_omega__ * diamlr_time )" enabled=".TRUE." comment="harmonic:sin:M2" />
@@ -109,62 +109,60 @@ that are available in the tidal-forcing implementation (see
<!-- T grid -->
<field_group id="grid_T" grid_ref="grid_T_2D" >
- <field id="e3t" long_name="T-cell thickness" standard_name="cell_thickness" unit="m" grid_ref="grid_T_3D" />
- <field id="e3ts" long_name="T-cell thickness" field_ref="e3t" standard_name="cell_thickness" unit="m" grid_ref="grid_T_SFC"/>
- <field id="e3t_0" long_name="Initial T-cell thickness" standard_name="ref_cell_thickness" unit="m" grid_ref="grid_T_3D" />
- <field id="e3tb" long_name="bottom T-cell thickness" standard_name="bottom_cell_thickness" unit="m" grid_ref="grid_T_2D"/>
- <field id="e3t_300" field_ref="e3t" grid_ref="grid_T_zoom_300" detect_missing_value="true" />
- <field id="e3t_vsum300" field_ref="e3t_300" grid_ref="grid_T_vsum" detect_missing_value="true" />
- <field id="masscello" long_name="Sea Water Mass per unit area" standard_name="sea_water_mass_per_unit_area" unit="kg/m2" grid_ref="grid_T_3D"/>
- <field id="volcello" long_name="Ocean Volume" standard_name="ocean_volume" unit="m3" grid_ref="grid_T_3D"/>
- <field id="toce" long_name="temperature" standard_name="sea_water_potential_temperature" unit="degC" grid_ref="grid_T_3D"/>
- <field id="toce_e3t" long_name="temperature (thickness weighted)" unit="degC" grid_ref="grid_T_3D" > toce * e3t </field >
- <field id="soce" long_name="salinity" standard_name="sea_water_practical_salinity" unit="1e-3" grid_ref="grid_T_3D"/>
- <field id="soce_e3t" long_name="salinity (thickness weighted)" unit="1e-3" grid_ref="grid_T_3D" > soce * e3t </field >
-
- <field id="toce_e3t_300" field_ref="toce_e3t" unit="degree_C" grid_ref="grid_T_zoom_300" detect_missing_value="true" />
- <field id="toce_e3t_vsum300" field_ref="toce_e3t_300" unit="degress_C*m" grid_ref="grid_T_vsum" detect_missing_value="true" />
- <field id="toce_vmean300" field_ref="toce_e3t_vsum300" unit="degree_C" grid_ref="grid_T_vsum" detect_missing_value="true" > toce_e3t_vsum300/e3t_vsum300 </field>
+ <field id="e3t" long_name="T-cell thickness" standard_name="cell_thickness" unit="m" grid_ref="grid_T_3D_inner" />
+ <field id="e3ts" long_name="T-cell thickness" field_ref="e3t" standard_name="cell_thickness" unit="m" grid_ref="grid_T_SFC_inner" />
+ <field id="e3t_0" long_name="Initial T-cell thickness" standard_name="ref_cell_thickness" unit="m" grid_ref="grid_T_3D" />
+ <field id="e3tb" long_name="bottom T-cell thickness" standard_name="bottom_cell_thickness" unit="m" grid_ref="grid_T_2D_inner" />
+ <field id="e3t_300" field_ref="e3t" grid_ref="grid_T_zoom_300_inner" detect_missing_value="true" />
+ <field id="e3t_vsum300" field_ref="e3t_300" grid_ref="grid_T_vsum_inner" detect_missing_value="true" />
+
+ <field id="masscello" long_name="Sea Water Mass per unit area" standard_name="sea_water_mass_per_unit_area" unit="kg/m2" grid_ref="grid_T_3D_inner"/>
+ <field id="volcello" long_name="Ocean Volume" standard_name="ocean_volume" unit="m3" grid_ref="grid_T_3D_inner"/>
+ <field id="toce" long_name="temperature" standard_name="sea_water_potential_temperature" unit="degC" grid_ref="grid_T_3D"/>
+ <field id="toce_e3t" long_name="temperature (thickness weighted)" unit="degC" grid_ref="grid_T_3D" > toce * e3t </field >
+ <field id="soce" long_name="salinity" standard_name="sea_water_practical_salinity" unit="1e-3" grid_ref="grid_T_3D"/>
+ <field id="soce_e3t" long_name="salinity (thickness weighted)" unit="1e-3" grid_ref="grid_T_3D" > soce * e3t </field >
+
+ <field id="toce_e3t_300" field_ref="toce_e3t" unit="degree_C" grid_ref="grid_T_zoom_300" detect_missing_value="true" />
+ <field id="toce_e3t_vsum300" field_ref="toce_e3t_300" unit="degress_C*m" grid_ref="grid_T_vsum" detect_missing_value="true" />
+ <field id="toce_vmean300" field_ref="toce_e3t_vsum300" unit="degree_C" grid_ref="grid_T_vsum" detect_missing_value="true" > toce_e3t_vsum300/e3t_vsum300 </field>
<!-- AGRIF sponge -->
<field id="agrif_spt" long_name=" AGRIF t-sponge coefficient" unit=" " />
<!-- additions to diawri.F90 -->
- <field id="sssgrad" long_name="module of surface salinity gradient" unit="1e-3/m" grid_ref="grid_T_2D_inner"/>
- <field id="sssgrad2" long_name="square of module of surface salinity gradient" unit="1e-6/m2" grid_ref="grid_T_2D_inner"/>
- <field id="ke" long_name="kinetic energy" standard_name="specific_kinetic_energy_of_sea_water" unit="m2/s2" grid_ref="grid_T_3D" />
- <field id="ke_int" long_name="vertical integration of kinetic energy" unit="m3/s2" grid_ref="grid_T_2D_inner" />
+ <field id="sssgrad" long_name="module of surface salinity gradient" unit="1e-3/m" grid_ref="grid_T_2D_inner" />
+ <field id="sssgrad2" long_name="square of module of surface salinity gradient" unit="1e-6/m2" grid_ref="grid_T_2D_inner" />
+ <field id="ke" long_name="kinetic energy" standard_name="specific_kinetic_energy_of_sea_water" unit="m2/s2" grid_ref="grid_T_3D_inner" />
+ <field id="ke_int" long_name="vertical integration of kinetic energy" unit="m3/s2" grid_ref="grid_T_2D_inner" />
+ <field id="taubot" long_name="bottom stress module" unit="N/m2" grid_ref="grid_T_2D_inner" />
<!-- t-eddy viscosity coefficients (ldfdyn) -->
<field id="ahmt_2d" long_name=" surface t-eddy viscosity coefficient" unit="m2/s or m4/s" />
<field id="ahmt_3d" long_name=" 3D t-eddy viscosity coefficient" unit="m2/s or m4/s" grid_ref="grid_T_3D"/>
<field id="sst" long_name="Bulk sea surface temperature" standard_name="bulk_sea_surface_temperature" unit="degC" />
- <field id="t_skin" long_name="Skin temperature aka SSST" standard_name="skin_temperature" unit="degC" />
+ <field id="sss" long_name="sea surface salinity" standard_name="sea_surface_salinity" unit="1e-3" />
<field id="sst2" long_name="square of sea surface temperature" standard_name="square_of_sea_surface_temperature" unit="degC2" > sst * sst </field >
+ <field id="sss2" long_name="square of sea surface salinity" unit="1e-6" > sss * sss </field >
<field id="sstmax" long_name="max of sea surface temperature" field_ref="sst" operation="maximum" />
+ <field id="sssmax" long_name="max of sea surface salinity" field_ref="sss" operation="maximum" />
<field id="sstmin" long_name="min of sea surface temperature" field_ref="sst" operation="minimum" />
+ <field id="sssmin" long_name="min of sea surface salinity" field_ref="sss" operation="minimum" />
<field id="sstgrad" long_name="module of sst gradient" unit="degC/m" grid_ref="grid_T_2D_inner" />
<field id="sstgrad2" long_name="square of module of sst gradient" unit="degC2/m2" grid_ref="grid_T_2D_inner" />
<field id="sbt" long_name="sea bottom temperature" unit="degC" grid_ref="grid_T_2D_inner" />
- <field id="tosmint" long_name="vertical integral of temperature times density" standard_name="integral_wrt_depth_of_product_of_density_and_potential_temperature" unit="(kg m2) degree_C" grid_ref="grid_T_2D_inner" />
- <field id="sst_wl" long_name="Delta SST of warm layer" unit="degC" />
- <field id="sst_cs" long_name="Delta SST of cool skin" unit="degC" />
- <field id="temp_3m" long_name="temperature at 3m" unit="degC" />
-
- <field id="sss" long_name="sea surface salinity" standard_name="sea_surface_salinity" unit="1e-3" />
- <field id="sss2" long_name="square of sea surface salinity" unit="1e-6" > sss * sss </field >
- <field id="sssmax" long_name="max of sea surface salinity" field_ref="sss" operation="maximum" />
- <field id="sssmin" long_name="min of sea surface salinity" field_ref="sss" operation="minimum" />
- <field id="sbs" long_name="sea bottom salinity" unit="0.001" grid_ref="grid_T_2D_inner" />
- <field id="somint" long_name="vertical integral of salinity times density" standard_name="integral_wrt_depth_of_product_of_density_and_salinity" unit="(kg m2) x (1e-3)" grid_ref="grid_T_2D_inner" />
+ <field id="sbs" long_name="sea bottom salinity" unit="0.001" grid_ref="grid_T_2D_inner" />
+ <field id="sst_wl" long_name="Delta SST of warm layer" unit="degC" grid_ref="grid_T_2D_inner" />
+ <field id="sst_cs" long_name="Delta SST of cool skin" unit="degC" grid_ref="grid_T_2D_inner" />
- <field id="taubot" long_name="bottom stress module" unit="N/m2" grid_ref="grid_T_2D_inner" />
+ <field id="tosmint" long_name="vertical integral of temperature times density" standard_name="integral_wrt_depth_of_product_of_density_and_potential_temperature" unit="(kg m2) degree_C" grid_ref="grid_T_2D_inner" />
+ <field id="somint" long_name="vertical integral of salinity times density" standard_name="integral_wrt_depth_of_product_of_density_and_salinity" unit="(kg m2) x (1e-3)" grid_ref="grid_T_2D_inner" />
<!-- Case EOS = TEOS-10 : output potential temperature -->
- <field id="toce_pot" long_name="Sea Water Potential Temperature" standard_name="sea_water_potential_temperature" unit="degC" grid_ref="grid_T_3D"/>
- <field id="sst_pot" long_name="potential sea surface temperature" standard_name="sea_surface_temperature" unit="degC" />
- <field id="tosmint_pot" long_name="vertical integral of potential temperature times density" standard_name="integral_wrt_depth_of_product_of_density_and_potential_temperature" unit="(kg m2) degree_C" />
+ <field id="toce_pot" long_name="Sea Water Potential Temperature" standard_name="sea_water_potential_temperature" unit="degC" grid_ref="grid_T_3D_inner"/>
+ <field id="sst_pot" long_name="potential sea surface temperature" standard_name="sea_surface_temperature" unit="degC" grid_ref="grid_T_2D_inner"/>
+ <field id="tosmint_pot" long_name="vertical integral of potential temperature times density" standard_name="integral_wrt_depth_of_product_of_density_and_potential_temperature" unit="(kg m2) degree_C" grid_ref="grid_T_2D_inner"/>
<field id="ht" long_name="water column height at T point" standard_name="water_column_height_T" unit="m" />
<field id="ssh" long_name="sea surface height" standard_name="sea_surface_height_above_geoid" unit="m" />
@@ -172,13 +170,13 @@ that are available in the tidal-forcing implementation (see
<field id="wetdep" long_name="wet depth" standard_name="wet_depth" unit="m" />
<field id="sshmax" long_name="max of sea surface height" field_ref="ssh" operation="maximum" />
- <field id="mldkz5" long_name="Turbocline depth (Kz = 5e-4)" standard_name="ocean_mixed_layer_thickness_defined_by_vertical_tracer_diffusivity" unit="m" />
- <field id="mldr10_1" long_name="Mixed Layer Depth (dsigma = 0.01 wrt 10m)" standard_name="ocean_mixed_layer_thickness_defined_by_sigma_theta" unit="m" />
- <field id="mldr10_1max" long_name="Max of Mixed Layer Depth (dsigma = 0.01 wrt 10m)" field_ref="mldr10_1" operation="maximum" />
- <field id="mldr10_1min" long_name="Min of Mixed Layer Depth (dsigma = 0.01 wrt 10m)" field_ref="mldr10_1" operation="minimum" />
- <field id="heatc" long_name="Heat content vertically integrated" standard_name="integral_of_sea_water_potential_temperature_wrt_depth_expressed_as_heat_content" unit="J/m2" grid_ref="grid_T_2D_inner" />
- <field id="saltc" long_name="Salt content vertically integrated" unit="PSU*kg/m2" grid_ref="grid_T_2D_inner" />
- <field id="salt2c" long_name="square of Salt content vertically integrated" unit="PSU2*kg/m2" grid_ref="grid_T_2D_inner" />
+ <field id="mldkz5" long_name="Turbocline depth (Kz = 5e-4)" standard_name="ocean_mixed_layer_thickness_defined_by_vertical_tracer_diffusivity" unit="m" grid_ref="grid_T_2D_inner" />
+ <field id="mldr10_1" long_name="Mixed Layer Depth (dsigma = 0.01 wrt 10m)" standard_name="ocean_mixed_layer_thickness_defined_by_sigma_theta" unit="m" grid_ref="grid_T_2D_inner" />
+ <field id="mldr10_1max" long_name="Max of Mixed Layer Depth (dsigma = 0.01 wrt 10m)" field_ref="mldr10_1" operation="maximum" grid_ref="grid_T_2D_inner" />
+ <field id="mldr10_1min" long_name="Min of Mixed Layer Depth (dsigma = 0.01 wrt 10m)" field_ref="mldr10_1" operation="minimum" grid_ref="grid_T_2D_inner" />
+ <field id="heatc" long_name="Heat content vertically integrated" standard_name="integral_of_sea_water_potential_temperature_wrt_depth_expressed_as_heat_content" unit="J/m2" grid_ref="grid_T_2D_inner" />
+ <field id="saltc" long_name="Salt content vertically integrated" unit="PSU*kg/m2" grid_ref="grid_T_2D_inner" />
+ <field id="salt2c" long_name="square of Salt content vertically integrated" unit="PSU2*kg/m2" grid_ref="grid_T_2D_inner" />
<!-- EOS -->
<field id="alpha" long_name="thermal expansion" unit="degC-1" grid_ref="grid_T_3D" />
@@ -199,83 +197,83 @@ that are available in the tidal-forcing implementation (see
<field id="wi_cff" long_name="Fraction of implicit vertical velocity" unit="#" grid_ref="grid_T_3D" />
<!-- next variables available with key_diahth -->
- <field id="mlddzt" long_name="Thermocline Depth (depth of max dT/dz)" standard_name="depth_at_maximum_upward_derivative_of_sea_water_potential_temperature" unit="m" />
- <field id="mldr10_3" long_name="Mixed Layer Depth (dsigma = 0.03 wrt 10m)" standard_name="ocean_mixed_layer_thickness_defined_by_sigma_theta" unit="m" />
- <field id="mldr0_1" long_name="Mixed Layer Depth (dsigma = 0.01 wrt sfc)" standard_name="ocean_mixed_layer_thickness_defined_by_sigma_theta" unit="m" />
- <field id="mldr0_3" long_name="Mixed Layer Depth (dsigma = 0.03 wrt sfc)" standard_name="ocean_mixed_layer_thickness_defined_by_sigma_theta" unit="m" />
- <field id="mld_dt02" long_name="Mixed Layer Depth (|dT| = 0.2 wrt 10m)" standard_name="ocean_mixed_layer_thickness_defined_by_temperature" unit="m" />
- <field id="topthdep" long_name="Top of Thermocline Depth (dT = -0.2 wrt 10m)" standard_name="ocean_mixed_layer_thickness_defined_by_temperature" unit="m" />
- <field id="pycndep" long_name="Pycnocline Depth (dsigma[dT=-0.2] wrt 10m)" standard_name="ocean_mixed_layer_thickness_defined_by_sigma_theta" unit="m" />
- <field id="BLT" long_name="Barrier Layer Thickness" unit="m" > topthdep - pycndep </field>
- <field id="tinv" long_name="Max of vertical invertion of temperature" unit="degC" />
- <field id="depti" long_name="Depth of max. vert. inv. of temperature" unit="m" />
- <field id="20d" long_name="Depth of 20C isotherm" standard_name="depth_of_isosurface_of_sea_water_potential_temperature" unit="m" axis_ref="iax_20C" />
- <field id="26d" long_name="Depth of 26C isotherm" standard_name="depth_of_isosurface_of_sea_water_potential_temperature" unit="m" axis_ref="iax_26C" />
- <field id="28d" long_name="Depth of 28C isotherm" standard_name="depth_of_isosurface_of_sea_water_potential_temperature" unit="m" axis_ref="iax_28C" />
- <field id="hc300" long_name="Heat content 0-300m" standard_name="integral_of_sea_water_potential_temperature_wrt_depth_expressed_as_heat_content" unit="J/m2" />
- <field id="hc700" long_name="Heat content 0-700m" standard_name="integral_of_sea_water_potential_temperature_wrt_depth_expressed_as_heat_content" unit="J/m2" />
- <field id="hc2000" long_name="Heat content 0-2000m" standard_name="integral_of_sea_water_potential_temperature_wrt_depth_expressed_as_heat_content" unit="J/m2" />
+ <field id="mlddzt" long_name="Thermocline Depth (depth of max dT/dz)" standard_name="depth_at_maximum_upward_derivative_of_sea_water_potential_temperature" unit="m" grid_ref="grid_T_2D_inner" />
+ <field id="mldr10_3" long_name="Mixed Layer Depth (dsigma = 0.03 wrt 10m)" standard_name="ocean_mixed_layer_thickness_defined_by_sigma_theta" unit="m" grid_ref="grid_T_2D_inner" />
+ <field id="mldr0_1" long_name="Mixed Layer Depth (dsigma = 0.01 wrt sfc)" standard_name="ocean_mixed_layer_thickness_defined_by_sigma_theta" unit="m" grid_ref="grid_T_2D_inner" />
+ <field id="mldr0_3" long_name="Mixed Layer Depth (dsigma = 0.03 wrt sfc)" standard_name="ocean_mixed_layer_thickness_defined_by_sigma_theta" unit="m" grid_ref="grid_T_2D_inner" />
+ <field id="mld_dt02" long_name="Mixed Layer Depth (|dT| = 0.2 wrt 10m)" standard_name="ocean_mixed_layer_thickness_defined_by_temperature" unit="m" grid_ref="grid_T_2D_inner" />
+ <field id="topthdep" long_name="Top of Thermocline Depth (dT = -0.2 wrt 10m)" standard_name="ocean_mixed_layer_thickness_defined_by_temperature" unit="m" grid_ref="grid_T_2D_inner" />
+ <field id="pycndep" long_name="Pycnocline Depth (dsigma[dT=-0.2] wrt 10m)" standard_name="ocean_mixed_layer_thickness_defined_by_sigma_theta" unit="m" grid_ref="grid_T_2D_inner" />
+ <field id="BLT" long_name="Barrier Layer Thickness" unit="m" grid_ref="grid_T_2D_inner" > topthdep - pycndep </field>
+ <field id="tinv" long_name="Max of vertical invertion of temperature" unit="degC" grid_ref="grid_T_2D_inner" />
+ <field id="depti" long_name="Depth of max. vert. inv. of temperature" unit="m" grid_ref="grid_T_2D_inner" />
+ <field id="20d" long_name="Depth of 20C isotherm" standard_name="depth_of_isosurface_of_sea_water_potential_temperature" unit="m" grid_ref="grid_T_2D_inner" axis_ref="iax_20C" />
+ <field id="26d" long_name="Depth of 26C isotherm" standard_name="depth_of_isosurface_of_sea_water_potential_temperature" unit="m" grid_ref="grid_T_2D_inner" axis_ref="iax_26C" />
+ <field id="28d" long_name="Depth of 28C isotherm" standard_name="depth_of_isosurface_of_sea_water_potential_temperature" unit="m" grid_ref="grid_T_2D_inner" axis_ref="iax_28C" />
+ <field id="hc300" long_name="Heat content 0-300m" standard_name="integral_of_sea_water_potential_temperature_wrt_depth_expressed_as_heat_content" unit="J/m2" grid_ref="grid_T_2D_inner" />
+ <field id="hc700" long_name="Heat content 0-700m" standard_name="integral_of_sea_water_potential_temperature_wrt_depth_expressed_as_heat_content" unit="J/m2" grid_ref="grid_T_2D_inner" />
+ <field id="hc2000" long_name="Heat content 0-2000m" standard_name="integral_of_sea_water_potential_temperature_wrt_depth_expressed_as_heat_content" unit="J/m2" grid_ref="grid_T_2D_inner" />
<!-- variables available with diaar5 -->
- <field id="botpres" long_name="Sea Water Pressure at Sea Floor" standard_name="sea_water_pressure_at_sea_floor" unit="dbar" />
+ <field id="botpres" long_name="Sea Water Pressure at Sea Floor" standard_name="sea_water_pressure_at_sea_floor" unit="dbar" grid_ref="grid_T_2D_inner" />
<field id="sshdyn" long_name="dynamic sea surface height" standard_name="dynamic_sea_surface_height_above_geoid" unit="m" />
<field id="sshdyn2" long_name="square of dynamic sea surface height" standard_name="dynamic_sea_surface_height_above_geoid_squared" unit="m2" > sshdyn * sshdyn </field>
- <field id="tnpeo" long_name="Tendency of ocean potential energy content" unit="W/m2" />
+ <field id="tnpeo" long_name="Tendency of ocean potential energy content" unit="W/m2" grid_ref="grid_T_2D_inner" />
<!-- variables available ln_linssh=.FALSE. -->
- <field id="tpt_dep" long_name="T-point depth" standard_name="depth_below_geoid" unit="m" grid_ref="grid_T_3D" />
- <field id="e3tdef" long_name="T-cell thickness deformation" unit="%" grid_ref="grid_T_3D" />
+ <field id="tpt_dep" long_name="T-point depth" standard_name="depth_below_geoid" unit="m" grid_ref="grid_T_3D_inner" />
+ <field id="e3tdef" long_name="T-cell thickness deformation" unit="%" grid_ref="grid_T_3D_inner" />
<!-- variables available with ln_diacfl=.true. -->
- <field id="cfl_cu" long_name="u-courant number" unit="#" />
- <field id="cfl_cv" long_name="v-courant number" unit="#" />
- <field id="cfl_cw" long_name="w-courant number" unit="#" />
+ <field id="cfl_cu" long_name="u-courant number" unit="#" grid_ref="grid_T_2D_inner" />
+ <field id="cfl_cv" long_name="v-courant number" unit="#" grid_ref="grid_T_2D_inner" />
+ <field id="cfl_cw" long_name="w-courant number" unit="#" grid_ref="grid_T_2D_inner" />
<!-- variables available with ln_zdfmfc=.true. -->
- <field id="mf_Tp" long_name="plume_temperature" standard_name="plume_temperature" unit="degC" grid_ref="grid_T_3D" />
- <field id="mf_Sp" long_name="plume_salinity" standard_name="plume_salinity" unit="1e-3" grid_ref="grid_T_3D" />
- <field id="mf_mf" long_name="mass flux" standard_name="mf_mass_flux" unit="m" grid_ref="grid_T_3D" />
+ <field id="mf_Tp" long_name="plume_temperature" standard_name="plume_temperature" unit="degC" grid_ref="grid_T_3D_inner" />
+ <field id="mf_Sp" long_name="plume_salinity" standard_name="plume_salinity" unit="1e-3" grid_ref="grid_T_3D_inner" />
+ <field id="mf_mf" long_name="mass flux" standard_name="mf_mass_flux" unit="m" grid_ref="grid_T_3D_inner" />
<!-- fluxes from damping -->
- <field id="sflx_dmp_cea" long_name="salt flux due to damping" standard_name="salt_flux_due_to_damping" unit="g/m2/s" />
- <field id="hflx_dmp_cea" long_name="heat flux due to damping" standard_name="heat_flux_due_to_damping" unit="W/m2" />
+ <field id="sflx_dmp_cea" long_name="salt flux due to damping" standard_name="salt_flux_due_to_damping" unit="g/m2/s" grid_ref="grid_T_2D_inner" />
+ <field id="hflx_dmp_cea" long_name="heat flux due to damping" standard_name="heat_flux_due_to_damping" unit="W/m2" grid_ref="grid_T_2D_inner" />
<!-- * variable related to ice shelf forcing * -->
<!-- * fwf * -->
- <field id="fwfisf_cav" long_name="Ice shelf fresh water flux ( from isf to oce )" unit="kg/m2/s" />
- <field id="fwfisf_par" long_name="Ice shelf fresh water flux ( from isf to oce )" unit="kg/m2/s" />
- <field id="fwfisf3d_cav" long_name="3d Ice shelf fresh water flux ( from isf to oce )" unit="kg/m2/s" grid_ref="grid_T_3D" />
- <field id="fwfisf3d_par" long_name="3d Ice shelf fresh water flux ( from isf to oce )" unit="kg/m2/s" grid_ref="grid_T_3D" />
+ <field id="fwfisf_cav" long_name="Ice shelf fresh water flux ( from isf to oce )" unit="kg/m2/s" grid_ref="grid_T_2D_inner" />
+ <field id="fwfisf_par" long_name="Ice shelf fresh water flux ( from isf to oce )" unit="kg/m2/s" grid_ref="grid_T_2D_inner" />
+ <field id="fwfisf3d_cav" long_name="3d Ice shelf fresh water flux ( from isf to oce )" unit="kg/m2/s" grid_ref="grid_T_3D_inner" />
+ <field id="fwfisf3d_par" long_name="3d Ice shelf fresh water flux ( from isf to oce )" unit="kg/m2/s" grid_ref="grid_T_3D_inner" />
<!-- * heat fluxes * -->
- <field id="qoceisf_cav" long_name="Ice shelf ocean heat flux ( from isf to oce )" unit="W/m2" />
- <field id="qoceisf_par" long_name="Ice shelf ocean heat flux ( from isf to oce )" unit="W/m2" />
- <field id="qlatisf_cav" long_name="Ice shelf latent heat flux ( from isf to oce )" unit="W/m2" />
- <field id="qlatisf_par" long_name="Ice shelf latent heat flux ( from isf to oce )" unit="W/m2" />
- <field id="qhcisf_cav" long_name="Ice shelf heat content flux of injected water ( from isf to oce )" unit="W/m2" />
- <field id="qhcisf_par" long_name="Ice shelf heat content flux of injected water ( from isf to oce )" unit="W/m2" />
- <field id="qoceisf3d_cav" long_name="Ice shelf ocean heat flux ( from isf to oce )" unit="W/m2" grid_ref="grid_T_3D" />
- <field id="qoceisf3d_par" long_name="Ice shelf ocean heat flux ( from isf to oce )" unit="W/m2" grid_ref="grid_T_3D" />
- <field id="qlatisf3d_cav" long_name="Ice shelf latent heat flux ( from isf to oce )" unit="W/m2" grid_ref="grid_T_3D" />
- <field id="qlatisf3d_par" long_name="Ice shelf latent heat flux ( from isf to oce )" unit="W/m2" grid_ref="grid_T_3D" />
- <field id="qhcisf3d_cav" long_name="Ice shelf heat content flux of injected water ( from isf to oce )" unit="W/m2" grid_ref="grid_T_3D" />
- <field id="qhcisf3d_par" long_name="Ice shelf heat content flux of injected water ( from isf to oce )" unit="W/m2" grid_ref="grid_T_3D" />
- <field id="qconisf" long_name="Conductive heat flux through the ice shelf ( from isf to oce )" unit="W/m2" />
+ <field id="qoceisf_cav" long_name="Ice shelf ocean heat flux ( from isf to oce )" unit="W/m2" grid_ref="grid_T_2D_inner" />
+ <field id="qoceisf_par" long_name="Ice shelf ocean heat flux ( from isf to oce )" unit="W/m2" grid_ref="grid_T_2D_inner" />
+ <field id="qlatisf_cav" long_name="Ice shelf latent heat flux ( from isf to oce )" unit="W/m2" grid_ref="grid_T_2D_inner" />
+ <field id="qlatisf_par" long_name="Ice shelf latent heat flux ( from isf to oce )" unit="W/m2" grid_ref="grid_T_2D_inner" />
+ <field id="qhcisf_cav" long_name="Ice shelf heat content flux of injected water ( from isf to oce )" unit="W/m2" grid_ref="grid_T_2D_inner" />
+ <field id="qhcisf_par" long_name="Ice shelf heat content flux of injected water ( from isf to oce )" unit="W/m2" grid_ref="grid_T_2D_inner" />
+ <field id="qoceisf3d_cav" long_name="Ice shelf ocean heat flux ( from isf to oce )" unit="W/m2" grid_ref="grid_T_3D_inner" />
+ <field id="qoceisf3d_par" long_name="Ice shelf ocean heat flux ( from isf to oce )" unit="W/m2" grid_ref="grid_T_3D_inner" />
+ <field id="qlatisf3d_cav" long_name="Ice shelf latent heat flux ( from isf to oce )" unit="W/m2" grid_ref="grid_T_3D_inner" />
+ <field id="qlatisf3d_par" long_name="Ice shelf latent heat flux ( from isf to oce )" unit="W/m2" grid_ref="grid_T_3D_inner" />
+ <field id="qhcisf3d_cav" long_name="Ice shelf heat content flux of injected water ( from isf to oce )" unit="W/m2" grid_ref="grid_T_3D_inner" />
+ <field id="qhcisf3d_par" long_name="Ice shelf heat content flux of injected water ( from isf to oce )" unit="W/m2" grid_ref="grid_T_3D_inner" />
+ <field id="qconisf" long_name="Conductive heat flux through the ice shelf ( from isf to oce )" unit="W/m2" grid_ref="grid_T_2D_inner" />
<!-- top boundary layer properties -->
- <field id="isftfrz_cav" long_name="freezing point temperature at ocean/isf interface" unit="degC" />
- <field id="isftfrz_par" long_name="freezing point temperature in the parametrization boundary layer" unit="degC" />
- <field id="isfthermald_cav" long_name="thermal driving of ice shelf melting" unit="degC" />
- <field id="isfthermald_par" long_name="thermal driving of ice shelf melting" unit="degC" />
- <field id="isfgammat" long_name="Ice shelf heat-transfert velocity" unit="m/s" />
- <field id="isfgammas" long_name="Ice shelf salt-transfert velocity" unit="m/s" />
- <field id="ttbl_cav" long_name="temperature in Losch tbl" unit="degC" />
- <field id="ttbl_par" long_name="temperature in the parametrisation boundary layer" unit="degC" />
- <field id="stbl" long_name="salinity in the Losh tbl" unit="1e-3" />
- <field id="utbl" long_name="zonal current in the Losh tbl at T point" unit="m/s" />
- <field id="vtbl" long_name="merid current in the Losh tbl at T point" unit="m/s" />
- <field id="isfustar" long_name="ustar at T point used in ice shelf melting" unit="m/s" />
+ <field id="isftfrz_cav" long_name="freezing point temperature at ocean/isf interface" unit="degC" grid_ref="grid_T_2D_inner" />
+ <field id="isftfrz_par" long_name="freezing point temperature in the parametrization boundary layer" unit="degC" grid_ref="grid_T_2D_inner" />
+ <field id="isfthermald_cav" long_name="thermal driving of ice shelf melting" unit="degC" grid_ref="grid_T_2D_inner" />
+ <field id="isfthermald_par" long_name="thermal driving of ice shelf melting" unit="degC" grid_ref="grid_T_2D_inner" />
+ <field id="isfgammat" long_name="Ice shelf heat-transfert velocity" unit="m/s" grid_ref="grid_T_2D_inner" />
+ <field id="isfgammas" long_name="Ice shelf salt-transfert velocity" unit="m/s" grid_ref="grid_T_2D_inner" />
+ <field id="ttbl_cav" long_name="temperature in Losch tbl" unit="degC" grid_ref="grid_T_2D_inner" />
+ <field id="ttbl_par" long_name="temperature in the parametrisation boundary layer" unit="degC" grid_ref="grid_T_2D_inner" />
+ <field id="stbl" long_name="salinity in the Losh tbl" unit="1e-3" grid_ref="grid_T_2D_inner" />
+ <field id="utbl" long_name="zonal current in the Losh tbl" unit="m/s" grid_ref="grid_T_2D_inner" />
+ <field id="vtbl" long_name="meridional current in the Losh tbl" unit="m/s" grid_ref="grid_T_2D_inner" />
+ <field id="isfustar" long_name="ustar at T point used in ice shelf melting" unit="m/s" grid_ref="grid_T_2D_inner" />
</field_group> <!-- grid_T -->
@@ -415,61 +413,64 @@ that are available in the tidal-forcing implementation (see
<!-- SBC -->
<field_group id="SBC" > <!-- time step automaticaly defined based on nn_fsbc -->
- <field_group id="SBC_2D" grid_ref="grid_T_2D" >
+ <field_group id="SBC_2D" grid_ref="grid_T_2D_inner" >
<field id="empmr" long_name="Net Upward Water Flux" standard_name="water_flux_out_of_sea_ice_and_sea_water" unit="kg/m2/s" />
<field id="empbmr" long_name="Net Upward Water Flux at pre. tstep" standard_name="water_flux_out_of_sea_ice_and_sea_water" unit="kg/m2/s" />
<field id="emp_oce" long_name="Evap minus Precip over ocean" standard_name="evap_minus_precip_over_sea_water" unit="kg/m2/s" />
<field id="emp_ice" long_name="Evap minus Precip over ice" standard_name="evap_minus_precip_over_sea_ice" unit="kg/m2/s" />
<field id="saltflx" long_name="Downward salt flux" unit="g/m2/s" />
- <field id="fmmflx" long_name="Water flux due to freezing/melting" unit="kg/m2/s" />
+ <field id="fwfice" long_name="Ice-Ocean Freshwater Flux (>0 to the ocean)" unit="kg/m2/s" />
<field id="snowpre" long_name="Snow precipitation" standard_name="snowfall_flux" unit="kg/m2/s" />
- <field id="runoffs" long_name="River Runoffs" standard_name="water_flux_into_sea_water_from_rivers" unit="kg/m2/s" />
+ <field id="runoffs" long_name="River Runoffs" standard_name="water_flux_into_sea_water_from_rivers" unit="kg/m2/s" grid_ref="grid_T_2D" />
<field id="precip" long_name="Total precipitation" standard_name="precipitation_flux" unit="kg/m2/s" />
<field id="wclosea" long_name="closed sea empmr correction" standard_name="closea_empmr" unit="kg/m2/s" />
- <field id="qt" long_name="Net Downward Heat Flux" standard_name="surface_downward_heat_flux_in_sea_water" unit="W/m2" />
- <field id="qns" long_name="non solar Downward Heat Flux" unit="W/m2" />
- <field id="qsr" long_name="Shortwave Radiation" standard_name="net_downward_shortwave_flux_at_sea_water_surface" unit="W/m2" />
- <field id="qsr3d" long_name="Shortwave Radiation 3D distribution" standard_name="downwelling_shortwave_flux_in_sea_water" unit="W/m2" grid_ref="grid_T_3D" />
- <field id="qrp" long_name="Surface Heat Flux: Damping" standard_name="heat_flux_into_sea_water_due_to_newtonian_relaxation" unit="W/m2" />
+ <field id="qt" long_name="Net Downward Heat Flux" standard_name="surface_downward_heat_flux_in_sea_water" unit="W/m2" />
+ <field id="qns" long_name="non solar Downward Heat Flux" unit="W/m2" />
+ <field id="qsr" long_name="Shortwave Radiation" standard_name="net_downward_shortwave_flux_at_sea_water_surface" unit="W/m2" />
+ <field id="qsr3d" long_name="Shortwave Radiation 3D distribution" standard_name="downwelling_shortwave_flux_in_sea_water" unit="W/m2" grid_ref="grid_T_3D" />
+ <field id="qrp" long_name="Surface Heat Flux: Damping" standard_name="heat_flux_into_sea_water_due_to_newtonian_relaxation" unit="W/m2" />
<field id="qclosea" long_name="closed sea heat content flux" standard_name="closea_heat_content_downward_flux" unit="W/m2" />
- <field id="erp" long_name="Surface Water Flux: Damping" standard_name="water_flux_out_of_sea_water_due_to_newtonian_relaxation" unit="kg/m2/s" />
- <field id="taum" long_name="wind stress module" standard_name="magnitude_of_surface_downward_stress" unit="N/m2" />
- <field id="wspd" long_name="wind speed module" standard_name="wind_speed" unit="m/s" />
+ <field id="erp" long_name="Surface Water Flux: Damping" standard_name="water_flux_out_of_sea_water_due_to_newtonian_relaxation" unit="kg/m2/s" />
+ <field id="taum" long_name="wind stress module" standard_name="magnitude_of_surface_downward_stress" unit="N/m2" />
+ <field id="wspd" long_name="wind speed module" standard_name="wind_speed" unit="m/s" />
+ <field id="utau" long_name="Wind Stress along i-axis" standard_name="surface_downward_x_stress" unit="N/m2" grid_ref="grid_T_2D" />
+ <field id="vtau" long_name="Wind Stress along j-axis" standard_name="surface_downward_y_stress" unit="N/m2" grid_ref="grid_T_2D" />
<!-- * variable relative to atmospheric pressure forcing : available with ln_apr_dyn -->
- <field id="ssh_ib" long_name="Inverse barometer sea surface height" standard_name="sea_surface_height_correction_due_to_air_pressure_at_low_frequency" unit="m" />
+ <field id="ssh_ib" long_name="Inverse barometer sea surface height" standard_name="sea_surface_height_correction_due_to_air_pressure_at_low_frequency" unit="m" grid_ref="grid_T_2D" />
<!-- *_oce variables available with ln_blk_clio or ln_blk_core -->
- <field id="rho_air" long_name="Air density at 10m above sea surface" standard_name="rho_air_10m" unit="kg/m3" />
- <field id="dt_skin" long_name="SSST-SST temperature difference" standard_name="SSST-SST" unit="K" />
- <field id="qlw_oce" long_name="Longwave Downward Heat Flux over open ocean" standard_name="surface_net_downward_longwave_flux" unit="W/m2" />
- <field id="qsb_oce" long_name="Sensible Downward Heat Flux over open ocean" standard_name="surface_downward_sensible_heat_flux" unit="W/m2" />
- <field id="qla_oce" long_name="Latent Downward Heat Flux over open ocean" standard_name="surface_downward_latent_heat_flux" unit="W/m2" />
- <field id="evap_oce" long_name="Evaporation over open ocean" standard_name="evaporation" unit="kg/m2/s" />
- <field id="qt_oce" long_name="total flux at ocean surface" standard_name="surface_downward_heat_flux_in_sea_water" unit="W/m2" />
- <field id="qsr_oce" long_name="solar heat flux at ocean surface" standard_name="net_downward_shortwave_flux_at_sea_water_surface" unit="W/m2" />
- <field id="qns_oce" long_name="non-solar heat flux at ocean surface (including E-P)" unit="W/m2" />
- <field id="qemp_oce" long_name="Downward Heat Flux from E-P over open ocean" unit="W/m2" />
- <field id="taum_oce" long_name="wind stress module over open ocean" standard_name="magnitude_of_surface_downward_stress" unit="N/m2" />
- <field id="utau_oce" long_name="Wind Stress along i-axis over open ocean (T-points)" standard_name="surf_down_x_stress_open_oce_Tpoints" unit="N/m2" />
- <field id="vtau_oce" long_name="Wind Stress along j-axis over open ocean (T-points)" standard_name="surf_down_y_stress_open_oce_Tpoints" unit="N/m2" />
+ <field id="rho_air" long_name="Air density at 10m above sea surface" standard_name="rho_air_10m" unit="kg/m3" />
+ <field id="t_skin" long_name="Skin temperature aka SSST" standard_name="skin_temperature" unit="degC" />
+ <field id="dt_skin" long_name="SSST-SST temperature difference" standard_name="SSST-SST" unit="K" />
+ <field id="qlw_oce" long_name="Longwave Downward Heat Flux over open ocean" standard_name="surface_net_downward_longwave_flux" unit="W/m2" />
+ <field id="qsb_oce" long_name="Sensible Downward Heat Flux over open ocean" standard_name="surface_downward_sensible_heat_flux" unit="W/m2" />
+ <field id="qla_oce" long_name="Latent Downward Heat Flux over open ocean" standard_name="surface_downward_latent_heat_flux" unit="W/m2" />
+ <field id="evap_oce" long_name="Evaporation over open ocean" standard_name="evaporation" unit="kg/m2/s"/>
+ <field id="qt_oce" long_name="total flux at ocean surface" standard_name="surface_downward_heat_flux_in_sea_water" unit="W/m2" />
+ <field id="qsr_oce" long_name="solar heat flux at ocean surface" standard_name="net_downward_shortwave_flux_at_sea_water_surface" unit="W/m2" />
+ <field id="qns_oce" long_name="non-solar heat flux at ocean surface (including E-P)" unit="W/m2" />
+ <field id="qemp_oce" long_name="Downward Heat Flux from E-P over open ocean" unit="W/m2" />
+ <field id="taum_oce" long_name="wind stress module over open ocean" standard_name="magnitude_of_surface_downward_stress" unit="N/m2" />
+ <field id="utau_oce" long_name="Wind Stress along i-axis over open ocean (T-points)" standard_name="surf_down_x_stress_open_oce_Tpoints" unit="N/m2" grid_ref="grid_T_2D" />
+ <field id="vtau_oce" long_name="Wind Stress along j-axis over open ocean (T-points)" standard_name="surf_down_y_stress_open_oce_Tpoints" unit="N/m2" grid_ref="grid_T_2D" />
<!-- variables computed by the bulk parameterization algorithms (ln_blk) -->
- <field id="Cd_oce" long_name="Drag coefficient over open ocean" standard_name="drag_coefficient_water" unit="" />
- <field id="Ce_oce" long_name="Evaporaion coefficient over open ocean" standard_name="evap_coefficient_water" unit="" />
- <field id="Ch_oce" long_name="Sensible heat coefficient over open ocean" standard_name="sensible_heat_coefficient_water" unit="" />
+ <field id="Cd_oce" long_name="Drag coefficient over open ocean" standard_name="drag_coefficient_water" unit="" />
+ <field id="Ce_oce" long_name="Evaporaion coefficient over open ocean" standard_name="evap_coefficient_water" unit="" />
+ <field id="Ch_oce" long_name="Sensible heat coefficient over open ocean" standard_name="sensible_heat_coefficient_water" unit="" />
<field id="theta_zt" long_name="Potential air temperature at z=zt" standard_name="potential_air_temperature_at_zt" unit="degC" />
- <field id="q_zt" long_name="Specific air humidity at z=zt" standard_name="specific_air_humidity_at_zt" unit="kg/kg" />
+ <field id="q_zt" long_name="Specific air humidity at z=zt" standard_name="specific_air_humidity_at_zt" unit="kg/kg"/>
<field id="theta_zu" long_name="Potential air temperature at z=zu" standard_name="potential_air_temperature_at_zu" unit="degC" />
- <field id="q_zu" long_name="Specific air humidity at z=zu" standard_name="specific_air_humidity_at_zu" unit="kg/kg" />
- <field id="ssq" long_name="Saturation specific humidity of air at z=0" standard_name="surface_air_saturation_spec_humidity" unit="kg/kg" />
- <field id="wspd_blk" long_name="Bulk wind speed at z=zu" standard_name="bulk_wind_speed_at_zu" unit="m/s" />
+ <field id="q_zu" long_name="Specific air humidity at z=zu" standard_name="specific_air_humidity_at_zu" unit="kg/kg"/>
+ <field id="ssq" long_name="Saturation specific humidity of air at z=0" standard_name="surface_air_saturation_spec_humidity" unit="kg/kg"/>
+ <field id="wspd_blk" long_name="Bulk wind speed at z=zu" standard_name="bulk_wind_speed_at_zu" unit="m/s" />
<!-- ln_blk + key_si3 -->
- <field id="Cd_ice" long_name="Drag coefficient over ice" standard_name="drag_coefficient_ice" unit="" />
- <field id="Ce_ice" long_name="Evaporaion coefficient over ice" standard_name="evap_coefficient_ice" unit="" />
- <field id="Ch_ice" long_name="Sensible heat coefficient over ice" standard_name="sensible_heat_coefficient_ice" unit="" />
+ <field id="Cd_ice" long_name="Drag coefficient over ice" standard_name="drag_coefficient_ice" unit="" />
+ <field id="Ce_ice" long_name="Evaporaion coefficient over ice" standard_name="evap_coefficient_ice" unit="" />
+ <field id="Ch_ice" long_name="Sensible heat coefficient over ice" standard_name="sensible_heat_coefficient_ice" unit="" />
<!-- available key_oasis3 -->
<field id="snow_ao_cea" long_name="Snow over ice-free ocean (cell average)" standard_name="snowfall_flux" unit="kg/m2/s" />
@@ -515,22 +516,22 @@ that are available in the tidal-forcing implementation (see
<field id="vflx_fwb_cea" long_name="volume flux due to fwb" standard_name="volume_flux_due_to_fwb" unit="kg/m2/s" />
<!-- ice field (nn_ice=1) -->
- <field id="ice_cover" long_name="Ice fraction" standard_name="sea_ice_area_fraction" unit="1" />
+ <field id="ice_cover" long_name="Ice fraction" standard_name="sea_ice_area_fraction" unit="1" grid_ref="grid_T_2D" />
<!-- dilution -->
- <field id="emp_x_sst" long_name="Concentration/Dilution term on SST" unit="kg*degC/m2/s" />
- <field id="emp_x_sss" long_name="Concentration/Dilution term on SSS" unit="kg*1e-3/m2/s" />
- <field id="rnf_x_sst" long_name="Runoff term on SST" unit="kg*degC/m2/s" />
- <field id="rnf_x_sss" long_name="Runoff term on SSS" unit="kg*1e-3/m2/s" />
+ <field id="emp_x_sst" long_name="Concentration/Dilution term on SST" unit="kg*degC/m2/s" grid_ref="grid_T_2D" />
+ <field id="emp_x_sss" long_name="Concentration/Dilution term on SSS" unit="kg*1e-3/m2/s" grid_ref="grid_T_2D" />
+ <field id="rnf_x_sst" long_name="Runoff term on SST" unit="kg*degC/m2/s" grid_ref="grid_T_2D" />
+ <field id="rnf_x_sss" long_name="Runoff term on SSS" unit="kg*1e-3/m2/s" grid_ref="grid_T_2D" />
<!-- sbcssm variables -->
- <field id="sst_m" unit="degC" />
- <field id="sss_m" unit="psu" />
- <field id="ssu_m" unit="m/s" />
- <field id="ssv_m" unit="m/s" />
- <field id="ssh_m" unit="m" />
- <field id="e3t_m" unit="m" />
- <field id="frq_m" unit="-" />
+ <field id="sst_m" unit="degC" grid_ref="grid_T_2D" />
+ <field id="sss_m" unit="psu" grid_ref="grid_T_2D" />
+ <field id="ssu_m" unit="m/s" grid_ref="grid_T_2D" />
+ <field id="ssv_m" unit="m/s" grid_ref="grid_T_2D" />
+ <field id="ssh_m" unit="m" grid_ref="grid_T_2D" />
+ <field id="e3t_m" unit="m" grid_ref="grid_T_2D" />
+ <field id="frq_m" unit="-" grid_ref="grid_T_2D" />
</field_group>
@@ -585,18 +586,17 @@ that are available in the tidal-forcing implementation (see
<field_group id="grid_U" grid_ref="grid_U_2D">
<field id="hu" long_name="water column height at U point" standard_name="water_column_height_U" unit="m" />
- <field id="e2u" long_name="U-cell width in meridional direction" standard_name="cell_width" unit="m" />
- <field id="e3u" long_name="U-cell thickness" standard_name="cell_thickness" unit="m" grid_ref="grid_U_3D" />
- <field id="e3u_0" long_name="Initial U-cell thickness" standard_name="ref_cell_thickness" unit="m" grid_ref="grid_U_3D"/>
- <field id="utau" long_name="Wind Stress along i-axis" standard_name="surface_downward_x_stress" unit="N/m2" />
- <field id="uoce" long_name="ocean current along i-axis" standard_name="sea_water_x_velocity" unit="m/s" grid_ref="grid_U_3D" />
- <field id="uoce_e3u" long_name="ocean current along i-axis (thickness weighted)" unit="m/s" grid_ref="grid_U_3D" > uoce * e3u </field>
- <field id="uoce_e3u_vsum" long_name="ocean current along i-axis * e3u summed on the vertical" field_ref="uoce_e3u" unit="m3/s" grid_ref="grid_U_vsum"/>
- <field id="uocetr_vsum" long_name="ocean transport along i-axis summed on the vertical" field_ref="e2u" unit="m3/s"> this * uoce_e3u_vsum </field>
-
- <field id="uocetr_vsum_op" long_name="ocean current along i-axis * e3u * e2u summed on the vertical" read_access="true" freq_op="1mo" field_ref="e2u" unit="m3/s"> @uocetr_vsum </field>
+ <field id="e2u" long_name="U-cell width in meridional direction" standard_name="cell_width" unit="m" />
+ <field id="e3u" long_name="U-cell thickness" standard_name="cell_thickness" unit="m" grid_ref="grid_U_3D_inner" />
+ <field id="e3u_0" long_name="Initial U-cell thickness" standard_name="ref_cell_thickness" unit="m" grid_ref="grid_U_3D" />
+ <field id="uoce" long_name="ocean current along i-axis" standard_name="sea_water_x_velocity" unit="m/s" grid_ref="grid_U_3D" />
+ <field id="uoce_e3u" long_name="ocean current along i-axis (thickness weighted)" unit="m/s" grid_ref="grid_U_3D" > uoce * e3u </field>
+ <field id="uoce_e3u_vsum" long_name="ocean current along i-axis * e3u summed on the vertical" field_ref="uoce_e3u" unit="m3/s" grid_ref="grid_U_vsum" />
+ <field id="uocetr_vsum" long_name="ocean transport along i-axis summed on the vertical" field_ref="e2u" unit="m3/s" > this * uoce_e3u_vsum </field>
+
+ <field id="uocetr_vsum_op" long_name="ocean current along i-axis * e3u * e2u summed on the vertical" read_access="true" freq_op="1mo" field_ref="e2u" unit="m3/s" > @uocetr_vsum </field>
<field id="uocetr_vsum_cumul" long_name="ocean current along i-axis * e3u * e2u cumulated from southwest point" freq_offset="_reset_" operation="instant" freq_op="1mo" unit="m3/s" />
- <field id="msftbarot" long_name="ocean_barotropic_mass_streamfunction" unit="kg s-1" > uocetr_vsum_cumul * $rho0 </field>
+ <field id="msftbarot" long_name="ocean_barotropic_mass_streamfunction" unit="kg s-1" > uocetr_vsum_cumul * $rho0 </field>
<field id="ssu" long_name="ocean surface current along i-axis" unit="m/s" />
@@ -610,21 +610,21 @@ that are available in the tidal-forcing implementation (see
<field id="agrif_spu" long_name=" AGRIF u-sponge coefficient" unit=" " />
<!-- u-eddy diffusivity coefficients (available if ln_traldf_OFF=F) -->
<field id="ahtu_2d" long_name=" surface u-eddy diffusivity coefficient" unit="m2/s or m4/s" />
- <field id="ahtu_3d" long_name=" 3D u-EIV coefficient" unit="m2/s or m4/s" grid_ref="grid_U_3D"/>
+ <field id="ahtu_3d" long_name=" 3D u-EIV coefficient" unit="m2/s or m4/s" grid_ref="grid_U_3D" />
<!-- u-eiv diffusivity coefficients (available if ln_ldfeiv=F) -->
- <field id="aeiu_2d" long_name=" surface u-EIV coefficient" unit="m2/s" />
- <field id="aeiu_3d" long_name=" 3D u-EIV coefficient" unit="m2/s" grid_ref="grid_U_3D"/>
+ <field id="aeiu_2d" long_name=" surface u-EIV coefficient" unit="m2/s" />
+ <field id="aeiu_3d" long_name=" 3D u-EIV coefficient" unit="m2/s" grid_ref="grid_U_3D" />
<!-- variables available with MLE (ln_mle=T) -->
- <field id="psiu_mle" long_name="MLE streamfunction along i-axis" unit="m3/s" grid_ref="grid_U_3D" />
+ <field id="psiu_mle" long_name="MLE streamfunction along i-axis" unit="m3/s" grid_ref="grid_U_3D" />
<!-- uoce_eiv: available EIV (ln_ldfeiv=T and ln_ldfeiv_dia=T) -->
- <field id="uoce_eiv" long_name="EIV ocean current along i-axis" standard_name="bolus_sea_water_x_velocity" unit="m/s" grid_ref="grid_U_3D" />
- <field id="ueiv_masstr" long_name="EIV Ocean Mass X Transport" standard_name="bolus_ocean_mass_x_transport" unit="kg/s" grid_ref="grid_U_3D" />
- <field id="ueiv_heattr" long_name="ocean bolus heat transport along i-axis" standard_name="ocean_heat_x_transport_due_to_bolus_advection" unit="W" />
- <field id="ueiv_salttr" long_name="ocean bolus salt transport along i-axis" standard_name="ocean_salt_x_transport_due_to_bolus_advection" unit="Kg" />
- <field id="ueiv_heattr3d" long_name="ocean bolus heat transport along i-axis" standard_name="ocean_heat_x_transport_due_to_bolus_advection" unit="W" grid_ref="grid_U_3D" />
- <field id="ueiv_salttr3d" long_name="ocean bolus salt transport along i-axis" standard_name="ocean_salt_x_transport_due_to_bolus_advection" unit="kg" grid_ref="grid_U_3D" />
+ <field id="uoce_eiv" long_name="EIV ocean current along i-axis" standard_name="bolus_sea_water_x_velocity" unit="m/s" grid_ref="grid_U_3D_inner" />
+ <field id="ueiv_masstr" long_name="EIV Ocean Mass X Transport" standard_name="bolus_ocean_mass_x_transport" unit="kg/s" grid_ref="grid_U_3D_inner" />
+ <field id="ueiv_heattr" long_name="ocean bolus heat transport along i-axis" standard_name="ocean_heat_x_transport_due_to_bolus_advection" unit="W" grid_ref="grid_U_2D_inner" />
+ <field id="ueiv_salttr" long_name="ocean bolus salt transport along i-axis" standard_name="ocean_salt_x_transport_due_to_bolus_advection" unit="Kg" grid_ref="grid_U_2D_inner" />
+ <field id="ueiv_heattr3d" long_name="ocean bolus heat transport along i-axis" standard_name="ocean_heat_x_transport_due_to_bolus_advection" unit="W" grid_ref="grid_U_3D_inner" />
+ <field id="ueiv_salttr3d" long_name="ocean bolus salt transport along i-axis" standard_name="ocean_salt_x_transport_due_to_bolus_advection" unit="kg" grid_ref="grid_U_3D_inner" />
<!-- uoce_bbl: available with ln_trabbl=T and nn_bbl_adv=1 -->
<field id="uoce_bbl" long_name="BBL ocean current along i-axis" unit="m/s" />
@@ -635,28 +635,24 @@ that are available in the tidal-forcing implementation (see
<field id="ustokes" long_name="Stokes Drift Velocity i-axis" standard_name="StokesDrift_x_velocity" unit="m/s" grid_ref="grid_U_3D" />
<field id="ustokes_e3u" long_name="Stokes Drift Velocity i-axis (thickness weighted)" unit="m/s" grid_ref="grid_U_3D" > ustokes * e3u </field>
- <!-- variable for ice shelves -->
- <field id="utbl" long_name="zonal current in the Losh tbl" unit="m/s" />
-
<!-- variables available with diaar5 -->
- <field id="u_masstr" long_name="Ocean Mass X Transport" standard_name="ocean_mass_x_transport" unit="kg/s" grid_ref="grid_U_3D" />
- <field id="u_masstr_vint" long_name="vertical integral of ocean eulerian mass transport along i-axis" standard_name="vertical_integral_of_ocean_mass_x_transport" unit="kg/s" grid_ref="grid_U_2D_inner" />
- <field id="u_heattr" long_name="ocean eulerian heat transport along i-axis" standard_name="ocean_heat_x_transport" unit="W" grid_ref="grid_U_2D_inner" />
+ <field id="u_masstr" long_name="Ocean Mass X Transport" standard_name="ocean_mass_x_transport" unit="kg/s" grid_ref="grid_U_3D_inner" />
+ <field id="u_masstr_vint" long_name="vertical integral of ocean eulerian mass transport along i-axis" standard_name="vertical_integral_of_ocean_mass_x_transport" unit="kg/s" grid_ref="grid_U_2D_inner" />
+ <field id="u_heattr" long_name="ocean eulerian heat transport along i-axis" standard_name="ocean_heat_x_transport" unit="W" grid_ref="grid_U_2D_inner" />
<field id="u_salttr" long_name="ocean eulerian salt transport along i-axis" standard_name="ocean_salt_x_transport" unit="1e-3*kg/s" grid_ref="grid_U_2D_inner" />
- <field id="uadv_heattr" long_name="ocean advective heat transport along i-axis" standard_name="advectice_ocean_heat_x_transport" unit="W" />
- <field id="uadv_salttr" long_name="ocean advective salt transport along i-axis" standard_name="advectice_ocean_salt_x_transport" unit="1e-3*kg/s" />
- <field id="udiff_heattr" long_name="ocean diffusion heat transport along i-axis" standard_name="ocean_heat_x_transport_due_to_diffusion" unit="W" />
- <field id="udiff_salttr" long_name="ocean diffusion salt transport along i-axis" standard_name="ocean_salt_x_transport_due_to_diffusion" unit="1e-3*kg/s" />
+ <field id="uadv_heattr" long_name="ocean advective heat transport along i-axis" standard_name="advectice_ocean_heat_x_transport" unit="W" grid_ref="grid_U_2D_inner" />
+ <field id="uadv_salttr" long_name="ocean advective salt transport along i-axis" standard_name="advectice_ocean_salt_x_transport" unit="1e-3*kg/s" grid_ref="grid_U_2D_inner" />
+ <field id="udiff_heattr" long_name="ocean diffusion heat transport along i-axis" standard_name="ocean_heat_x_transport_due_to_diffusion" unit="W" grid_ref="grid_U_2D_inner" />
+ <field id="udiff_salttr" long_name="ocean diffusion salt transport along i-axis" standard_name="ocean_salt_x_transport_due_to_diffusion" unit="1e-3*kg/s" grid_ref="grid_U_2D_inner" />
</field_group>
<!-- V grid -->
<field_group id="grid_V" grid_ref="grid_V_2D">
- <field id="e1v" long_name="V-cell width in longitudinal direction" standard_name="cell_width" unit="m" />
- <field id="e3v" long_name="V-cell thickness" standard_name="cell_thickness" unit="m" grid_ref="grid_V_3D" />
+ <field id="e1v" long_name="V-cell width in longitudinal direction" standard_name="cell_width" unit="m" />
+ <field id="e3v" long_name="V-cell thickness" standard_name="cell_thickness" unit="m" grid_ref="grid_V_3D_inner" />
<field id="e3v_0" long_name="Initial V-cell thickness" standard_name="ref_cell_thickness" unit="m" grid_ref="grid_V_3D" />
<field id="hv" long_name="water column height at V point" standard_name="water_column_height_V" unit="m" />
- <field id="vtau" long_name="Wind Stress along j-axis" standard_name="surface_downward_y_stress" unit="N/m2" />
<field id="voce" long_name="ocean current along j-axis" standard_name="sea_water_y_velocity" unit="m/s" grid_ref="grid_V_3D" />
<field id="voce_e3v" long_name="ocean current along j-axis (thickness weighted)" unit="m/s" grid_ref="grid_V_3D" > voce * e3v </field>
<field id="ssv" long_name="ocean surface current along j-axis" unit="m/s" />
@@ -670,21 +666,21 @@ that are available in the tidal-forcing implementation (see
<field id="agrif_spv" long_name=" AGRIF v-sponge coefficient" unit=" " />
<!-- v-eddy diffusivity coefficients (available if ln_traldf_OFF=F) -->
<field id="ahtv_2d" long_name=" surface v-eddy diffusivity coefficient" unit="m2/s or (m4/s)^1/2" />
- <field id="ahtv_3d" long_name=" 3D v-eddy diffusivity coefficient" unit="m2/s or (m4/s)^1/2" grid_ref="grid_V_3D"/>
+ <field id="ahtv_3d" long_name=" 3D v-eddy diffusivity coefficient" unit="m2/s or (m4/s)^1/2" grid_ref="grid_V_3D" />
<!-- v-eiv diffusivity coefficients (available if ln_ldfeiv=F) -->
- <field id="aeiv_2d" long_name=" surface v-EIV coefficient" unit="m2/s" />
- <field id="aeiv_3d" long_name=" 3D v-EIV coefficient" unit="m2/s" grid_ref="grid_V_3D" />
+ <field id="aeiv_2d" long_name=" surface v-EIV coefficient" unit="m2/s" />
+ <field id="aeiv_3d" long_name=" 3D v-EIV coefficient" unit="m2/s" grid_ref="grid_V_3D" />
<!-- variables available with MLE (ln_mle=T) -->
- <field id="psiv_mle" long_name="MLE streamfunction along j-axis" unit="m3/s" grid_ref="grid_V_3D" />
+ <field id="psiv_mle" long_name="MLE streamfunction along j-axis" unit="m3/s" grid_ref="grid_V_3D" />
<!-- voce_eiv: available EIV (ln_ldfeiv=T and ln_ldfeiv_dia=T) -->
- <field id="voce_eiv" long_name="EIV ocean current along j-axis" standard_name="bolus_sea_water_y_velocity" unit="m/s" grid_ref="grid_V_3D" />
- <field id="veiv_masstr" long_name="EIV Ocean Mass Y Transport" standard_name="bolus_ocean_mass_y_transport" unit="kg/s" grid_ref="grid_V_3D" />
- <field id="veiv_heattr" long_name="ocean bolus heat transport along j-axis" standard_name="ocean_heat_y_transport_due_to_bolus_advection" unit="W" />
- <field id="veiv_salttr" long_name="ocean bolus salt transport along j-axis" standard_name="ocean_salt_x_transport_due_to_bolus_advection" unit="Kg" />
- <field id="veiv_heattr3d" long_name="ocean bolus heat transport along j-axis" standard_name="ocean_heat_y_transport_due_to_bolus_advection" unit="W" grid_ref="grid_V_3D" />
- <field id="veiv_salttr3d" long_name="ocean bolus salt transport along j-axis" standard_name="ocean_salt_y_transport_due_to_bolus_advection" unit="kg" grid_ref="grid_V_3D" />
+ <field id="voce_eiv" long_name="EIV ocean current along j-axis" standard_name="bolus_sea_water_y_velocity" unit="m/s" grid_ref="grid_V_3D_inner" />
+ <field id="veiv_masstr" long_name="EIV Ocean Mass Y Transport" standard_name="bolus_ocean_mass_y_transport" unit="kg/s" grid_ref="grid_V_3D_inner" />
+ <field id="veiv_heattr" long_name="ocean bolus heat transport along j-axis" standard_name="ocean_heat_y_transport_due_to_bolus_advection" unit="W" grid_ref="grid_V_2D_inner" />
+ <field id="veiv_salttr" long_name="ocean bolus salt transport along j-axis" standard_name="ocean_salt_x_transport_due_to_bolus_advection" unit="Kg" grid_ref="grid_V_2D_inner" />
+ <field id="veiv_heattr3d" long_name="ocean bolus heat transport along j-axis" standard_name="ocean_heat_y_transport_due_to_bolus_advection" unit="W" grid_ref="grid_V_3D_inner" />
+ <field id="veiv_salttr3d" long_name="ocean bolus salt transport along j-axis" standard_name="ocean_salt_y_transport_due_to_bolus_advection" unit="kg" grid_ref="grid_V_3D_inner" />
<!-- voce_bbl: available with ln_trabbl=T and nn_bbl_adv=1 -->
@@ -696,91 +692,88 @@ that are available in the tidal-forcing implementation (see
<field id="vstokes" long_name="Stokes Drift Velocity j-axis" standard_name="StokesDrift_y_velocity" unit="m/s" grid_ref="grid_V_3D" />
<field id="vstokes_e3v" long_name="Stokes Drift Velocity j-axis (thickness weighted)" unit="m/s" grid_ref="grid_V_3D" > vstokes * e3v </field>
- <!-- variable for ice shelves -->
- <field id="vtbl" long_name="meridional current in the Losh tbl" unit="m/s" />
-
<!-- variables available with diaar5 -->
- <field id="v_masstr" long_name="ocean eulerian mass transport along j-axis" standard_name="ocean_mass_y_transport" unit="kg/s" grid_ref="grid_V_3D" />
+ <field id="v_masstr" long_name="ocean eulerian mass transport along j-axis" standard_name="ocean_mass_y_transport" unit="kg/s" grid_ref="grid_V_3D_inner" />
<field id="v_heattr" long_name="ocean eulerian heat transport along j-axis" standard_name="ocean_heat_y_transport" unit="W" grid_ref="grid_V_2D_inner" />
<field id="v_salttr" long_name="ocean eulerian salt transport along i-axis" standard_name="ocean_salt_y_transport" unit="1e-3*kg/s" grid_ref="grid_V_2D_inner" />
- <field id="vadv_heattr" long_name="ocean advective heat transport along j-axis" standard_name="advectice_ocean_heat_y_transport" unit="W" />
- <field id="vadv_salttr" long_name="ocean advective salt transport along j-axis" standard_name="advectice_ocean_salt_y_transport" unit="1e-3*kg/s" />
- <field id="vdiff_heattr" long_name="ocean diffusion heat transport along j-axis" standard_name="ocean_heat_y_transport_due_to_diffusion" unit="W" />
- <field id="vdiff_salttr" long_name="ocean diffusion salt transport along j-axis" standard_name="ocean_salt_y_transport_due_to_diffusion" unit="1e-3*kg/s" />
+ <field id="vadv_heattr" long_name="ocean advective heat transport along j-axis" standard_name="advectice_ocean_heat_y_transport" unit="W" grid_ref="grid_V_2D_inner" />
+ <field id="vadv_salttr" long_name="ocean advective salt transport along j-axis" standard_name="advectice_ocean_salt_y_transport" unit="1e-3*kg/s" grid_ref="grid_V_2D_inner" />
+ <field id="vdiff_heattr" long_name="ocean diffusion heat transport along j-axis" standard_name="ocean_heat_y_transport_due_to_diffusion" unit="W" grid_ref="grid_V_2D_inner" />
+ <field id="vdiff_salttr" long_name="ocean diffusion salt transport along j-axis" standard_name="ocean_salt_y_transport_due_to_diffusion" unit="1e-3*kg/s" grid_ref="grid_V_2D_inner" />
</field_group>
<!-- W grid -->
<field_group id="grid_W" grid_ref="grid_W_3D">
- <field id="e3w" long_name="W-cell thickness" standard_name="cell_thickness" unit="m" />
+ <field id="e3w" long_name="W-cell thickness" standard_name="cell_thickness" unit="m" grid_ref="grid_W_3D_inner" />
<field id="woce" long_name="ocean vertical velocity" standard_name="upward_sea_water_velocity" unit="m/s" />
<field id="woce_e3w" long_name="ocean vertical velocity * e3w" unit="m2/s" > woce * e3w </field>
<field id="wocetr_eff" long_name="effective ocean vertical transport" unit="m3/s" />
- <!-- woce_eiv: available with EIV (ln_ldfeiv=T and ln_ldfeiv_dia=T) -->
- <field id="woce_eiv" long_name="EIV ocean vertical velocity" standard_name="bolus_upward_sea_water_velocity" unit="m/s" />
- <field id="weiv_masstr" long_name="EIV Upward Ocean Mass Transport" standard_name="bolus_upward_ocean_mass_transport" unit="kg/s" />
- <field id="weiv_heattr3d" long_name="ocean bolus heat transport" standard_name="ocean_heat_z_transport_due_to_bolus_advection" unit="W" />
- <field id="weiv_salttr3d" long_name="ocean bolus salt transport" standard_name="ocean_salt_z_transport_due_to_bolus_advection" unit="kg" />
+ <!-- variables available with WAVE (ln_wave=T) -->
+ <field id="wstokes" long_name="Stokes Drift vertical velocity" standard_name="upward_StokesDrift_velocity" unit="m/s" />
- <field id="avt" long_name="vertical eddy diffusivity" standard_name="ocean_vertical_heat_diffusivity" unit="m2/s" />
- <field id="avt_e3w" long_name="vertical heat diffusivity * e3w" unit="m3/s" > avt * e3w </field>
- <field id="logavt" long_name="logarithm of vertical eddy diffusivity" standard_name="ocean_vertical_heat_diffusivity" unit="m2/s" />
- <field id="avm" long_name="vertical eddy viscosity" standard_name="ocean_vertical_momentum_diffusivity" unit="m2/s" />
- <field id="avm_e3w" long_name="vertical eddy viscosity * e3w" unit="m3/s" > avm * e3w </field>
+ <!-- woce_eiv: available with EIV (ln_ldfeiv=T and ln_ldfeiv_dia=T) -->
+ <field id="woce_eiv" long_name="EIV ocean vertical velocity" standard_name="bolus_upward_sea_water_velocity" unit="m/s" grid_ref="grid_W_3D_inner" />
+ <field id="weiv_masstr" long_name="EIV Upward Ocean Mass Transport" standard_name="bolus_upward_ocean_mass_transport" unit="kg/s" grid_ref="grid_W_3D_inner" />
+ <field id="weiv_heattr3d" long_name="ocean bolus heat transport" standard_name="ocean_heat_z_transport_due_to_bolus_advection" unit="W" grid_ref="grid_W_3D_inner" />
+ <field id="weiv_salttr3d" long_name="ocean bolus salt transport" standard_name="ocean_salt_z_transport_due_to_bolus_advection" unit="kg" grid_ref="grid_W_3D_inner" />
+
+ <!-- avt, avm -->
+ <field id="avt" long_name="vertical eddy diffusivity" standard_name="ocean_vertical_heat_diffusivity" unit="m2/s" grid_ref="grid_W_3D_inner" />
+ <field id="avt_e3w" long_name="vertical heat diffusivity * e3w" unit="m3/s" > avt * e3w </field>
+ <field id="logavt" long_name="logarithm of vertical eddy diffusivity" standard_name="ocean_vertical_heat_diffusivity" unit="m2/s" grid_ref="grid_W_3D_inner" />
+ <field id="avm" long_name="vertical eddy viscosity" standard_name="ocean_vertical_momentum_diffusivity" unit="m2/s" />
+ <field id="avm_e3w" long_name="vertical eddy viscosity * e3w" unit="m3/s" > avm * e3w </field>
<!-- avs: /= avt with ln_zdfddm=T -->
- <field id="avs" long_name="salt vertical eddy diffusivity" standard_name="ocean_vertical_salt_diffusivity" unit="m2/s" />
- <field id="avs_e3w" long_name="vertical salt diffusivity * e3w" unit="m3/s" > avs * e3w </field>
- <field id="logavs" long_name="logarithm of salt vertical eddy diffusivity" standard_name="ocean_vertical_heat_diffusivity" unit="m2/s" />
+ <field id="avs" long_name="salt vertical eddy diffusivity" standard_name="ocean_vertical_salt_diffusivity" unit="m2/s" grid_ref="grid_W_3D_inner" />
+ <field id="avs_e3w" long_name="vertical salt diffusivity * e3w" unit="m3/s" > avs * e3w </field>
+ <field id="logavs" long_name="logarithm of salt vertical eddy diffusivity" standard_name="ocean_vertical_heat_diffusivity" unit="m2/s" grid_ref="grid_W_3D_inner" />
<!-- avt_evd and avm_evd: available with ln_zdfevd -->
- <field id="avt_evd" long_name="convective enhancement of vertical diffusivity" standard_name="ocean_vertical_tracer_diffusivity_due_to_convection" unit="m2/s" />
- <field id="avt_evd_e3w" long_name="convective enhancement to vertical diffusivity * e3w " unit="m3/s" > avt_evd * e3w </field>
- <field id="avm_evd" long_name="convective enhancement of vertical viscosity" standard_name="ocean_vertical_momentum_diffusivity_due_to_convection" unit="m2/s" />
+ <field id="avt_evd" long_name="convective enhancement of vertical diffusivity" standard_name="ocean_vertical_tracer_diffusivity_due_to_convection" unit="m2/s" grid_ref="grid_W_3D_inner" />
+ <field id="avt_evd_e3w" long_name="convective enhancement to vertical diffusivity * e3w " unit="m3/s" > avt_evd * e3w </field>
+ <field id="avm_evd" long_name="convective enhancement of vertical viscosity" standard_name="ocean_vertical_momentum_diffusivity_due_to_convection" unit="m2/s" grid_ref="grid_W_3D_inner" />
<!-- mf_app and mf_wp: available with ln_zdfmfc -->
- <field id="mf_app" long_name="convective area" standard_name="mf_convective_area" unit="%" grid_ref="grid_W_3D" />
- <field id="mf_wp" long_name="convective velocity" standard_name="mf_convective_velo" unit="m/s" grid_ref="grid_W_3D" />
-
+ <field id="mf_app" long_name="convective area" standard_name="mf_convective_area" unit="%" grid_ref="grid_W_3D_inner" />
+ <field id="mf_wp" long_name="convective velocity" standard_name="mf_convective_velo" unit="m/s" grid_ref="grid_W_3D_inner" />
<!-- avt_tide: available with ln_zdfiwm=T -->
- <field id="av_ratio" long_name="S over T diffusivity ratio" standard_name="salinity_over_temperature_diffusivity_ratio" unit="1" />
- <field id="av_wave" long_name="internal wave-induced vertical diffusivity" standard_name="ocean_vertical_tracer_diffusivity_due_to_internal_waves" unit="m2/s" />
- <field id="bflx_iwm" long_name="internal wave-induced buoyancy flux" standard_name="buoyancy_flux_due_to_internal_waves" unit="W/kg" />
- <field id="pcmap_iwm" long_name="power consumed by wave-driven mixing" standard_name="vertically_integrated_power_consumption_by_wave_driven_mixing" unit="W/m2" grid_ref="grid_W_2D" />
- <field id="emix_iwm" long_name="power density available for mixing" standard_name="power_available_for_mixing_from_breaking_internal_waves" unit="W/kg" />
-
- <!-- variables available with WAVE (ln_wave=T) -->
- <field id="wstokes" long_name="Stokes Drift vertical velocity" standard_name="upward_StokesDrift_velocity" unit="m/s" />
+ <field id="av_ratio" long_name="S over T diffusivity ratio" standard_name="salinity_over_temperature_diffusivity_ratio" unit="1" grid_ref="grid_W_3D_inner" />
+ <field id="av_wave" long_name="internal wave-induced vertical diffusivity" standard_name="ocean_vertical_tracer_diffusivity_due_to_internal_waves" unit="m2/s" grid_ref="grid_W_3D_inner" />
+ <field id="bflx_iwm" long_name="internal wave-induced buoyancy flux" standard_name="buoyancy_flux_due_to_internal_waves" unit="W/kg" grid_ref="grid_W_3D_inner" />
+ <field id="pcmap_iwm" long_name="power consumed by wave-driven mixing" standard_name="vertically_integrated_power_consumption_by_wave_driven_mixing" unit="W/m2" grid_ref="grid_W_2D_inner" />
+ <field id="emix_iwm" long_name="power density available for mixing" standard_name="power_available_for_mixing_from_breaking_internal_waves" unit="W/kg" grid_ref="grid_W_3D_inner" />
<!-- variables available with diaar5 -->
- <field id="w_masstr" long_name="vertical mass transport" standard_name="upward_ocean_mass_transport" unit="kg/s" />
- <field id="w_masstr2" long_name="square of vertical mass transport" standard_name="square_of_upward_ocean_mass_transport" unit="kg2/s2" />
+ <field id="w_masstr" long_name="vertical mass transport" standard_name="upward_ocean_mass_transport" unit="kg/s" grid_ref="grid_W_3D_inner" />
+ <field id="w_masstr2" long_name="square of vertical mass transport" standard_name="square_of_upward_ocean_mass_transport" unit="kg2/s2" grid_ref="grid_W_3D_inner" />
<!-- EOS -->
<field id="bn2" long_name="squared Brunt-Vaisala frequency" unit="s-2" />
<!-- dissipation diagnostics (note: ediss_k is only available with tke scheme) -->
- <field id="avt_k" long_name="vertical eddy diffusivity from closure schemes" standard_name="ocean_vertical_eddy_diffusivity" unit="m2/s" />
- <field id="avm_k" long_name="vertical eddy viscosity from closure schemes" standard_name="ocean_vertical_eddy_viscosity" unit="m2/s" />
- <field id="ediss_k" long_name="Kolmogorov energy dissipation (tke scheme)" standard_name="Kolmogorov_energy_dissipation" unit="W/kg" />
- <field id="eshear_k" long_name="energy source from vertical shear" standard_name="energy_source_from_shear" unit="W/kg" />
- <field id="estrat_k" long_name="energy sink from stratification" standard_name="energy_sink_from_stratification" unit="W/kg" />
+ <field id="avt_k" long_name="vertical eddy diffusivity from closure schemes" standard_name="ocean_vertical_eddy_diffusivity" unit="m2/s" grid_ref="grid_W_3D_inner" />
+ <field id="avm_k" long_name="vertical eddy viscosity from closure schemes" standard_name="ocean_vertical_eddy_viscosity" unit="m2/s" />
+ <field id="ediss_k" long_name="Kolmogorov energy dissipation (tke scheme)" standard_name="Kolmogorov_energy_dissipation" unit="W/kg" grid_ref="grid_W_3D_inner" />
+ <field id="eshear_k" long_name="energy source from vertical shear" standard_name="energy_source_from_shear" unit="W/kg" grid_ref="grid_W_3D_inner" />
+ <field id="estrat_k" long_name="energy sink from stratification" standard_name="energy_sink_from_stratification" unit="W/kg" grid_ref="grid_W_3D_inner" />
</field_group>
<!-- F grid -->
<field_group id="grid_F" grid_ref="grid_F_2D">
- <field id="e3f" long_name="F-cell thickness" standard_name="cell_thickness" unit="m" grid_ref="grid_F_3D" />
- <field id="e3f_0" long_name="F-cell thickness" standard_name="cell_thickness" unit="m" grid_ref="grid_F_3D" />
- <field id="hf" long_name="water column height at F point" standard_name="water_column_height_F" unit="m" />
- <field id="ssKEf" long_name="surface kinetic energy at F point" standard_name="specific_kinetic_energy_of_sea_water" unit="m2/s2" grid_ref="grid_F_2D_inner" />
- <field id="ssrelvor" long_name="surface relative vorticity" standard_name="relative_vorticity" unit="1/s" grid_ref="grid_F_2D_inner" />
- <field id="ssplavor" long_name="surface planetary vorticity" standard_name="planetary_vorticity" unit="1/s" />
- <field id="ssrelpotvor" long_name="surface relative potential vorticity" standard_name="relpot_vorticity" unit="1/m.s" grid_ref="grid_F_2D_inner" />
- <field id="ssabspotvor" long_name="surface absolute potential vorticity" standard_name="abspot_vorticity" unit="1/m.s" grid_ref="grid_F_2D_inner" />
- <field id="ssEns" long_name="surface enstrophy" standard_name="enstrophy" unit="1/m2.s2" grid_ref="grid_F_2D_inner" />
+ <field id="e3f" long_name="F-cell thickness" standard_name="cell_thickness" unit="m" grid_ref="grid_F_3D_inner" />
+ <field id="e3f_0" long_name="F-cell thickness" standard_name="cell_thickness" unit="m" grid_ref="grid_F_3D" />
+ <field id="hf" long_name="water column height at F point" standard_name="water_column_height_F" unit="m" />
+ <field id="ssKEf" long_name="surface kinetic energy at F point" standard_name="specific_kinetic_energy_of_sea_water" unit="m2/s2" grid_ref="grid_F_2D_inner" />
+ <field id="ssrelvor" long_name="surface relative vorticity" standard_name="relative_vorticity" unit="1/s" grid_ref="grid_F_2D_inner" />
+ <field id="ssplavor" long_name="surface planetary vorticity" standard_name="planetary_vorticity" unit="1/s" grid_ref="grid_F_2D_inner" />
+ <field id="ssrelpotvor" long_name="surface relative potential vorticity" standard_name="relpot_vorticity" unit="1/m.s" grid_ref="grid_F_2D_inner" />
+ <field id="ssabspotvor" long_name="surface absolute potential vorticity" standard_name="abspot_vorticity" unit="1/m.s" grid_ref="grid_F_2D_inner" />
+ <field id="ssEns" long_name="surface enstrophy" standard_name="enstrophy" unit="1/m2.s2" grid_ref="grid_F_2D_inner" />
</field_group>
<!-- AGRIF sponge -->
@@ -822,16 +815,16 @@ that are available in the tidal-forcing implementation (see
<!-- transects -->
<field_group id="oce_straits">
- <field id="uoce_e3u_ave" long_name="Monthly average of u*e3u" field_ref="uoce_e3u" freq_op="1mo" freq_offset="_reset_" > @uoce_e3u </field>
- <field id="uoce_e3u_ave_vsum" long_name="Vertical sum of u*e3u" field_ref="uoce_e3u_ave" grid_ref="grid_U_vsum" />
+ <field id="uoce_e3u_ave" long_name="Monthly average of u*e3u" field_ref="uoce_e3u" freq_op="1mo" freq_offset="_reset_" > @uoce_e3u </field>
+ <field id="uoce_e3u_ave_vsum" long_name="Vertical sum of u*e3u" field_ref="uoce_e3u_ave" grid_ref="grid_U_vsum" />
<field id="uocetr_vsum_section" long_name="Total 2D transport in i-direction" field_ref="uoce_e3u_ave_vsum" grid_ref="grid_U_scalar" detect_missing_value="true"> this * e2u </field>
<field id="uocetr_strait" long_name="Total transport across lines in i-direction" field_ref="uocetr_vsum_section" grid_ref="grid_U_4strait" />
<field id="u_masstr_strait" long_name="Sea water transport across line in i-direction" field_ref="uocetr_strait" grid_ref="grid_U_4strait_hsum" unit="kg/s"> this * maskMFO_u * $rho0 </field>
- <field id="voce_e3v_ave" long_name="Monthly average of v*e3v" field_ref="voce_e3v" freq_op="1mo" freq_offset="_reset_" > @voce_e3v </field>
- <field id="voce_e3v_ave_vsum" long_name="Vertical sum of v*e3v" field_ref="voce_e3v_ave" grid_ref="grid_V_vsum" />
+ <field id="voce_e3v_ave" long_name="Monthly average of v*e3v" field_ref="voce_e3v" freq_op="1mo" freq_offset="_reset_" > @voce_e3v </field>
+ <field id="voce_e3v_ave_vsum" long_name="Vertical sum of v*e3v" field_ref="voce_e3v_ave" grid_ref="grid_V_vsum" />
<field id="vocetr_vsum_section" long_name="Total 2D transport of in j-direction" field_ref="voce_e3v_ave_vsum" grid_ref="grid_V_scalar" detect_missing_value="true"> this * e1v </field>
- <field id="vocetr_strait" long_name="Total transport across lines in j-direction" field_ref="vocetr_vsum_section" grid_ref="grid_V_4strait" />
+ <field id="vocetr_strait" long_name="Total transport across lines in j-direction" field_ref="vocetr_vsum_section" grid_ref="grid_V_4strait" />
<field id="v_masstr_strait" long_name="Sea water transport across line in j-direction" field_ref="vocetr_strait" grid_ref="grid_V_4strait_hsum" unit="kg/s"> this * maskMFO_v * $rho0 </field>
<field id="masstr_strait" long_name="Sea water transport across line" grid_ref="grid_4strait" > u_masstr_strait + v_masstr_strait </field>
@@ -1024,7 +1017,7 @@ that are available in the tidal-forcing implementation (see
</field_group>
<!-- Total trends calculated every time step-->
- <field_group id="trendT" grid_ref="grid_T_3D">
+ <field_group id="trendT" grid_ref="grid_T_3D_inner">
<field id="ttrd_tot" long_name="temperature-trend: total model trend" unit="degC/s" />
<field id="strd_tot" long_name="salinity -trend: total model trend" unit="1e-3/s" />
<!-- Thickness weighted versions: -->
@@ -1040,10 +1033,10 @@ that are available in the tidal-forcing implementation (see
<field id="ketrd_spg" long_name="ke-trend: surface pressure gradient" unit="W/s^3" />
<field id="ketrd_spgexp" long_name="ke-trend: surface pressure gradient (explicit)" unit="W/s^3" />
<field id="ketrd_spgflt" long_name="ke-trend: surface pressure gradient (filter)" unit="W/s^3" />
- <field id="ssh_flt" long_name="filtered contribution to ssh (dynspg_flt)" unit="m" grid_ref="grid_T_2D" />
- <field id="w0" long_name="surface vertical velocity" unit="m/s" grid_ref="grid_T_2D" />
- <field id="pw0_exp" long_name="surface pressure flux due to ssh" unit="W/s^2" grid_ref="grid_T_2D" />
- <field id="pw0_flt" long_name="surface pressure flux due to filtered ssh" unit="W/s^2" grid_ref="grid_T_2D" />
+ <field id="ssh_flt" long_name="filtered contribution to ssh (dynspg_flt)" unit="m" grid_ref="grid_T_2D_inner" />
+ <field id="w0" long_name="surface vertical velocity" unit="m/s" grid_ref="grid_T_2D_inner" />
+ <field id="pw0_exp" long_name="surface pressure flux due to ssh" unit="W/s^2" grid_ref="grid_T_2D_inner" />
+ <field id="pw0_flt" long_name="surface pressure flux due to filtered ssh" unit="W/s^2" grid_ref="grid_T_2D_inner" />
<field id="ketrd_keg" long_name="ke-trend: KE gradient or hor. adv." unit="W/s^3" />
<field id="ketrd_rvo" long_name="ke-trend: relative vorticity or metric term" unit="W/s^3" />
<field id="ketrd_pvo" long_name="ke-trend: planetary vorticity" unit="W/s^3" />
@@ -1051,24 +1044,18 @@ that are available in the tidal-forcing implementation (see
<field id="ketrd_udx" long_name="ke-trend: U.dx[U]" unit="W/s^3" />
<field id="ketrd_ldf" long_name="ke-trend: lateral diffusion" unit="W/s^3" />
<field id="ketrd_zdf" long_name="ke-trend: vertical diffusion" unit="W/s^3" />
- <field id="ketrd_tau" long_name="ke-trend: wind stress " unit="W/s^3" grid_ref="grid_T_2D" />
+ <field id="ketrd_tau" long_name="ke-trend: wind stress " unit="W/s^3" grid_ref="grid_T_2D_inner" />
<field id="ketrd_bfr" long_name="ke-trend: bottom friction (explicit)" unit="W/s^3" />
<field id="ketrd_bfri" long_name="ke-trend: bottom friction (implicit)" unit="W/s^3" />
<field id="ketrd_atf" long_name="ke-trend: asselin time filter trend" unit="W/s^3" />
<field id="ketrd_convP2K" long_name="ke-trend: conversion (potential to kinetic)" unit="W/s^3" />
<field id="KE" long_name="kinetic energy: u(n)*u(n+1)/2" unit="W/s^2" />
- <!-- variables available when explicit lateral mixing is used (ln_dynldf_OFF=F) -->
- <field id="dispkexyfo" long_name="KE-trend: lateral mixing induced dissipation" standard_name="ocean_kinetic_energy_dissipation_per_unit_area_due_to_xy_friction" unit="W/m^2" grid_ref="grid_T_2D" />
- <field id="dispkevfo" long_name="KE-trend: vertical mixing induced dissipation" standard_name="ocean_kinetic_energy_dissipation_per_unit_area_due_to_vertical_friction" unit="W/m^2" grid_ref="grid_T_2D" />
- <!-- variables available with ln_traadv_eiv=T and ln_diaeiv=T -->
- <field id="eketrd_eiv" long_name="EKE-trend due to parameterized eddy advection" standard_name="tendency_of_ocean_eddy_kinetic_energy_content_due_to_parameterized_eddy_advection" unit="W/m^2" grid_ref="grid_T_2D" />
-
<!-- variables available with ln_PE_trd -->
<field id="petrd_xad" long_name="pe-trend: i-advection" unit="W/m^3" />
<field id="petrd_yad" long_name="pe-trend: j-advection" unit="W/m^3" />
<field id="petrd_zad" long_name="pe-trend: k-advection" unit="W/m^3" />
- <field id="petrd_sad" long_name="pe-trend: surface adv. (linssh true)" unit="W/m^3" grid_ref="grid_T_2D" />
+ <field id="petrd_sad" long_name="pe-trend: surface adv. (linssh true)" unit="W/m^3" grid_ref="grid_T_2D_inner" />
<field id="petrd_ldf" long_name="pe-trend: lateral diffusion" unit="W/m^3" />
<field id="petrd_zdf" long_name="pe-trend: vertical diffusion" unit="W/m^3" />
<field id="petrd_zdfp" long_name="pe-trend: pure vert. diffusion" unit="W/m^3" />
@@ -1086,42 +1073,42 @@ that are available in the tidal-forcing implementation (see
<field_group id="trendU" grid_ref="grid_U_3D">
<!-- variables available with ln_dyn_trd -->
- <field id="utrd_hpg" long_name="i-trend: hydrostatic pressure gradient" unit="m/s^2" />
- <field id="utrd_spg" long_name="i-trend: surface pressure gradient" unit="m/s^2" />
- <field id="utrd_spgexp" long_name="i-trend: surface pressure gradient (explicit)" unit="m/s^2" />
- <field id="utrd_spgflt" long_name="i-trend: surface pressure gradient (filtered)" unit="m/s^2" />
- <field id="utrd_keg" long_name="i-trend: KE gradient or hor. adv." unit="m/s^2" />
- <field id="utrd_rvo" long_name="i-trend: relative vorticity or metric term" unit="m/s^2" />
- <field id="utrd_pvo" long_name="i-trend: planetary vorticity" unit="m/s^2" />
- <field id="utrd_zad" long_name="i-trend: vertical advection" unit="m/s^2" />
- <field id="utrd_udx" long_name="i-trend: U.dx[U]" unit="m/s^2" />
- <field id="utrd_ldf" long_name="i-trend: lateral diffusion" unit="m/s^2" />
- <field id="utrd_zdf" long_name="i-trend: vertical diffusion" unit="m/s^2" />
- <field id="utrd_tau" long_name="i-trend: wind stress " unit="m/s^2" grid_ref="grid_U_2D" />
- <field id="utrd_bfr" long_name="i-trend: bottom friction (explicit)" unit="m/s^2" />
- <field id="utrd_bfri" long_name="i-trend: bottom friction (implicit)" unit="m/s^2" />
- <field id="utrd_tot" long_name="i-trend: total momentum trend before atf" unit="m/s^2" />
- <field id="utrd_atf" long_name="i-trend: asselin time filter trend" unit="m/s^2" />
+ <field id="utrd_hpg" long_name="i-trend: hydrostatic pressure gradient" unit="m/s^2" grid_ref="grid_T_3D_inner" />
+ <field id="utrd_spg" long_name="i-trend: surface pressure gradient" unit="m/s^2" grid_ref="grid_T_3D_inner" />
+ <field id="utrd_spgexp" long_name="i-trend: surface pressure gradient (explicit)" unit="m/s^2" grid_ref="grid_T_3D_inner" />
+ <field id="utrd_spgflt" long_name="i-trend: surface pressure gradient (filtered)" unit="m/s^2" grid_ref="grid_T_3D_inner" />
+ <field id="utrd_keg" long_name="i-trend: KE gradient or hor. adv." unit="m/s^2" grid_ref="grid_T_3D_inner" />
+ <field id="utrd_rvo" long_name="i-trend: relative vorticity or metric term" unit="m/s^2" grid_ref="grid_T_3D_inner" />
+ <field id="utrd_pvo" long_name="i-trend: planetary vorticity" unit="m/s^2" grid_ref="grid_T_3D_inner" />
+ <field id="utrd_zad" long_name="i-trend: vertical advection" unit="m/s^2" grid_ref="grid_T_3D_inner" />
+ <field id="utrd_udx" long_name="i-trend: U.dx[U]" unit="m/s^2" grid_ref="grid_T_3D_inner" />
+ <field id="utrd_ldf" long_name="i-trend: lateral diffusion" unit="m/s^2" grid_ref="grid_T_3D_inner" />
+ <field id="utrd_zdf" long_name="i-trend: vertical diffusion" unit="m/s^2" grid_ref="grid_T_3D_inner" />
+ <field id="utrd_tau" long_name="i-trend: wind stress " unit="m/s^2" grid_ref="grid_U_2D_inner" />
+ <field id="utrd_bfr" long_name="i-trend: bottom friction (explicit)" unit="m/s^2" grid_ref="grid_T_3D_inner" />
+ <field id="utrd_bfri" long_name="i-trend: bottom friction (implicit)" unit="m/s^2" grid_ref="grid_T_3D_inner" />
+ <field id="utrd_tot" long_name="i-trend: total momentum trend before atf" unit="m/s^2" grid_ref="grid_T_3D_inner" />
+ <field id="utrd_atf" long_name="i-trend: asselin time filter trend" unit="m/s^2" grid_ref="grid_T_3D_inner" />
</field_group>
<field_group id="trendV" grid_ref="grid_V_3D">
<!-- variables available with ln_dyn_trd -->
- <field id="vtrd_hpg" long_name="j-trend: hydrostatic pressure gradient" unit="m/s^2" />
- <field id="vtrd_spg" long_name="j-trend: surface pressure gradient" unit="m/s^2" />
- <field id="vtrd_spgexp" long_name="j-trend: surface pressure gradient (explicit)" unit="m/s^2" />
- <field id="vtrd_spgflt" long_name="j-trend: surface pressure gradient (filtered)" unit="m/s^2" />
- <field id="vtrd_keg" long_name="j-trend: KE gradient or hor. adv." unit="m/s^2" />
- <field id="vtrd_rvo" long_name="j-trend: relative vorticity or metric term" unit="m/s^2" />
- <field id="vtrd_pvo" long_name="j-trend: planetary vorticity" unit="m/s^2" />
- <field id="vtrd_zad" long_name="j-trend: vertical advection" unit="m/s^2" />
- <field id="vtrd_vdy" long_name="i-trend: V.dx[V]" unit="m/s^2" />
- <field id="vtrd_ldf" long_name="j-trend: lateral diffusion" unit="m/s^2" />
- <field id="vtrd_zdf" long_name="j-trend: vertical diffusion" unit="m/s^2" />
- <field id="vtrd_tau" long_name="j-trend: wind stress " unit="m/s^2" grid_ref="grid_V_2D" />
- <field id="vtrd_bfr" long_name="j-trend: bottom friction (explicit)" unit="m/s^2" />
- <field id="vtrd_bfri" long_name="j-trend: bottom friction (implicit)" unit="m/s^2" />
- <field id="vtrd_tot" long_name="j-trend: total momentum trend before atf" unit="m/s^2" />
- <field id="vtrd_atf" long_name="j-trend: asselin time filter trend" unit="m/s^2" />
+ <field id="vtrd_hpg" long_name="j-trend: hydrostatic pressure gradient" unit="m/s^2" grid_ref="grid_T_3D_inner" />
+ <field id="vtrd_spg" long_name="j-trend: surface pressure gradient" unit="m/s^2" grid_ref="grid_T_3D_inner" />
+ <field id="vtrd_spgexp" long_name="j-trend: surface pressure gradient (explicit)" unit="m/s^2" grid_ref="grid_T_3D_inner" />
+ <field id="vtrd_spgflt" long_name="j-trend: surface pressure gradient (filtered)" unit="m/s^2" grid_ref="grid_T_3D_inner" />
+ <field id="vtrd_keg" long_name="j-trend: KE gradient or hor. adv." unit="m/s^2" grid_ref="grid_T_3D_inner" />
+ <field id="vtrd_rvo" long_name="j-trend: relative vorticity or metric term" unit="m/s^2" grid_ref="grid_T_3D_inner" />
+ <field id="vtrd_pvo" long_name="j-trend: planetary vorticity" unit="m/s^2" grid_ref="grid_T_3D_inner" />
+ <field id="vtrd_zad" long_name="j-trend: vertical advection" unit="m/s^2" grid_ref="grid_T_3D_inner" />
+ <field id="vtrd_vdy" long_name="i-trend: V.dx[V]" unit="m/s^2" grid_ref="grid_T_3D_inner" />
+ <field id="vtrd_ldf" long_name="j-trend: lateral diffusion" unit="m/s^2" grid_ref="grid_T_3D_inner" />
+ <field id="vtrd_zdf" long_name="j-trend: vertical diffusion" unit="m/s^2" grid_ref="grid_T_3D_inner" />
+ <field id="vtrd_tau" long_name="j-trend: wind stress " unit="m/s^2" grid_ref="grid_V_2D_inner" />
+ <field id="vtrd_bfr" long_name="j-trend: bottom friction (explicit)" unit="m/s^2" grid_ref="grid_T_3D_inner" />
+ <field id="vtrd_bfri" long_name="j-trend: bottom friction (implicit)" unit="m/s^2" grid_ref="grid_T_3D_inner" />
+ <field id="vtrd_tot" long_name="j-trend: total momentum trend before atf" unit="m/s^2" grid_ref="grid_T_3D_inner" />
+ <field id="vtrd_atf" long_name="j-trend: asselin time filter trend" unit="m/s^2" grid_ref="grid_T_3D_inner" />
</field_group>
<!-- shared variables available with TOP interface -->
@@ -1195,6 +1182,8 @@ that are available in the tidal-forcing implementation (see
<field field_ref="qsr" name="rsntds" long_name="surface_net_downward_shortwave_flux" />
<field field_ref="qt" name="tohfls" long_name="surface_net_downward_total_heat_flux" />
<field field_ref="taum" />
+ <field field_ref="utau" name="tauuo" long_name="surface_downward_x_stress" />
+ <field field_ref="vtau" name="tauvo" long_name="surface_downward_y_stress" />
<field field_ref="20d" />
<field field_ref="mldkz5" />
<field field_ref="mldr10_1" />
@@ -1209,12 +1198,10 @@ that are available in the tidal-forcing implementation (see
<field_group id="groupU" >
<field field_ref="uoce" name="uo" long_name="sea_water_x_velocity" />
- <field field_ref="utau" name="tauuo" long_name="surface_downward_x_stress" />
</field_group>
<field_group id="groupV" >
<field field_ref="voce" name="vo" long_name="sea_water_y_velocity" />
- <field field_ref="vtau" name="tauvo" long_name="surface_downward_y_stress" />
</field_group>
<field_group id="groupW" >
diff --git a/cfgs/SHARED/field_def_nemo-pisces.xml b/cfgs/SHARED/field_def_nemo-pisces.xml
index d73853f06c74506f33d5eb346555ee0588a91d03..a24903779d7c1565d18919c54835c1c2162d33d5 100644
--- a/cfgs/SHARED/field_def_nemo-pisces.xml
+++ b/cfgs/SHARED/field_def_nemo-pisces.xml
@@ -172,140 +172,137 @@
<!-- PISCES additional diagnostics on T grid -->
- <field_group id="diad_T" grid_ref="grid_T_2D">
- <field id="PH" long_name="PH" unit="1" grid_ref="grid_T_3D" />
- <field id="CO3" long_name="Bicarbonates" unit="mol/m3" grid_ref="grid_T_3D" />
- <field id="CO3sat" long_name="CO3 saturation" unit="mol/m3" grid_ref="grid_T_3D" />
- <field id="PAR" long_name="Photosynthetically Available Radiation" unit="W/m2" grid_ref="grid_T_3D" />
- <field id="PPPHYN" long_name="Primary production of nanophyto" unit="molC/m3/s" grid_ref="grid_T_3D" />
- <field id="PPPHYP" long_name="Primary production of picophyto" unit="molC/m3/s" grid_ref="grid_T_3D" />
- <field id="PPPHYD" long_name="Primary production of diatoms" unit="molC/m3/s" grid_ref="grid_T_3D" />
- <field id="PPNEWN" long_name="New Primary production of nanophyto" unit="molC/m3/s" grid_ref="grid_T_3D" />
- <field id="PPNEWP" long_name="New Primary production of picophyto" unit="molC/m3/s" grid_ref="grid_T_3D" />
- <field id="PPNEWD" long_name="New Primary production of diatoms" unit="molC/m3/s" grid_ref="grid_T_3D" />
- <field id="PBSi" long_name="Primary production of Si diatoms" unit="molC/m3/s" grid_ref="grid_T_3D" />
- <field id="PFeN" long_name="Primary production of nano iron" unit="molC/m3/s" grid_ref="grid_T_3D" />
- <field id="PFeP" long_name="Primary production of pico iron" unit="molC/m3/s" grid_ref="grid_T_3D" />
- <field id="PFeD" long_name="Primary production of diatoms iron" unit="mol/m3/s" grid_ref="grid_T_3D" />
- <field id="xfracal" long_name="Calcifying fraction" unit="1" grid_ref="grid_T_3D" />
- <field id="PCAL" long_name="Calcite production" unit="mol/m3/s" grid_ref="grid_T_3D" />
- <field id="DCAL" long_name="Calcite dissolution" unit="mol/m3/s" grid_ref="grid_T_3D" />
- <field id="GRAZ1" long_name="Grazing by microzooplankton" unit="mol/m3/s" grid_ref="grid_T_3D" />
- <field id="GRAZ2" long_name="Grazing by mesozooplankton" unit="mol/m3/s" grid_ref="grid_T_3D" />
- <field id="REMIN" long_name="Oxic remineralization of OM" unit="mol/m3/s" grid_ref="grid_T_3D" />
- <field id="DENIT" long_name="Anoxic remineralization of OM" unit="mol/m3/s" grid_ref="grid_T_3D" />
- <field id="REMINP" long_name="Oxic remineralization rate of POC" unit="d-1" grid_ref="grid_T_3D" />
- <field id="REMING" long_name="Oxic remineralization rate of GOC" unit="d-1" grid_ref="grid_T_3D" />
- <field id="Nfix" long_name="Nitrogen fixation" unit="mol/m3/s" grid_ref="grid_T_3D" />
- <field id="Mumax" long_name="Maximum growth rate" unit="s-1" grid_ref="grid_T_3D" />
- <field id="MuN" long_name="Realized growth rate for nanophyto" unit="s-1" grid_ref="grid_T_3D" />
- <field id="MuP" long_name="Realized growth rate for picophyto" unit="s-1" grid_ref="grid_T_3D" />
- <field id="MuD" long_name="Realized growth rate for diatomes" unit="s-1" grid_ref="grid_T_3D" />
- <field id="MunetN" long_name="Net growth rate for nanophyto" unit="s-1" grid_ref="grid_T_3D" />
- <field id="MunetP" long_name="Net growth rate for picophyto" unit="s-1" grid_ref="grid_T_3D" />
- <field id="MunetD" long_name="Net growth rate for diatomes" unit="s-1" grid_ref="grid_T_3D" />
- <field id="LNnut" long_name="Nutrient limitation term in Nanophyto" unit="" grid_ref="grid_T_3D" />
- <field id="LPnut" long_name="Nutrient limitation term in Picophyto" unit="-" grid_ref="grid_T_3D" />
- <field id="LDnut" long_name="Nutrient limitation term in Diatoms" unit="" grid_ref="grid_T_3D" />
- <field id="LNFe" long_name="Iron limitation term in Nanophyto" unit="" grid_ref="grid_T_3D" />
- <field id="LPFe" long_name="Iron limitation term in Picophyto" unit="-" grid_ref="grid_T_3D" />
- <field id="LDFe" long_name="Iron limitation term in Diatoms" unit="" grid_ref="grid_T_3D" />
- <field id="LNlight" long_name="Light limitation term in Nanophyto" unit="" grid_ref="grid_T_3D" />
- <field id="LPlight" long_name="Light limitation term in Picophyto" unit="-" grid_ref="grid_T_3D" />
- <field id="LDlight" long_name="Light limitation term in Diatoms" unit="" grid_ref="grid_T_3D" />
- <field id="SIZEN" long_name="Mean relative size of nanophyto." unit="-" grid_ref="grid_T_3D" />
- <field id="SIZEP" long_name="Mean relative size of picophyto." unit="-" grid_ref="grid_T_3D" />
- <field id="SIZED" long_name="Mean relative size of diatoms" unit="-" grid_ref="grid_T_3D" />
- <field id="RASSD" long_name="Size of the protein machinery (Diat.)" unit="-" grid_ref="grid_T_3D" />
- <field id="RASSN" long_name="Size of the protein machinery (Nano.)" unit="-" grid_ref="grid_T_3D" />
- <field id="RASSP" long_name="Size of the protein machinery (Pico.)" unit="-" grid_ref="grid_T_3D" />
- <field id="Fe3" long_name="Iron III concentration" unit="nmol/m3" grid_ref="grid_T_3D" />
- <field id="FeL1" long_name="Complexed Iron concentration with L1" unit="nmol/m3" grid_ref="grid_T_3D" />
- <field id="TL1" long_name="Total L1 concentration" unit="nmol/m3" grid_ref="grid_T_3D" />
- <field id="pdust" long_name="dust concentration" unit="g/m3" />
- <field id="Totlig" long_name="Total ligand concentation" unit="nmol/m3" grid_ref="grid_T_3D" />
- <field id="Biron" long_name="Bioavailable iron" unit="nmol/m3" grid_ref="grid_T_3D" />
- <field id="Sdenit" long_name="Nitrate reduction in the sediments" unit="mol/m2/s" />
- <field id="Ironice" long_name="Iron input/uptake due to sea ice" unit="mol/m2/s" />
- <field id="SedCal" long_name="Calcite burial in the sediments" unit="molC/m2/s" />
- <field id="SedSi" long_name="Silicon burial in the sediments" unit="molSi/m2/s" />
- <field id="SedC" long_name="Organic C burial in the sediments" unit="molC/m2/s" />
- <field id="HYDR" long_name="Iron input from hydrothemal vents" unit="mol/m2/s" grid_ref="grid_T_3D" />
- <field id="EPC100" long_name="Export of carbon particles at 100 m" unit="mol/m2/s" />
- <field id="EPFE100" long_name="Export of biogenic iron at 100 m" unit="mol/m2/s" />
- <field id="EPSI100" long_name="Export of Silicate at 100 m" unit="mol/m2/s" />
- <field id="EPCAL100" long_name="Export of Calcite at 100 m" unit="mol/m2/s" />
- <field id="EXPC" long_name="Export of carbon" unit="mol/m2/s" grid_ref="grid_T_3D" />
- <field id="EXPFE" long_name="Export of biogenic iron" unit="mol/m2/s" grid_ref="grid_T_3D" />
- <field id="EXPSI" long_name="Export of Silicate" unit="mol/m2/s" grid_ref="grid_T_3D" />
- <field id="EXPCAL" long_name="Export of Calcite" unit="mol/m2/s" grid_ref="grid_T_3D" />
- <field id="Cflx" long_name="DIC flux" unit="mol/m2/s" />
- <field id="Oflx" long_name="Oxygen flux" unit="mol/m2/s" />
- <field id="Kg" long_name="Gas transfer" unit="mol/m2/s/uatm" />
- <field id="Dpco2" long_name="Delta CO2" unit="uatm" />
- <field id="pCO2sea" long_name="surface ocean pCO2" unit="uatm" />
- <field id="Dpo2" long_name="Delta O2" unit="uatm" />
- <field id="Heup" long_name="Euphotic layer depth" unit="m" />
- <field id="AtmCo2" long_name="Atmospheric CO2 concentration" unit="ppm" />
- <field id="Irondep" long_name="Iron deposition from dust" unit="mol/m2/s" />
- <field id="Ironsed" long_name="Iron deposition from sediment" unit="mol/m2/s" grid_ref="grid_T_3D" />
- <field id="FESCAV" long_name="Scavenging of Iron" unit="mmol-Fe/m3/s" grid_ref="grid_T_3D" />
- <field id="FECOLL" long_name="Colloidal Pumping of FeL" unit="mmol-FeL/m3/s" grid_ref="grid_T_3D" />
- <field id="LGWCOLL" long_name="Coagulation loss of ligands" unit="mmol-L/m3/s" grid_ref="grid_T_3D" />
- <field id="REMINF" long_name="Oxic remineralization suppy of Fe" unit="mmol-Fe/m3/s" grid_ref="grid_T_3D" />
- <field id="BACT" long_name="Bacterial Biomass" unit="mmol/m3" grid_ref="grid_T_3D" />
- <field id="FEBACT" long_name="Bacterial uptake of Fe" unit="molFe/m3/s" grid_ref="grid_T_3D" />
- <field id="FEPREC" long_name="Precipitation of Fe" unit="molFe/m3/s" grid_ref="grid_T_3D" />
- <field id="LPRODR" long_name="OM remineralisation ligand production rate" unit="nmol-L/m3/s" grid_ref="grid_T_3D" />
- <field id="LPRODP" long_name="phytoplankton ligand production rate" unit="nmol-L/m3/s" grid_ref="grid_T_3D" />
- <field id="LIGREM" long_name="Remineralisation loss of ligands" unit="nmol-L/m3/s" grid_ref="grid_T_3D" />
- <field id="LIGPR" long_name="Photochemical loss of ligands" unit="nmol-L/m3/s" grid_ref="grid_T_3D" />
- <field id="LDETP" long_name="Ligand destruction during phytoplankton uptake" unit="nmol-L/m3/s" grid_ref="grid_T_3D" />
- <field id="LPRODZ2" long_name="mesozooplankton ligand production rate" unit="nmol-L/m3/s" grid_ref="grid_T_3D" />
- <field id="LPRODZ" long_name="microzooplankton ligand production rate" unit="nmol-L/m3/s" grid_ref="grid_T_3D" />
- <field id="FEZOO" long_name="microzooplankton iron recycling rate" unit="nmol-FeL/m3/s" grid_ref="grid_T_3D" />
- <field id="FEZOO2" long_name="mesozooplankton iron recycling rate" unit="nmol-FeL/m3/s" grid_ref="grid_T_3D" />
+ <field_group id="diad_T" grid_ref="grid_T_2D_inner" >
+ <field id="PH" long_name="PH" unit="1" grid_ref="grid_T_3D_inner" />
+ <field id="CO3" long_name="Bicarbonates" unit="mol/m3" grid_ref="grid_T_3D_inner" />
+ <field id="CO3sat" long_name="CO3 saturation" unit="mol/m3" grid_ref="grid_T_3D_inner" />
+ <field id="DCAL" long_name="Calcite dissolution" unit="mol/m3/s" grid_ref="grid_T_3D_inner" />
+ <field id="PAR" long_name="Photosynthetically Available Radiation" unit="W/m2" grid_ref="grid_T_3D_inner" />
+ <field id="PPPHYN" long_name="Primary production of nanophyto" unit="molC/m3/s" grid_ref="grid_T_3D_inner" />
+ <field id="PPPHYP" long_name="Primary production of picophyto" unit="molC/m3/s" grid_ref="grid_T_3D_inner" />
+ <field id="PPPHYD" long_name="Primary production of diatoms" unit="molC/m3/s" grid_ref="grid_T_3D_inner" />
+ <field id="PPNEWN" long_name="New Primary production of nanophyto" unit="molC/m3/s" grid_ref="grid_T_3D_inner" />
+ <field id="PPNEWP" long_name="New Primary production of picophyto" unit="molC/m3/s" grid_ref="grid_T_3D_inner" />
+ <field id="PPNEWD" long_name="New Primary production of diatoms" unit="molC/m3/s" grid_ref="grid_T_3D_inner" />
+ <field id="PBSi" long_name="Primary production of Si diatoms" unit="molC/m3/s" grid_ref="grid_T_3D_inner" />
+ <field id="PFeN" long_name="Primary production of nano iron" unit="molC/m3/s" grid_ref="grid_T_3D_inner" />
+ <field id="PFeP" long_name="Primary production of pico iron" unit="molC/m3/s" grid_ref="grid_T_3D_inner" />
+ <field id="PFeD" long_name="Primary production of diatoms iron" unit="mol/m3/s" grid_ref="grid_T_3D_inner" />
+ <field id="xfracal" long_name="Calcifying fraction" unit="1" grid_ref="grid_T_3D_inner" />
+ <field id="PCAL" long_name="Calcite production" unit="mol/m3/s" grid_ref="grid_T_3D_inner" />
+ <field id="GRAZ1" long_name="Grazing by microzooplankton" unit="mol/m3/s" grid_ref="grid_T_3D_inner" />
+ <field id="GRAZ2" long_name="Grazing by mesozooplankton" unit="mol/m3/s" grid_ref="grid_T_3D_inner" />
+ <field id="REMIN" long_name="Oxic remineralization of OM" unit="mol/m3/s" grid_ref="grid_T_3D_inner" />
+ <field id="DENIT" long_name="Anoxic remineralization of OM" unit="mol/m3/s" grid_ref="grid_T_3D_inner" />
+ <field id="REMINP" long_name="Oxic remineralization rate of POC" unit="d-1" grid_ref="grid_T_3D_inner" />
+ <field id="REMING" long_name="Oxic remineralization rate of GOC" unit="d-1" grid_ref="grid_T_3D_inner" />
+ <field id="Nfix" long_name="Nitrogen fixation" unit="mol/m3/s" grid_ref="grid_T_3D_inner" />
+ <field id="Mumax" long_name="Maximum growth rate" unit="s-1" grid_ref="grid_T_3D_inner" />
+ <field id="MuN" long_name="Realized growth rate for nanophyto" unit="s-1" grid_ref="grid_T_3D_inner" />
+ <field id="MuP" long_name="Realized growth rate for picophyto" unit="s-1" grid_ref="grid_T_3D_inner" />
+ <field id="MuD" long_name="Realized growth rate for diatomes" unit="s-1" grid_ref="grid_T_3D_inner" />
+ <field id="MunetN" long_name="Net growth rate for nanophyto" unit="s-1" grid_ref="grid_T_3D_inner" />
+ <field id="MunetP" long_name="Net growth rate for picophyto" unit="s-1" grid_ref="grid_T_3D_inner" />
+ <field id="MunetD" long_name="Net growth rate for diatomes" unit="s-1" grid_ref="grid_T_3D_inner" />
+ <field id="LNnut" long_name="Nutrient limitation term in Nanophyto" unit="" grid_ref="grid_T_3D_inner" />
+ <field id="LPnut" long_name="Nutrient limitation term in Picophyto" unit="-" grid_ref="grid_T_3D_inner" />
+ <field id="LDnut" long_name="Nutrient limitation term in Diatoms" unit="" grid_ref="grid_T_3D_inner" />
+ <field id="LNFe" long_name="Iron limitation term in Nanophyto" unit="" grid_ref="grid_T_3D_inner" />
+ <field id="LPFe" long_name="Iron limitation term in Picophyto" unit="-" grid_ref="grid_T_3D_inner" />
+ <field id="LDFe" long_name="Iron limitation term in Diatoms" unit="" grid_ref="grid_T_3D_inner" />
+ <field id="LNlight" long_name="Light limitation term in Nanophyto" unit="" grid_ref="grid_T_3D_inner" />
+ <field id="LPlight" long_name="Light limitation term in Picophyto" unit="-" grid_ref="grid_T_3D_inner" />
+ <field id="LDlight" long_name="Light limitation term in Diatoms" unit="" grid_ref="grid_T_3D_inner" />
+ <field id="SIZEN" long_name="Mean relative size of nanophyto." unit="-" grid_ref="grid_T_3D_inner" />
+ <field id="SIZEP" long_name="Mean relative size of picophyto." unit="-" grid_ref="grid_T_3D_inner" />
+ <field id="SIZED" long_name="Mean relative size of diatoms" unit="-" grid_ref="grid_T_3D_inner" />
+ <field id="RASSD" long_name="Size of the protein machinery (Diat.)" unit="-" grid_ref="grid_T_3D_inner" />
+ <field id="RASSN" long_name="Size of the protein machinery (Nano.)" unit="-" grid_ref="grid_T_3D_inner" />
+ <field id="RASSP" long_name="Size of the protein machinery (Pico.)" unit="-" grid_ref="grid_T_3D_inner" />
+ <field id="Fe3" long_name="Iron III concentration" unit="nmol/m3" grid_ref="grid_T_3D_inner" />
+ <field id="FeL1" long_name="Complexed Iron concentration with L1" unit="nmol/m3" grid_ref="grid_T_3D_inner" />
+ <field id="TL1" long_name="Total L1 concentration" unit="nmol/m3" grid_ref="grid_T_3D_inner" />
+ <field id="pdust" long_name="dust concentration" unit="g/m3" />
+ <field id="Totlig" long_name="Total ligand concentation" unit="nmol/m3" grid_ref="grid_T_3D_inner" />
+ <field id="Biron" long_name="Bioavailable iron" unit="nmol/m3" grid_ref="grid_T_3D_inner" />
+ <field id="Sdenit" long_name="Nitrate reduction in the sediments" unit="mol/m2/s" />
+ <field id="Ironice" long_name="Iron input/uptake due to sea ice" unit="mol/m2/s" />
+ <field id="SedCal" long_name="Calcite burial in the sediments" unit="molC/m2/s" />
+ <field id="SedSi" long_name="Silicon burial in the sediments" unit="molSi/m2/s" />
+ <field id="SedC" long_name="Organic C burial in the sediments" unit="molC/m2/s" />
+ <field id="HYDR" long_name="Iron input from hydrothemal vents" unit="mol/m2/s" grid_ref="grid_T_3D_inner" />
+ <field id="EPC100" long_name="Export of carbon particles at 100 m" unit="mol/m2/s" />
+ <field id="EPFE100" long_name="Export of biogenic iron at 100 m" unit="mol/m2/s" />
+ <field id="EPSI100" long_name="Export of Silicate at 100 m" unit="mol/m2/s" />
+ <field id="EPCAL100" long_name="Export of Calcite at 100 m" unit="mol/m2/s" />
+ <field id="EXPC" long_name="Export of carbon" unit="mol/m2/s" grid_ref="grid_T_3D_inner" />
+ <field id="EXPFE" long_name="Export of biogenic iron" unit="mol/m2/s" grid_ref="grid_T_3D_inner" />
+ <field id="EXPSI" long_name="Export of Silicate" unit="mol/m2/s" grid_ref="grid_T_3D_inner" />
+ <field id="EXPCAL" long_name="Export of Calcite" unit="mol/m2/s" grid_ref="grid_T_3D_inner" />
+ <field id="Cflx" long_name="DIC flux" unit="mol/m2/s" />
+ <field id="Oflx" long_name="Oxygen flux" unit="mol/m2/s" />
+ <field id="Kg" long_name="Gas transfer" unit="mol/m2/s/uatm" />
+ <field id="Dpco2" long_name="Delta CO2" unit="uatm" />
+ <field id="pCO2sea" long_name="surface ocean pCO2" unit="uatm" />
+ <field id="Dpo2" long_name="Delta O2" unit="uatm" />
+ <field id="Heup" long_name="Euphotic layer depth" unit="m" grid_ref="grid_T_2D_inner" />
+ <field id="AtmCo2" long_name="Atmospheric CO2 concentration" unit="ppm" />
+ <field id="Irondep" long_name="Iron deposition from dust" unit="mol/m2/s" />
+ <field id="Ironsed" long_name="Iron deposition from sediment" unit="mol/m2/s" grid_ref="grid_T_3D_inner" />
+ <field id="FESCAV" long_name="Scavenging of Iron" unit="mmol-Fe/m3/s" grid_ref="grid_T_3D_inner" />
+ <field id="FECOLL" long_name="Colloidal Pumping of FeL" unit="mmol-FeL/m3/s" grid_ref="grid_T_3D_inner" />
+ <field id="LGWCOLL" long_name="Coagulation loss of ligands" unit="mmol-L/m3/s" grid_ref="grid_T_3D_inner" />
+ <field id="REMINF" long_name="Oxic remineralization suppy of Fe" unit="mmol-Fe/m3/s" grid_ref="grid_T_3D_inner" />
+ <field id="BACT" long_name="Bacterial Biomass" unit="mmol/m3" grid_ref="grid_T_3D_inner" />
+ <field id="FEBACT" long_name="Bacterial uptake of Fe" unit="molFe/m3/s" grid_ref="grid_T_3D_inner" />
+ <field id="FEPREC" long_name="Precipitation of Fe" unit="molFe/m3/s" grid_ref="grid_T_3D_inner" />
+ <field id="LPRODR" long_name="OM remineralisation ligand production rate" unit="nmol-L/m3/s" grid_ref="grid_T_3D_inner" />
+ <field id="LPRODP" long_name="phytoplankton ligand production rate" unit="nmol-L/m3/s" grid_ref="grid_T_3D_inner" />
+ <field id="LIGREM" long_name="Remineralisation loss of ligands" unit="nmol-L/m3/s" grid_ref="grid_T_3D_inner" />
+ <field id="LIGPR" long_name="Photochemical loss of ligands" unit="nmol-L/m3/s" grid_ref="grid_T_3D_inner" />
+ <field id="LDETP" long_name="Ligand destruction during phytoplankton uptake" unit="nmol-L/m3/s" grid_ref="grid_T_3D_inner" />
+ <field id="LPRODZ2" long_name="mesozooplankton ligand production rate" unit="nmol-L/m3/s" grid_ref="grid_T_3D_inner" />
+ <field id="LPRODZ" long_name="microzooplankton ligand production rate" unit="nmol-L/m3/s" grid_ref="grid_T_3D_inner" />
+ <field id="FEZOO" long_name="microzooplankton iron recycling rate" unit="nmol-FeL/m3/s" grid_ref="grid_T_3D_inner" />
+ <field id="FEZOO2" long_name="mesozooplankton iron recycling rate" unit="nmol-FeL/m3/s" grid_ref="grid_T_3D_inner" />
<!-- PISCES tracers trends -->
- <field id="INTdtAlk" long_name="Vertically int. of change of alkalinity" unit="mol/m2/s" />
- <field id="INTdtDIC" long_name="Vertically int. of change of dissic " unit="mol/m2/s" />
- <field id="INTdtFer" long_name="Vertically int. of change of iron " unit="mol/m2/s" />
- <field id="INTdtDIN" long_name="Vertically int. of change of nitrogen " unit="mol/m2/s" />
- <field id="INTdtDIP" long_name="Vertically int. of change of phophate " unit="mol/m2/s" />
- <field id="INTdtSil" long_name="Vertically int. of change of silicon " unit="mol/m2/s" />
+ <field id="INTdtAlk" long_name="Vertically int. of change of alkalinity" unit="mol/m2/s" />
+ <field id="INTdtDIC" long_name="Vertically int. of change of dissic " unit="mol/m2/s" />
+ <field id="INTdtFer" long_name="Vertically int. of change of iron " unit="mol/m2/s" />
+ <field id="INTdtDIN" long_name="Vertically int. of change of nitrogen " unit="mol/m2/s" />
+ <field id="INTdtDIP" long_name="Vertically int. of change of phophate " unit="mol/m2/s" />
+ <field id="INTdtSil" long_name="Vertically int. of change of silicon " unit="mol/m2/s" />
+ <field id="TPP" long_name="Total Primary production of phyto" unit="mol/m3/s" grid_ref="grid_T_3D_inner" />
+ <field id="TPNEW" long_name="New Primary production of phyto" unit="mol/m3/s" grid_ref="grid_T_3D_inner" />
+ <field id="TPBFE" long_name="Total biogenic iron production" unit="mol/m3/s" grid_ref="grid_T_3D_inner" />
+ <field id="INTDIC" long_name="DIC content" unit="kg/m2" />
+ <field id="O2MIN" long_name="Oxygen minimum concentration" unit="mol/m3" />
+ <field id="ZO2MIN" long_name="Depth of oxygen minimum concentration" unit="m" />
- <!-- dbio_T on T grid : variables available with diaar5 -->
- <field id="TPP" long_name="Total Primary production of phyto" unit="mol/m3/s" grid_ref="grid_T_3D" />
- <field id="TPNEW" long_name="New Primary production of phyto" unit="mol/m3/s" grid_ref="grid_T_3D" />
- <field id="TPBFE" long_name="Total biogenic iron production" unit="mol/m3/s" grid_ref="grid_T_3D" />
- <field id="INTDIC" long_name="DIC content" unit="kg/m2" />
- <field id="O2MIN" long_name="Oxygen minimum concentration" unit="mol/m3" />
- <field id="ZO2MIN" long_name="Depth of oxygen minimum concentration" unit="m" />
+ <field id="Nfix_e3t" long_name="Nfix * e3t" unit="molN/m2/s" grid_ref="grid_T_3D_inner" > Nfix * e3t </field >
+ <field id="PPPHYN_e3t" long_name="PPPHYN * e3t" unit="mol/m2/s" grid_ref="grid_T_3D_inner" > PPPHYN * e3t </field >
+ <field id="PPPHYD_e3t" long_name="PPPHYD * e3t" unit="mol/m2/s" grid_ref="grid_T_3D_inner" > PPPHYD * e3t </field >
+ <field id="PPPHYP_e3t" long_name="PPPHYP * e3t" unit="mol/m2/s" grid_ref="grid_T_3D_inner" > PPPHYP * e3t </field >
+ <field id="PBSi_e3t" long_name="PBSi * e3t" unit="mol/m2/s" grid_ref="grid_T_3D_inner" > PBSi * e3t </field >
+ <field id="TPP_e3t" long_name="TPP * e3t" unit="mol/m2/s" grid_ref="grid_T_3D_inner" > TPP * e3t </field >
+ <field id="TPNEW_e3t" long_name="TPNEW * e3t" unit="mol/m2/s" grid_ref="grid_T_3D_inner" > TPNEW * e3t </field >
+ <field id="TPBFE_e3t" long_name="TPBFE * e3t" unit="mol/m2/s" grid_ref="grid_T_3D_inner" > TPBFE * e3t </field >
-
- <field id="Nfix_e3t" long_name="Nfix * e3t" unit="molN/m2/s" grid_ref="grid_T_3D" > Nfix * e3t </field >
- <field id="PPPHYN_e3t" long_name="PPPHYN * e3t" unit="mol/m2/s" grid_ref="grid_T_3D" > PPPHYN * e3t </field >
- <field id="PPPHYD_e3t" long_name="PPPHYD * e3t" unit="mol/m2/s" grid_ref="grid_T_3D" > PPPHYD * e3t </field >
- <field id="PPPHYP_e3t" long_name="PPPHYP * e3t" unit="mol/m2/s" grid_ref="grid_T_3D" > PPPHYP * e3t </field >
- <field id="PBSi_e3t" long_name="PBSi * e3t" unit="mol/m2/s" grid_ref="grid_T_3D" > PBSi * e3t </field >
- <field id="TPP_e3t" long_name="TPP * e3t" unit="mol/m2/s" grid_ref="grid_T_3D" > TPP * e3t </field >
- <field id="TPNEW_e3t" long_name="TPNEW * e3t" unit="mol/m2/s" grid_ref="grid_T_3D" > TPNEW * e3t </field >
- <field id="TPBFE_e3t" long_name="TPBFE * e3t" unit="mol/m2/s" grid_ref="grid_T_3D" > TPBFE * e3t </field >
-
- <field id="INTNFIX" long_name="Nitrogen fixation rate : vert. integrated" field_ref="Nfix_e3t" unit="mol/m2/s" grid_ref="grid_T_vsum" detect_missing_value="true" />
- <field id="INTPPPHYN" long_name="Vertically integrated primary production by nanophy" field_ref="PPPHYN_e3t" unit="mol/m2/s" grid_ref="grid_T_vsum" detect_missing_value="true" />
- <field id="INTPPPHYD" long_name="Vertically integrated primary production by diatom" field_ref="PPPHYD_e3t" unit="mol/m2/s" grid_ref="grid_T_vsum" detect_missing_value="true" />
- <field id="INTPPPHYP" long_name="Vertically integrated primary production by picophy" field_ref="PPPHYP_e3t" unit="mol/m2/s" grid_ref="grid_T_vsum" detect_missing_value="true" />
- <field id="INTPP" long_name="Vertically integrated primary production by phyto" field_ref="TPP_e3t" unit="mol/m2/s" grid_ref="grid_T_vsum" detect_missing_value="true" />
- <field id="INTPNEW" long_name="Vertically integrated new primary production" field_ref="TPNEW_e3t" unit="mol/m2/s" grid_ref="grid_T_vsum" detect_missing_value="true" />
- <field id="INTPBFE" long_name="Vertically integrated of biogenic iron production" field_ref="TPBFE_e3t" unit="mol/m2/s" grid_ref="grid_T_vsum" detect_missing_value="true" />
- <field id="INTPBSI" long_name="Vertically integrated of biogenic Si production" field_ref="PBSi_e3t" unit="mol/m2/s" grid_ref="grid_T_vsum" detect_missing_value="true" />
+ <field id="INTNFIX" long_name="Nitrogen fixation rate : vert. integrated" field_ref="Nfix_e3t" unit="mol/m2/s" grid_ref="grid_T_vsum" detect_missing_value="true" />
+ <field id="INTPPPHYN" long_name="Vertically integrated primary production by nanophy" field_ref="PPPHYN_e3t" unit="mol/m2/s" grid_ref="grid_T_vsum" detect_missing_value="true" />
+ <field id="INTPPPHYD" long_name="Vertically integrated primary production by diatom" field_ref="PPPHYD_e3t" unit="mol/m2/s" grid_ref="grid_T_vsum" detect_missing_value="true" />
+ <field id="INTPPPHYP" long_name="Vertically integrated primary production by picophy" field_ref="PPPHYP_e3t" unit="mol/m2/s" grid_ref="grid_T_vsum" detect_missing_value="true" />
+ <field id="INTPP" long_name="Vertically integrated primary production by phyto" field_ref="TPP_e3t" unit="mol/m2/s" grid_ref="grid_T_vsum" detect_missing_value="true" />
+ <field id="INTPNEW" long_name="Vertically integrated new primary production" field_ref="TPNEW_e3t" unit="mol/m2/s" grid_ref="grid_T_vsum" detect_missing_value="true" />
+ <field id="INTPBFE" long_name="Vertically integrated of biogenic iron production" field_ref="TPBFE_e3t" unit="mol/m2/s" grid_ref="grid_T_vsum" detect_missing_value="true" />
+ <field id="INTPBSI" long_name="Vertically integrated of biogenic Si production" field_ref="PBSi_e3t" unit="mol/m2/s" grid_ref="grid_T_vsum" detect_missing_value="true" />
<!-- PISCES light : variables available with key_pisces_reduced -->
- <field id="FNO3PHY" long_name="FNO3PHY" unit="" grid_ref="grid_T_3D" />
- <field id="FNH4PHY" long_name="FNH4PHY" unit="" grid_ref="grid_T_3D" />
- <field id="FNH4NO3" long_name="FNH4NO3" unit="" grid_ref="grid_T_3D" />
+ <field id="FNO3PHY" long_name="FNO3PHY" unit="" grid_ref="grid_T_3D_inner" />
+ <field id="FNH4PHY" long_name="FNH4PHY" unit="" grid_ref="grid_T_3D_inner" />
+ <field id="FNH4NO3" long_name="FNH4NO3" unit="" grid_ref="grid_T_3D_inner" />
<field id="TNO3PHY" long_name="TNO3PHY" unit="" />
<field id="TNH4PHY" long_name="TNH4PHY" unit="" />
<field id="TPHYDOM" long_name="TPHYDOM" unit="" />
diff --git a/cfgs/SHARED/grid_def_nemo.xml b/cfgs/SHARED/grid_def_nemo.xml
index d66b314f3725db6760d6959092b332822086aeb9..eb0aab010e849c268be2121a104e42c29673a4f1 100644
--- a/cfgs/SHARED/grid_def_nemo.xml
+++ b/cfgs/SHARED/grid_def_nemo.xml
@@ -184,6 +184,12 @@
<extract_axis position="0" />
</scalar>
</grid>
+ <grid id="grid_T_SFC_inner">
+ <domain domain_ref="grid_T_inner" name="grid_T" />
+ <scalar>
+ <extract_axis position="0" />
+ </scalar>
+ </grid>
<grid id="grid_T_vsum">
<domain domain_ref="grid_T"/>
@@ -191,6 +197,12 @@
<reduce_axis operation="sum" />
</scalar>
</grid>
+ <grid id="grid_T_vsum_inner">
+ <domain domain_ref="grid_T_inner" name="grid_T"/>
+ <scalar>
+ <reduce_axis operation="sum" />
+ </scalar>
+ </grid>
<grid id="grid_U_vsum">
<domain domain_ref="grid_U"/>
@@ -232,6 +244,10 @@
<domain domain_ref="grid_T" />
<axis axis_ref="deptht300" />
</grid>
+ <grid id="grid_T_zoom_300_inner">
+ <domain domain_ref="grid_T_inner" name="grid_T" />
+ <axis axis_ref="deptht300" />
+ </grid>
<grid id="grid_U_scalar" >
<domain domain_ref="grid_U" />
@@ -318,14 +334,14 @@
<!-- ABL grid definition -->
<grid id="grid_TA_2D">
- <domain domain_ref="grid_T" />
+ <domain domain_ref="grid_T_inner" name="grid_T" />
</grid>
<grid id="grid_TA_3D">
- <domain domain_ref="grid_T" />
+ <domain domain_ref="grid_T_inner" name="grid_T" />
<axis id="ght_abl" />
</grid>
<grid id="grid_WA_3D">
- <domain domain_ref="grid_T" />
+ <domain domain_ref="grid_T_inner" name="grid_T" />
<axis id="ghw_abl" />
</grid>
<!-- -->
@@ -336,41 +352,44 @@
<scalar />
</grid>
<grid id="diamlr_grid_T_2D" >
- <domain domain_ref="grid_T" />
+ <domain domain_ref="grid_T_inner" name="grid_T" />
<scalar />
</grid>
+ <grid id="diamlr_grid_T_2D_inner" >
+ <domain domain_ref="grid_T_inner" name="grid_T" />
+ </grid>
<grid id="diamlr_grid_U_2D" >
- <domain domain_ref="grid_U" />
+ <domain domain_ref="grid_U_inner" name="grid_U" />
<scalar />
</grid>
<grid id="diamlr_grid_V_2D" >
- <domain domain_ref="grid_V" />
+ <domain domain_ref="grid_V_inner" name="grid_V" />
<scalar />
</grid>
<grid id="diamlr_grid_W_2D" >
- <domain domain_ref="grid_W" />
+ <domain domain_ref="grid_W_inner" name="grid_W" />
<scalar />
</grid>
<grid id="diamlr_grid_2D_to_grid_T_3D" >
- <domain domain_ref="grid_T" />
+ <domain domain_ref="grid_T_inner" name="grid_T" />
<axis axis_ref="deptht">
<duplicate_scalar />
</axis>
</grid>
<grid id="diamlr_grid_2D_to_grid_U_3D" >
- <domain domain_ref="grid_U" />
+ <domain domain_ref="grid_U_inner" name="grid_U" />
<axis axis_ref="depthu">
<duplicate_scalar />
</axis>
</grid>
<grid id="diamlr_grid_2D_to_grid_V_3D" >
- <domain domain_ref="grid_V" />
+ <domain domain_ref="grid_V_inner" name="grid_V" />
<axis axis_ref="depthv">
<duplicate_scalar />
</axis>
</grid>
<grid id="diamlr_grid_2D_to_grid_W_3D" >
- <domain domain_ref="grid_W" />
+ <domain domain_ref="grid_W_inner" name="grid_W" />
<axis axis_ref="depthw">
<duplicate_scalar />
</axis>
@@ -383,37 +402,37 @@
</grid>
<!-- grid definitions for the computation of daily detided model diagnostics (diadetide) -->
<grid id="diadetide_grid_T_2D" >
- <domain domain_ref="grid_T" />
+ <domain domain_ref="grid_T_inner" name="grid_T" />
<scalar />
</grid>
<grid id="diadetide_grid_U_2D" >
- <domain domain_ref="grid_U" />
+ <domain domain_ref="grid_U_inner" name="grid_U" />
<scalar />
</grid>
<grid id="diadetide_grid_V_2D" >
- <domain domain_ref="grid_V" />
+ <domain domain_ref="grid_V_inner" name="grid_V" />
<scalar />
</grid>
<grid id="diadetide_grid_2D_to_grid_T_3D" >
- <domain domain_ref="grid_T" />
+ <domain domain_ref="grid_T_inner" name="grid_T" />
<axis axis_ref="deptht">
<duplicate_scalar />
</axis>
</grid>
<grid id="diadetide_grid_2D_to_grid_U_3D" >
- <domain domain_ref="grid_U" />
+ <domain domain_ref="grid_U_inner" name="grid_U" />
<axis axis_ref="depthu">
<duplicate_scalar />
</axis>
</grid>
<grid id="diadetide_grid_2D_to_grid_V_3D" >
- <domain domain_ref="grid_V" />
+ <domain domain_ref="grid_V_inner" name="grid_V" />
<axis axis_ref="depthv">
<duplicate_scalar />
</axis>
</grid>
<grid id="diadetide_grid_2D_to_grid_W_3D" >
- <domain domain_ref="grid_W" />
+ <domain domain_ref="grid_W_inner" name="grid_W" />
<axis axis_ref="depthw">
<duplicate_scalar />
</axis>
diff --git a/cfgs/SHARED/namelist_ref b/cfgs/SHARED/namelist_ref
index 72affc4a899d521b5ddca5da6cdb6475cafa0901..4e241a48d84606275f48bd7ceb0498de99ca9d67 100644
--- a/cfgs/SHARED/namelist_ref
+++ b/cfgs/SHARED/namelist_ref
@@ -312,7 +312,7 @@
&namsbc_abl ! Atmospheric Boundary Layer formulation (ln_abl = T)
!-----------------------------------------------------------------------
cn_dir = './' ! root directory for the location of the ABL grid file
- cn_dom = 'dom_cfg_abl.nc'
+ cn_dom = 'dom_cfg_abl'
cn_ablrst_in = "restart_abl" ! suffix of abl restart name (input)
cn_ablrst_out = "restart_abl" ! suffix of abl restart name (output)
@@ -326,11 +326,11 @@
nn_dyn_restore = 0 ! restoring option for dynamical ABL variables: = 0 no restoring
! = 1 equatorial restoring
! = 2 global restoring
- rn_vfac = 0.
- rn_ldyn_min = 4.5 ! dynamics nudging magnitude inside the ABL [hour] (~3 rn_Dt)
- rn_ldyn_max = 1.5 ! dynamics nudging magnitude above the ABL [hour] (~1 rn_Dt)
- rn_ltra_min = 4.5 ! tracers nudging magnitude inside the ABL [hour] (~3 rn_Dt)
- rn_ltra_max = 1.5 ! tracers nudging magnitude above the ABL [hour] (~1 rn_Dt)
+ rn_ldyn_min = 0. ! dynamics nudging magnitude inside the ABL [hour] (~3 rn_Dt)
+ rn_ldyn_max = 0. ! dynamics nudging magnitude above the ABL [hour] (~1 rn_Dt)
+ rn_ltra_min = 0. ! tracers nudging magnitude inside the ABL [hour] (~3 rn_Dt)
+ rn_ltra_max = 0. ! tracers nudging magnitude above the ABL [hour] (~1 rn_Dt)
+ rn_vfac = 0.
nn_amxl = 0 ! mixing length: = 0 Deardorff 80 length-scale
! = 1 length-scale based on the distance to the PBL height
! = 2 Bougeault & Lacarrere 89 length-scale
@@ -370,7 +370,7 @@
!*** receive ***
sn_rcv_w10m = 'none' , 'no' , '' , '' , ''
sn_rcv_taumod = 'coupled' , 'no' , '' , '' , ''
- sn_rcv_tau = 'oce only' , 'no' , 'cartesian' , 'eastward-northward' , 'U,V'
+ sn_rcv_tau = 'oce only' , 'no' , 'cartesian' , 'eastward-northward' , ''
sn_rcv_dqnsdt = 'coupled' , 'no' , '' , '' , ''
sn_rcv_qsr = 'oce and ice' , 'no' , '' , '' , ''
sn_rcv_qns = 'oce and ice' , 'no' , '' , '' , ''
@@ -381,21 +381,22 @@
sn_rcv_iceflx = 'none' , 'no' , '' , '' , ''
sn_rcv_mslp = 'none' , 'no' , '' , '' , ''
sn_rcv_ts_ice = 'none' , 'no' , '' , '' , ''
+ sn_rcv_qtrice = 'none' , 'no' , '' , '' , ''
sn_rcv_isf = 'none' , 'no' , '' , '' , ''
sn_rcv_icb = 'none' , 'no' , '' , '' , ''
- sn_rcv_hsig = 'none' , 'no' , '' , '' , 'T'
- sn_rcv_phioc = 'none' , 'no' , '' , '' , 'T'
- sn_rcv_sdrfx = 'none' , 'no' , '' , '' , 'T'
- sn_rcv_sdrfy = 'none' , 'no' , '' , '' , 'T'
- sn_rcv_wper = 'none' , 'no' , '' , '' , 'T'
- sn_rcv_wnum = 'none' , 'no' , '' , '' , 'T'
- sn_rcv_wstrf = 'none' , 'no' , '' , '' , 'T'
- sn_rcv_wdrag = 'none' , 'no' , '' , '' , 'T'
- sn_rcv_charn = 'none' , 'no' , '' , '' , 'T'
- sn_rcv_taw = 'none' , 'no' , '' , '' , 'U,V'
- sn_rcv_bhd = 'none' , 'no' , '' , '' , 'T'
- sn_rcv_tusd = 'none' , 'no' , '' , '' , 'T'
- sn_rcv_tvsd = 'none' , 'no' , '' , '' , 'T'
+ sn_rcv_hsig = 'none' , 'no' , '' , '' , ''
+ sn_rcv_phioc = 'none' , 'no' , '' , '' , ''
+ sn_rcv_sdrfx = 'none' , 'no' , '' , '' , ''
+ sn_rcv_sdrfy = 'none' , 'no' , '' , '' , ''
+ sn_rcv_wper = 'none' , 'no' , '' , '' , ''
+ sn_rcv_wnum = 'none' , 'no' , '' , '' , ''
+ sn_rcv_wstrf = 'none' , 'no' , '' , '' , ''
+ sn_rcv_wdrag = 'none' , 'no' , '' , '' , ''
+ sn_rcv_charn = 'none' , 'no' , '' , '' , ''
+ sn_rcv_taw = 'none' , 'no' , '' , '' , ''
+ sn_rcv_bhd = 'none' , 'no' , '' , '' , ''
+ sn_rcv_tusd = 'none' , 'no' , '' , '' , ''
+ sn_rcv_tvsd = 'none' , 'no' , '' , '' , ''
/
!-----------------------------------------------------------------------
&namsbc_sas ! Stand-Alone Surface module: ocean data (SAS_SRC only)
@@ -440,7 +441,7 @@
! ! RGB & 2BD choices:
rn_abs = 0.58 ! RGB & 2BD: fraction absorbed in the very near surface
rn_si0 = 0.35 ! RGB & 2BD: shortess depth of extinction
- nn_chldta = 0 ! RGB : Chl data (=1) or cst value (=0)
+ nn_chldta = 0 ! RGB : 3D Chl data (=2), Surface Chl data (=1) or Cst value (=0)
rn_si1 = 23.0 ! 2BD : longest depth of extinction
cn_dir = './' ! root directory for the chlorophyl data location
@@ -888,6 +889,9 @@
!
! ! S-EOS coefficients (ln_seos=T):
! ! rd(T,S,Z)*rho0 = -a0*(1+.5*lambda*dT+mu*Z+nu*dS)*dT+b0*dS
+ ! ! dT = T-rn_T0 ; dS = S-rn_S0
+ rn_T0 = 10. ! reference temperature
+ rn_S0 = 35. ! reference salinity
rn_a0 = 1.6550e-1 ! thermal expension coefficient
rn_b0 = 7.6554e-1 ! saline expension coefficient
rn_lambda1 = 5.9520e-2 ! cabbeling coeff in T^2 (=0 for linear eos)
@@ -1118,7 +1122,7 @@
sn_sal = 'dyna_grid_T' , 120. , 'vosaline' , .true. , .true. , 'yearly' , '' , '' , ''
sn_mld = 'dyna_grid_T' , 120. , 'somixhgt' , .true. , .true. , 'yearly' , '' , '' , ''
sn_emp = 'dyna_grid_T' , 120. , 'sowaflup' , .true. , .true. , 'yearly' , '' , '' , ''
- sn_fmf = 'dyna_grid_T' , 120. , 'iowaflup' , .true. , .true. , 'yearly' , '' , '' , ''
+ sn_fwf = 'dyna_grid_T' , 120. , 'iowaflup' , .true. , .true. , 'yearly' , '' , '' , ''
sn_ice = 'dyna_grid_T' , 120. , 'soicecov' , .true. , .true. , 'yearly' , '' , '' , ''
sn_qsr = 'dyna_grid_T' , 120. , 'soshfldo' , .true. , .true. , 'yearly' , '' , '' , ''
sn_wnd = 'dyna_grid_T' , 120. , 'sowindsp' , .true. , .true. , 'yearly' , '' , '' , ''
@@ -1519,7 +1523,7 @@
ln_nnogather = .true. ! activate code to avoid mpi_allgather use at the northfold
jpni = 0 ! number of processors following i (set automatically if < 1), see also ln_listonly = T
jpnj = 0 ! number of processors following j (set automatically if < 1), see also ln_listonly = T
- nn_hls = 1 ! halo width (applies to both rows and columns)
+ nn_hls = 2 ! halo width (applies to both rows and columns)
nn_comm = 1 ! comm choice
/
!-----------------------------------------------------------------------
diff --git a/cfgs/SPITZ12/EXPREF/file_def_nemo-oce.xml b/cfgs/SPITZ12/EXPREF/file_def_nemo-oce.xml
index aa6deff58516c5d377db0c0f9193c1ad4260bb4f..ee0982291a1ef1a38d24837c6a912f81346fdf84 100644
--- a/cfgs/SPITZ12/EXPREF/file_def_nemo-oce.xml
+++ b/cfgs/SPITZ12/EXPREF/file_def_nemo-oce.xml
@@ -34,6 +34,8 @@
<field field_ref="qt_oce" name="qt_oce" />
<field field_ref="saltflx" name="sfx" />
<field field_ref="taum" name="taum" />
+ <field field_ref="utau" name="tauuo" />
+ <field field_ref="vtau" name="tauvo" />
<field field_ref="wspd" name="windsp" />
<field field_ref="precip" name="precip" />
<!-- ice and snow -->
@@ -44,7 +46,6 @@
<field field_ref="e3u" />
<field field_ref="ssu" name="uos" />
<field field_ref="uoce" name="uo" operation="instant" freq_op="5d" > @uoce_e3u / @e3u </field>
- <field field_ref="utau" name="tauuo" />
<field field_ref="uocetr_eff" name="uocetr_eff" />
<!-- available with diaar5 -->
<field field_ref="u_masstr" name="vozomatr" />
@@ -56,7 +57,6 @@
<field field_ref="e3v" />
<field field_ref="ssv" name="vos" />
<field field_ref="voce" name="vo" operation="instant" freq_op="5d" > @voce_e3v / @e3v </field>
- <field field_ref="vtau" name="tauvo" />
<field field_ref="vocetr_eff" name="vocetr_eff" />
<!-- available with diaar5 -->
<field field_ref="v_masstr" name="vomematr" />
diff --git a/cfgs/WED025/EXPREF/file_def_nemo-oce.xml b/cfgs/WED025/EXPREF/file_def_nemo-oce.xml
index 8d9d89e5fb2ddc8a404054b9b15ac9bf4c19cd3e..d08f13e1f8bae0dfaf39b75951205adbd5c0c194 100644
--- a/cfgs/WED025/EXPREF/file_def_nemo-oce.xml
+++ b/cfgs/WED025/EXPREF/file_def_nemo-oce.xml
@@ -31,6 +31,8 @@
<field field_ref="qt_oce" name="qt_oce" />
<field field_ref="saltflx" name="sfx" />
<field field_ref="taum" name="taum" />
+ <field field_ref="utau" name="tauuo" />
+ <field field_ref="vtau" name="tauvo" />
<field field_ref="wspd" name="windsp" />
<field field_ref="precip" name="precip" />
<field field_ref="snowpre" />
@@ -67,14 +69,12 @@
<field field_ref="e3u" />
<field field_ref="ssu" name="uos" />
<field field_ref="uoce" name="uo" operation="instant" freq_op="5d" > @uoce_e3u / @e3u </field>
- <field field_ref="utau" name="tauuo" />
</file>
<file id="file13" name_suffix="_grid_V" description="ocean V grid variables" >
<field field_ref="e3v" />
<field field_ref="ssv" name="vos" />
<field field_ref="voce" name="vo" operation="instant" freq_op="5d" > @voce_e3v / @e3v </field>
- <field field_ref="vtau" name="tauvo" />
</file>
<file id="file14" name_suffix="_grid_W" description="ocean W grid variables" >
diff --git a/cfgs/WED025/cpp_WED025.fcm b/cfgs/WED025/cpp_WED025.fcm
index 43fb50e446e2b9113075b1e817ef4dcbd948851a..d3199f1470c84a7bc4e7177c4b55639e18a01155 100644
--- a/cfgs/WED025/cpp_WED025.fcm
+++ b/cfgs/WED025/cpp_WED025.fcm
@@ -1 +1 @@
- bld::tool::fppkeys key_xios key_si3 key_qco key_isf
+ bld::tool::fppkeys key_xios key_si3 key_qco key_vco_1d3d key_isf
diff --git a/mk/Flist_cfgs.sh b/mk/Flist_cfgs.sh
index 8a19b67d80a34c40685971370b92c0251a5a5c67..34c8b36c7e4a6632f2c9cd3f4d13efe40809810e 100755
--- a/mk/Flist_cfgs.sh
+++ b/mk/Flist_cfgs.sh
@@ -8,9 +8,6 @@ echo -e "\n ¤ Demonstrations cases (see https://github.com/sflavoni/NEMO-test-
cat ${MAIN_DIR}/tests/demo_cfgs.txt \
| awk '{printf "%-20s", $1}{$1 = ""; printf "%s\n", $0}'
-echo -e "\n ¤ Full scripted remote configurations (CPP file + EXP00 inputs + MY_SRC + ...)"
-cat ${MAIN_DIR}/tests/rmt_cfgs.txt
-
echo -e "\n ¤ Available sub-components ('OCE' is mandatory in any set)"
ls ${MAIN_DIR}/src | awk -F/ '{ print $NF }' | column
diff --git a/sette/BATCH_TEMPLATE/batch-X64_AA_INTEL_OMPI b/sette/BATCH_TEMPLATE/batch-X64_AA_INTEL_OMPI
index bdd075c6c25cfc14359dcc9eced3b355eed74968..3eca6d7c613a4911733c6577b9a0bc0a05442565 100644
--- a/sette/BATCH_TEMPLATE/batch-X64_AA_INTEL_OMPI
+++ b/sette/BATCH_TEMPLATE/batch-X64_AA_INTEL_OMPI
@@ -98,7 +98,7 @@ EOF
#
# Run SPMD case
#
- time ./nemo
+ $MPIRUN --ntasks=TOTAL_NPROCS ./nemo
fi
#
diff --git a/sette/BATCH_TEMPLATE/batch-X64_IRENE_GCC b/sette/BATCH_TEMPLATE/batch-X64_IRENE_GCC
index bc2856cf02574ee6fbc2dba5d66b60011d6cfe18..e825954108b5f171b3c80c9d3570a72f2d32a62f 100644
--- a/sette/BATCH_TEMPLATE/batch-X64_IRENE_GCC
+++ b/sette/BATCH_TEMPLATE/batch-X64_IRENE_GCC
@@ -1,5 +1,5 @@
#!/bin/bash
-#MSUB -T 2000 # elapsed time limit in seconds (60 minutes)
+#MSUB -T 3600 # elapsed time limit in seconds (60 minutes)
#MSUB -r SETTE_JOB # Job name
#MSUB -o sette.jobid_%I.txt # standard output
#MSUB -e sette.jobid_%I.txt # standard error
@@ -21,9 +21,9 @@
module purge
module load gnu/8.3.0
module load flavor/buildcompiler/gcc/8
- module load flavor/buildmpi/openmpi/2.0
+ module load flavor/buildmpi/openmpi/4.0
module load flavor/hdf5/parallel
- module load mpi/openmpi/2.0.4
+ module load mpi/openmpi/4.0.5.3
module load hdf5/1.8.20
module load netcdf-c/4.6.0
module load netcdf-fortran/4.4.4
diff --git a/sette/BATCH_TEMPLATE/batch-X64_JEANZAY b/sette/BATCH_TEMPLATE/batch-X64_JEANZAY
index e7af8cea409ad356de3c20c0fc777b3fcb767e2d..cafaff218d723068ced9983a689be4ccef41bd4e 100644
--- a/sette/BATCH_TEMPLATE/batch-X64_JEANZAY
+++ b/sette/BATCH_TEMPLATE/batch-X64_JEANZAY
@@ -2,6 +2,7 @@
#SBATCH -A GROUP_IDRIS@cpu
#SBATCH --job-name=SETTE_JOB # nom du job
#SBATCH --partition=cpu_p1 # Nom de la partition d'exécution
+#SBATCH --qos=qos_cpu-dev # quality of service
#SBATCH --ntasks=NPROCS # Nombre total de processus MPI
#SBATCH --ntasks-per-node=40 # Nombre de processus MPI par noeud
# /!\ Attention, la ligne suivante est trompeuse mais dans le vocabulaire
diff --git a/sette/BATCH_TEMPLATE/batch-X64_JEANZAY_GCC b/sette/BATCH_TEMPLATE/batch-X64_JEANZAY_GCC
new file mode 100644
index 0000000000000000000000000000000000000000..68a5a3343614e8f1ad312ca0c4ab8809735fbc2a
--- /dev/null
+++ b/sette/BATCH_TEMPLATE/batch-X64_JEANZAY_GCC
@@ -0,0 +1,93 @@
+#!/bin/bash
+#SBATCH -A GROUP_IDRIS@cpu
+#SBATCH --job-name=SETTE_JOB # nom du job
+#SBATCH --partition=cpu_p1 # Nom de la partition d'exécution
+#SBATCH --qos=qos_cpu-dev # quality of service
+#SBATCH --ntasks=NPROCS # Nombre total de processus MPI
+#SBATCH --ntasks-per-node=40 # Nombre de processus MPI par noeud
+# /!\ Attention, la ligne suivante est trompeuse mais dans le vocabulaire
+# de Slurm "multithread" fait bien référence à l'hyperthreading.
+#SBATCH --hint=nomultithread # 1 processus MPI par coeur physique (pas d'hyperthreading)
+#SBATCH --time=00:59:00 # Temps d’exécution maximum demande (HH:MM:SS)
+#SBATCH --output=sette.jobid_%j.out # Nom du fichier de sortie
+#SBATCH --error=sette.jobid_%j.out # Nom du fichier d'erreur (ici commun avec la sortie)
+##########################################################################
+#
+# Test specific settings. Do not hand edit these lines; the fcm_job.sh script will set these
+# (via sed operating on this template job file).
+#
+
+module purge
+module load gcc/8.3.1
+module load openmpi/4.1.1
+module load hdf5/1.12.0-mpi
+module load netcdf-c/4.7.4-mpi
+module load netcdf-fortran/4.5.3-mpi
+module load subversion/1.9.7
+module load git/2.31.1
+
+export SETTE_COMPILER=X64_JEANZAY_GCC
+
+#
+ OCEANCORES=NPROCS
+ export SETTE_DIR=DEF_SETTE_DIR
+#
+# set up mpp computing environment
+#
+# Local settings for machine BULL (TITANE at CCRT France)
+#
+export MPIRUN="srun "
+
+#
+# load sette functions (only post_test_tidyup needed)
+#
+ . ${SETTE_DIR}/all_functions.sh
+#
+
+# modules to load
+
+# Don't remove neither change the following line
+# BODY
+
+#
+# These variables are needed by post_test_tidyup function in all_functions.sh
+#
+ export EXE_DIR=DEF_EXE_DIR
+ export INPUT_DIR=DEF_INPUT_DIR
+ export CONFIG_DIR=DEF_CONFIG_DIR
+ export TOOLS_DIR=DEF_TOOLS_DIR
+ export NEMO_VALIDATION_DIR=DEF_NEMO_VALIDATION
+ export NEW_CONF=DEF_NEW_CONF
+ export CMP_NAM=DEF_CMP_NAM
+ export TEST_NAME=DEF_TEST_NAME
+#
+# end of set up
+###############################################################
+#
+# change to the working directory
+#
+cd ${EXE_DIR}
+
+ echo Running on host `hostname`
+ echo Time is `date`
+ echo Directory is `pwd`
+#
+# Run the parallel MPI executable
+#
+ echo "Running time ${MPIRUN} ./nemo"
+#
+ if [ MPI_FLAG == "yes" ]; then
+ time ${MPIRUN} ./nemo
+ else
+ time ./nemo
+ fi
+
+#
+ post_test_tidyup
+
+# END_BODY
+# Don't remove neither change the previous line
+
+
+ exit
+
diff --git a/sette/sette.sh b/sette/sette.sh
index 9de659ab280883b36e0e18a82b4b9ab448e1f3fc..9aa98eb87d78f5e03e82491b5468275367db0c3a 100755
--- a/sette/sette.sh
+++ b/sette/sette.sh
@@ -40,10 +40,10 @@ export USER_INPUT='yes' # Default: yes => request user input on decisions
#
# Check that git branch is usable
export DETACHED_HEAD="no"
-git branch --show-current >& /dev/null
+git -C ${MAIN_DIR} branch --show-current >& /dev/null
if [[ $? == 0 ]] ; then
# subdirectory below NEMO_VALIDATION_DIR defaults to branchname
- export SETTE_SUB_VAL="$(git branch --show-current)"
+ export SETTE_SUB_VAL="$(git -C ${MAIN_DIR} branch --show-current)"
if [ -z $SETTE_SUB_VAL ] ; then
# Probabably on a detached HEAD (possibly testing an old commit).
# Verify this and try to recover original commit
@@ -76,6 +76,7 @@ if [ $# -gt 0 ]; then
y) dry_run=1
echo "";;
b) NEMO_DEBUG="-b"
+ echo "-b: Nemo will be compiled with DEBUG options"
echo "";;
r) NO_REPORT=1
echo "";;
diff --git a/sette/sette_reference-configurations.sh b/sette/sette_reference-configurations.sh
index 6fdae2599d80ce43d182603fc5aee1a9b3054637..88536464e363e0f9437e07d3b5f1c522a01fc34e 100755
--- a/sette/sette_reference-configurations.sh
+++ b/sette/sette_reference-configurations.sh
@@ -1608,7 +1608,7 @@ fi
if [ ${config} == "WED025" ] && [ ${DO_REPRO} == "1" ] ; then
## Reproducibility tests
- export TEST_NAME="REPRO_5_6"
+ export TEST_NAME="REPRO_6_7"
cd ${MAIN_DIR}
cd ${SETTE_DIR}
. ./prepare_exe_dir.sh
@@ -1618,7 +1618,7 @@ if [ ${config} == "WED025" ] && [ ${DO_REPRO} == "1" ] ; then
NPROC=32
if [ -f ${JOB_FILE} ] ; then \rm ${JOB_FILE} ; fi
cd ${EXE_DIR}
- set_namelist namelist_cfg cn_exp \"WED025_56\"
+ set_namelist namelist_cfg cn_exp \"WED025_67\"
set_namelist namelist_cfg nn_it000 1
set_namelist namelist_cfg nn_itend ${ITEND}
set_namelist namelist_cfg nn_date0 20000115
diff --git a/src/ABL/abl.F90 b/src/ABL/abl.F90
index ccffa088d6e3caddc643458ab076c440454fccf5..c89f0c1b6e4875be1d00fc64bd0dbcf99acbbe98 100644
--- a/src/ABL/abl.F90
+++ b/src/ABL/abl.F90
@@ -41,6 +41,8 @@ MODULE abl
!
INTEGER , PUBLIC :: nt_n, nt_a !: now / after indices (equal 1 or 2)
!
+ !! * Substitutions
+# include "do_loop_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OPA 4.0 , NEMO Consortium (2011)
!! $Id: abl.F90 4990 2014-12-15 16:42:49Z timgraham $
@@ -55,18 +57,18 @@ CONTAINS
INTEGER :: ierr
!!----------------------------------------------------------------------
!
- ALLOCATE( u_abl (1:jpi,1:jpj,1:jpka,jptime ), &
- & v_abl (1:jpi,1:jpj,1:jpka,jptime ), &
- & tq_abl (1:jpi,1:jpj,1:jpka,jptime,jptq), &
- & tke_abl (1:jpi,1:jpj,1:jpka,jptime ), &
- & avm_abl (1:jpi,1:jpj,1:jpka ), &
- & avt_abl (1:jpi,1:jpj,1:jpka ), &
- & mxld_abl(1:jpi,1:jpj,1:jpka ), &
- & mxlm_abl(1:jpi,1:jpj,1:jpka ), &
- & fft_abl (1:jpi,1:jpj ), &
- & pblh (1:jpi,1:jpj ), &
- & msk_abl (1:jpi,1:jpj ), &
- & rest_eq (1:jpi,1:jpj ), &
+ ALLOCATE( u_abl (A2D(0),1:jpka,jptime ), &
+ & v_abl (A2D(0),1:jpka,jptime ), &
+ & tq_abl (A2D(0),1:jpka,jptime,jptq), &
+ & tke_abl (A2D(0),1:jpka,jptime ), &
+ & avm_abl (A2D(0),1:jpka ), &
+ & avt_abl (A2D(0),1:jpka ), &
+ & mxld_abl(A2D(0),1:jpka ), &
+ & mxlm_abl(A2D(0),1:jpka ), &
+ & fft_abl (A2D(0) ), &
+ & pblh (A2D(1) ), & ! needed for optional smoothing
+ & msk_abl (A2D(0) ), &
+ & rest_eq (A2D(0) ), &
& e3t_abl (1:jpka), e3w_abl(1:jpka) , &
& ght_abl (1:jpka), ghw_abl(1:jpka) , STAT=ierr )
!
diff --git a/src/ABL/ablmod.F90 b/src/ABL/ablmod.F90
index b5b66b8a6d129be51693c33859efd507f543476d..d14691e4e56216314d10e8143d85aca8b7cace4c 100644
--- a/src/ABL/ablmod.F90
+++ b/src/ABL/ablmod.F90
@@ -67,54 +67,50 @@ CONTAINS
!! - Finalize flux computation in psen, pevp, pwndm, ptaui, ptauj, ptaum
!!
!!----------------------------------------------------------------------
- INTEGER , INTENT(in ) :: kt ! time step index
- REAL(wp) , INTENT(in ), DIMENSION(:,: ) :: psst ! sea-surface temperature [Celsius]
- REAL(wp) , INTENT(in ), DIMENSION(:,: ) :: pssu ! sea-surface u (U-point)
- REAL(wp) , INTENT(in ), DIMENSION(:,: ) :: pssv ! sea-surface v (V-point)
- REAL(wp) , INTENT(in ), DIMENSION(:,: ) :: pssq ! sea-surface humidity
- REAL(wp) , INTENT(in ), DIMENSION(:,:,:) :: pu_dta ! large-scale windi
- REAL(wp) , INTENT(in ), DIMENSION(:,:,:) :: pv_dta ! large-scale windj
- REAL(wp) , INTENT(in ), DIMENSION(:,:,:) :: pgu_dta ! large-scale hpgi
- REAL(wp) , INTENT(in ), DIMENSION(:,:,:) :: pgv_dta ! large-scale hpgj
- REAL(wp) , INTENT(in ), DIMENSION(:,:,:) :: pt_dta ! large-scale pot. temp.
- REAL(wp) , INTENT(in ), DIMENSION(:,:,:) :: pq_dta ! large-scale humidity
- REAL(wp) , INTENT(in ), DIMENSION(:,: ) :: pslp_dta ! sea-level pressure
- REAL(wp) , INTENT(in ), DIMENSION(:,: ) :: pcd_du ! Cd x Du (T-point)
- REAL(wp) , INTENT(inout), DIMENSION(:,: ) :: psen ! Ch x Du
- REAL(wp) , INTENT(inout), DIMENSION(:,: ) :: pevp ! Ce x Du
- REAL(wp) , INTENT(inout), DIMENSION(:,: ) :: pwndm ! ||uwnd - uoce||
- REAL(wp) , INTENT( out), DIMENSION(:,: ) :: plat ! latent heat flux
- REAL(wp) , INTENT( out), DIMENSION(:,: ) :: ptaui ! taux
- REAL(wp) , INTENT( out), DIMENSION(:,: ) :: ptauj ! tauy
- REAL(wp) , INTENT( out), DIMENSION(:,: ) :: ptaum ! ||tau||
- !
+
+ INTEGER , INTENT(in ) :: kt ! time step index
+ REAL(wp) , INTENT(in ), DIMENSION(A2D(0)) :: psst ! sea-surface temperature [Celsius]
+ REAL(wp) , INTENT(in ), DIMENSION(A2D(nn_hls)) :: pssu ! sea-surface u (U-point)
+ REAL(wp) , INTENT(in ), DIMENSION(A2D(nn_hls)) :: pssv ! sea-surface v (V-point)
+ REAL(wp) , INTENT(in ), DIMENSION(A2D(0)) :: pssq ! sea-surface humidity
+ REAL(wp) , INTENT(in ), DIMENSION(A2D(0),1:jpka) :: pu_dta ! large-scale windi
+ REAL(wp) , INTENT(in ), DIMENSION(A2D(0),1:jpka) :: pv_dta ! large-scale windj
+ REAL(wp) , INTENT(in ), DIMENSION(A2D(0),1:jpka) :: pgu_dta ! large-scale hpgi
+ REAL(wp) , INTENT(in ), DIMENSION(A2D(0),1:jpka) :: pgv_dta ! large-scale hpgj
+ REAL(wp) , INTENT(in ), DIMENSION(A2D(0),1:jpka) :: pt_dta ! large-scale pot. temp.
+ REAL(wp) , INTENT(in ), DIMENSION(A2D(0),1:jpka) :: pq_dta ! large-scale humidity
+ REAL(wp) , INTENT(in ), DIMENSION(A2D(0)) :: pslp_dta ! sea-level pressure
+ REAL(wp) , INTENT(in ), DIMENSION(A2D(0)) :: pcd_du ! Cd x Du (T-point)
+ REAL(wp) , INTENT(inout), DIMENSION(A2D(0)) :: psen ! Ch x Du
+ REAL(wp) , INTENT(inout), DIMENSION(A2D(0)) :: pevp ! Ce x Du
+ REAL(wp) , INTENT(inout), DIMENSION(A2D(0)) :: pwndm ! ||uwnd - uoce||
+ REAL(wp) , INTENT( out), DIMENSION(A2D(0)) :: plat ! latent heat flux
+ REAL(wp) , INTENT( out), DIMENSION(A2D(nn_hls)) :: ptaui ! taux
+ REAL(wp) , INTENT( out), DIMENSION(A2D(nn_hls)) :: ptauj ! tauy
+ REAL(wp) , INTENT( out), DIMENSION(A2D(0)) :: ptaum ! ||tau||
#if defined key_si3
- REAL(wp) , INTENT(in ), DIMENSION(:,: ) :: ptm_su ! ice-surface temperature [K]
- REAL(wp) , INTENT(in ), DIMENSION(:,: ) :: pssu_ice ! ice-surface u (U-point)
- REAL(wp) , INTENT(in ), DIMENSION(:,: ) :: pssv_ice ! ice-surface v (V-point)
- REAL(wp) , INTENT(in ), DIMENSION(:,: ) :: pssq_ice ! ice-surface humidity
- REAL(wp) , INTENT(in ), DIMENSION(:,: ) :: pcd_du_ice ! Cd x Du over ice (T-point)
- REAL(wp) , INTENT(in ), DIMENSION(:,: ) :: psen_ice ! Ch x Du over ice (T-point)
- REAL(wp) , INTENT(in ), DIMENSION(:,: ) :: pevp_ice ! Ce x Du over ice (T-point)
- REAL(wp) , INTENT(in ), DIMENSION(:,: ) :: pwndm_ice ! ||uwnd - uice||
- REAL(wp) , INTENT(in ), DIMENSION(:,: ) :: pfrac_oce ! ocean fraction
- REAL(wp) , INTENT( out), DIMENSION(:,: ) :: ptaui_ice ! ice-surface taux stress (U-point)
- REAL(wp) , INTENT( out), DIMENSION(:,: ) :: ptauj_ice ! ice-surface tauy stress (V-point)
+ REAL(wp) , INTENT(in ), DIMENSION(A2D(0)) :: ptm_su ! ice-surface temperature [K]
+ REAL(wp) , INTENT(in ), DIMENSION(A2D(nn_hls)) :: pssu_ice ! ice-surface u (U-point)
+ REAL(wp) , INTENT(in ), DIMENSION(A2D(nn_hls)) :: pssv_ice ! ice-surface v (V-point)
+ REAL(wp) , INTENT(in ), DIMENSION(A2D(0)) :: pssq_ice ! ice-surface humidity
+ REAL(wp) , INTENT(in ), DIMENSION(A2D(0)) :: pcd_du_ice ! Cd x Du over ice (T-point)
+ REAL(wp) , INTENT(in ), DIMENSION(A2D(0)) :: psen_ice ! Ch x Du over ice (T-point)
+ REAL(wp) , INTENT(in ), DIMENSION(A2D(0)) :: pevp_ice ! Ce x Du over ice (T-point)
+ REAL(wp) , INTENT(in ), DIMENSION(A2D(0)) :: pwndm_ice ! ||uwnd - uice||
+ REAL(wp) , INTENT(in ), DIMENSION(A2D(0)) :: pfrac_oce ! ocean fraction
+ REAL(wp) , INTENT( out), DIMENSION(A2D(nn_hls)) :: ptaui_ice ! ice-surface taux stress (T-point)
+ REAL(wp) , INTENT( out), DIMENSION(A2D(nn_hls)) :: ptauj_ice ! ice-surface tauy stress (T-point)
#endif
!
- REAL(wp), DIMENSION(1:jpi,1:jpj ) :: zwnd_i, zwnd_j
- REAL(wp), DIMENSION(1:jpi,1:jpj ) :: zsspt
- REAL(wp), DIMENSION(1:jpi,1:jpj ) :: ztabs, zpre
- REAL(wp), DIMENSION(1:jpi ,2:jpka) :: zCF
+ REAL(wp), DIMENSION(A2D(0)) :: zwnd_i, zwnd_j
+ REAL(wp), DIMENSION(A2D(0)) :: zsspt, ztabs, zpre
+ REAL(wp), DIMENSION(A1Di(0),2:jpka) :: zCF
+ REAL(wp), DIMENSION(A1Di(0),1:jpka) :: z_elem_a, z_elem_b, z_elem_c
!
- REAL(wp), DIMENSION(1:jpi ,1:jpka) :: z_elem_a
- REAL(wp), DIMENSION(1:jpi ,1:jpka) :: z_elem_b
- REAL(wp), DIMENSION(1:jpi ,1:jpka) :: z_elem_c
- !
- INTEGER :: ji, jj, jk, jtra, jbak ! dummy loop indices
- REAL(wp) :: zztmp, zcff, ztemp, zhumi, zcff1, zztmp1, zztmp2
- REAL(wp) :: zcff2, zfcor, zmsk, zsig, zcffu, zcffv, zzice,zzoce
- LOGICAL :: SemiImp_Cor = .TRUE.
+ INTEGER :: ji, jj, jk, jtra, jbak ! dummy loop indices
+ REAL(wp) :: zztmp, zcff, ztemp, zhumi, zcff1, zztmp1, zztmp2
+ REAL(wp) :: zcff2, zfcor, zmsk, zsig, zcffu, zcffv, zzice,zzoce
+ LOGICAL :: SemiImp_Cor = .TRUE.
!
!!---------------------------------------------------------------------
!
@@ -124,12 +120,12 @@ CONTAINS
WRITE(numout,*) '~~~~~~'
ENDIF
!
- IF( kt == nit000 ) ALLOCATE ( ustar2( 1:jpi, 1:jpj ) )
- IF( kt == nit000 ) ALLOCATE ( zrough( 1:jpi, 1:jpj ) )
+ IF( kt == nit000 ) ALLOCATE ( ustar2( A2D(0) ) )
+ IF( kt == nit000 ) ALLOCATE ( zrough( A2D(0) ) )
!! Compute ustar squared as Cd || Uatm-Uoce ||^2
!! needed for surface boundary condition of TKE
!! pwndm contains | U10m - U_oce | (see blk_oce_1 in sbcblk)
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
zzoce = pCd_du (ji,jj) * pwndm (ji,jj)
#if defined key_si3
zzice = pCd_du_ice(ji,jj) * pwndm_ice(ji,jj)
@@ -137,39 +133,40 @@ CONTAINS
#else
ustar2(ji,jj) = zzoce
#endif
- !#LB: sorry Cdn_oce is gone:
- !zrough(ji,jj) = ght_abl(2) * EXP( - vkarmn / SQRT( MAX( Cdn_oce(ji,jj), 1.e-4 ) ) ) !<-- recover the value of z0 from Cdn_oce
+ zsspt(ji,jj) = theta_exner( psst(ji,jj)+rt0, pslp_dta(ji,jj) ) ! potential SST [K]
END_2D
+ !#LB: sorry Cdn_oce is gone:
+ !zrough(:,:) = ght_abl(2) * EXP( - vkarmn / SQRT( MAX( Cdn_oce(:,:), 1.e-4 ) ) ) !<-- recover the value of z0 from Cdn_oce
zrough(:,:) = z0_from_Cd( ght_abl(2), pCd_du(:,:) / MAX( pwndm(:,:), 0.5_wp ) ) ! #LB: z0_from_Cd is define in sbc_phy.F90...
! sea surface potential temperature [K]
- zsspt(:,:) = theta_exner( psst(:,:)+rt0, pslp_dta(:,:) )
+ !zsspt(:,:) = theta_exner( psst(A2D(0))+rt0, pslp_dta(:,:) )
+
- !
! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
! ! 1 *** Advance TKE to time n+1 and compute Avm_abl, Avt_abl, PBLh
! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
- CALL abl_zdf_tke( ) !--> Avm_abl, Avt_abl, pblh defined on (1,jpi) x (1,jpj)
+ CALL abl_zdf_tke( ) !--> Avm_abl, Avt_abl, pblh defined on (A1Di(0)) x (A1Dj(0))
! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
! ! 2 *** Advance tracers to time n+1
! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
!-------------
- DO jj = 1, jpj ! outer loop !--> tq_abl computed on (1:jpi) x (1:jpj)
+ DO_1Dj(0,0) ! outer loop !--> tq_abl computed on (A1Di(0)) x (A1Dj(0))
!-------------
! Compute matrix elements for interior points
DO jk = 3, jpkam1
- DO ji = 1, jpi ! vector opt.
+ DO_1Di(0,0)
z_elem_a( ji, jk ) = - rDt_abl * Avt_abl( ji, jj, jk-1 ) / e3w_abl( jk-1 ) ! lower-diagonal
z_elem_c( ji, jk ) = - rDt_abl * Avt_abl( ji, jj, jk ) / e3w_abl( jk ) ! upper-diagonal
z_elem_b( ji, jk ) = e3t_abl(jk) - z_elem_a( ji, jk ) - z_elem_c( ji, jk ) ! diagonal
- END DO
+ END_1D
END DO
! Boundary conditions
- DO ji = 1, jpi ! vector opt.
+ DO_1Di(0,0)
! Neumann at the bottom
z_elem_a( ji, 2 ) = 0._wp
z_elem_c( ji, 2 ) = - rDt_abl * Avt_abl( ji, jj, 2 ) / e3w_abl( 2 )
@@ -177,19 +174,18 @@ CONTAINS
z_elem_a( ji, jpka ) = - rDt_abl * Avt_abl( ji, jj, jpka ) / e3w_abl( jpka )
z_elem_c( ji, jpka ) = 0._wp
z_elem_b( ji, jpka ) = e3t_abl( jpka ) - z_elem_a( ji, jpka )
- END DO
+ END_1D
DO jtra = 1,jptq ! loop on active tracers
DO jk = 3, jpkam1
- !DO ji = 2, jpim1
- DO ji = 1,jpi !!GS: to be checked if needed
+ DO_1Di(0,0)
tq_abl( ji, jj, jk, nt_a, jtra ) = e3t_abl(jk) * tq_abl( ji, jj, jk, nt_n, jtra ) ! initialize right-hand-side
- END DO
+ END_1D
END DO
IF(jtra == jp_ta) THEN
- DO ji = 1,jpi ! surface boundary condition for temperature
+ DO_1Di(0,0) ! surface boundary condition for temperature
zztmp1 = psen(ji, jj)
zztmp2 = psen(ji, jj) * zsspt(ji, jj)
#if defined key_si3
@@ -199,9 +195,9 @@ CONTAINS
z_elem_b( ji, 2 ) = e3t_abl( 2 ) - z_elem_c( ji, 2 ) + rDt_abl * zztmp1
tq_abl ( ji, jj, 2, nt_a, jtra ) = e3t_abl( 2 ) * tq_abl ( ji, jj, 2, nt_n, jtra ) + rDt_abl * zztmp2
tq_abl ( ji, jj, jpka, nt_a, jtra ) = e3t_abl( jpka ) * tq_abl ( ji, jj, jpka, nt_n, jtra )
- END DO
+ END_1D
ELSE ! jp_qa
- DO ji = 1,jpi ! surface boundary condition for humidity
+ DO_1Di(0,0) ! surface boundary condition for humidity
zztmp1 = pevp(ji, jj)
zztmp2 = pevp(ji, jj) * pssq(ji, jj)
#if defined key_si3
@@ -211,31 +207,31 @@ CONTAINS
z_elem_b( ji, 2 ) = e3t_abl( 2 ) - z_elem_c( ji, 2 ) + rDt_abl * zztmp1
tq_abl ( ji, jj, 2 , nt_a, jtra ) = e3t_abl( 2 ) * tq_abl ( ji, jj, 2, nt_n, jtra ) + rDt_abl * zztmp2
tq_abl ( ji, jj, jpka, nt_a, jtra ) = e3t_abl( jpka ) * tq_abl ( ji, jj, jpka, nt_n, jtra )
- END DO
+ END_1D
END IF
!!
!! Matrix inversion
!! ----------------------------------------------------------
- DO ji = 1,jpi
+ DO_1Di(0,0)
zcff = 1._wp / z_elem_b( ji, 2 )
zCF ( ji, 2 ) = - zcff * z_elem_c( ji, 2 )
tq_abl( ji, jj, 2, nt_a, jtra ) = zcff * tq_abl( ji, jj, 2, nt_a, jtra )
- END DO
+ END_1D
DO jk = 3, jpka
- DO ji = 1,jpi
+ DO_1Di(0,0)
zcff = 1._wp / ( z_elem_b( ji, jk ) + z_elem_a( ji, jk ) * zCF( ji, jk-1 ) )
zCF(ji,jk) = - zcff * z_elem_c( ji, jk )
tq_abl(ji,jj,jk,nt_a,jtra) = zcff * ( tq_abl(ji,jj,jk ,nt_a,jtra) &
& - z_elem_a(ji, jk) * tq_abl(ji,jj,jk-1,nt_a,jtra) )
- END DO
+ END_1D
END DO
!!FL at this point we could check positivity of tq_abl(:,:,:,nt_a,jp_qa) ... test to do ...
DO jk = jpkam1,2,-1
- DO ji = 1,jpi
+ DO_1Di(0,0)
tq_abl(ji,jj,jk,nt_a,jtra) = tq_abl(ji,jj,jk,nt_a,jtra) + &
& zCF(ji,jk) * tq_abl(ji,jj,jk+1,nt_a,jtra)
- END DO
+ END_1D
END DO
END DO !<-- loop on tracers
@@ -254,7 +250,7 @@ CONTAINS
!-------------
!
! Advance u_abl & v_abl to time n+1
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
zcff = ( fft_abl(ji,jj) * rDt_abl )*( fft_abl(ji,jj) * rDt_abl ) ! (f dt)**2
u_abl( ji, jj, jk, nt_a ) = e3t_abl(jk) *( &
@@ -269,13 +265,13 @@ CONTAINS
END_2D
!
!-------------
- END DO ! end outer loop !<-- u_abl and v_abl are properly updated on (1:jpi) x (1:jpj)
+ END DO ! end outer loop !<-- u_abl and v_abl are properly updated on (A1Di(0)) x (A1Dj(0))
!-------------
!
IF( ln_geos_winds ) THEN
- DO jj = 1, jpj ! outer loop
+ DO_1Dj( 0, 0 ) ! outer loop
DO jk = 1, jpka
- DO ji = 1, jpi
+ DO_1Di( 0, 0 )
u_abl( ji, jj, jk, nt_a ) = u_abl( ji, jj, jk, nt_a ) &
& - rDt_abl * e3t_abl(jk) * fft_abl(ji , jj) * pgv_dta(ji ,jj ,jk)
v_abl( ji, jj, jk, nt_a ) = v_abl( ji, jj, jk, nt_a ) &
@@ -286,14 +282,14 @@ CONTAINS
END IF
!
IF( ln_hpgls_frc ) THEN
- DO jj = 1, jpj ! outer loop
+ DO_1Dj( 0, 0 ) ! outer loop
DO jk = 1, jpka
- DO ji = 1, jpi
+ DO_1Di( 0, 0 )
u_abl( ji, jj, jk, nt_a ) = u_abl( ji, jj, jk, nt_a ) - rDt_abl * e3t_abl(jk) * pgu_dta(ji,jj,jk)
v_abl( ji, jj, jk, nt_a ) = v_abl( ji, jj, jk, nt_a ) - rDt_abl * e3t_abl(jk) * pgv_dta(ji,jj,jk)
- ENDDO
+ END_1D
ENDDO
- ENDDO
+ END_1D
END IF
ELSE ! SemiImp_Cor = .FALSE.
@@ -306,29 +302,25 @@ CONTAINS
!
IF( MOD( kt, 2 ) == 0 ) then
! Advance u_abl & v_abl to time n+1
- DO jj = 1, jpj
- DO ji = 1, jpi
- zcff = fft_abl(ji,jj) * ( v_abl ( ji , jj , jk, nt_n ) - pgv_dta(ji ,jj ,jk) )
- u_abl( ji, jj, jk, nt_a ) = u_abl( ji, jj, jk, nt_n ) + rDt_abl * zcff
- zcff = fft_abl(ji,jj) * ( u_abl ( ji , jj , jk, nt_a ) - pgu_dta(ji ,jj ,jk) )
- v_abl( ji, jj, jk, nt_a ) = e3t_abl(jk) *( v_abl( ji, jj, jk, nt_n ) - rDt_abl * zcff )
- u_abl( ji, jj, jk, nt_a ) = e3t_abl(jk) * u_abl( ji, jj, jk, nt_a )
- END DO
- END DO
+ DO_2D( 0, 0, 0, 0 )
+ zcff = fft_abl(ji,jj) * ( v_abl ( ji , jj , jk, nt_n ) - pgv_dta(ji ,jj ,jk) )
+ u_abl( ji, jj, jk, nt_a ) = u_abl( ji, jj, jk, nt_n ) + rDt_abl * zcff
+ zcff = fft_abl(ji,jj) * ( u_abl ( ji , jj , jk, nt_a ) - pgu_dta(ji ,jj ,jk) )
+ v_abl( ji, jj, jk, nt_a ) = e3t_abl(jk) *( v_abl( ji, jj, jk, nt_n ) - rDt_abl * zcff )
+ u_abl( ji, jj, jk, nt_a ) = e3t_abl(jk) * u_abl( ji, jj, jk, nt_a )
+ END_2D
ELSE
- DO jj = 1, jpj
- DO ji = 1, jpi
- zcff = fft_abl(ji,jj) * ( u_abl ( ji , jj , jk, nt_n ) - pgu_dta(ji ,jj ,jk) )
- v_abl( ji, jj, jk, nt_a ) = v_abl( ji, jj, jk, nt_n ) - rDt_abl * zcff
- zcff = fft_abl(ji,jj) * ( v_abl ( ji , jj , jk, nt_a ) - pgv_dta(ji ,jj ,jk) )
- u_abl( ji, jj, jk, nt_a ) = e3t_abl(jk) *( u_abl( ji, jj, jk, nt_n ) + rDt_abl * zcff )
- v_abl( ji, jj, jk, nt_a ) = e3t_abl(jk) * v_abl( ji, jj, jk, nt_a )
- END DO
- END DO
+ DO_2D( 0, 0, 0, 0 )
+ zcff = fft_abl(ji,jj) * ( u_abl ( ji , jj , jk, nt_n ) - pgu_dta(ji ,jj ,jk) )
+ v_abl( ji, jj, jk, nt_a ) = v_abl( ji, jj, jk, nt_n ) - rDt_abl * zcff
+ zcff = fft_abl(ji,jj) * ( v_abl ( ji , jj , jk, nt_a ) - pgv_dta(ji ,jj ,jk) )
+ u_abl( ji, jj, jk, nt_a ) = e3t_abl(jk) *( u_abl( ji, jj, jk, nt_n ) + rDt_abl * zcff )
+ v_abl( ji, jj, jk, nt_a ) = e3t_abl(jk) * v_abl( ji, jj, jk, nt_a )
+ END_2D
END IF
!
!-------------
- END DO ! end outer loop !<-- u_abl and v_abl are properly updated on (1:jpi) x (1:jpj)
+ END DO ! end outer loop !<-- u_abl and v_abl are properly updated on (A1Di(0)) x (A1Dj(0))
!-------------
ENDIF ! ln_geos_winds
@@ -340,18 +332,19 @@ CONTAINS
!
! Vertical diffusion for u_abl
!-------------
- DO jj = 1, jpj ! outer loop
+ DO_1Dj(0,0) ! outer loop
!-------------
DO jk = 3, jpkam1
- DO ji = 1, jpi
+ DO_1Di(0,0)
z_elem_a( ji, jk ) = - rDt_abl * Avm_abl( ji, jj, jk-1 ) / e3w_abl( jk-1 ) ! lower-diagonal
z_elem_c( ji, jk ) = - rDt_abl * Avm_abl( ji, jj, jk ) / e3w_abl( jk ) ! upper-diagonal
z_elem_b( ji, jk ) = e3t_abl(jk) - z_elem_a( ji, jk ) - z_elem_c( ji, jk ) ! diagonal
- END DO
+ END_1D
END DO
- DO ji = 2, jpi ! boundary conditions (Avm_abl and pcd_du must be available at ji=jpi)
+ DO_1Di(0,0) ! boundary conditions
+
!++ Surface boundary condition
z_elem_a( ji, 2 ) = 0._wp
z_elem_c( ji, 2 ) = - rDt_abl * Avm_abl( ji, jj, 2 ) / e3w_abl( 2 )
@@ -381,29 +374,29 @@ CONTAINS
u_abl ( ji, jj, jpka, nt_a ) = e3t_abl( jpka ) * pu_dta(ji,jj,jk)
!ENDIF
- END DO
+ END_1D
!!
!! Matrix inversion
!! ----------------------------------------------------------
- DO ji = 1, jpi !DO ji = 2, jpi !!GS: TBI
+ DO_1Di(0,0)
zcff = 1._wp / z_elem_b( ji, 2 )
zCF (ji, 2 ) = - zcff * z_elem_c( ji, 2 )
u_abl (ji,jj,2,nt_a) = zcff * u_abl ( ji, jj, 2, nt_a )
- END DO
+ END_1D
DO jk = 3, jpka
- DO ji = 2, jpi
+ DO_1Di(0,0)
zcff = 1._wp / ( z_elem_b( ji, jk ) + z_elem_a( ji, jk ) * zCF (ji, jk-1 ) )
zCF(ji,jk) = - zcff * z_elem_c( ji, jk )
u_abl(ji,jj,jk,nt_a) = zcff * ( u_abl(ji,jj,jk ,nt_a) &
& - z_elem_a(ji, jk) * u_abl(ji,jj,jk-1,nt_a) )
- END DO
+ END_1D
END DO
DO jk = jpkam1,2,-1
- DO ji = 2, jpi
+ DO_1Di(0,0)
u_abl(ji,jj,jk,nt_a) = u_abl(ji,jj,jk,nt_a) + zCF(ji,jk) * u_abl(ji,jj,jk+1,nt_a)
- END DO
+ END_1D
END DO
!-------------
@@ -413,18 +406,19 @@ CONTAINS
!
! Vertical diffusion for v_abl
!-------------
- DO jj = 2, jpj ! outer loop
+ DO_1Dj(0,0) ! outer loop
!-------------
!
DO jk = 3, jpkam1
- DO ji = 1, jpi
+ DO_1Di(0,0)
z_elem_a( ji, jk ) = - rDt_abl * Avm_abl( ji, jj, jk-1 ) / e3w_abl( jk-1 ) ! lower-diagonal
z_elem_c( ji, jk ) = - rDt_abl * Avm_abl( ji, jj, jk ) / e3w_abl( jk ) ! upper-diagonal
z_elem_b( ji, jk ) = e3t_abl(jk) - z_elem_a( ji, jk ) - z_elem_c( ji, jk ) ! diagonal
- END DO
+ END_1D
END DO
- DO ji = 1, jpi ! boundary conditions (Avm_abl and pcd_du must be available at jj=jpj)
+ DO_1Di(0,0) ! boundary conditions
+
!++ Surface boundary condition
z_elem_a( ji, 2 ) = 0._wp
z_elem_c( ji, 2 ) = - rDt_abl * Avm_abl( ji, jj, 2 ) / e3w_abl( 2 )
@@ -454,29 +448,29 @@ CONTAINS
v_abl ( ji, jj, jpka, nt_a ) = e3t_abl( jpka ) * pv_dta(ji,jj,jk)
!ENDIF
- END DO
+ END_1D
!!
!! Matrix inversion
!! ----------------------------------------------------------
- DO ji = 1, jpi
+ DO_1Di(0,0)
zcff = 1._wp / z_elem_b( ji, 2 )
zCF (ji, 2 ) = - zcff * z_elem_c( ji, 2 )
v_abl (ji,jj,2,nt_a) = zcff * v_abl ( ji, jj, 2, nt_a )
- END DO
+ END_1D
DO jk = 3, jpka
- DO ji = 1, jpi
+ DO_1Di(0,0)
zcff = 1._wp / ( z_elem_b( ji, jk ) + z_elem_a( ji, jk ) * zCF (ji, jk-1 ) )
zCF(ji,jk) = - zcff * z_elem_c( ji, jk )
v_abl(ji,jj,jk,nt_a) = zcff * ( v_abl(ji,jj,jk ,nt_a) &
& - z_elem_a(ji, jk) * v_abl(ji,jj,jk-1,nt_a) )
- END DO
+ END_1D
END DO
DO jk = jpkam1,2,-1
- DO ji = 1, jpi
+ DO_1Di(0,0)
v_abl(ji,jj,jk,nt_a) = v_abl(ji,jj,jk,nt_a) + zCF(ji,jk) * v_abl(ji,jj,jk+1,nt_a)
- END DO
+ END_1D
END DO
!
!-------------
@@ -491,7 +485,7 @@ CONTAINS
!-------------
DO jk = 2, jpka ! outer loop
!-------------
- DO_2D( nn_hls-1, nn_hls, nn_hls-1, nn_hls )
+ DO_2D( 0, 0, 0, 0)
zcff1 = pblh( ji, jj )
zsig = ght_abl(jk) / MAX( jp_pblh_min, MIN( jp_pblh_max, zcff1 ) )
zsig = MIN( jp_bmax , MAX( zsig, jp_bmin) )
@@ -514,7 +508,7 @@ CONTAINS
!-------------
DO jk = 2, jpka ! outer loop
!-------------
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0)
zcff1 = pblh( ji, jj )
zsig = ght_abl(jk) / MAX( jp_pblh_min, MIN( jp_pblh_max, zcff1 ) )
zsig = MIN( jp_bmax , MAX( zsig, jp_bmin) )
@@ -528,21 +522,17 @@ CONTAINS
tq_abl( ji, jj, jk, nt_a, jp_qa ) = (1._wp - zcff ) * tq_abl( ji, jj, jk, nt_a, jp_qa ) &
& + zcff * pq_dta( ji, jj, jk )
-
END_2D
!-------------
END DO ! end outer loop
!-------------
! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
- ! ! 6 *** MPI exchanges & IOM outputs
+ ! ! 6 *** IOM outputs
! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
!
- CALL lbc_lnk( 'ablmod', u_abl(:,:,:,nt_a ), 'T', -1._wp, v_abl(:,:,:,nt_a) , 'T', -1._wp )
- !CALL lbc_lnk( 'ablmod', tq_abl(:,:,:,nt_a,jp_ta), 'T', 1._wp, tq_abl(:,:,:,nt_a,jp_qa), 'T', 1._wp, kfillmode = jpfillnothing ) ! ++++ this should not be needed...
- !
#if defined key_xios
! 2D & first ABL level
- IF ( iom_use("pblh" ) ) CALL iom_put ( "pblh", pblh(:,: ) )
+ IF ( iom_use("pblh" ) ) CALL iom_put ( "pblh", pblh(A2D(0) ) )
IF ( iom_use("uz1_abl") ) CALL iom_put ( "uz1_abl", u_abl(:,:,2,nt_a ) )
IF ( iom_use("vz1_abl") ) CALL iom_put ( "vz1_abl", v_abl(:,:,2,nt_a ) )
IF ( iom_use("tz1_abl") ) CALL iom_put ( "tz1_abl", tq_abl(:,:,2,nt_a,jp_ta) )
@@ -588,7 +578,7 @@ CONTAINS
! ! 7 *** Finalize flux computation
! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
!
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
ztemp = tq_abl( ji, jj, 2, nt_a, jp_ta )
zhumi = tq_abl( ji, jj, 2, nt_a, jp_qa )
zpre( ji, jj ) = pres_temp( zhumi, pslp_dta(ji,jj), ght_abl(2), ptpot=ztemp, pta=ztabs( ji, jj ) )
@@ -599,15 +589,13 @@ CONTAINS
rhoa( ji, jj ) = zcff
END_2D
- DO_2D( nn_hls-1, nn_hls, nn_hls-1, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
zwnd_i(ji,jj) = u_abl(ji ,jj,2,nt_a) - 0.5_wp * ( pssu(ji ,jj) + pssu(ji-1,jj) ) * rn_vfac
zwnd_j(ji,jj) = v_abl(ji,jj ,2,nt_a) - 0.5_wp * ( pssv(ji,jj ) + pssv(ji,jj-1) ) * rn_vfac
END_2D
!
- CALL lbc_lnk( 'ablmod', zwnd_i(:,:) , 'T', -1.0_wp, zwnd_j(:,:) , 'T', -1.0_wp )
- !
! ... scalar wind ( = | U10m - U_oce | ) at T-point (masked)
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
zcff = SQRT( zwnd_i(ji,jj) * zwnd_i(ji,jj) &
& + zwnd_j(ji,jj) * zwnd_j(ji,jj) ) ! * msk_abl(ji,jj)
zztmp = rhoa(ji,jj) * pcd_du(ji,jj)
@@ -617,25 +605,18 @@ CONTAINS
zwnd_i(ji,jj) = zztmp * zwnd_i(ji,jj)
zwnd_j(ji,jj) = zztmp * zwnd_j(ji,jj)
END_2D
- ! ... utau, vtau at U- and V_points, resp.
- ! Note the use of 0.5*(2-umask) in order to unmask the stress along coastlines
- ! Note the use of MAX(tmask(i,j),tmask(i+1,j) is to mask tau over ice shelves
+ CALL iom_put( "taum_oce", ptaum )
+
+ ! ... utau, vtau at T-points
DO_2D( 0, 0, 0, 0 )
- zcff = 0.5_wp * ( 2._wp - msk_abl(ji,jj)*msk_abl(ji+1,jj) )
- zztmp = MAX(msk_abl(ji,jj),msk_abl(ji+1,jj))
- ptaui(ji,jj) = zcff * zztmp * ( zwnd_i(ji,jj) + zwnd_i(ji+1,jj ) )
- zcff = 0.5_wp * ( 2._wp - msk_abl(ji,jj)*msk_abl(ji,jj+1) )
- zztmp = MAX(msk_abl(ji,jj),msk_abl(ji,jj+1))
- ptauj(ji,jj) = zcff * zztmp * ( zwnd_j(ji,jj) + zwnd_j(ji ,jj+1) )
+ ptaui(ji,jj) = zwnd_i(ji,jj) * msk_abl(ji,jj)
+ ptauj(ji,jj) = zwnd_j(ji,jj) * msk_abl(ji,jj)
END_2D
- !
- CALL lbc_lnk( 'ablmod', ptaui(:,:), 'U', -1.0_wp, ptauj(:,:), 'V', -1.0_wp )
-
- CALL iom_put( "taum_oce", ptaum )
+ CALL lbc_lnk( 'ablmod', ptaui(:,:) , 'T', -1.0_wp, ptauj(:,:) , 'T', -1.0_wp )
IF(sn_cfctl%l_prtctl) THEN
- CALL prt_ctl( tab2d_1=ptaui , clinfo1=' abl_stp: utau : ', mask1=umask, &
- & tab2d_2=ptauj , clinfo2=' vtau : ', mask2=vmask )
+ CALL prt_ctl( tab2d_1=ptaui , clinfo1=' abl_stp: utau : ', mask1=tmask, &
+ & tab2d_2=ptauj , clinfo2=' vtau : ', mask2=tmask )
CALL prt_ctl( tab2d_1=pwndm , clinfo1=' abl_stp: wndm : ' )
ENDIF
@@ -643,37 +624,16 @@ CONTAINS
! ------------------------------------------------------------ !
! Wind stress relative to the moving ice ( U10m - U_ice ) !
! ------------------------------------------------------------ !
- !DO_2D( 0, 0, 0, 0 )
- ! ptaui_ice(ji,jj) = 0.5_wp * ( rhoa(ji+1,jj) * pCd_du_ice(ji+1,jj) + rhoa(ji,jj) * pCd_du_ice(ji,jj) ) &
- ! & * ( 0.5_wp * ( u_abl(ji+1,jj,2,nt_a) + u_abl(ji,jj,2,nt_a) ) - pssu_ice(ji,jj) )
- ! ptauj_ice(ji,jj) = 0.5_wp * ( rhoa(ji,jj+1) * pCd_du_ice(ji,jj+1) + rhoa(ji,jj) * pCd_du_ice(ji,jj) ) &
- ! & * ( 0.5_wp * ( v_abl(ji,jj+1,2,nt_a) + v_abl(ji,jj,2,nt_a) ) - pssv_ice(ji,jj) )
- !END_2D
- !CALL lbc_lnk( 'ablmod', ptaui_ice, 'U', -1.0_wp, ptauj_ice, 'V', -1.0_wp )
- !!
- !IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab2d_1=ptaui_ice , clinfo1=' abl_stp: putaui : ' &
- ! & , tab2d_2=ptauj_ice , clinfo2=' pvtaui : ' )
-
- ! ------------------------------------------------------------ !
- ! Wind stress relative to the moving ice ( U10m - U_ice ) !
- ! ------------------------------------------------------------ !
- DO_2D( 0, 0, 0, 0 )
-
- zztmp1 = 0.5_wp * ( u_abl(ji+1,jj ,2,nt_a) + u_abl(ji,jj,2,nt_a) )
- zztmp2 = 0.5_wp * ( v_abl(ji ,jj+1,2,nt_a) + v_abl(ji,jj,2,nt_a) )
-
- ptaui_ice(ji,jj) = 0.5_wp * ( rhoa(ji+1,jj) * pCd_du_ice(ji+1,jj) &
- & + rhoa(ji ,jj) * pCd_du_ice(ji ,jj) ) &
- & * ( zztmp1 - pssu_ice(ji,jj) * rn_vfac )
- ptauj_ice(ji,jj) = 0.5_wp * ( rhoa(ji,jj+1) * pCd_du_ice(ji,jj+1) &
- & + rhoa(ji,jj ) * pCd_du_ice(ji,jj ) ) &
- & * ( zztmp2 - pssv_ice(ji,jj) * rn_vfac )
+ DO_2D(0,0,0,0)
+ zztmp = rhoa(ji,jj) * pCd_du_ice(ji,jj)
+ ptaui_ice(ji,jj) = zztmp * ( u_abl(ji,jj,2,nt_a) - 0.5_wp * ( pssu_ice(ji,jj) + pssu_ice(ji-1,jj ) ) * rn_vfac )
+ ptauj_ice(ji,jj) = zztmp * ( v_abl(ji,jj,2,nt_a) - 0.5_wp * ( pssv_ice(ji,jj) + pssv_ice(ji ,jj-1) ) * rn_vfac )
END_2D
- CALL lbc_lnk( 'ablmod', ptaui_ice, 'U', -1.0_wp, ptauj_ice,'V', -1.0_wp )
+ CALL lbc_lnk( 'ablmod', ptaui_ice(:,:) , 'T', -1.0_wp, ptauj_ice(:,:) , 'T', -1.0_wp )
!
IF(sn_cfctl%l_prtctl) THEN
- CALL prt_ctl( tab2d_1=ptaui_ice , clinfo1=' abl_stp: utau_ice : ', mask1=umask, &
- & tab2d_2=ptauj_ice , clinfo2=' vtau_ice : ', mask2=vmask )
+ CALL prt_ctl( tab2d_1=ptaui_ice , clinfo1=' abl_stp: utau_ice : ', mask1=tmask, &
+ & tab2d_2=ptauj_ice , clinfo2=' vtau_ice : ', mask2=tmask )
END IF
#endif
! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
@@ -707,21 +667,22 @@ CONTAINS
!! - avmu, avmv : production of TKE by shear at u and v-points
!! (= Kz dz[Ub] * dz[Un] )
!! ---------------------------------------------------------------------
- INTEGER :: ji, jj, jk, tind, jbak, jkup, jkdwn
- INTEGER, DIMENSION(1:jpi ) :: ikbl
- REAL(wp) :: zcff, zcff2, ztken, zesrf, zetop, ziRic, ztv
- REAL(wp) :: zdU , zdV , zcff1, zshear, zbuoy, zsig, zustar2
- REAL(wp) :: zdU2, zdV2, zbuoy1, zbuoy2 ! zbuoy for BL89
- REAL(wp) :: zwndi, zwndj
- REAL(wp), DIMENSION(1:jpi, 1:jpka) :: zsh2
- REAL(wp), DIMENSION(1:jpi,1:jpj,1:jpka) :: zbn2
- REAL(wp), DIMENSION(1:jpi,1:jpka ) :: zFC, zRH, zCF
- REAL(wp), DIMENSION(1:jpi,1:jpka ) :: z_elem_a
- REAL(wp), DIMENSION(1:jpi,1:jpka ) :: z_elem_b
- REAL(wp), DIMENSION(1:jpi,1:jpka ) :: z_elem_c
- LOGICAL :: ln_Patankar = .FALSE.
- LOGICAL :: ln_dumpvar = .FALSE.
- LOGICAL , DIMENSION(1:jpi ) :: ln_foundl
+
+ INTEGER :: ji, jj, jk, tind, jbak, jkup, jkdwn
+ INTEGER, DIMENSION(A1Di(0)) :: ikbl
+ REAL(wp) :: zcff, zcff2, ztken, zesrf, zetop, ziRic, ztv
+ REAL(wp) :: zdU , zdV , zcff1, zshear, zbuoy, zsig, zustar2
+ REAL(wp) :: zdU2, zdV2, zbuoy1, zbuoy2 ! zbuoy for BL89
+ REAL(wp) :: zwndi, zwndj
+ REAL(wp), DIMENSION(A1Di(0),1:jpka) :: zsh2
+ REAL(wp), DIMENSION(A2D(0) ,1:jpka) :: zbn2
+ REAL(wp), DIMENSION(A1Di(0),1:jpka) :: zFC, zRH, zCF
+ REAL(wp), DIMENSION(A1Di(0),1:jpka) :: z_elem_a
+ REAL(wp), DIMENSION(A1Di(0),1:jpka) :: z_elem_b
+ REAL(wp), DIMENSION(A1Di(0),1:jpka) :: z_elem_c
+ LOGICAL :: ln_Patankar = .FALSE.
+ LOGICAL :: ln_dumpvar = .FALSE.
+ LOGICAL , DIMENSION(A1Di(0)) :: ln_foundl
!
tind = nt_n
ziRic = 1._wp / rn_Ric
@@ -730,33 +691,33 @@ CONTAINS
! ! Advance TKE equation to time n+1
! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
!-------------
- DO jj = 1, jpj ! outer loop
+ DO_1Dj( 0, 0 ) ! outer loop
!-------------
!
! Compute vertical shear
DO jk = 2, jpkam1
- DO ji = 1, jpi
+ DO_1Di( 0, 0 )
zcff = 1.0_wp / e3w_abl( jk )**2
zdU = zcff* Avm_abl(ji,jj,jk) * (u_abl( ji, jj, jk+1, tind)-u_abl( ji, jj, jk , tind) )**2
zdV = zcff* Avm_abl(ji,jj,jk) * (v_abl( ji, jj, jk+1, tind)-v_abl( ji, jj, jk , tind) )**2
zsh2(ji,jk) = zdU+zdV !<-- zsh2 = Km ( ( du/dz )^2 + ( dv/dz )^2 )
- END DO
+ END_1D
END DO
!
! Compute brunt-vaisala frequency
DO jk = 2, jpkam1
- DO ji = 1,jpi
+ DO_1Di( 0, 0 )
zcff = grav * itvref / e3w_abl( jk )
zcff1 = tq_abl( ji, jj, jk+1, tind, jp_ta) - tq_abl( ji, jj, jk , tind, jp_ta)
zcff2 = tq_abl( ji, jj, jk+1, tind, jp_ta) * tq_abl( ji, jj, jk+1, tind, jp_qa) &
& - tq_abl( ji, jj, jk , tind, jp_ta) * tq_abl( ji, jj, jk , tind, jp_qa)
zbn2(ji,jj,jk) = zcff * ( zcff1 + rctv0 * zcff2 ) !<-- zbn2 defined on (2,jpi)
- END DO
+ END_1D
END DO
!
! Terms for the tridiagonal problem
DO jk = 2, jpkam1
- DO ji = 1, jpi
+ DO_1Di( 0, 0 )
zshear = zsh2( ji, jk ) ! zsh2 is already multiplied by Avm_abl at this point
zsh2(ji,jk) = zsh2( ji, jk ) / Avm_abl( ji, jj, jk ) ! reformulate zsh2 as a 'true' vertical shear for PBLH computation
zbuoy = - Avt_abl( ji, jj, jk ) * zbn2( ji, jj, jk )
@@ -773,10 +734,10 @@ CONTAINS
& - e3w_abl(jk) * rDt_abl * zbuoy
tke_abl( ji, jj, jk, nt_a ) = e3w_abl(jk) * ( tke_abl( ji, jj, jk, nt_n ) + rDt_abl * zshear ) ! right-hand-side
END IF
- END DO
+ END_1D
END DO
- DO ji = 1,jpi ! vector opt.
+ DO_1Di( 0, 0 )
zesrf = MAX( rn_Esfc * ustar2(ji,jj), tke_min )
zetop = tke_min
@@ -805,44 +766,41 @@ CONTAINS
!!
!! Matrix inversion
!! ----------------------------------------------------------
- DO ji = 1,jpi
+ DO_1Di( 0, 0 )
zcff = 1._wp / z_elem_b( ji, 1 )
zCF (ji, 1 ) = - zcff * z_elem_c( ji, 1 )
tke_abl(ji,jj,1,nt_a) = zcff * tke_abl ( ji, jj, 1, nt_a )
- END DO
+ END_1D
DO jk = 2, jpka
- DO ji = 1,jpi
+ DO_1Di( 0, 0 )
zcff = 1._wp / ( z_elem_b( ji, jk ) + z_elem_a( ji, jk ) * zCF(ji, jk-1 ) )
zCF(ji,jk) = - zcff * z_elem_c( ji, jk )
tke_abl(ji,jj,jk,nt_a) = zcff * ( tke_abl(ji,jj,jk ,nt_a) &
& - z_elem_a(ji, jk) * tke_abl(ji,jj,jk-1,nt_a) )
- END DO
+ END_1D
END DO
DO jk = jpkam1,1,-1
- DO ji = 1,jpi
+ DO_1Di( 0, 0 )
tke_abl(ji,jj,jk,nt_a) = tke_abl(ji,jj,jk,nt_a) + zCF(ji,jk) * tke_abl(ji,jj,jk+1,nt_a)
- END DO
+ END_1D
END DO
-!!FL should not be needed because of Patankar procedure
- tke_abl(2:jpi,jj,1:jpka,nt_a) = MAX( tke_abl(2:jpi,jj,1:jpka,nt_a), tke_min )
+ !!FL should not be needed because of Patankar procedure
+ tke_abl(A2D(0),1:jpka,nt_a) = MAX( tke_abl(A2D(0),1:jpka,nt_a), tke_min )
!!
!! Diagnose PBL height
!! ----------------------------------------------------------
-
-
- !
! arrays zRH, zFC and zCF are available at this point
! and zFC(:, 1 ) = 0.
! diagnose PBL height based on zsh2 and zbn2
zFC ( : ,1) = 0._wp
- ikbl( 1:jpi ) = 0
+ ikbl( A1Di(0) ) = 0
DO jk = 2,jpka
- DO ji = 1, jpi
+ DO_1Di( 0, 0 )
zcff = ghw_abl( jk-1 )
zcff1 = zcff / ( zcff + rn_epssfc * pblh ( ji, jj ) )
zcff = ghw_abl( jk )
@@ -854,11 +812,11 @@ CONTAINS
- rn_Cek * ( fft_abl( ji, jj ) * fft_abl( ji, jj ) ) ) &
& )
IF( ikbl(ji) == 0 .and. zFC( ji, jk ).lt.0._wp ) ikbl(ji)=jk
- END DO
+ END_1D
END DO
!
! finalize the computation of the PBL height
- DO ji = 1, jpi
+ DO_1Di( 0, 0 )
jk = ikbl(ji)
IF( jk > 2 ) THEN ! linear interpolation to get subgrid value of pblh
pblh( ji, jj ) = ( ghw_abl( jk-1 ) * zFC( ji, jk ) &
@@ -869,16 +827,16 @@ CONTAINS
ELSE
pblh( ji, jj ) = ghw_abl(jpka)
END IF
- END DO
+ END_1D
!-------------
END DO
!-------------
!
! Optional : could add pblh smoothing if pblh is noisy horizontally ...
IF(ln_smth_pblh) THEN
- CALL lbc_lnk( 'ablmod', pblh, 'T', 1.0_wp) !, kfillmode = jpfillnothing)
- CALL smooth_pblh( pblh, msk_abl )
- CALL lbc_lnk( 'ablmod', pblh, 'T', 1.0_wp) !, kfillmode = jpfillnothing)
+ CALL lbc_lnk( 'ablmod', pblh, 'T', 1.0_wp )
+ CALL smooth_pblh( pblh, tmask(A2D(0),1) )
+ CALL lbc_lnk( 'ablmod', pblh, 'T', 1.0_wp )
ENDIF
! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
! ! Diagnostic mixing length computation
@@ -889,55 +847,55 @@ CONTAINS
CASE ( 0 ) ! Deardroff 80 length-scale bounded by the distance to surface and bottom
# define zlup zRH
# define zldw zFC
- DO jj = 1, jpj ! outer loop
+ DO_1Dj(0,0) ! outer loop
!
- DO ji = 1, jpi
+ DO_1Di(0,0)
mxld_abl( ji, jj, 1 ) = mxl_min
mxld_abl( ji, jj, jpka ) = mxl_min
mxlm_abl( ji, jj, 1 ) = mxl_min
mxlm_abl( ji, jj, jpka ) = mxl_min
zldw ( ji, 1 ) = zrough(ji,jj) * rn_Lsfc
zlup ( ji, jpka ) = mxl_min
- END DO
+ END_1D
!
DO jk = 2, jpkam1
- DO ji = 1, jpi
+ DO_1Di(0,0)
zbuoy = MAX( zbn2(ji, jj, jk), rsmall )
mxlm_abl( ji, jj, jk ) = MAX( mxl_min, &
& SQRT( 2._wp * tke_abl( ji, jj, jk, nt_a ) / zbuoy ) )
- END DO
+ END_1D
END DO
!
! Limit mxl
DO jk = jpkam1,1,-1
- DO ji = 1, jpi
+ DO_1Di(0,0)
zlup(ji,jk) = MIN( zlup(ji,jk+1) + (ghw_abl(jk+1)-ghw_abl(jk)) , mxlm_abl(ji, jj, jk) )
- END DO
+ END_1D
END DO
!
DO jk = 2, jpka
- DO ji = 1, jpi
+ DO_1Di(0,0)
zldw(ji,jk) = MIN( zldw(ji,jk-1) + (ghw_abl(jk)-ghw_abl(jk-1)) , mxlm_abl(ji, jj, jk) )
- END DO
+ END_1D
END DO
!
! DO jk = 1, jpka
-! DO ji = 1, jpi
+! DO_1Di(0,0)
! mxlm_abl( ji, jj, jk ) = SQRT( zldw( ji, jk ) * zlup( ji, jk ) )
! mxld_abl( ji, jj, jk ) = MIN ( zldw( ji, jk ), zlup( ji, jk ) )
-! END DO
+! END_1D
! END DO
!
DO jk = 1, jpka
- DO ji = 1, jpi
+ DO_1Di(0,0)
! zcff = 2.*SQRT(2.)*( zldw( ji, jk )**(-2._wp/3._wp) + zlup( ji, jk )**(-2._wp/3._wp) )**(-3._wp/2._wp)
zcff = SQRT( zldw( ji, jk ) * zlup( ji, jk ) )
mxlm_abl( ji, jj, jk ) = MAX( zcff, mxl_min )
mxld_abl( ji, jj, jk ) = MAX( MIN( zldw( ji, jk ), zlup( ji, jk ) ), mxl_min )
- END DO
+ END_1D
END DO
!
- END DO
+ END_1D ! outer loop
# undef zlup
# undef zldw
!
@@ -945,18 +903,18 @@ CONTAINS
CASE ( 1 ) ! Modified Deardroff 80 length-scale bounded by the distance to surface and bottom
# define zlup zRH
# define zldw zFC
- DO jj = 1, jpj ! outer loop
+ DO_1Dj( 0, 0 ) ! outer loop
!
DO jk = 2, jpkam1
- DO ji = 1,jpi
- zcff = 1.0_wp / e3w_abl( jk )**2
+ DO_1Di( 0, 0 )
+ zcff = 1.0_wp / e3w_abl( jk )**2
zdU = zcff* (u_abl( ji, jj, jk+1, tind)-u_abl( ji, jj, jk , tind) )**2
zdV = zcff* (v_abl( ji, jj, jk+1, tind)-v_abl( ji, jj, jk , tind) )**2
zsh2(ji,jk) = SQRT(zdU+zdV) !<-- zsh2 = SQRT ( ( du/dz )^2 + ( dv/dz )^2 )
- ENDDO
- ENDDO
- !
- DO ji = 1, jpi
+ END_1D
+ END DO
+ !
+ DO_1Di( 0, 0 )
zcff = zrough(ji,jj) * rn_Lsfc
mxld_abl ( ji, jj, 1 ) = zcff
mxld_abl ( ji, jj, jpka ) = mxl_min
@@ -964,42 +922,42 @@ CONTAINS
mxlm_abl ( ji, jj, jpka ) = mxl_min
zldw ( ji, 1 ) = zcff
zlup ( ji, jpka ) = mxl_min
- END DO
+ END_1D
!
DO jk = 2, jpkam1
- DO ji = 1, jpi
+ DO_1Di( 0, 0 )
zbuoy = MAX( zbn2(ji, jj, jk), rsmall )
zcff = 2.0_wp*SQRT(tke_abl( ji, jj, jk, nt_a )) / ( rn_Rod*zsh2(ji,jk) &
& + SQRT(rn_Rod*rn_Rod*zsh2(ji,jk)*zsh2(ji,jk)+2.0_wp*zbuoy ) )
mxlm_abl( ji, jj, jk ) = MAX( mxl_min, zcff )
- END DO
+ END_1D
END DO
!
! Limit mxl
DO jk = jpkam1,1,-1
- DO ji = 1, jpi
+ DO_1Di( 0, 0 )
zlup(ji,jk) = MIN( zlup(ji,jk+1) + (ghw_abl(jk+1)-ghw_abl(jk)) , mxlm_abl(ji, jj, jk) )
- END DO
+ END_1D
END DO
!
DO jk = 2, jpka
- DO ji = 1, jpi
+ DO_1Di( 0, 0 )
zldw(ji,jk) = MIN( zldw(ji,jk-1) + (ghw_abl(jk)-ghw_abl(jk-1)) , mxlm_abl(ji, jj, jk) )
- END DO
+ END_1D
END DO
!
DO jk = 1, jpka
- DO ji = 1, jpi
+ DO_1Di( 0, 0 )
!mxlm_abl( ji, jj, jk ) = SQRT( zldw( ji, jk ) * zlup( ji, jk ) )
!zcff = 2.*SQRT(2.)*( zldw( ji, jk )**(-2._wp/3._wp) + zlup( ji, jk )**(-2._wp/3._wp) )**(-3._wp/2._wp)
zcff = SQRT( zldw( ji, jk ) * zlup( ji, jk ) )
mxlm_abl( ji, jj, jk ) = MAX( zcff, mxl_min )
!mxld_abl( ji, jj, jk ) = MIN( zldw( ji, jk ), zlup( ji, jk ) )
mxld_abl( ji, jj, jk ) = MAX( MIN( zldw( ji, jk ), zlup( ji, jk ) ), mxl_min )
- END DO
+ END_1D
END DO
- !
- END DO
+ !
+ END_1D ! outer loop
# undef zlup
# undef zldw
!
@@ -1009,35 +967,35 @@ CONTAINS
# define zldw zFC
! zCF is used for matrix inversion
!
- DO jj = 1, jpj ! outer loop
+ DO_1Dj( 0, 0 ) ! outer loop
- DO ji = 1, jpi
+ DO_1Di( 0, 0 )
zcff = zrough(ji,jj) * rn_Lsfc
zlup( ji, 1 ) = zcff
zldw( ji, 1 ) = zcff
zlup( ji, jpka ) = mxl_min
zldw( ji, jpka ) = mxl_min
- END DO
+ END_1D
DO jk = 2,jpka-1
- DO ji = 1, jpi
+ DO_1Di( 0, 0 )
zlup(ji,jk) = ghw_abl(jpka) - ghw_abl(jk)
zldw(ji,jk) = ghw_abl(jk ) - ghw_abl( 1)
- END DO
+ END_1D
END DO
!!
!! BL89 search for lup
!! ----------------------------------------------------------
DO jk=2,jpka-1
!
- DO ji = 1, jpi
+ DO_1Di( 0, 0 )
zCF(ji,1:jpka) = 0._wp
zCF(ji, jk ) = - tke_abl( ji, jj, jk, nt_a )
ln_foundl(ji ) = .false.
- END DO
+ END_1D
!
DO jkup=jk+1,jpka-1
- DO ji = 1, jpi
+ DO_1Di( 0, 0 )
zbuoy1 = MAX( zbn2(ji,jj,jkup ), rsmall )
zbuoy2 = MAX( zbn2(ji,jj,jkup-1), rsmall )
zCF (ji,jkup) = zCF (ji,jkup-1) + 0.5_wp * e3t_abl(jkup) * &
@@ -1052,7 +1010,7 @@ CONTAINS
zlup(ji,jk) = ghw_abl(jkup ) - ghw_abl(jk)
ln_foundl(ji) = .true.
END IF
- END DO
+ END_1D
END DO
!
END DO
@@ -1061,14 +1019,14 @@ CONTAINS
!! ----------------------------------------------------------
DO jk=2,jpka-1
!
- DO ji = 1, jpi
+ DO_1Di( 0, 0 )
zCF(ji,1:jpka) = 0._wp
zCF(ji, jk ) = - tke_abl( ji, jj, jk, nt_a )
ln_foundl(ji ) = .false.
- END DO
+ END_1D
!
DO jkdwn=jk-1,1,-1
- DO ji = 1, jpi
+ DO_1Di( 0, 0 )
zbuoy1 = MAX( zbn2(ji,jj,jkdwn+1), rsmall )
zbuoy2 = MAX( zbn2(ji,jj,jkdwn ), rsmall )
zCF (ji,jkdwn) = zCF (ji,jkdwn+1) + 0.5_wp * e3t_abl(jkdwn+1) &
@@ -1083,21 +1041,21 @@ CONTAINS
zldw(ji,jk) = ghw_abl(jk) - ghw_abl(jkdwn )
ln_foundl(ji) = .true.
END IF
- END DO
+ END_1D
END DO
!
END DO
DO jk = 1, jpka
- DO ji = 1, jpi
+ DO_1Di( 0, 0 )
!zcff = 2.*SQRT(2.)*( zldw( ji, jk )**(-2._wp/3._wp) + zlup( ji, jk )**(-2._wp/3._wp) )**(-3._wp/2._wp)
zcff = SQRT( zldw( ji, jk ) * zlup( ji, jk ) )
mxlm_abl( ji, jj, jk ) = MAX( zcff, mxl_min )
mxld_abl( ji, jj, jk ) = MAX( MIN( zldw( ji, jk ), zlup( ji, jk ) ), mxl_min )
- END DO
+ END_1D
END DO
- END DO
+ END_1D ! outer loop
# undef zlup
# undef zldw
!
@@ -1107,46 +1065,46 @@ CONTAINS
# define zldw zFC
! zCF is used for matrix inversion
!
- DO jj = 1, jpj ! outer loop
+ DO_1Dj( 0, 0 ) ! outer loop
!
DO jk = 2, jpkam1
- DO ji = 1,jpi
+ DO_1Di( 0, 0 )
zcff = 1.0_wp / e3w_abl( jk )**2
zdU = zcff* (u_abl( ji, jj, jk+1, tind)-u_abl( ji, jj, jk , tind) )**2
zdV = zcff* (v_abl( ji, jj, jk+1, tind)-v_abl( ji, jj, jk , tind) )**2
zsh2(ji,jk) = SQRT(zdU+zdV) !<-- zsh2 = SQRT ( ( du/dz )^2 + ( dv/dz )^2 )
- ENDDO
- ENDDO
+ END_1D
+ ENDDO
zsh2(:, 1) = zsh2( :, 2)
zsh2(:, jpka) = zsh2( :, jpkam1)
- DO ji = 1, jpi
- zcff = zrough(ji,jj) * rn_Lsfc
- zlup( ji, 1 ) = zcff
- zldw( ji, 1 ) = zcff
- zlup( ji, jpka ) = mxl_min
- zldw( ji, jpka ) = mxl_min
- END DO
+ DO_1Di( 0, 0 )
+ zcff = zrough(ji,jj) * rn_Lsfc
+ zlup( ji, 1 ) = zcff
+ zldw( ji, 1 ) = zcff
+ zlup( ji, jpka ) = mxl_min
+ zldw( ji, jpka ) = mxl_min
+ END_1D
DO jk = 2,jpka-1
- DO ji = 1, jpi
+ DO_1Di( 0, 0 )
zlup(ji,jk) = ghw_abl(jpka) - ghw_abl(jk)
zldw(ji,jk) = ghw_abl(jk ) - ghw_abl( 1)
- END DO
+ END_1D
END DO
!!
!! BL89 search for lup
!! ----------------------------------------------------------
DO jk=2,jpka-1
!
- DO ji = 1, jpi
+ DO_1Di( 0, 0 )
zCF(ji,1:jpka) = 0._wp
zCF(ji, jk ) = - tke_abl( ji, jj, jk, nt_a )
ln_foundl(ji ) = .false.
- END DO
+ END_1D
!
DO jkup=jk+1,jpka-1
- DO ji = 1, jpi
+ DO_1Di( 0, 0 )
zbuoy1 = MAX( zbn2(ji,jj,jkup ), rsmall )
zbuoy2 = MAX( zbn2(ji,jj,jkup-1), rsmall )
zCF (ji,jkup) = zCF (ji,jkup-1) + 0.5_wp * e3t_abl(jkup) * &
@@ -1165,7 +1123,7 @@ CONTAINS
zlup(ji,jk) = ghw_abl(jkup ) - ghw_abl(jk)
ln_foundl(ji) = .true.
END IF
- END DO
+ END_1D
END DO
!
END DO
@@ -1174,14 +1132,14 @@ CONTAINS
!! ----------------------------------------------------------
DO jk=2,jpka-1
!
- DO ji = 1, jpi
+ DO_1Di( 0, 0 )
zCF(ji,1:jpka) = 0._wp
zCF(ji, jk ) = - tke_abl( ji, jj, jk, nt_a )
ln_foundl(ji ) = .false.
- END DO
+ END_1D
!
DO jkdwn=jk-1,1,-1
- DO ji = 1, jpi
+ DO_1Di( 0, 0 )
zbuoy1 = MAX( zbn2(ji,jj,jkdwn+1), rsmall )
zbuoy2 = MAX( zbn2(ji,jj,jkdwn ), rsmall )
zCF (ji,jkdwn) = zCF (ji,jkdwn+1) + 0.5_wp * e3t_abl(jkdwn+1) &
@@ -1200,18 +1158,18 @@ CONTAINS
zldw(ji,jk) = ghw_abl(jk) - ghw_abl(jkdwn )
ln_foundl(ji) = .true.
END IF
- END DO
+ END_1D
END DO
!
END DO
DO jk = 1, jpka
- DO ji = 1, jpi
+ DO_1Di( 0, 0 )
!zcff = 2.*SQRT(2.)*( zldw( ji, jk )**(-2._wp/3._wp) + zlup( ji, jk )**(-2._wp/3._wp) )**(-3._wp/2._wp)
zcff = SQRT( zldw( ji, jk ) * zlup( ji, jk ) )
mxlm_abl( ji, jj, jk ) = MAX( zcff, mxl_min )
mxld_abl( ji, jj, jk ) = MAX( MIN( zldw( ji, jk ), zlup( ji, jk ) ), mxl_min )
- END DO
+ END_1D
END DO
END DO
@@ -1225,10 +1183,10 @@ CONTAINS
! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
!-------------
- DO jj = 1, jpj ! outer loop
+ DO_1Dj( 0, 0 ) ! outer loop
!-------------
DO jk = 1, jpka
- DO ji = 1, jpi ! vector opt.
+ DO_1Di( 0, 0 )
zcff = MAX( rn_phimax, rn_Ric * mxlm_abl( ji, jj, jk ) * mxld_abl( ji, jj, jk ) &
& * MAX( zbn2(ji, jj, jk), rsmall ) / tke_abl( ji, jj, jk, nt_a ) )
zcff2 = 1. / ( 1. + zcff ) !<-- phi_z(z)
@@ -1236,10 +1194,10 @@ CONTAINS
!!FL: MAX function probably useless because of the definition of mxl_min
Avm_abl( ji, jj, jk ) = MAX( rn_Cm * zcff , avm_bak )
Avt_abl( ji, jj, jk ) = MAX( rn_Ct * zcff * zcff2 , avt_bak )
- END DO
+ END_1D
END DO
!-------------
- END DO
+ END_1D ! outer loop
!-------------
!---------------------------------------------------------------------------------------------------
@@ -1257,46 +1215,47 @@ CONTAINS
!! ** Purpose : 2D Hanning filter on atmospheric PBL height
!!
!! ---------------------------------------------------------------------
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: msk
- REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pvar2d
- INTEGER :: ji,jj
- REAL(wp) :: smth_a, smth_b
- REAL(wp), DIMENSION(jpi,jpj) :: zdX,zdY,zFX,zFY
- REAL(wp) :: zumsk,zvmsk
- !!
+
+ REAL(wp), DIMENSION(A2D(1)), INTENT(in ) :: msk
+ REAL(wp), DIMENSION(A2D(1)), INTENT(inout) :: pvar2d
+ INTEGER :: ji,jj
+ REAL(wp) :: smth_a, smth_b
+ REAL(wp), DIMENSION(A2D(1)) :: zdX,zdY,zFX,zFY
+ REAL(wp) :: zumsk,zvmsk
+
!!=========================================================
!!
!! Hanning filter
smth_a = 1._wp / 8._wp
smth_b = 1._wp / 4._wp
!
- DO_2D( nn_hls, nn_hls-1, nn_hls, nn_hls )
+ DO_2D( 1, 0, 1, 1 )
zumsk = msk(ji,jj) * msk(ji+1,jj)
zdX ( ji, jj ) = ( pvar2d( ji+1,jj ) - pvar2d( ji ,jj ) ) * zumsk
END_2D
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls-1 )
+ DO_2D( 1, 1, 1, 0 )
zvmsk = msk(ji,jj) * msk(ji,jj+1)
zdY ( ji, jj ) = ( pvar2d( ji, jj+1 ) - pvar2d( ji ,jj ) ) * zvmsk
END_2D
- DO_2D( nn_hls-1, nn_hls-1, nn_hls, nn_hls-1 )
+ DO_2D( 0, 0, 1, 0 )
zFY ( ji, jj ) = zdY ( ji, jj ) &
- & + smth_a* ( (zdX ( ji, jj+1 ) - zdX( ji-1, jj+1 )) &
+ & + smth_a* ( (zdX ( ji, jj+1 ) - zdX( ji-1, jj+1 )) & ! add () for NP repro
& - (zdX ( ji, jj ) - zdX( ji-1, jj )) )
END_2D
- DO_2D( nn_hls, nn_hls-1, nn_hls-1, nn_hls-1 )
+ DO_2D( 1, 0, 0, 0 )
zFX( ji, jj ) = zdX( ji, jj ) &
- & + smth_a*( (zdY( ji+1, jj ) - zdY( ji+1, jj-1)) &
+ & + smth_a*( (zdY( ji+1, jj ) - zdY( ji+1, jj-1)) & ! add () for NP repro
& - (zdY( ji , jj ) - zdY( ji , jj-1)) )
END_2D
- DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 )
+ DO_2D( 0, 0, 0, 0 )
pvar2d( ji ,jj ) = pvar2d( ji ,jj ) &
& + msk(ji,jj) * smth_b * ( &
- & zFX( ji, jj ) - zFX( ji-1, jj ) &
- & +zFY( ji, jj ) - zFY( ji, jj-1 ) )
+ & ( zFX( ji, jj ) - zFX( ji-1, jj ) ) & ! add () for NP repro
+ & + ( zFY( ji, jj ) - zFY( ji, jj-1 ) ) )
END_2D
!---------------------------------------------------------------------------------------------------
diff --git a/src/ABL/ablrst.F90 b/src/ABL/ablrst.F90
index 925234b3e73663d1aeeba26e750649f20f3ab062..de4172974cef6032d7050d3aca32e655e31caf07 100644
--- a/src/ABL/ablrst.F90
+++ b/src/ABL/ablrst.F90
@@ -202,12 +202,12 @@ CONTAINS
! --- mandatory fields --- !
CALL iom_get( numrar, jpdom_auto, 'u_abl', u_abl(:,:,:,nt_n ), cd_type = 'T', psgn = -1._wp )
CALL iom_get( numrar, jpdom_auto, 'v_abl', v_abl(:,:,:,nt_n ), cd_type = 'T', psgn = -1._wp )
- CALL iom_get( numrar, jpdom_auto, 't_abl', tq_abl(:,:,:,nt_n,jp_ta), kfill = jpfillcopy )
+ CALL iom_get( numrar, jpdom_auto, 't_abl', tq_abl(:,:,:,nt_n,jp_ta) ) !, kfill = jpfillcopy )
CALL iom_get( numrar, jpdom_auto, 'q_abl', tq_abl(:,:,:,nt_n,jp_qa) )
CALL iom_get( numrar, jpdom_auto, 'tke_abl', tke_abl(:,:,:,nt_n ) )
- CALL iom_get( numrar, jpdom_auto, 'avm_abl', avm_abl(:,:,: ), kfill = jpfillcopy )
+ CALL iom_get( numrar, jpdom_auto, 'avm_abl', avm_abl(:,:,: ) ) !, kfill = jpfillcopy )
CALL iom_get( numrar, jpdom_auto, 'avt_abl', avt_abl(:,:,: ) )
- CALL iom_get( numrar, jpdom_auto,'mxld_abl',mxld_abl(:,:,: ), kfill = jpfillcopy )
+ CALL iom_get( numrar, jpdom_auto,'mxld_abl',mxld_abl(:,:,: ) ) !, kfill = jpfillcopy )
CALL iom_get( numrar, jpdom_auto, 'pblh', pblh(:,: ), kfill = jpfillcopy )
IF(.NOT.lrxios) CALL iom_delay_rst( 'READ', 'ABL', numrar ) ! read only abl delayed global communication variables
diff --git a/src/ABL/sbcabl.F90 b/src/ABL/sbcabl.F90
index c3977c5b02f79d31a5d422be44c20ffd1db8cf79..f4ac4657b3e061b336fdaaa2f35a30c451ef4bc9 100644
--- a/src/ABL/sbcabl.F90
+++ b/src/ABL/sbcabl.F90
@@ -44,6 +44,8 @@ MODULE sbcabl
PUBLIC sbc_abl_init ! routine called in sbcmod module
PUBLIC sbc_abl ! routine called in sbcmod module
+ !! * Substitutions
+# include "do_loop_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OPA 3.7 , NEMO-consortium (2014)
!! $Id: sbcabl.F90 6416 2016-04-01 12:22:17Z clem $
@@ -259,7 +261,7 @@ CONTAINS
rest_eq(:,:) = 1._wp
END IF
! T-mask
- msk_abl(:,:) = tmask(:,:,1)
+ msk_abl(:,:) = tmask(A2D(0),1)
!!-------------------------------------------------------------------------------------------
@@ -307,8 +309,8 @@ CONTAINS
!! - Perform 1 time-step of the ABL model
!! - Finalize flux computation in blk_oce_2
!!
- !! ** Outputs : - utau : i-component of the stress at U-point (N/m2)
- !! - vtau : j-component of the stress at V-point (N/m2)
+ !! ** Outputs : - utau : i-component of the stress at T-point (N/m2)
+ !! - vtau : j-component of the stress at T-point (N/m2)
!! - taum : Wind stress module at T-point (N/m2)
!! - wndm : Wind speed module at T-point (m/s)
!! - qsr : Solar heat flux over the ocean (W/m2)
@@ -318,9 +320,11 @@ CONTAINS
!!---------------------------------------------------------------------
INTEGER , INTENT(in) :: kt ! ocean time step
!!
- REAL(wp), DIMENSION(jpi,jpj) :: zssq, zcd_du, zsen, zlat, zevp
+ !REAL(wp), DIMENSION(jpi,jpj) :: zssq, zcd_du, zsen, zlat, zevp
+ REAL(wp), DIMENSION(A2D(0)) :: zssq, zcd_du, zsen, zlat, zevp
#if defined key_si3
- REAL(wp), DIMENSION(jpi,jpj) :: zssqi, zcd_dui, zseni, zevpi
+ !REAL(wp), DIMENSION(jpi,jpj) :: zssqi, zcd_dui, zseni, zevpi
+ REAL(wp), DIMENSION(A2D(0)) :: zssqi, zcd_dui, zseni, zevpi
#endif
INTEGER :: jbak, jbak_dta, ji, jj
!!---------------------------------------------------------------------
@@ -339,7 +343,7 @@ CONTAINS
CALL blk_oce_1( kt, u_abl(:,:,2,nt_n ), v_abl(:,:,2,nt_n ), & ! <<= in
& tq_abl(:,:,2,nt_n,jp_ta), tq_abl(:,:,2,nt_n,jp_qa), & ! <<= in
- & sf(jp_slp )%fnow(:,:,1) , sst_m, ssu_m, ssv_m , & ! <<= in
+ & sf(jp_slp )%fnow(:,:,1) , sst_m(A2D(0)), ssu_m(A2D(0)), ssv_m(A2D(0)), & ! <<= in
& sf(jp_uoatm)%fnow(:,:,1), sf(jp_voatm)%fnow(:,:,1), & ! <<= in
& sf(jp_qsr )%fnow(:,:,1) , sf(jp_qlw )%fnow(:,:,1) , & ! <<= in
& tsk_m, zssq, zcd_du, zsen, zlat, zevp ) ! =>> out
@@ -347,7 +351,7 @@ CONTAINS
#if defined key_si3
CALL blk_ice_1( u_abl(:,:,2,nt_n ), v_abl(:,:,2,nt_n ), & ! <<= in
& tq_abl(:,:,2,nt_n,jp_ta), tq_abl(:,:,2,nt_n,jp_qa), & ! <<= in
- & sf(jp_slp)%fnow(:,:,1) , u_ice, v_ice, tm_su , & ! <<= in
+ & sf(jp_slp)%fnow(:,:,1) , tm_su(:,:) , & ! <<= in
& pseni=zseni, pevpi=zevpi, pssqi=zssqi, pcd_dui=zcd_dui ) ! <<= out
#endif
@@ -355,7 +359,7 @@ CONTAINS
!! 3 - Advance ABL variables from now (n) to after (n+1)
!!-------------------------------------------------------------------------------------------
- CALL abl_stp( kt, tsk_m, ssu_m, ssv_m, zssq, & ! <<= in
+ CALL abl_stp( kt, tsk_m(A2D(0)), ssu_m, ssv_m, zssq, & ! <<= in
& sf(jp_wndi)%fnow(:,:,:), sf(jp_wndj)%fnow(:,:,:), & ! <<= in
& sf(jp_tair)%fnow(:,:,:), sf(jp_humi)%fnow(:,:,:), & ! <<= in
& sf(jp_slp )%fnow(:,:,1), & ! <<= in
@@ -364,7 +368,7 @@ CONTAINS
& zlat, wndm, utau, vtau, taum & ! =>> out
#if defined key_si3
& , tm_su, u_ice, v_ice, zssqi, zcd_dui & ! <<= in
- & , zseni, zevpi, wndm_ice, ato_i & ! <<= in
+ & , zseni, zevpi, wndm_ice, ato_i(A2D(0)) & ! <<= in
& , utau_ice, vtau_ice & ! =>> out
#endif
& )
diff --git a/src/ICE/ice.F90 b/src/ICE/ice.F90
index 67bce2c4ae0e5ab22daceb6760abbceef7a2ef66..1eb9d9943214f7a294fb9381f440d996ee0b059b 100644
--- a/src/ICE/ice.F90
+++ b/src/ICE/ice.F90
@@ -257,7 +257,6 @@ MODULE ice
REAL(wp), PUBLIC :: r1_Dt_ice !: = 1. / rDt_ice
REAL(wp), PUBLIC :: r1_nlay_i !: 1 / nlay_i
REAL(wp), PUBLIC :: r1_nlay_s !: 1 / nlay_s
- REAL(wp), PUBLIC :: rswitch !: switch for the presence of ice (1) or not (0)
REAL(wp), PUBLIC :: rdiag_v, rdiag_s, rdiag_t, rdiag_fv, rdiag_fs, rdiag_ft !: conservation diagnostics
REAL(wp), PUBLIC, PARAMETER :: epsi06 = 1.e-06_wp !: small number
REAL(wp), PUBLIC, PARAMETER :: epsi10 = 1.e-10_wp !: small number
@@ -451,6 +450,8 @@ MODULE ice
REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: qcn_ice_bot !: Bottom conduction flux (W/m2)
REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: qcn_ice_top !: Surface conduction flux (W/m2)
!
+ !! * Substitutions
+# include "do_loop_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/ICE 4.0 , NEMO Consortium (2018)
!! $Id: ice.F90 15388 2021-10-17 11:33:47Z clem $
@@ -464,71 +465,99 @@ CONTAINS
!!-----------------------------------------------------------------
INTEGER :: ice_alloc
!
- INTEGER :: ierr(16), ii
+ INTEGER :: ierr(21), ii
!!-----------------------------------------------------------------
ierr(:) = 0
-
- ii = 1
- ALLOCATE( u_oce (jpi,jpj) , v_oce (jpi,jpj) , ht_i_new (jpi,jpj) , fraz_frac (jpi,jpj) , &
- & strength (jpi,jpj) , stress1_i(jpi,jpj) , stress2_i(jpi,jpj) , stress12_i(jpi,jpj) , &
- & delta_i (jpi,jpj) , divu_i (jpi,jpj) , shear_i (jpi,jpj) , &
- & aniso_11 (jpi,jpj) , aniso_12 (jpi,jpj) , rdg_conv (jpi,jpj) , STAT=ierr(ii) )
+ ii = 0
+ ! ----------------- !
+ ! == FULL ARRAYS == !
+ ! ----------------- !
+
+ ! * Ice global state variables
+ ii = ii + 1
+ ALLOCATE( u_ice(jpi,jpj) , v_ice(jpi,jpj) , STAT=ierr(ii) )
ii = ii + 1
- ALLOCATE( t_bo (jpi,jpj) , wfx_snw_sni(jpi,jpj) , &
- & wfx_snw (jpi,jpj) , wfx_snw_dyn(jpi,jpj) , wfx_snw_sum(jpi,jpj) , wfx_snw_sub(jpi,jpj) , &
- & wfx_ice (jpi,jpj) , wfx_sub (jpi,jpj) , wfx_ice_sub(jpi,jpj) , wfx_lam (jpi,jpj) , &
- & wfx_pnd (jpi,jpj) , &
- & wfx_bog (jpi,jpj) , wfx_dyn (jpi,jpj) , wfx_bom(jpi,jpj) , wfx_sum(jpi,jpj) , &
- & wfx_res (jpi,jpj) , wfx_sni (jpi,jpj) , wfx_opw(jpi,jpj) , wfx_spr(jpi,jpj) , &
- & rn_amax_2d (jpi,jpj) , &
- & qsb_ice_bot(jpi,jpj) , qlead (jpi,jpj) , &
- & sfx_res (jpi,jpj) , sfx_bri (jpi,jpj) , sfx_dyn(jpi,jpj) , sfx_sub(jpi,jpj) , sfx_lam(jpi,jpj) , &
- & sfx_bog (jpi,jpj) , sfx_bom (jpi,jpj) , sfx_sum(jpi,jpj) , sfx_sni(jpi,jpj) , sfx_opw(jpi,jpj) , &
- & hfx_res (jpi,jpj) , hfx_snw (jpi,jpj) , hfx_sub(jpi,jpj) , &
- & qt_atm_oi (jpi,jpj) , qt_oce_ai (jpi,jpj) , fhld (jpi,jpj) , &
- & hfx_sum (jpi,jpj) , hfx_bom (jpi,jpj) , hfx_bog(jpi,jpj) , hfx_dif(jpi,jpj) , &
- & hfx_opw (jpi,jpj) , hfx_thd (jpi,jpj) , hfx_dyn(jpi,jpj) , hfx_spr(jpi,jpj) , &
- & hfx_err_dif(jpi,jpj) , wfx_err_sub(jpi,jpj) , STAT=ierr(ii) )
+ ALLOCATE( h_i (jpi,jpj,jpl) , a_i (jpi,jpj,jpl) , v_i (jpi,jpj,jpl) , &
+ & v_s (jpi,jpj,jpl) , h_s (jpi,jpj,jpl) , &
+ & s_i (jpi,jpj,jpl) , sv_i(jpi,jpj,jpl) , o_i (jpi,jpj,jpl) , oa_i (jpi,jpj,jpl) , &
+ & a_ip (jpi,jpj,jpl) , v_ip(jpi,jpj,jpl) , h_ip(jpi,jpj,jpl), &
+ & v_il (jpi,jpj,jpl) , h_il(jpi,jpj,jpl) , &
+ & t_su (jpi,jpj,jpl) , t_s (jpi,jpj,nlay_s,jpl) , t_i(jpi,jpj,nlay_i,jpl) , sz_i(jpi,jpj,nlay_i,jpl) , &
+ & ato_i(jpi,jpj) , STAT = ierr(ii) )
- ! * Ice global state variables
ii = ii + 1
- ALLOCATE( qtr_ice_bot(jpi,jpj,jpl) , cnd_ice(jpi,jpj,jpl) , t1_ice(jpi,jpj,jpl) , &
- & h_i (jpi,jpj,jpl) , a_i (jpi,jpj,jpl) , v_i (jpi,jpj,jpl) , &
- & v_s (jpi,jpj,jpl) , h_s (jpi,jpj,jpl) , t_su (jpi,jpj,jpl) , &
- & s_i (jpi,jpj,jpl) , sv_i (jpi,jpj,jpl) , o_i (jpi,jpj,jpl) , &
- & oa_i (jpi,jpj,jpl) , bv_i (jpi,jpj,jpl) , STAT=ierr(ii) )
+ ALLOCATE( e_s(jpi,jpj,nlay_s,jpl) , e_i(jpi,jpj,nlay_i,jpl) , STAT=ierr(ii) )
+ ! * Before values of global variables
ii = ii + 1
- ALLOCATE( u_ice(jpi,jpj) , v_ice(jpi,jpj) , &
- & vt_i (jpi,jpj) , vt_s (jpi,jpj) , st_i(jpi,jpj) , at_i(jpi,jpj) , ato_i(jpi,jpj) , &
- & et_i (jpi,jpj) , et_s (jpi,jpj) , tm_i(jpi,jpj) , tm_s(jpi,jpj) , &
- & sm_i (jpi,jpj) , tm_su(jpi,jpj) , hm_i(jpi,jpj) , hm_s(jpi,jpj) , &
- & om_i (jpi,jpj) , bvm_i(jpi,jpj) , tau_icebfr(jpi,jpj), icb_mask(jpi,jpj), STAT=ierr(ii) )
+ ALLOCATE( u_ice_b(jpi,jpj) , v_ice_b(jpi,jpj) , STAT=ierr(ii) )
+
+ ! * ice rheology
+ ii = ii+1
+ ALLOCATE( u_oce (jpi,jpj) , v_oce (jpi,jpj) , &
+ & strength (jpi,jpj) , stress1_i(jpi,jpj) , stress2_i(jpi,jpj) , stress12_i(jpi,jpj) , &
+ & aniso_11 (jpi,jpj) , aniso_12 (jpi,jpj) , rdg_conv (jpi,jpj) , &
+ & icb_mask (jpi,jpj) , STAT=ierr(ii) )
+ ! * mean and total
ii = ii + 1
- ALLOCATE( t_s(jpi,jpj,nlay_s,jpl) , e_s(jpi,jpj,nlay_s,jpl) , STAT=ierr(ii) )
+ ALLOCATE( vt_i (jpi,jpj) , vt_s (jpi,jpj) , at_i (jpi,jpj) , & ! full arrays since they are used in rheology
+ & vt_ip(jpi,jpj) , vt_il(jpi,jpj) , at_ip(jpi,jpj) , STAT=ierr(ii) )
+
+ ! * others
+ ii = ii + 1
+ ALLOCATE( rn_amax_2d(jpi,jpj) , STAT=ierr(ii) )
+
+ ! -------------------- !
+ ! == REDUCED ARRAYS == !
+ ! -------------------- !
+ ! * Ice global state variables
ii = ii + 1
- ALLOCATE( t_i(jpi,jpj,nlay_i,jpl) , e_i(jpi,jpj,nlay_i,jpl) , sz_i(jpi,jpj,nlay_i,jpl) , STAT=ierr(ii) )
+ ALLOCATE( bv_i(A2D(0),jpl) , a_ip_frac(A2D(0),jpl) , a_ip_eff(A2D(0),jpl) , STAT=ierr(ii) )
+ ! * Before values of global variables
ii = ii + 1
- ALLOCATE( a_ip(jpi,jpj,jpl) , v_ip(jpi,jpj,jpl) , a_ip_frac(jpi,jpj,jpl) , h_ip(jpi,jpj,jpl), &
- & v_il(jpi,jpj,jpl) , h_il(jpi,jpj,jpl) , a_ip_eff (jpi,jpj,jpl) , &
- & dh_i_sum_2d(jpi,jpj,jpl) , dh_s_mlt_2d(jpi,jpj,jpl) , STAT = ierr(ii) )
+ ALLOCATE( at_i_b(A2D(0)) , h_i_b (A2D(0),jpl) , a_i_b(A2D(0),jpl) , v_i_b(A2D(0),jpl) , &
+ & v_s_b (A2D(0),jpl) , h_s_b (A2D(0),jpl) , &
+ & v_ip_b(A2D(0),jpl) , v_il_b(A2D(0),jpl) , &
+ & sv_i_b(A2D(0),jpl) , e_i_b (A2D(0),nlay_i,jpl) , e_s_b(A2D(0),nlay_s,jpl) , STAT=ierr(ii) )
+ ! * fluxes
+ ii = ii + 1
+ ALLOCATE( qsb_ice_bot(A2D(0)) , qlead (A2D(0)) , qt_atm_oi (A2D(0)) , qt_oce_ai (A2D(0)) , fhld (A2D(0)) , &
+ & wfx_snw_sni(A2D(0)) , wfx_snw (A2D(0)) , wfx_snw_dyn(A2D(0)) , wfx_snw_sum(A2D(0)) , wfx_snw_sub(A2D(0)) , &
+ & wfx_ice (A2D(0)) , wfx_sub (A2D(0)) , wfx_ice_sub(A2D(0)) , wfx_lam (A2D(0)) , &
+ & wfx_pnd (A2D(0)) , wfx_bog (A2D(0)) , wfx_dyn (A2D(0)) , wfx_bom (A2D(0)) , wfx_sum (A2D(0)) , &
+ & wfx_sni (A2D(0)) , wfx_opw (A2D(0)) , wfx_spr(A2D(0)) , &
+ & sfx_bri (A2D(0)) , sfx_dyn (A2D(0)) , sfx_sub(A2D(0)) , sfx_lam(A2D(0)) , &
+ & sfx_bog (A2D(0)) , sfx_bom (A2D(0)) , sfx_sum(A2D(0)) , sfx_sni(A2D(0)) , sfx_opw(A2D(0)) , &
+ & hfx_snw (A2D(0)) , hfx_sub (A2D(0)) , &
+ & hfx_sum (A2D(0)) , hfx_bom (A2D(0)) , hfx_bog(A2D(0)) , hfx_dif(A2D(0)) , &
+ & hfx_opw (A2D(0)) , hfx_thd (A2D(0)) , hfx_dyn(A2D(0)) , hfx_spr(A2D(0)) , &
+ & hfx_err_dif(A2D(0)) , wfx_err_sub(A2D(0)) , STAT=ierr(ii) )
ii = ii + 1
- ALLOCATE( at_ip(jpi,jpj) , hm_ip(jpi,jpj) , vt_ip(jpi,jpj) , hm_il(jpi,jpj) , vt_il(jpi,jpj) , STAT = ierr(ii) )
+ ALLOCATE( wfx_res(A2D(0)) , sfx_res(A2D(0)) , hfx_res(A2D(0)) , STAT=ierr(ii) )
+ ii = ii + 1
+ ALLOCATE( qtr_ice_bot(A2D(0),jpl) , cnd_ice(A2D(0),jpl) , t1_ice(A2D(0),jpl) , STAT=ierr(ii) )
+
+ ! * ice rheology
+ ii = ii+1
+ ALLOCATE( delta_i(A2D(0)) , divu_i(A2D(0)) , shear_i(A2D(0)) , STAT=ierr(ii) )
- ! * Old values of global variables
+ ! * mean and total
ii = ii + 1
- ALLOCATE( v_s_b (jpi,jpj,jpl) , v_i_b (jpi,jpj,jpl) , h_s_b(jpi,jpj,jpl) , h_i_b(jpi,jpj,jpl), &
- & v_ip_b(jpi,jpj,jpl) , v_il_b(jpi,jpj,jpl) , &
- & a_i_b (jpi,jpj,jpl) , sv_i_b(jpi,jpj,jpl) , e_i_b(jpi,jpj,nlay_i,jpl) , e_s_b(jpi,jpj,nlay_s,jpl) , &
- & STAT=ierr(ii) )
+ ALLOCATE( t_bo (A2D(0)) , st_i (A2D(0)) , et_i(A2D(0)) , et_s (A2D(0)) , hm_i (A2D(0)) , &
+ & hm_ip(A2D(0)) , hm_il(A2D(0)) , tm_i(A2D(0)) , tm_s (A2D(0)) , &
+ & sm_i (A2D(0)) , hm_s (A2D(0)) , om_i(A2D(0)) , bvm_i(A2D(0)) , &
+ & tm_su(A2D(0)) , STAT=ierr(ii) )
+ ! * others
ii = ii + 1
- ALLOCATE( u_ice_b(jpi,jpj) , v_ice_b(jpi,jpj) , at_i_b(jpi,jpj) , STAT=ierr(ii) )
+ ALLOCATE( tau_icebfr(A2D(0)) , dh_i_sum_2d(A2D(0),jpl) , dh_s_mlt_2d(A2D(0),jpl) , STAT=ierr(ii) )
+ ii = 1
+ ALLOCATE( ht_i_new (A2D(0)) , fraz_frac (A2D(0)) , STAT=ierr(ii) )
! * Ice thickness distribution variables
ii = ii + 1
@@ -536,19 +565,19 @@ CONTAINS
! * Ice diagnostics
ii = ii + 1
- ALLOCATE( diag_trp_vi(jpi,jpj) , diag_trp_vs (jpi,jpj) , diag_trp_ei(jpi,jpj), &
- & diag_trp_es(jpi,jpj) , diag_trp_sv (jpi,jpj) , diag_heat (jpi,jpj), &
- & diag_sice (jpi,jpj) , diag_vice (jpi,jpj) , diag_vsnw (jpi,jpj), diag_aice(jpi,jpj), diag_vpnd(jpi,jpj), &
- & diag_adv_mass(jpi,jpj), diag_adv_salt(jpi,jpj), diag_adv_heat(jpi,jpj), STAT=ierr(ii) )
+ ALLOCATE( diag_trp_vi (A2D(0)) , diag_trp_vs (A2D(0)) , diag_trp_ei (A2D(0)) , &
+ & diag_trp_es (A2D(0)) , diag_trp_sv (A2D(0)) , diag_heat (A2D(0)) , &
+ & diag_sice (A2D(0)) , diag_vice (A2D(0)) , diag_vsnw (A2D(0)) , diag_aice(A2D(0)) , diag_vpnd(A2D(0)) , &
+ & diag_adv_mass(A2D(0)) , diag_adv_salt(A2D(0)) , diag_adv_heat(A2D(0)) , STAT=ierr(ii) )
! * Ice conservation
ii = ii + 1
- ALLOCATE( diag_v (jpi,jpj) , diag_s (jpi,jpj) , diag_t (jpi,jpj), &
- & diag_fv(jpi,jpj) , diag_fs(jpi,jpj) , diag_ft(jpi,jpj), STAT=ierr(ii) )
+ ALLOCATE( diag_v (A2D(0)) , diag_s (A2D(0)) , diag_t (A2D(0)), &
+ & diag_fv(A2D(0)) , diag_fs(A2D(0)) , diag_ft(A2D(0)), STAT=ierr(ii) )
! * SIMIP diagnostics
ii = ii + 1
- ALLOCATE( t_si(jpi,jpj,jpl) , tm_si(jpi,jpj) , qcn_ice_bot(jpi,jpj,jpl) , qcn_ice_top(jpi,jpj,jpl) , STAT = ierr(ii) )
+ ALLOCATE( t_si(A2D(0),jpl) , tm_si(A2D(0)) , qcn_ice_bot(A2D(0),jpl) , qcn_ice_top(A2D(0),jpl) , STAT = ierr(ii) )
ice_alloc = MAXVAL( ierr(:) )
IF( ice_alloc /= 0 ) CALL ctl_stop( 'STOP', 'ice_alloc: failed to allocate arrays.' )
diff --git a/src/ICE/ice1d.F90 b/src/ICE/ice1d.F90
index 8c610bf4955f32dd4e9ec6d6ff45cca4a76c9c26..a0afce7e48e2f62ed193087c2c4f508f91de5dd7 100644
--- a/src/ICE/ice1d.F90
+++ b/src/ICE/ice1d.F90
@@ -134,9 +134,6 @@ MODULE ice1D
REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: e_i_1d !: Ice enthalpy per unit volume
REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: e_s_1d !: Snow enthalpy per unit volume
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: eh_i_old !: ice heat content (q*h, J.m-2)
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: h_i_old !: ice thickness layer (m)
-
! Conduction flux diagnostics (SIMIP)
REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: qcn_ice_bot_1d
REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: qcn_ice_top_1d
@@ -163,9 +160,13 @@ MODULE ice1D
REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: v_il_2d
REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: t_su_2d
REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: h_i_2d
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: s_i_2d
REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: a_ib_2d
REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: h_ib_2d
+
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: e_i_2d
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: e_s_2d
!!----------------------------------------------------------------------
!! NEMO/ICE 4.0 , NEMO Consortium (2018)
@@ -179,62 +180,79 @@ CONTAINS
!! *** ROUTINE ice1D_alloc ***
!!---------------------------------------------------------------------!
INTEGER :: ice1D_alloc ! return value
- INTEGER :: ierr(8), ii
+ INTEGER :: ierr(12), ii
!!---------------------------------------------------------------------!
ierr(:) = 0
+ ii = 0
+
+ ! * Ice global state variables
+ ii = ii + 1
+ ALLOCATE( nptidx (jpij) , &
+ & h_i_1d (jpij) , a_i_1d (jpij) , v_i_1d (jpij) , &
+ & v_s_1d (jpij) , h_s_1d (jpij) , &
+ & s_i_1d (jpij) , sv_i_1d(jpij) , o_i_1d (jpij) , oa_i_1d (jpij) , &
+ & a_ip_1d (jpij) , v_ip_1d(jpij) , h_ip_1d (jpij) , &
+ & v_il_1d (jpij) , h_il_1d(jpij) , &
+ & t_su_1d (jpij) , t_s_1d (jpij,nlay_s) , t_i_1d (jpij,nlay_i), sz_i_1d(jpij,nlay_i) , &
+ & ato_i_1d(jpij) , STAT=ierr(ii) )
+ ii = ii + 1
+ ALLOCATE( e_i_1d(jpij,nlay_i) , e_s_1d(jpij,nlay_s) , STAT=ierr(ii) )
- ii = 1
- ALLOCATE( nptidx (jpij) , &
- & qlead_1d (jpij) , qtr_ice_bot_1d(jpij) , qsr_ice_1d(jpij) , &
- & qns_ice_1d(jpij) , qml_ice_1d (jpij) , qcn_ice_1d(jpij) , qtr_ice_top_1d(jpij) , &
- & cnd_ice_1d(jpij) , t1_ice_1d (jpij) , t_bo_1d (jpij) , &
+ ! * Before values of global variables
+ ii = ii + 1
+ ALLOCATE( a_ib_1d (jpij) , h_ib_1d (jpij) , STAT=ierr(ii) )
+
+ ! * heat fluxes
+ ii = ii + 1
+ ALLOCATE( qsr_ice_1d (jpij) , qsb_ice_bot_1d(jpij) , qns_ice_1d (jpij) , qml_ice_1d(jpij) , &
+ & qprec_ice_1d(jpij) , dqns_ice_1d (jpij) , qlead_1d (jpij) , fhld_1d (jpij) , &
+ & qt_oce_ai_1d(jpij) , qtr_ice_bot_1d(jpij) , qtr_ice_top_1d(jpij) , &
& hfx_sum_1d(jpij) , hfx_bom_1d (jpij) , hfx_bog_1d(jpij) , &
& hfx_dif_1d(jpij) , hfx_opw_1d (jpij) , hfx_dyn_1d(jpij) , &
- & rn_amax_1d(jpij) , &
& hfx_thd_1d(jpij) , hfx_spr_1d (jpij) , &
& hfx_snw_1d(jpij) , hfx_sub_1d (jpij) , &
- & hfx_res_1d(jpij) , hfx_err_dif_1d(jpij) , qt_oce_ai_1d(jpij), STAT=ierr(ii) )
- !
+ & hfx_res_1d(jpij) , hfx_err_dif_1d(jpij) , STAT=ierr(ii) )
+ ii = ii + 1
+ ALLOCATE( qcn_ice_1d(jpij) , qcn_ice_bot_1d(jpij) , qcn_ice_top_1d(jpij) , &
+ & cnd_ice_1d(jpij) , t1_ice_1d (jpij) , STAT=ierr(ii) )
+
+ ! * mass fluxes
ii = ii + 1
- ALLOCATE( sprecip_1d (jpij) , at_i_1d (jpij) , ato_i_1d (jpij) , &
- & qsb_ice_bot_1d(jpij) , wfx_snw_sni_1d(jpij) , wfx_spr_1d (jpij) , wfx_snw_sum_1d(jpij) , &
- & fhld_1d (jpij) , wfx_sub_1d (jpij) , wfx_bog_1d (jpij) , wfx_bom_1d (jpij) , &
+ ALLOCATE( sprecip_1d (jpij) , evap_ice_1d (jpij) , &
+ & wfx_snw_sni_1d(jpij) , wfx_spr_1d (jpij) , wfx_snw_sum_1d(jpij) , &
+ & wfx_sub_1d (jpij) , wfx_bog_1d (jpij) , wfx_bom_1d (jpij) , &
& wfx_sum_1d (jpij) , wfx_sni_1d (jpij) , wfx_opw_1d (jpij) , wfx_res_1d (jpij) , &
& wfx_snw_sub_1d(jpij) , wfx_snw_dyn_1d(jpij) , wfx_ice_sub_1d(jpij) , wfx_err_sub_1d(jpij) , &
- & wfx_lam_1d (jpij) , wfx_dyn_1d (jpij) , wfx_pnd_1d (jpij) , dqns_ice_1d (jpij) , evap_ice_1d (jpij) , &
- & qprec_ice_1d (jpij) , &
- & sfx_bri_1d (jpij) , sfx_bog_1d (jpij) , sfx_bom_1d (jpij) , sfx_sum_1d (jpij), &
- & sfx_sni_1d (jpij) , sfx_opw_1d (jpij) , sfx_res_1d (jpij) , sfx_sub_1d (jpij), &
- & sfx_lam_1d (jpij) , sfx_dyn_1d(jpij) , STAT=ierr(ii) )
- !
+ & wfx_lam_1d (jpij) , wfx_dyn_1d (jpij) , wfx_pnd_1d (jpij) , STAT=ierr(ii) )
+
+ ! * salt fluxes
ii = ii + 1
- ALLOCATE( t_su_1d (jpij) , t_si_1d (jpij) , a_i_1d (jpij) , a_ib_1d (jpij) , &
- & h_i_1d (jpij) , h_ib_1d (jpij) , h_s_1d (jpij) , &
- & dh_s_tot(jpij) , dh_i_sum(jpij) , dh_i_itm (jpij) , dh_i_bom(jpij) , dh_i_bog(jpij) , &
- & dh_i_sub(jpij) , dh_s_mlt(jpij) , dh_snowice(jpij) , s_i_1d (jpij) , s_i_new (jpij) , &
- & a_ip_1d (jpij) , v_ip_1d (jpij) , v_i_1d (jpij) , v_s_1d (jpij) , v_il_1d (jpij) , &
- & h_il_1d (jpij) , h_ip_1d (jpij) , &
- & sv_i_1d (jpij) , oa_i_1d (jpij) , o_i_1d (jpij) , STAT=ierr(ii) )
- !
+ ALLOCATE( sfx_bri_1d(jpij) , sfx_bog_1d (jpij) , sfx_bom_1d (jpij) , sfx_sum_1d (jpij), &
+ & sfx_sni_1d(jpij) , sfx_opw_1d (jpij) , sfx_res_1d (jpij) , sfx_sub_1d (jpij), &
+ & sfx_lam_1d(jpij) , sfx_dyn_1d(jpij) , STAT=ierr(ii) )
+
+ ! * thermo tickness change
ii = ii + 1
- ALLOCATE( t_s_1d (jpij,nlay_s) , t_i_1d (jpij,nlay_i) , sz_i_1d(jpij,nlay_i) , &
- & e_i_1d (jpij,nlay_i) , e_s_1d (jpij,nlay_s) , &
- & eh_i_old(jpij,0:nlay_i+1) , h_i_old(jpij,0:nlay_i+1) , STAT=ierr(ii) )
- !
- ii = ii + 1
- ALLOCATE( qcn_ice_bot_1d(jpij) , qcn_ice_top_1d(jpij) , STAT=ierr(ii) )
- !
+ ALLOCATE( dh_s_tot(jpij) , dh_i_sum(jpij) , dh_i_itm (jpij) , dh_i_bom(jpij) , dh_i_bog(jpij) , &
+ & dh_i_sub(jpij) , dh_s_mlt(jpij) , dh_snowice(jpij) , STAT=ierr(ii) )
+
+ ! * other
ii = ii + 1
- ALLOCATE( sst_1d(jpij) , sss_1d(jpij) , frq_m_1d(jpij) , STAT=ierr(ii) )
- !
+ ALLOCATE( at_i_1d(jpij) , rn_amax_1d(jpij) , t_si_1d(jpij) , t_bo_1d (jpij) , &
+ & s_i_new(jpij) , sst_1d (jpij) , sss_1d (jpij) , frq_m_1d(jpij) , STAT=ierr(ii) )
ii = ii + 1
ALLOCATE( tice_cvgerr_1d(jpij) , tice_cvgstp_1d(jpij) , STAT=ierr(ii) )
!
+ ! * 2d arrays
ii = ii + 1
ALLOCATE( a_i_2d (jpij,jpl) , a_ib_2d(jpij,jpl) , h_i_2d (jpij,jpl) , h_ib_2d(jpij,jpl) , &
& v_i_2d (jpij,jpl) , v_s_2d (jpij,jpl) , oa_i_2d(jpij,jpl) , sv_i_2d(jpij,jpl) , &
- & a_ip_2d(jpij,jpl) , v_ip_2d(jpij,jpl) , t_su_2d(jpij,jpl) , v_il_2d(jpij,jpl) , &
+ & a_ip_2d(jpij,jpl) , v_ip_2d(jpij,jpl) , t_su_2d(jpij,jpl) , v_il_2d(jpij,jpl) , s_i_2d(jpij,jpl) , &
& STAT=ierr(ii) )
+ !
+ ! * 3d arrays
+ ii = ii + 1
+ ALLOCATE( e_i_2d(jpij,nlay_i,jpl) , e_s_2d(jpij,nlay_s,jpl) , STAT=ierr(ii) )
ice1D_alloc = MAXVAL( ierr(:) )
IF( ice1D_alloc /= 0 ) CALL ctl_stop( 'STOP', 'ice1D_alloc: failed to allocate arrays.' )
diff --git a/src/ICE/icealb.F90 b/src/ICE/icealb.F90
index 7a7b3e42af1420de1b15357108daf681858dbdc3..af7e868657a385de80f4030979f09463adac5813 100644
--- a/src/ICE/icealb.F90
+++ b/src/ICE/icealb.F90
@@ -48,7 +48,7 @@ MODULE icealb
!!----------------------------------------------------------------------
CONTAINS
- SUBROUTINE ice_alb( pt_su, ph_ice, ph_snw, ld_pnd_alb, pafrac_pnd, ph_pnd, pcloud_fra, palb_ice )
+ SUBROUTINE ice_alb( ld_pnd_alb, pt_su, ph_ice, ph_snw, pafrac_pnd, ph_pnd, pcloud_fra, palb_ice )
!!----------------------------------------------------------------------
!! *** ROUTINE ice_alb ***
!!
@@ -94,16 +94,16 @@ CONTAINS
!! Brandt et al. 2005, J. Climate, vol 18
!! Grenfell & Perovich 2004, JGR, vol 109
!!----------------------------------------------------------------------
- REAL(wp), INTENT(in ), DIMENSION(:,:,:) :: pt_su ! ice surface temperature (Kelvin)
- REAL(wp), INTENT(in ), DIMENSION(:,:,:) :: ph_ice ! sea-ice thickness
- REAL(wp), INTENT(in ), DIMENSION(:,:,:) :: ph_snw ! snow depth
- LOGICAL , INTENT(in ) :: ld_pnd_alb ! effect of melt ponds on albedo
- REAL(wp), INTENT(in ), DIMENSION(:,:,:) :: pafrac_pnd ! melt pond relative fraction (per unit ice area)
- REAL(wp), INTENT(in ), DIMENSION(:,:,:) :: ph_pnd ! melt pond depth
- REAL(wp), INTENT(in ), DIMENSION(:,:) :: pcloud_fra ! cloud fraction
- REAL(wp), INTENT( out), DIMENSION(:,:,:) :: palb_ice ! albedo of ice
+ LOGICAL , INTENT(in ) :: ld_pnd_alb ! effect of melt ponds on albedo
+ REAL(wp), INTENT(in ), DIMENSION(A2D(0),jpl) :: pt_su ! ice surface temperature (Kelvin)
+ REAL(wp), INTENT(in ), DIMENSION(A2D(0),jpl) :: ph_ice ! sea-ice thickness
+ REAL(wp), INTENT(in ), DIMENSION(A2D(0),jpl) :: ph_snw ! snow depth
+ REAL(wp), INTENT(in ), DIMENSION(A2D(0),jpl) :: pafrac_pnd ! melt pond relative fraction (per unit ice area)
+ REAL(wp), INTENT(in ), DIMENSION(A2D(0),jpl) :: ph_pnd ! melt pond depth
+ REAL(wp), INTENT(in ), DIMENSION(A2D(0)) :: pcloud_fra ! cloud fraction
+ REAL(wp), INTENT( out), DIMENSION(A2D(0),jpl) :: palb_ice ! albedo of ice
!
- REAL(wp), DIMENSION(jpi,jpj,jpl) :: za_s_fra ! ice fraction covered by snow
+ REAL(wp), DIMENSION(A2D(0),jpl) :: za_s_fra ! ice fraction covered by snow
INTEGER :: ji, jj, jl ! dummy loop indices
REAL(wp) :: z1_c1, z1_c2,z1_c3, z1_c4 ! local scalar
REAL(wp) :: z1_href_pnd ! inverse of the characteristic length scale (Lecomte et al. 2015)
@@ -121,10 +121,10 @@ CONTAINS
z1_c3 = 1._wp / 0.02_wp
z1_c4 = 1._wp / 0.03_wp
!
- CALL ice_var_snwfra( ph_snw, za_s_fra ) ! calculate ice fraction covered by snow
+ CALL ice_var_snwfra( ph_snw(:,:,:), za_s_fra(:,:,:) ) ! calculate ice fraction covered by snow
!
DO jl = 1, jpl
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) ! palb_ice used over the full domain in icesbc
+ DO_2D( 0, 0, 0, 0 ) ! palb_ice used over the full domain in icesbc
!
!---------------------------------------------!
!--- Specific snow, ice and pond fractions ---!
@@ -164,10 +164,10 @@ CONTAINS
zalb_pnd = rn_alb_dpnd - ( rn_alb_dpnd - zalb_ice ) * EXP( - ph_pnd(ji,jj,jl) * z1_href_pnd )
!
! !--- Surface albedo is weighted mean of snow, ponds and bare ice contributions
- zalb_os = ( zafrac_snw * zalb_snw + zafrac_pnd * zalb_pnd + zafrac_ice * zalb_ice ) * tmask(ji,jj,1)
+ zalb_os = ( zafrac_snw * zalb_snw + zafrac_pnd * zalb_pnd + zafrac_ice * zalb_ice ) * smask0(ji,jj)
!
zalb_cs = zalb_os - ( - 0.1010_wp * zalb_os * zalb_os &
- & + 0.1933_wp * zalb_os - 0.0148_wp ) * tmask(ji,jj,1)
+ & + 0.1933_wp * zalb_os - 0.0148_wp ) * smask0(ji,jj)
!
! albedo depends on cloud fraction because of non-linear spectral effects
palb_ice(ji,jj,jl) = ( 1._wp - pcloud_fra(ji,jj) ) * zalb_cs + pcloud_fra(ji,jj) * zalb_os
diff --git a/src/ICE/icecor.F90 b/src/ICE/icecor.F90
index 0b7b53e6a3c4d9b40a8d13e6b3f8d38bbf104705..d208956073a61380341c2e2c43dfd49d49d5f946 100644
--- a/src/ICE/icecor.F90
+++ b/src/ICE/icecor.F90
@@ -25,7 +25,6 @@ MODULE icecor
USE iom ! I/O manager library
USE lib_mpp ! MPP library
USE lib_fortran ! fortran utilities (glob_sum + no signed zero)
- USE lbclnk ! lateral boundary conditions (or mpp links)
USE timing ! Timing
IMPLICIT NONE
@@ -68,29 +67,32 @@ CONTAINS
! !-----------------------------------------------------
! ! ice thickness must exceed himin (for temp. diff.) !
! !-----------------------------------------------------
- WHERE( a_i(:,:,:) >= epsi20 ) ; h_i(:,:,:) = v_i(:,:,:) / a_i(:,:,:)
- ELSEWHERE ; h_i(:,:,:) = 0._wp
+ WHERE( a_i(A2D(0),:) >= epsi20 ) ; h_i(A2D(0),:) = v_i(A2D(0),:) / a_i(A2D(0),:)
+ ELSEWHERE ; h_i(A2D(0),:) = 0._wp
END WHERE
- WHERE( h_i(:,:,:) < rn_himin ) a_i(:,:,:) = a_i(:,:,:) * h_i(:,:,:) / rn_himin
+ IF( ln_pnd_LEV .OR. ln_pnd_TOPO ) THEN
+ WHERE( h_i(A2D(0),:) < rn_himin ) a_ip(A2D(0),:) = a_ip(A2D(0),:) * h_i(A2D(0),:) / rn_himin
+ ENDIF
+ WHERE( h_i(A2D(0),:) < rn_himin ) a_i (A2D(0),:) = a_i (A2D(0),:) * h_i(A2D(0),:) / rn_himin
!
! !-----------------------------------------------------
! ! ice concentration should not exceed amax !
! !-----------------------------------------------------
- at_i(:,:) = SUM( a_i(:,:,:), dim=3 )
+ at_i(A2D(0)) = SUM( a_i(A2D(0),:), dim=3 )
DO jl = 1, jpl
- WHERE( at_i(:,:) > rn_amax_2d(:,:) ) a_i(:,:,jl) = a_i(:,:,jl) * rn_amax_2d(:,:) / at_i(:,:)
+ WHERE( at_i(A2D(0)) > rn_amax_2d(A2D(0)) ) a_i(A2D(0),jl) = a_i(A2D(0),jl) * rn_amax_2d(A2D(0)) / at_i(A2D(0))
END DO
! !-----------------------------------------------------
! ! Rebin categories with thickness out of bounds !
! !-----------------------------------------------------
- IF ( jpl > 1 ) CALL ice_itd_reb( kt )
+ IF( jpl > 1 ) CALL ice_itd_reb( kt )
!
! !-----------------------------------------------------
IF ( nn_icesal == 2 ) THEN ! salinity must stay in bounds [Simin,Simax] !
! !-----------------------------------------------------
zzc = rhoi * r1_Dt_ice
DO jl = 1, jpl
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
zsal = sv_i(ji,jj,jl)
sv_i(ji,jj,jl) = MIN( MAX( rn_simin*v_i(ji,jj,jl) , sv_i(ji,jj,jl) ) , rn_simax*v_i(ji,jj,jl) )
IF( kn /= 0 ) & ! no ice-ocean exchanges if kn=0 (for bdy for instance) otherwise conservation diags will fail
diff --git a/src/ICE/icectl.F90 b/src/ICE/icectl.F90
index ad20e6734e4f96454372ef4f8ea548145b473d4a..a235e05626a3fbf91f8f58d664fd4ee1e268c396 100644
--- a/src/ICE/icectl.F90
+++ b/src/ICE/icectl.F90
@@ -83,25 +83,33 @@ CONTAINS
CHARACTER(len=*), INTENT(in) :: cd_routine ! name of the routine
REAL(wp) , INTENT(inout) :: pdiag_v, pdiag_s, pdiag_t, pdiag_fv, pdiag_fs, pdiag_ft
!!
+ INTEGER :: ji, jj, jl ! dummy loop index
REAL(wp) :: zdiag_mass, zdiag_salt, zdiag_heat
- REAL(wp), DIMENSION(jpi,jpj,10) :: ztmp3
- REAL(wp), DIMENSION(jpi,jpj,jpl,8) :: ztmp4
- REAL(wp), DIMENSION(10) :: zchk3
- REAL(wp), DIMENSION(8) :: zchk4
+ REAL(wp), DIMENSION(A2D(0),10) :: ztmp3
+ REAL(wp), DIMENSION(A2D(0),jpl,8) :: ztmp4
+ REAL(wp), DIMENSION(10) :: zchk3
+ REAL(wp), DIMENSION(8) :: zchk4
!!-------------------------------------------------------------------
!
- ! -- quantities -- !
- ztmp3(:,:,1) = SUM( v_i * rhoi + v_s * rhos + ( v_ip + v_il ) * rhow, dim=3 ) * e1e2t ! volume
- ztmp3(:,:,2) = SUM( sv_i * rhoi, dim=3 ) * e1e2t ! salt
- ztmp3(:,:,3) = ( SUM( SUM( e_i, dim=4 ), dim=3 ) + SUM( SUM( e_s, dim=4 ), dim=3 ) ) * e1e2t ! heat
- !
- ! -- fluxes -- !
- ztmp3(:,:,4) = ( wfx_bog + wfx_bom + wfx_sum + wfx_sni + wfx_opw + wfx_res + wfx_dyn + wfx_lam + wfx_pnd & ! mass
- & + wfx_snw_sni + wfx_snw_sum + wfx_snw_dyn + wfx_snw_sub + wfx_ice_sub + wfx_spr ) * e1e2t
- ztmp3(:,:,5) = ( sfx_bri + sfx_bog + sfx_bom + sfx_sum + sfx_sni + sfx_opw & ! salt
- & + sfx_res + sfx_dyn + sfx_sub + sfx_lam ) * e1e2t
- ztmp3(:,:,6) = ( hfx_sum + hfx_bom + hfx_bog + hfx_dif + hfx_opw + hfx_snw & ! heat
- & - hfx_thd - hfx_dyn - hfx_res - hfx_sub - hfx_spr ) * e1e2t
+ DO_2D( 0, 0, 0, 0 )
+ ! -- quantities -- !
+ ztmp3(ji,jj,1) = SUM( v_i(ji,jj,:) * rhoi + v_s(ji,jj,:) * rhos + &
+ & ( v_ip(ji,jj,:) + v_il(ji,jj,:) ) * rhow ) * e1e2t(ji,jj) ! volume
+ ztmp3(ji,jj,2) = SUM( sv_i(ji,jj,:) * rhoi ) * e1e2t(ji,jj) ! salt
+ ztmp3(ji,jj,3) = ( SUM( SUM( e_i(ji,jj,:,:), dim=2 ) ) + & ! heat
+ & SUM( SUM( e_s(ji,jj,:,:), dim=2 ) ) ) * e1e2t(ji,jj)
+ !
+ ! -- fluxes -- !
+ ztmp3(ji,jj,4) = ( wfx_bog (ji,jj) + wfx_bom (ji,jj) + wfx_sum (ji,jj) + wfx_sni (ji,jj) & ! mass
+ & + wfx_opw (ji,jj) + wfx_res (ji,jj) + wfx_dyn (ji,jj) + wfx_lam (ji,jj) + wfx_pnd(ji,jj) &
+ & + wfx_snw_sni(ji,jj) + wfx_snw_sum(ji,jj) + wfx_snw_dyn(ji,jj) + wfx_snw_sub(ji,jj) &
+ & + wfx_ice_sub(ji,jj) + wfx_spr(ji,jj) ) * e1e2t(ji,jj)
+ ztmp3(ji,jj,5) = ( sfx_bri(ji,jj) + sfx_bog(ji,jj) + sfx_bom(ji,jj) + sfx_sum(ji,jj) + sfx_sni(ji,jj) + sfx_opw(ji,jj) & ! salt
+ & + sfx_res(ji,jj) + sfx_dyn(ji,jj) + sfx_sub(ji,jj) + sfx_lam(ji,jj) ) * e1e2t(ji,jj)
+ ztmp3(ji,jj,6) = ( hfx_sum(ji,jj) + hfx_bom(ji,jj) + hfx_bog(ji,jj) + hfx_dif(ji,jj) + hfx_opw(ji,jj) + hfx_snw(ji,jj) & ! heat
+ & - hfx_thd(ji,jj) - hfx_dyn(ji,jj) - hfx_res(ji,jj) - hfx_sub(ji,jj) - hfx_spr(ji,jj) ) * e1e2t(ji,jj)
+ !
+ END_2D
!
! -- global sum -- !
zchk3(1:6) = glob_sum_vec( 'icectl', ztmp3(:,:,1:6) )
@@ -123,25 +131,33 @@ CONTAINS
zdiag_heat = ( zchk3(3) - pdiag_t ) * r1_Dt_ice + ( zchk3(6) - pdiag_ft )
! -- max concentration diag -- !
- ztmp3(:,:,7) = SUM( a_i, dim=3 )
- zchk3(7) = glob_max( 'icectl', ztmp3(:,:,7) )
-
+ DO_2D( 0, 0, 0, 0 )
+ ztmp3(ji,jj,7) = SUM( a_i(ji,jj,:) )
+ END_2D
+ zchk3(7) = glob_max( 'icectl', ztmp3(:,:,7) )
+
! -- advection scheme is conservative? -- !
- ztmp3(:,:,8 ) = diag_adv_mass * e1e2t
- ztmp3(:,:,9 ) = diag_adv_heat * e1e2t
- ztmp3(:,:,10) = SUM( a_i + epsi10, dim=3 ) * e1e2t ! ice area (+epsi10 to set a threshold > 0 when there is no ice)
- zchk3(8:10) = glob_sum_vec( 'icectl', ztmp3(:,:,8:10) )
+ DO_2D( 0, 0, 0, 0 )
+ ztmp3(ji,jj,8 ) = diag_adv_mass(ji,jj) * e1e2t(ji,jj)
+ ztmp3(ji,jj,9 ) = diag_adv_heat(ji,jj) * e1e2t(ji,jj)
+ ztmp3(ji,jj,10) = SUM( a_i(ji,jj,:) + epsi10 ) * e1e2t(ji,jj) ! ice area (+epsi10 to set a threshold > 0 when there is no ice)
+ END_2D
+ zchk3(8:10) = glob_sum_vec( 'icectl', ztmp3(:,:,8:10) )
! -- min diags -- !
- ztmp4(:,:,:,1) = v_i
- ztmp4(:,:,:,2) = v_s
- ztmp4(:,:,:,3) = v_ip
- ztmp4(:,:,:,4) = v_il
- ztmp4(:,:,:,5) = a_i
- ztmp4(:,:,:,6) = sv_i
- ztmp4(:,:,:,7) = SUM( e_i, dim=3 )
- ztmp4(:,:,:,8) = SUM( e_s, dim=3 )
- zchk4(1:8) = glob_min_vec( 'icectl', ztmp4(:,:,:,1:8) )
+ DO jl = 1, jpl
+ DO_2D( 0, 0, 0, 0 )
+ ztmp4(ji,jj,jl,1) = v_i(ji,jj,jl)
+ ztmp4(ji,jj,jl,2) = v_s(ji,jj,jl)
+ ztmp4(ji,jj,jl,3) = v_ip(ji,jj,jl)
+ ztmp4(ji,jj,jl,4) = v_il(ji,jj,jl)
+ ztmp4(ji,jj,jl,5) = a_i(ji,jj,jl)
+ ztmp4(ji,jj,jl,6) = sv_i(ji,jj,jl)
+ ztmp4(ji,jj,jl,7) = SUM( e_i(ji,jj,:,jl) )
+ ztmp4(ji,jj,jl,8) = SUM( e_s(ji,jj,:,jl) )
+ END_2D
+ ENDDO
+ zchk4(1:8) = glob_min_vec( 'icectl', ztmp4(:,:,:,1:8) )
IF( lwp ) THEN
! check conservation issues
@@ -188,17 +204,21 @@ CONTAINS
!!-------------------------------------------------------------------
CHARACTER(len=*), INTENT(in) :: cd_routine ! name of the routine
!!
- REAL(wp), DIMENSION(jpi,jpj,4) :: ztmp
- REAL(wp), DIMENSION(4) :: zchk
+ INTEGER :: ji, jj ! dummy loop index
+ REAL(wp), DIMENSION(A2D(0),4) :: ztmp
+ REAL(wp), DIMENSION(4) :: zchk
!!-------------------------------------------------------------------
-
- ztmp(:,:,1) = ( wfx_ice + wfx_snw + wfx_spr + wfx_sub + wfx_pnd + diag_vice + diag_vsnw + diag_vpnd - diag_adv_mass ) * e1e2t ! mass diag
- ztmp(:,:,2) = ( sfx + diag_sice - diag_adv_salt ) * e1e2t ! salt
- ztmp(:,:,3) = ( qt_oce_ai - qt_atm_oi + diag_heat - diag_adv_heat ) * e1e2t ! heat
- ! equivalent to this:
- !! ( -diag_heat + hfx_sum + hfx_bom + hfx_bog + hfx_dif + hfx_opw + hfx_snw &
- !! & - hfx_thd - hfx_dyn - hfx_res - hfx_sub - hfx_spr ) * e1e2t )
- ztmp(:,:,4) = SUM( a_i + epsi10, dim=3 ) * e1e2t ! ice area (+epsi10 to set a threshold > 0 when there is no ice)
+ DO_2D( 0, 0, 0, 0 )
+ !
+ ztmp(ji,jj,1) = ( wfx_ice (ji,jj) + wfx_snw (ji,jj) + wfx_pnd (ji,jj) + wfx_spr(ji,jj) + wfx_sub(ji,jj) &
+ & + diag_vice(ji,jj) + diag_vsnw(ji,jj) + diag_vpnd(ji,jj) - diag_adv_mass(ji,jj) ) * e1e2t(ji,jj) ! mass diag
+ ztmp(ji,jj,2) = ( sfx(ji,jj) + diag_sice(ji,jj) - diag_adv_salt(ji,jj) ) * e1e2t(ji,jj) ! salt
+ ztmp(ji,jj,3) = ( qt_oce_ai(ji,jj) - qt_atm_oi(ji,jj) + diag_heat(ji,jj) - diag_adv_heat(ji,jj) ) * e1e2t(ji,jj) ! heat
+ ! equivalent to this:
+ !! ( -diag_heat + hfx_sum + hfx_bom + hfx_bog + hfx_dif + hfx_opw + hfx_snw &
+ !! & - hfx_thd - hfx_dyn - hfx_res - hfx_sub - hfx_spr ) * e1e2t )
+ ztmp(ji,jj,4) = SUM( a_i(ji,jj,:) + epsi10 ) * e1e2t(ji,jj) ! ice area (+epsi10 to set a threshold > 0 when there is no ice)
+ END_2D
! global sums
zchk(1:4) = glob_sum_vec( 'icectl', ztmp(:,:,1:4) )
@@ -226,11 +246,11 @@ CONTAINS
!!-------------------------------------------------------------------
INTEGER , INTENT(in) :: icount ! called at: =0 the begining of the routine, =1 the end
CHARACTER(len=*), INTENT(in) :: cd_routine ! name of the routine
- REAL(wp) , DIMENSION(jpi,jpj), INTENT(inout) :: pdiag_v, pdiag_s, pdiag_t, pdiag_fv, pdiag_fs, pdiag_ft
+ REAL(wp) , DIMENSION(A2D(0)), INTENT(inout) :: pdiag_v, pdiag_s, pdiag_t, pdiag_fv, pdiag_fs, pdiag_ft
!!
- REAL(wp), DIMENSION(jpi,jpj) :: zdiag_mass, zdiag_salt, zdiag_heat, &
- & zdiag_amin, zdiag_vmin, zdiag_smin, zdiag_emin !!, zdiag_amax
- INTEGER :: jl, jk
+ REAL(wp), DIMENSION(A2D(0)) :: zdiag_mass, zdiag_salt, zdiag_heat, &
+ & zdiag_amin, zdiag_vmin, zdiag_smin, zdiag_emin !!, zdiag_amax
+ INTEGER :: ji, jj, jl, jk
LOGICAL :: ll_stop_m = .FALSE.
LOGICAL :: ll_stop_s = .FALSE.
LOGICAL :: ll_stop_t = .FALSE.
@@ -239,62 +259,79 @@ CONTAINS
!
IF( icount == 0 ) THEN
- pdiag_v = SUM( v_i * rhoi + v_s * rhos + ( v_ip + v_il ) * rhow, dim=3 )
- pdiag_s = SUM( sv_i * rhoi , dim=3 )
- pdiag_t = SUM( SUM( e_i, dim=4 ), dim=3 ) + SUM( SUM( e_s, dim=4 ), dim=3 )
+ DO_2D( 0, 0, 0, 0 )
+ pdiag_v(ji,jj) = SUM( v_i(ji,jj,:) * rhoi + v_s(ji,jj,:) * rhos + ( v_ip(ji,jj,:) + v_il(ji,jj,:) ) * rhow )
+ pdiag_s(ji,jj) = SUM( sv_i(ji,jj,:) * rhoi )
+ pdiag_t(ji,jj) = SUM( SUM( e_i(ji,jj,:,:), dim=2 ) ) + SUM( SUM( e_s(ji,jj,:,:), dim=2 ) )
! mass flux
- pdiag_fv = wfx_bog + wfx_bom + wfx_sum + wfx_sni + wfx_opw + wfx_res + wfx_dyn + wfx_lam + wfx_pnd + &
- & wfx_snw_sni + wfx_snw_sum + wfx_snw_dyn + wfx_snw_sub + wfx_ice_sub + wfx_spr
+ pdiag_fv(ji,jj) = wfx_bog(ji,jj) + wfx_bom(ji,jj) + wfx_sum(ji,jj) + wfx_sni(ji,jj) &
+ & + wfx_opw(ji,jj) + wfx_res(ji,jj) + wfx_dyn(ji,jj) + wfx_lam(ji,jj) + wfx_pnd (ji,jj) &
+ & + wfx_snw_sni(ji,jj) + wfx_snw_sum(ji,jj) + wfx_snw_dyn(ji,jj) &
+ & + wfx_snw_sub(ji,jj) + wfx_ice_sub(ji,jj) + wfx_spr(ji,jj)
! salt flux
- pdiag_fs = sfx_bri + sfx_bog + sfx_bom + sfx_sum + sfx_sni + sfx_opw + sfx_res + sfx_dyn + sfx_sub + sfx_lam
+ pdiag_fs(ji,jj) = sfx_bri(ji,jj) + sfx_bog(ji,jj) + sfx_bom(ji,jj) + sfx_sum(ji,jj) + sfx_sni(ji,jj) &
+ & + sfx_opw(ji,jj) + sfx_res(ji,jj) + sfx_dyn(ji,jj) + sfx_sub(ji,jj) + sfx_lam(ji,jj)
! heat flux
- pdiag_ft = hfx_sum + hfx_bom + hfx_bog + hfx_dif + hfx_opw + hfx_snw &
- & - hfx_thd - hfx_dyn - hfx_res - hfx_sub - hfx_spr
+ pdiag_ft(ji,jj) = hfx_sum(ji,jj) + hfx_bom(ji,jj) + hfx_bog(ji,jj) + hfx_dif(ji,jj) + hfx_opw(ji,jj) + hfx_snw(ji,jj) &
+ & - hfx_thd(ji,jj) - hfx_dyn(ji,jj) - hfx_res(ji,jj) - hfx_sub(ji,jj) - hfx_spr(ji,jj)
+ END_2D
ELSEIF( icount == 1 ) THEN
-
+
! -- mass diag -- !
- zdiag_mass = ( SUM( v_i * rhoi + v_s * rhos + ( v_ip + v_il ) * rhow, dim=3 ) - pdiag_v ) * r1_Dt_ice &
- & + ( wfx_bog + wfx_bom + wfx_sum + wfx_sni + wfx_opw + wfx_res + wfx_dyn + wfx_lam + wfx_pnd + &
- & wfx_snw_sni + wfx_snw_sum + wfx_snw_dyn + wfx_snw_sub + wfx_ice_sub + wfx_spr ) &
- & - pdiag_fv
+ DO_2D( 0, 0, 0, 0 )
+ zdiag_mass(ji,jj) = ( SUM( v_i(ji,jj,:) * rhoi + v_s(ji,jj,:) * rhos &
+ & + ( v_ip(ji,jj,:) + v_il(ji,jj,:) ) * rhow ) - pdiag_v(ji,jj) ) * r1_Dt_ice &
+ & + ( wfx_bog(ji,jj) + wfx_bom(ji,jj) + wfx_sum(ji,jj) + wfx_sni(ji,jj) + wfx_opw(ji,jj) &
+ & + wfx_res(ji,jj) + wfx_dyn(ji,jj) + wfx_lam(ji,jj) + wfx_pnd(ji,jj) &
+ & + wfx_snw_sni(ji,jj) + wfx_snw_sum(ji,jj) + wfx_snw_dyn(ji,jj) &
+ & + wfx_snw_sub(ji,jj) + wfx_ice_sub(ji,jj) + wfx_spr(ji,jj) ) &
+ & - pdiag_fv(ji,jj)
+ END_2D
IF( MAXVAL( ABS(zdiag_mass) ) > rchk_m * rn_icechk_cel ) ll_stop_m = .TRUE.
!
! -- salt diag -- !
- zdiag_salt = ( SUM( sv_i * rhoi , dim=3 ) - pdiag_s ) * r1_Dt_ice &
- & + ( sfx_bri + sfx_bog + sfx_bom + sfx_sum + sfx_sni + sfx_opw + sfx_res + sfx_dyn + sfx_sub + sfx_lam ) &
- & - pdiag_fs
+ DO_2D( 0, 0, 0, 0 )
+ zdiag_salt(ji,jj) = ( SUM( sv_i(ji,jj,:) * rhoi ) - pdiag_s(ji,jj) ) * r1_Dt_ice &
+ & + ( sfx_bri(ji,jj) + sfx_bog(ji,jj) + sfx_bom(ji,jj) + sfx_sum(ji,jj) + sfx_sni(ji,jj) &
+ & + sfx_opw(ji,jj) + sfx_res(ji,jj) + sfx_dyn(ji,jj) + sfx_sub(ji,jj) + sfx_lam(ji,jj) ) &
+ & - pdiag_fs(ji,jj)
+ END_2D
IF( MAXVAL( ABS(zdiag_salt) ) > rchk_s * rn_icechk_cel ) ll_stop_s = .TRUE.
!
! -- heat diag -- !
- zdiag_heat = ( SUM( SUM( e_i, dim=4 ), dim=3 ) + SUM( SUM( e_s, dim=4 ), dim=3 ) - pdiag_t ) * r1_Dt_ice &
- & + ( hfx_sum + hfx_bom + hfx_bog + hfx_dif + hfx_opw + hfx_snw &
- & - hfx_thd - hfx_dyn - hfx_res - hfx_sub - hfx_spr ) &
- & - pdiag_ft
+ DO_2D( 0, 0, 0, 0 )
+ zdiag_heat(ji,jj) = ( SUM( SUM( e_i(ji,jj,:,:), dim=2 ) ) &
+ & + SUM( SUM( e_s(ji,jj,:,:), dim=2 ) ) - pdiag_t(ji,jj) ) * r1_Dt_ice &
+ & + ( hfx_sum(ji,jj) + hfx_bom(ji,jj) + hfx_bog(ji,jj) &
+ & + hfx_dif(ji,jj) + hfx_opw(ji,jj) + hfx_snw(ji,jj) &
+ & - hfx_thd(ji,jj) - hfx_dyn(ji,jj) - hfx_res(ji,jj) - hfx_sub(ji,jj) - hfx_spr(ji,jj) ) &
+ & - pdiag_ft(ji,jj)
+ END_2D
IF( MAXVAL( ABS(zdiag_heat) ) > rchk_t * rn_icechk_cel ) ll_stop_t = .TRUE.
!
! -- other diags -- !
! a_i < 0
zdiag_amin(:,:) = 0._wp
DO jl = 1, jpl
- WHERE( a_i(:,:,jl) < 0._wp ) zdiag_amin(:,:) = 1._wp
+ WHERE( a_i(A2D(0),jl) < 0._wp ) zdiag_amin(:,:) = 1._wp
ENDDO
! v_i < 0
zdiag_vmin(:,:) = 0._wp
DO jl = 1, jpl
- WHERE( v_i(:,:,jl) < 0._wp ) zdiag_vmin(:,:) = 1._wp
+ WHERE( v_i(A2D(0),jl) < 0._wp ) zdiag_vmin(:,:) = 1._wp
ENDDO
! s_i < 0
zdiag_smin(:,:) = 0._wp
DO jl = 1, jpl
- WHERE( s_i(:,:,jl) < 0._wp ) zdiag_smin(:,:) = 1._wp
+ WHERE( s_i(A2D(0),jl) < 0._wp ) zdiag_smin(:,:) = 1._wp
ENDDO
! e_i < 0
zdiag_emin(:,:) = 0._wp
DO jl = 1, jpl
DO jk = 1, nlay_i
- WHERE( e_i(:,:,jk,jl) < 0._wp ) zdiag_emin(:,:) = 1._wp
+ WHERE( e_i(A2D(0),jk,jl) < 0._wp ) zdiag_emin(:,:) = 1._wp
ENDDO
ENDDO
! a_i > amax
@@ -528,8 +565,8 @@ CONTAINS
INTEGER :: jl, ji, jj
!!-------------------------------------------------------------------
- DO ji = mi0(ki), mi1(ki)
- DO jj = mj0(kj), mj1(kj)
+ DO ji = mi0(ki,nn_hls), mi1(ki,nn_hls)
+ DO jj = mj0(kj,nn_hls), mj1(kj,nn_hls)
WRITE(numout,*) ' time step ',kt,' ',cd1 ! print title
@@ -696,6 +733,7 @@ CONTAINS
CALL prt_ctl(tab2d_1=ato_i , clinfo1=' ato_i :', mask1=tmask)
CALL prt_ctl(tab2d_1=vt_i , clinfo1=' vt_i :', mask1=tmask)
CALL prt_ctl(tab2d_1=vt_s , clinfo1=' vt_s :', mask1=tmask)
+ IF( ln_icedyn ) THEN
CALL prt_ctl(tab2d_1=divu_i , clinfo1=' divu_i :', mask1=tmask)
CALL prt_ctl(tab2d_1=delta_i , clinfo1=' delta_i :', mask1=tmask)
CALL prt_ctl(tab2d_1=stress1_i , clinfo1=' stress1_i :', mask1=tmask)
@@ -703,6 +741,7 @@ CONTAINS
CALL prt_ctl(tab2d_1=stress12_i , clinfo1=' stress12_i :') ! should be fmask
CALL prt_ctl(tab2d_1=strength , clinfo1=' strength :', mask1=tmask)
CALL prt_ctl(tab2d_1=delta_i , clinfo1=' delta_i :', mask1=tmask)
+ ENDIF
CALL prt_ctl(tab2d_1=u_ice , clinfo1=' u_ice :', mask1=umask, &
& tab2d_2=v_ice , clinfo2=' v_ice :', mask2=vmask)
@@ -733,10 +772,10 @@ CONTAINS
CALL prt_ctl_info(' ')
CALL prt_ctl_info(' - Stresses : ')
CALL prt_ctl_info(' ~~~~~~~~~~ ')
- CALL prt_ctl(tab2d_1=utau , clinfo1= ' utau : ', mask1 = umask, &
- & tab2d_2=vtau , clinfo2= ' vtau : ', mask2 = vmask)
- CALL prt_ctl(tab2d_1=utau_ice , clinfo1= ' utau_ice : ', mask1 = umask, &
- & tab2d_2=vtau_ice , clinfo2= ' vtau_ice : ', mask2 = vmask)
+ CALL prt_ctl(tab2d_1=utau , clinfo1= ' utau : ', mask1 = tmask, &
+ & tab2d_2=vtau , clinfo2= ' vtau : ', mask2 = tmask)
+ CALL prt_ctl(tab2d_1=utau_ice , clinfo1= ' utau_ice : ', mask1 = tmask, &
+ & tab2d_2=vtau_ice , clinfo2= ' vtau_ice : ', mask2 = tmask)
END SUBROUTINE ice_prt3D
@@ -751,8 +790,9 @@ CONTAINS
!!-------------------------------------------------------------------
INTEGER, INTENT(in) :: kt ! ice time-step index
!
- REAL(wp), DIMENSION(jpi,jpj,6) :: ztmp
- REAL(wp), DIMENSION(6) :: zchk
+ INTEGER :: ji, jj ! dummy loop index
+ REAL(wp), DIMENSION(A2D(0),6) :: ztmp
+ REAL(wp), DIMENSION(6) :: zchk
!!-------------------------------------------------------------------
!
IF( kt == nit000 .AND. lwp ) THEN
@@ -762,25 +802,27 @@ CONTAINS
ENDIF
!
! -- 2D budgets (must be close to 0) -- !
- ztmp(:,:,1) = wfx_ice (:,:) + wfx_snw (:,:) + wfx_spr (:,:) + wfx_sub(:,:) + wfx_pnd(:,:) &
- & + diag_vice(:,:) + diag_vsnw(:,:) + diag_vpnd(:,:) - diag_adv_mass(:,:)
- ztmp(:,:,2) = sfx(:,:) + diag_sice(:,:) - diag_adv_salt(:,:)
- ztmp(:,:,3) = qt_oce_ai(:,:) - qt_atm_oi(:,:) + diag_heat(:,:) - diag_adv_heat(:,:)
-
+ DO_2D( 0, 0, 0, 0 )
+ ztmp(ji,jj,1) = wfx_ice (ji,jj) + wfx_snw (ji,jj) + wfx_spr (ji,jj) + wfx_sub(ji,jj) + wfx_pnd(ji,jj) &
+ & + diag_vice(ji,jj) + diag_vsnw(ji,jj) + diag_vpnd(ji,jj) - diag_adv_mass(ji,jj)
+ ztmp(ji,jj,2) = sfx(ji,jj) + diag_sice(ji,jj) - diag_adv_salt(ji,jj)
+ ztmp(ji,jj,3) = qt_oce_ai(ji,jj) - qt_atm_oi(ji,jj) + diag_heat(ji,jj) - diag_adv_heat(ji,jj)
+ END_2D
! write outputs
CALL iom_put( 'icedrift_mass', ztmp(:,:,1) )
CALL iom_put( 'icedrift_salt', ztmp(:,:,2) )
CALL iom_put( 'icedrift_heat', ztmp(:,:,3) )
! -- 1D budgets -- !
- ztmp(:,:,1) = ztmp(:,:,1) * e1e2t * rDt_ice ! mass
- ztmp(:,:,2) = ztmp(:,:,2) * e1e2t * rDt_ice * 1.e-3 ! salt
- ztmp(:,:,3) = ztmp(:,:,3) * e1e2t ! heat
-
- ztmp(:,:,4) = diag_adv_mass * e1e2t * rDt_ice
- ztmp(:,:,5) = diag_adv_salt * e1e2t * rDt_ice * 1.e-3
- ztmp(:,:,6) = diag_adv_heat * e1e2t
-
+ DO_2D( 0, 0, 0, 0 )
+ ztmp(ji,jj,1) = ztmp(ji,jj,1) * e1e2t(ji,jj) * rDt_ice ! mass
+ ztmp(ji,jj,2) = ztmp(ji,jj,2) * e1e2t(ji,jj) * rDt_ice * 1.e-3 ! salt
+ ztmp(ji,jj,3) = ztmp(ji,jj,3) * e1e2t(ji,jj) ! heat
+
+ ztmp(ji,jj,4) = diag_adv_mass(ji,jj) * e1e2t(ji,jj) * rDt_ice
+ ztmp(ji,jj,5) = diag_adv_salt(ji,jj) * e1e2t(ji,jj) * rDt_ice * 1.e-3
+ ztmp(ji,jj,6) = diag_adv_heat(ji,jj) * e1e2t(ji,jj)
+ END_2D
! global sums
zchk(1:6) = glob_sum_vec( 'icectl', ztmp(:,:,1:6) )
diff --git a/src/ICE/icedia.F90 b/src/ICE/icedia.F90
index 154d89de1e4311b194a31b1e645aa65cf523a6d9..197a6a6c7508052c03e988d712c1eab81d8d77cc 100644
--- a/src/ICE/icedia.F90
+++ b/src/ICE/icedia.F90
@@ -33,6 +33,9 @@ MODULE icedia
PUBLIC ice_dia ! called by icestp.F90
PUBLIC ice_dia_init ! called in icestp.F90
+ !! * Substitutions
+# include "do_loop_substitute.h90"
+
REAL(wp), SAVE :: r1_area ! inverse of the ocean area
REAL(wp), DIMENSION(:,:), ALLOCATABLE :: vol_loc_ini, sal_loc_ini, tem_loc_ini ! initial volume, salt and heat contents
REAL(wp) :: frc_sal, frc_voltop, frc_volbot, frc_temtop, frc_tembot ! global forcing trends
@@ -48,7 +51,7 @@ CONTAINS
!!---------------------------------------------------------------------!
!! *** ROUTINE ice_dia_alloc ***
!!---------------------------------------------------------------------!
- ALLOCATE( vol_loc_ini(jpi,jpj), sal_loc_ini(jpi,jpj), tem_loc_ini(jpi,jpj), STAT=ice_dia_alloc )
+ ALLOCATE( vol_loc_ini(A2D(0)), sal_loc_ini(A2D(0)), tem_loc_ini(A2D(0)), STAT=ice_dia_alloc )
CALL mpp_sum ( 'icedia', ice_dia_alloc )
IF( ice_dia_alloc /= 0 ) CALL ctl_stop( 'STOP', 'ice_dia_alloc: failed to allocate arrays' )
@@ -64,8 +67,9 @@ CONTAINS
!!---------------------------------------------------------------------------
INTEGER, INTENT(in) :: kt ! ocean time step
!!
- REAL(wp), DIMENSION(jpi,jpj,16) :: ztmp
- REAL(wp), DIMENSION(16) :: zbg
+ INTEGER :: ji, jj ! dummy loop index
+ REAL(wp), DIMENSION(A2D(0),16) :: ztmp
+ REAL(wp), DIMENSION(16) :: zbg
!!---------------------------------------------------------------------------
IF( ln_timing ) CALL timing_start('ice_dia')
@@ -85,31 +89,32 @@ CONTAINS
! 1 - Trends due to forcing !
! ---------------------------!
! they must be kept outside an IF(iom_use) because of the call to dia_rst below
- ztmp(:,:,1) = - ( wfx_ice(:,:) + wfx_snw(:,:) + wfx_err_sub(:,:) ) * e1e2t(:,:) ! freshwater flux ice/snow-ocean
- ztmp(:,:,2) = - ( wfx_sub(:,:) + wfx_spr(:,:) ) * e1e2t(:,:) ! freshwater flux ice/snow-atm
- ztmp(:,:,3) = - sfx (:,:) * e1e2t(:,:) ! salt fluxes ice/snow-ocean
- ztmp(:,:,4) = qt_atm_oi(:,:) * e1e2t(:,:) ! heat on top of ice-ocean
- ztmp(:,:,5) = qt_oce_ai(:,:) * e1e2t(:,:) ! heat on top of ocean (and below ice)
-
+ DO_2D( 0, 0, 0, 0 )
+ ztmp(ji,jj,1) = - ( wfx_ice(ji,jj) + wfx_snw(ji,jj) + wfx_err_sub(ji,jj) ) * e1e2t(ji,jj) ! freshwater flux ice/snow-ocean
+ ztmp(ji,jj,2) = - ( wfx_sub(ji,jj) + wfx_spr(ji,jj) ) * e1e2t(ji,jj) ! freshwater flux ice/snow-atm
+ ztmp(ji,jj,3) = - sfx (ji,jj) * e1e2t(ji,jj) ! salt fluxes ice/snow-ocean
+ ztmp(ji,jj,4) = qt_atm_oi(ji,jj) * e1e2t(ji,jj) ! heat on top of ice-ocean
+ ztmp(ji,jj,5) = qt_oce_ai(ji,jj) * e1e2t(ji,jj) ! heat on top of ocean (and below ice)
+ END_2D
! ----------------------- !
! 2 - Contents !
! ----------------------- !
- IF( iom_use('ibgvol_tot' ) ) ztmp(:,:,6 ) = vt_i (:,:) * e1e2t(:,:) ! ice volume
- IF( iom_use('sbgvol_tot' ) ) ztmp(:,:,7 ) = vt_s (:,:) * e1e2t(:,:) ! snow volume
- IF( iom_use('ibgarea_tot') ) ztmp(:,:,8 ) = at_i (:,:) * e1e2t(:,:) ! area
- IF( iom_use('ibgsalt_tot') ) ztmp(:,:,9 ) = st_i (:,:) * e1e2t(:,:) ! salt content
- IF( iom_use('ibgheat_tot') ) ztmp(:,:,10) = et_i (:,:) * e1e2t(:,:) ! heat content
- IF( iom_use('sbgheat_tot') ) ztmp(:,:,11) = et_s (:,:) * e1e2t(:,:) ! heat content
- IF( iom_use('ipbgvol_tot') ) ztmp(:,:,12) = vt_ip(:,:) * e1e2t(:,:) ! ice pond volume
- IF( iom_use('ilbgvol_tot') ) ztmp(:,:,13) = vt_il(:,:) * e1e2t(:,:) ! ice pond lid volume
+ IF( iom_use('ibgvol_tot' ) ) ztmp(:,:,6 ) = vt_i (A2D(0)) * e1e2t(A2D(0)) ! ice volume
+ IF( iom_use('sbgvol_tot' ) ) ztmp(:,:,7 ) = vt_s (A2D(0)) * e1e2t(A2D(0)) ! snow volume
+ IF( iom_use('ibgarea_tot') ) ztmp(:,:,8 ) = at_i (A2D(0)) * e1e2t(A2D(0)) ! area
+ IF( iom_use('ibgsalt_tot') ) ztmp(:,:,9 ) = st_i (:,:) * e1e2t(A2D(0)) ! salt content
+ IF( iom_use('ibgheat_tot') ) ztmp(:,:,10) = et_i (:,:) * e1e2t(A2D(0)) ! heat content
+ IF( iom_use('sbgheat_tot') ) ztmp(:,:,11) = et_s (:,:) * e1e2t(A2D(0)) ! heat content
+ IF( iom_use('ipbgvol_tot') ) ztmp(:,:,12) = vt_ip(A2D(0)) * e1e2t(A2D(0)) ! ice pond volume
+ IF( iom_use('ilbgvol_tot') ) ztmp(:,:,13) = vt_il(A2D(0)) * e1e2t(A2D(0)) ! ice pond lid volume
! ---------------------------------- !
! 3 - Content variations and drifts !
! ---------------------------------- !
- IF( iom_use('ibgvolume') ) ztmp(:,:,14) = ( rhoi*vt_i(:,:) + rhos*vt_s(:,:) - vol_loc_ini(:,:) ) * e1e2t(:,:) ! freshwater trend
- IF( iom_use('ibgsaltco') ) ztmp(:,:,15) = ( rhoi*st_i(:,:) - sal_loc_ini(:,:) ) * e1e2t(:,:) ! salt content trend
+ IF( iom_use('ibgvolume') ) ztmp(:,:,14) = ( rhoi*vt_i(A2D(0)) + rhos*vt_s(A2D(0)) - vol_loc_ini(:,:) ) * e1e2t(A2D(0)) ! freshwater trend
+ IF( iom_use('ibgsaltco') ) ztmp(:,:,15) = ( rhoi*st_i(:,:) - sal_loc_ini(:,:) ) * e1e2t(A2D(0)) ! salt content trend
IF( iom_use('ibgheatco') .OR. iom_use('ibgheatfx') ) &
- & ztmp(:,:,16) = ( et_i(:,:) + et_s(:,:) - tem_loc_ini(:,:) ) * e1e2t(:,:) ! heat content trend
+ & ztmp(:,:,16) = ( et_i(:,:) + et_s(:,:) - tem_loc_ini(:,:) ) * e1e2t(A2D(0)) ! heat content trend
! global sum
zbg(1:16) = glob_sum_vec( 'icedia', ztmp(:,:,1:16) )
@@ -261,9 +266,9 @@ CONTAINS
frc_tembot = 0._wp
frc_sal = 0._wp
! record initial ice volume, salt and temp
- vol_loc_ini(:,:) = rhoi * vt_i(:,:) + rhos * vt_s(:,:) ! ice/snow volume (kg/m2)
- tem_loc_ini(:,:) = et_i(:,:) + et_s(:,:) ! ice/snow heat content (J)
- sal_loc_ini(:,:) = rhoi * st_i(:,:) ! ice salt content (pss*kg/m2)
+ vol_loc_ini(:,:) = rhoi * vt_i(A2D(0)) + rhos * vt_s(A2D(0)) ! ice/snow volume (kg/m2)
+ tem_loc_ini(:,:) = et_i(:,:) + et_s(:,:) ! ice/snow heat content (J)
+ sal_loc_ini(:,:) = rhoi * st_i(:,:) ! ice salt content (pss*kg/m2)
ENDIF
!
ELSEIF( TRIM(cdrw) == 'WRITE' ) THEN ! Create restart file
diff --git a/src/ICE/icedyn.F90 b/src/ICE/icedyn.F90
index dcbe3e77a3a7f6c9a6d9d37b2bc260c983736e6b..8ea874d6f968762021ab3a56812e14b0ad2b6b26 100644
--- a/src/ICE/icedyn.F90
+++ b/src/ICE/icedyn.F90
@@ -93,8 +93,8 @@ CONTAINS
!
! retrieve thickness from volume for landfast param. and UMx advection scheme
WHERE( a_i(:,:,:) >= epsi20 )
- h_i(:,:,:) = v_i(:,:,:) / a_i_b(:,:,:)
- h_s(:,:,:) = v_s(:,:,:) / a_i_b(:,:,:)
+ h_i(:,:,:) = v_i(:,:,:) / a_i(:,:,:)
+ h_s(:,:,:) = v_s(:,:,:) / a_i(:,:,:)
ELSEWHERE
h_i(:,:,:) = 0._wp
h_s(:,:,:) = 0._wp
@@ -142,6 +142,7 @@ CONTAINS
END_2D
! ---
CALL ice_dyn_adv ( kt ) ! -- advection of ice
+ CALL ice_var_zapsmall ! -- zap small areas
!
CASE ( np_dynADV2D ) !== pure advection ==! (2D w prescribed velocities)
!
@@ -151,6 +152,7 @@ CONTAINS
!CALL RANDOM_NUMBER(v_ice(:,:)) ; v_ice(:,:) = v_ice(:,:) * 0.1 + rn_vice * 0.9 * vmask(:,:,1)
! ---
CALL ice_dyn_adv ( kt ) ! -- advection of ice
+ CALL ice_var_zapsmall ! -- zap small areas
END SELECT
!
@@ -162,21 +164,30 @@ CONTAINS
CASE ( np_dynADV1D , np_dynADV2D )
- ALLOCATE( zdivu_i(jpi,jpj) )
+ ALLOCATE( zdivu_i(A2D(0)) )
DO_2D( 0, 0, 0, 0 )
- zdivu_i(ji,jj) = ( e2u(ji,jj) * u_ice(ji,jj) - e2u(ji-1,jj) * u_ice(ji-1,jj) &
- & + e1v(ji,jj) * v_ice(ji,jj) - e1v(ji,jj-1) * v_ice(ji,jj-1) ) * r1_e1e2t(ji,jj)
+ zdivu_i(ji,jj) = ( ( e2u(ji,jj) * u_ice(ji,jj) - e2u(ji-1,jj) * u_ice(ji-1,jj) ) & ! add () for NP repro
+ & + ( e1v(ji,jj) * v_ice(ji,jj) - e1v(ji,jj-1) * v_ice(ji,jj-1) ) ) * r1_e1e2t(ji,jj)
END_2D
- CALL lbc_lnk( 'icedyn', zdivu_i, 'T', 1.0_wp )
- ! output
CALL iom_put( 'icediv' , zdivu_i )
-
DEALLOCATE( zdivu_i )
END SELECT
!
ENDIF
!
+ ! --- Lateral boundary conditions --- !
+ ! caution: t_su update needed from itd_reb
+ ! plus, one needs ldfull=T to deal with the NorthFold in case of Prather advection
+ IF( ln_pnd_LEV .OR. ln_pnd_TOPO ) THEN
+ CALL lbc_lnk( 'icedyn', a_i , 'T', 1._wp, v_i , 'T', 1._wp, v_s , 'T', 1._wp, sv_i, 'T', 1._wp, oa_i, 'T', 1._wp, &
+ & t_su, 'T', 1._wp, a_ip, 'T', 1._wp, v_ip, 'T', 1._wp, v_il, 'T', 1._wp, ldfull = .TRUE. )
+ ELSE
+ CALL lbc_lnk( 'icedyn', a_i , 'T', 1._wp, v_i , 'T', 1._wp, v_s , 'T', 1._wp, sv_i, 'T', 1._wp, oa_i, 'T', 1._wp, &
+ & t_su, 'T', 1._wp, ldfull = .TRUE. )
+ ENDIF
+ CALL lbc_lnk( 'icedyn', e_i, 'T', 1._wp, e_s, 'T', 1._wp, ldfull = .TRUE. )
+
! controls
IF( ln_timing ) CALL timing_stop ('ice_dyn')
!
@@ -198,12 +209,13 @@ CONTAINS
! controls
IF( ln_icediachk ) CALL ice_cons_hsm(0, 'Hpiling', rdiag_v, rdiag_s, rdiag_t, rdiag_fv, rdiag_fs, rdiag_ft) ! conservation
!
- at_i(:,:) = SUM( a_i(:,:,:), dim=3 )
+ at_i(A2D(0)) = SUM( a_i(A2D(0),:), dim=3 )
DO jl = 1, jpl
- WHERE( at_i(:,:) > epsi20 )
- a_i(:,:,jl) = a_i(:,:,jl) * ( 1._wp + MIN( rn_amax_2d(:,:) - at_i(:,:) , 0._wp ) / at_i(:,:) )
+ WHERE( at_i(A2D(0)) > epsi20 )
+ a_i(A2D(0),jl) = a_i(A2D(0),jl) * ( 1._wp + MIN( rn_amax_2d(A2D(0)) - at_i(A2D(0)) , 0._wp ) / at_i(A2D(0)) )
END WHERE
END DO
+ !
! controls
IF( ln_icediachk ) CALL ice_cons_hsm(1, 'Hpiling', rdiag_v, rdiag_s, rdiag_t, rdiag_fv, rdiag_fs, rdiag_ft) ! conservation
!
diff --git a/src/ICE/icedyn_adv.F90 b/src/ICE/icedyn_adv.F90
index e2beb79a2b6d1d5801210c269b716259a8ec7823..6afabac00bcf4adc66c8cbd98cfb577df3151843 100644
--- a/src/ICE/icedyn_adv.F90
+++ b/src/ICE/icedyn_adv.F90
@@ -25,7 +25,6 @@ MODULE icedyn_adv
USE lib_mpp ! MPP library
USE lib_fortran ! fortran utilities (glob_sum + no signed zero)
USE timing ! Timing
- USE prtctl ! Print control
IMPLICIT NONE
PRIVATE
@@ -41,6 +40,8 @@ MODULE icedyn_adv
! ** namelist (namdyn_adv) **
INTEGER :: nn_UMx ! order of the UMx advection scheme
!
+ !! * Substitutions
+# include "do_loop_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/ICE 4.0 , NEMO Consortium (2018)
!! $Id: icedyn_adv.F90 13472 2020-09-16 13:05:19Z smasson $
@@ -92,11 +93,11 @@ CONTAINS
!------------
! diagnostics
!------------
- diag_trp_ei(:,:) = SUM(SUM( e_i (:,:,1:nlay_i,:) - e_i_b (:,:,1:nlay_i,:), dim=4 ), dim=3 ) * r1_Dt_ice
- diag_trp_es(:,:) = SUM(SUM( e_s (:,:,1:nlay_s,:) - e_s_b (:,:,1:nlay_s,:), dim=4 ), dim=3 ) * r1_Dt_ice
- diag_trp_sv(:,:) = SUM( sv_i(:,:,:) - sv_i_b(:,:,:) , dim=3 ) * r1_Dt_ice
- diag_trp_vi(:,:) = SUM( v_i (:,:,:) - v_i_b (:,:,:) , dim=3 ) * r1_Dt_ice
- diag_trp_vs(:,:) = SUM( v_s (:,:,:) - v_s_b (:,:,:) , dim=3 ) * r1_Dt_ice
+ diag_trp_ei(:,:) = SUM(SUM( e_i (A2D(0),1:nlay_i,:) - e_i_b (A2D(0),1:nlay_i,:), dim=4 ), dim=3 ) * r1_Dt_ice
+ diag_trp_es(:,:) = SUM(SUM( e_s (A2D(0),1:nlay_s,:) - e_s_b (A2D(0),1:nlay_s,:), dim=4 ), dim=3 ) * r1_Dt_ice
+ diag_trp_sv(:,:) = SUM( sv_i(A2D(0),:) - sv_i_b(A2D(0),:) , dim=3 ) * r1_Dt_ice
+ diag_trp_vi(:,:) = SUM( v_i (A2D(0),:) - v_i_b (A2D(0),:) , dim=3 ) * r1_Dt_ice
+ diag_trp_vs(:,:) = SUM( v_s (A2D(0),:) - v_s_b (A2D(0),:) , dim=3 ) * r1_Dt_ice
IF( iom_use('icemtrp') ) CALL iom_put( 'icemtrp' , diag_trp_vi * rhoi ) ! ice mass transport
IF( iom_use('snwmtrp') ) CALL iom_put( 'snwmtrp' , diag_trp_vs * rhos ) ! snw mass transport
IF( iom_use('salmtrp') ) CALL iom_put( 'salmtrp' , diag_trp_sv * rhoi * 1.e-03 ) ! salt mass transport (kg/m2/s)
@@ -106,6 +107,8 @@ CONTAINS
! controls
IF( ln_icediachk ) CALL ice_cons_hsm(1, 'icedyn_adv', rdiag_v, rdiag_s, rdiag_t, rdiag_fv, rdiag_fs, rdiag_ft) ! conservation
IF( ln_icectl ) CALL ice_prt (kt, iiceprt, jiceprt,-1, ' - ice dyn & trp - ') ! prints
+ IF( sn_cfctl%l_prtctl ) &
+ & CALL ice_prt3D('icedyn_adv') ! prints
IF( ln_timing ) CALL timing_stop ('icedyn_adv') ! timing
!
END SUBROUTINE ice_dyn_adv
diff --git a/src/ICE/icedyn_adv_pra.F90 b/src/ICE/icedyn_adv_pra.F90
index 28c12eb81037564fbadafa6a3f8ff8d1b217b875..7ad39b053816aeb5f6d3e879b0de8ee93e323ece 100644
--- a/src/ICE/icedyn_adv_pra.F90
+++ b/src/ICE/icedyn_adv_pra.F90
@@ -85,54 +85,27 @@ CONTAINS
REAL(wp), DIMENSION(:,:,:,:), INTENT(inout) :: pe_s ! snw heat content
REAL(wp), DIMENSION(:,:,:,:), INTENT(inout) :: pe_i ! ice heat content
!
- INTEGER :: ji, jj, jk, jl, jt ! dummy loop indices
- INTEGER :: icycle ! number of sub-timestep for the advection
- REAL(wp) :: zdt, z1_dt ! - -
- REAL(wp), DIMENSION(1) :: zcflprv, zcflnow ! for global communication
- REAL(wp), DIMENSION(jpi,jpj) :: zati1, zati2
- REAL(wp), DIMENSION(jpi,jpj) :: zudy, zvdx
- REAL(wp), DIMENSION(jpi,jpj,jpl) :: zhi_max, zhs_max, zhip_max, zs_i, zsi_max
- REAL(wp), DIMENSION(jpi,jpj,nlay_i,jpl) :: ze_i, zei_max
- REAL(wp), DIMENSION(jpi,jpj,nlay_s,jpl) :: ze_s, zes_max
- REAL(wp), DIMENSION(jpi,jpj,jpl) :: zarea
- REAL(wp), DIMENSION(jpi,jpj,jpl) :: z0ice, z0snw, z0ai, z0smi, z0oi
- REAL(wp), DIMENSION(jpi,jpj,jpl) :: z0ap , z0vp, z0vl
- REAL(wp), DIMENSION(jpi,jpj,nlay_s,jpl) :: z0es
- REAL(wp), DIMENSION(jpi,jpj,nlay_i,jpl) :: z0ei
+ INTEGER :: ji, jj, jk, jl, jt, ihls ! dummy loop indices
+ INTEGER :: icycle ! number of sub-timestep for the advection
+ REAL(wp) :: zdt, z1_dt ! - -
+ REAL(wp) :: zati2
+ REAL(wp), DIMENSION(1) :: zcflprv, zcflnow ! for global communication
+ REAL(wp), DIMENSION(jpi,jpj) :: zati1
+ REAL(wp), DIMENSION(jpi,jpj) :: zudy, zvdx
+ REAL(wp), DIMENSION(jpi,jpj) :: zh_i, zh_s, zh_ip, zs_i, zhi_max, zhs_max, zhip_max, zsi_max
+ REAL(wp), DIMENSION(jpi,jpj,nlay_i) :: ze_i, zei_max
+ REAL(wp), DIMENSION(jpi,jpj,nlay_s) :: ze_s, zes_max
+ REAL(wp), DIMENSION(jpi,jpj) :: zarea
+ REAL(wp), DIMENSION(jpi,jpj) :: z0ice, z0snw, z0ai, z0smi, z0oi
+ REAL(wp), DIMENSION(jpi,jpj) :: z0ap , z0vp, z0vl
+ REAL(wp), DIMENSION(jpi,jpj,nlay_s) :: z0es
+ REAL(wp), DIMENSION(jpi,jpj,nlay_i) :: z0ei
!! diagnostics
- REAL(wp), DIMENSION(jpi,jpj) :: zdiag_adv_mass, zdiag_adv_salt, zdiag_adv_heat
+ REAL(wp), DIMENSION(A2D(0)) :: zdiag_adv_mass, zdiag_adv_salt, zdiag_adv_heat
!!----------------------------------------------------------------------
!
IF( kt == nit000 .AND. lwp ) WRITE(numout,*) '-- ice_dyn_adv_pra: Prather advection scheme'
!
- ! --- Record max of the surrounding 9-pts (for call Hbig) --- !
- ! thickness and salinity
- WHERE( pv_i(:,:,:) >= epsi10 ) ; zs_i(:,:,:) = psv_i(:,:,:) / pv_i(:,:,:)
- ELSEWHERE ; zs_i(:,:,:) = 0._wp
- END WHERE
- CALL icemax3D( ph_i , zhi_max )
- CALL icemax3D( ph_s , zhs_max )
- CALL icemax3D( ph_ip, zhip_max)
- CALL icemax3D( zs_i , zsi_max )
- CALL lbc_lnk( 'icedyn_adv_pra', zhi_max, 'T', 1._wp, zhs_max, 'T', 1._wp, zhip_max, 'T', 1._wp, zsi_max, 'T', 1._wp )
- !
- ! enthalpies
- DO jk = 1, nlay_i
- WHERE( pv_i(:,:,:) >= epsi10 ) ; ze_i(:,:,jk,:) = pe_i(:,:,jk,:) / pv_i(:,:,:)
- ELSEWHERE ; ze_i(:,:,jk,:) = 0._wp
- END WHERE
- END DO
- DO jk = 1, nlay_s
- WHERE( pv_s(:,:,:) >= epsi10 ) ; ze_s(:,:,jk,:) = pe_s(:,:,jk,:) / pv_s(:,:,:)
- ELSEWHERE ; ze_s(:,:,jk,:) = 0._wp
- END WHERE
- END DO
- CALL icemax4D( ze_i , zei_max )
- CALL icemax4D( ze_s , zes_max )
- CALL lbc_lnk( 'icedyn_adv_pra', zei_max, 'T', 1._wp )
- CALL lbc_lnk( 'icedyn_adv_pra', zes_max, 'T', 1._wp )
- !
- !
! --- If ice drift is too fast, use subtime steps for advection (CFL test for stability) --- !
! Note: the advection split is applied at the next time-step in order to avoid blocking global comm.
! this should not affect too much the stability
@@ -142,9 +115,13 @@ CONTAINS
! non-blocking global communication send zcflnow and receive zcflprv
CALL mpp_delay_max( 'icedyn_adv_pra', 'cflice', zcflnow(:), zcflprv(:), kt == nitend - nn_fsbc + 1 )
- IF( zcflprv(1) > .5 ) THEN ; icycle = 2
- ELSE ; icycle = 1
+ IF ( zcflprv(1) > 1.5 ) THEN ; icycle = 3
+ ELSEIF( zcflprv(1) > .5 ) THEN ; icycle = 2
+ ELSE ; icycle = 1
ENDIF
+!!$ !!test clem
+!!$ icycle=3
+!!$ !!test clem
zdt = rDt_ice / REAL(icycle)
z1_dt = 1._wp / zdt
@@ -152,209 +129,304 @@ CONTAINS
zudy(:,:) = pu_ice(:,:) * e2u(:,:)
zvdx(:,:) = pv_ice(:,:) * e1v(:,:)
+ !---------------!
+ !== advection ==!
+ !---------------!
DO jt = 1, icycle
-
- ! diagnostics
- zdiag_adv_mass(:,:) = SUM( pv_i (:,:,:) , dim=3 ) * rhoi + SUM( pv_s (:,:,:) , dim=3 ) * rhos &
- & + SUM( pv_ip(:,:,:) , dim=3 ) * rhow + SUM( pv_il(:,:,:) , dim=3 ) * rhow
- zdiag_adv_salt(:,:) = SUM( psv_i(:,:,:) , dim=3 ) * rhoi
- zdiag_adv_heat(:,:) = - SUM(SUM( pe_i(:,:,1:nlay_i,:) , dim=4 ), dim=3 ) &
- & - SUM(SUM( pe_s(:,:,1:nlay_s,:) , dim=4 ), dim=3 )
-
+
+ IF( icycle == 1 ) THEN ; ihls = 0 ! optimization
+ ELSE ; ihls = MAX( 0, nn_hls - jt )
+ ENDIF
+ !
! record at_i before advection (for open water)
- zati1(:,:) = SUM( pa_i(:,:,:), dim=3 )
-
- ! --- transported fields --- !
- DO jl = 1, jpl
- zarea(:,:,jl) = e1e2t(:,:)
- z0snw(:,:,jl) = pv_s (:,:,jl) * e1e2t(:,:) ! Snow volume
- z0ice(:,:,jl) = pv_i (:,:,jl) * e1e2t(:,:) ! Ice volume
- z0ai (:,:,jl) = pa_i (:,:,jl) * e1e2t(:,:) ! Ice area
- z0smi(:,:,jl) = psv_i(:,:,jl) * e1e2t(:,:) ! Salt content
- z0oi (:,:,jl) = poa_i(:,:,jl) * e1e2t(:,:) ! Age content
- DO jk = 1, nlay_s
- z0es(:,:,jk,jl) = pe_s(:,:,jk,jl) * e1e2t(:,:) ! Snow heat content
- END DO
- DO jk = 1, nlay_i
- z0ei(:,:,jk,jl) = pe_i(:,:,jk,jl) * e1e2t(:,:) ! Ice heat content
- END DO
- IF ( ln_pnd_LEV .OR. ln_pnd_TOPO ) THEN
- z0ap(:,:,jl) = pa_ip(:,:,jl) * e1e2t(:,:) ! Melt pond fraction
- z0vp(:,:,jl) = pv_ip(:,:,jl) * e1e2t(:,:) ! Melt pond volume
- IF ( ln_pnd_lids ) THEN
- z0vl(:,:,jl) = pv_il(:,:,jl) * e1e2t(:,:) ! Melt pond lid volume
- ENDIF
- ENDIF
- END DO
+ DO_2D( ihls, ihls, ihls, ihls )
+ zati1(ji,jj) = SUM( pa_i(ji,jj,:) )
+ END_2D
!
- ! !--------------------------------------------!
- IF( MOD( (kt - 1) / nn_fsbc , 2 ) == MOD( (jt - 1) , 2 ) ) THEN !== odd ice time step: adv_x then adv_y ==!
- ! !--------------------------------------------!
- CALL adv_x( zdt , zudy , 1._wp , zarea , z0ice , sxice , sxxice , syice , syyice , sxyice ) !--- ice volume
- CALL adv_y( zdt , zvdx , 0._wp , zarea , z0ice , sxice , sxxice , syice , syyice , sxyice )
- CALL adv_x( zdt , zudy , 1._wp , zarea , z0snw , sxsn , sxxsn , sysn , syysn , sxysn ) !--- snow volume
- CALL adv_y( zdt , zvdx , 0._wp , zarea , z0snw , sxsn , sxxsn , sysn , syysn , sxysn )
- CALL adv_x( zdt , zudy , 1._wp , zarea , z0smi , sxsal , sxxsal , sysal , syysal , sxysal ) !--- ice salinity
- CALL adv_y( zdt , zvdx , 0._wp , zarea , z0smi , sxsal , sxxsal , sysal , syysal , sxysal )
- CALL adv_x( zdt , zudy , 1._wp , zarea , z0ai , sxa , sxxa , sya , syya , sxya ) !--- ice concentration
- CALL adv_y( zdt , zvdx , 0._wp , zarea , z0ai , sxa , sxxa , sya , syya , sxya )
- CALL adv_x( zdt , zudy , 1._wp , zarea , z0oi , sxage , sxxage , syage , syyage , sxyage ) !--- ice age
- CALL adv_y( zdt , zvdx , 0._wp , zarea , z0oi , sxage , sxxage , syage , syyage , sxyage )
+ ! ! =================== !
+ ! ! Start cat loop here !
+ ! ! =================== !
+ DO jl = 1, jpl
+
+ ! --- Record max of the surrounding 9-pts (for call Hbig) --- !
+ ! thickness and salinity
+ zh_i (:,:) = ph_i (:,:,jl)
+ zh_s (:,:) = ph_s (:,:,jl)
+ zh_ip(:,:) = ph_ip(:,:,jl)
+ WHERE( pv_i(:,:,jl) >= epsi10 ) ; zs_i(:,:) = psv_i(:,:,jl) / pv_i(:,:,jl)
+ ELSEWHERE ; zs_i(:,:) = 0._wp
+ END WHERE
+ CALL icemax2D_pra( ihls, zh_i , zhi_max )
+ CALL icemax2D_pra( ihls, zh_s , zhs_max )
+ CALL icemax2D_pra( ihls, zh_ip, zhip_max)
+ CALL icemax2D_pra( ihls, zs_i , zsi_max )
!
- DO jk = 1, nlay_s !--- snow heat content
- CALL adv_x( zdt, zudy, 1._wp, zarea, z0es (:,:,jk,:), sxc0(:,:,jk,:), &
- & sxxc0(:,:,jk,:), syc0(:,:,jk,:), syyc0(:,:,jk,:), sxyc0(:,:,jk,:) )
- CALL adv_y( zdt, zvdx, 0._wp, zarea, z0es (:,:,jk,:), sxc0(:,:,jk,:), &
- & sxxc0(:,:,jk,:), syc0(:,:,jk,:), syyc0(:,:,jk,:), sxyc0(:,:,jk,:) )
+ ! enthalpies
+ DO jk = 1, nlay_i
+ WHERE( pv_i(:,:,jl) >= epsi10 ) ; ze_i(:,:,jk) = pe_i(:,:,jk,jl) / pv_i(:,:,jl)
+ ELSEWHERE ; ze_i(:,:,jk) = 0._wp
+ END WHERE
END DO
- DO jk = 1, nlay_i !--- ice heat content
- CALL adv_x( zdt, zudy, 1._wp, zarea, z0ei(:,:,jk,:), sxe(:,:,jk,:), &
- & sxxe(:,:,jk,:), sye(:,:,jk,:), syye(:,:,jk,:), sxye(:,:,jk,:) )
- CALL adv_y( zdt, zvdx, 0._wp, zarea, z0ei(:,:,jk,:), sxe(:,:,jk,:), &
- & sxxe(:,:,jk,:), sye(:,:,jk,:), syye(:,:,jk,:), sxye(:,:,jk,:) )
+ DO jk = 1, nlay_s
+ WHERE( pv_s(:,:,jl) >= epsi10 ) ; ze_s(:,:,jk) = pe_s(:,:,jk,jl) / pv_s(:,:,jl)
+ ELSEWHERE ; ze_s(:,:,jk) = 0._wp
+ END WHERE
END DO
+ CALL icemax3D_pra( ihls, ze_i , zei_max )
+ CALL icemax3D_pra( ihls, ze_s , zes_max )
+
+ ! diagnostics
+ DO_2D( 0, 0, 0, 0 )
+ zdiag_adv_mass(ji,jj) = pv_i (ji,jj,jl) * rhoi + pv_s (ji,jj,jl) * rhos &
+ & + pv_ip(ji,jj,jl) * rhow + pv_il(ji,jj,jl) * rhow
+ zdiag_adv_salt(ji,jj) = psv_i(ji,jj,jl) * rhoi
+ zdiag_adv_heat(ji,jj) = - SUM( pe_i(ji,jj,1:nlay_i,jl) ) - SUM( pe_s(ji,jj,1:nlay_s,jl) )
+ END_2D
!
+
+ ! --- transported fields --- !
+ DO_2D( ihls+1, ihls+1, ihls+1, ihls+1 )
+ zarea(ji,jj) = e1e2t(ji,jj)
+ z0snw(ji,jj) = pv_s (ji,jj,jl) * e1e2t(ji,jj) ! Snow volume
+ z0ice(ji,jj) = pv_i (ji,jj,jl) * e1e2t(ji,jj) ! Ice volume
+ z0ai (ji,jj) = pa_i (ji,jj,jl) * e1e2t(ji,jj) ! Ice area
+ z0smi(ji,jj) = psv_i(ji,jj,jl) * e1e2t(ji,jj) ! Salt content
+ z0oi (ji,jj) = poa_i(ji,jj,jl) * e1e2t(ji,jj) ! Age content
+ DO jk = 1, nlay_s
+ z0es(ji,jj,jk) = pe_s(ji,jj,jk,jl) * e1e2t(ji,jj) ! Snow heat content
+ END DO
+ DO jk = 1, nlay_i
+ z0ei(ji,jj,jk) = pe_i(ji,jj,jk,jl) * e1e2t(ji,jj) ! Ice heat content
+ END DO
+ END_2D
IF ( ln_pnd_LEV .OR. ln_pnd_TOPO ) THEN
- CALL adv_x( zdt , zudy , 1._wp , zarea , z0ap , sxap , sxxap , syap , syyap , sxyap ) !--- melt pond fraction
- CALL adv_y( zdt , zvdx , 0._wp , zarea , z0ap , sxap , sxxap , syap , syyap , sxyap )
- CALL adv_x( zdt , zudy , 1._wp , zarea , z0vp , sxvp , sxxvp , syvp , syyvp , sxyvp ) !--- melt pond volume
- CALL adv_y( zdt , zvdx , 0._wp , zarea , z0vp , sxvp , sxxvp , syvp , syyvp , sxyvp )
- IF ( ln_pnd_lids ) THEN
- CALL adv_x( zdt , zudy , 1._wp , zarea , z0vl , sxvl , sxxvl , syvl , syyvl , sxyvl ) !--- melt pond lid volume
- CALL adv_y( zdt , zvdx , 0._wp , zarea , z0vl , sxvl , sxxvl , syvl , syyvl , sxyvl )
- ENDIF
- ENDIF
- ! !--------------------------------------------!
- ELSE !== even ice time step: adv_y then adv_x ==!
- ! !--------------------------------------------!
- CALL adv_y( zdt , zvdx , 1._wp , zarea , z0ice , sxice , sxxice , syice , syyice , sxyice ) !--- ice volume
- CALL adv_x( zdt , zudy , 0._wp , zarea , z0ice , sxice , sxxice , syice , syyice , sxyice )
- CALL adv_y( zdt , zvdx , 1._wp , zarea , z0snw , sxsn , sxxsn , sysn , syysn , sxysn ) !--- snow volume
- CALL adv_x( zdt , zudy , 0._wp , zarea , z0snw , sxsn , sxxsn , sysn , syysn , sxysn )
- CALL adv_y( zdt , zvdx , 1._wp , zarea , z0smi , sxsal , sxxsal , sysal , syysal , sxysal ) !--- ice salinity
- CALL adv_x( zdt , zudy , 0._wp , zarea , z0smi , sxsal , sxxsal , sysal , syysal , sxysal )
- CALL adv_y( zdt , zvdx , 1._wp , zarea , z0ai , sxa , sxxa , sya , syya , sxya ) !--- ice concentration
- CALL adv_x( zdt , zudy , 0._wp , zarea , z0ai , sxa , sxxa , sya , syya , sxya )
- CALL adv_y( zdt , zvdx , 1._wp , zarea , z0oi , sxage , sxxage , syage , syyage , sxyage ) !--- ice age
- CALL adv_x( zdt , zudy , 0._wp , zarea , z0oi , sxage , sxxage , syage , syyage , sxyage )
- DO jk = 1, nlay_s !--- snow heat content
- CALL adv_y( zdt, zvdx, 1._wp, zarea, z0es (:,:,jk,:), sxc0(:,:,jk,:), &
- & sxxc0(:,:,jk,:), syc0(:,:,jk,:), syyc0(:,:,jk,:), sxyc0(:,:,jk,:) )
- CALL adv_x( zdt, zudy, 0._wp, zarea, z0es (:,:,jk,:), sxc0(:,:,jk,:), &
- & sxxc0(:,:,jk,:), syc0(:,:,jk,:), syyc0(:,:,jk,:), sxyc0(:,:,jk,:) )
- END DO
- DO jk = 1, nlay_i !--- ice heat content
- CALL adv_y( zdt, zvdx, 1._wp, zarea, z0ei(:,:,jk,:), sxe(:,:,jk,:), &
- & sxxe(:,:,jk,:), sye(:,:,jk,:), syye(:,:,jk,:), sxye(:,:,jk,:) )
- CALL adv_x( zdt, zudy, 0._wp, zarea, z0ei(:,:,jk,:), sxe(:,:,jk,:), &
- & sxxe(:,:,jk,:), sye(:,:,jk,:), syye(:,:,jk,:), sxye(:,:,jk,:) )
- END DO
- IF ( ln_pnd_LEV .OR. ln_pnd_TOPO ) THEN
- CALL adv_y( zdt , zvdx , 1._wp , zarea , z0ap , sxap , sxxap , syap , syyap , sxyap ) !--- melt pond fraction
- CALL adv_x( zdt , zudy , 0._wp , zarea , z0ap , sxap , sxxap , syap , syyap , sxyap )
- CALL adv_y( zdt , zvdx , 1._wp , zarea , z0vp , sxvp , sxxvp , syvp , syyvp , sxyvp ) !--- melt pond volume
- CALL adv_x( zdt , zudy , 0._wp , zarea , z0vp , sxvp , sxxvp , syvp , syyvp , sxyvp )
+ DO_2D( ihls+1, ihls+1, ihls+1, ihls+1 )
+ z0ap(ji,jj) = pa_ip(ji,jj,jl) * e1e2t(ji,jj) ! Melt pond fraction
+ z0vp(ji,jj) = pv_ip(ji,jj,jl) * e1e2t(ji,jj) ! Melt pond volume
+ END_2D
IF ( ln_pnd_lids ) THEN
- CALL adv_y( zdt , zvdx , 1._wp , zarea , z0vl , sxvl , sxxvl , syvl , syyvl , sxyvl ) !--- melt pond lid volume
- CALL adv_x( zdt , zudy , 0._wp , zarea , z0vl , sxvl , sxxvl , syvl , syyvl , sxyvl )
+ DO_2D( ihls+1, ihls+1, ihls+1, ihls+1 )
+ z0vl(ji,jj) = pv_il(ji,jj,jl) * e1e2t(ji,jj) ! Melt pond lid volume
+ END_2D
ENDIF
ENDIF
!
- ENDIF
-
- ! --- Lateral boundary conditions --- !
- ! caution: for gradients (sx and sy) the sign changes
- CALL lbc_lnk( 'icedyn_adv_pra', z0ice , 'T', 1._wp, sxice , 'T', -1._wp, syice , 'T', -1._wp & ! ice volume
- & , sxxice, 'T', 1._wp, syyice, 'T', 1._wp, sxyice, 'T', 1._wp &
- & , z0snw , 'T', 1._wp, sxsn , 'T', -1._wp, sysn , 'T', -1._wp & ! snw volume
- & , sxxsn , 'T', 1._wp, syysn , 'T', 1._wp, sxysn , 'T', 1._wp &
- & , z0smi , 'T', 1._wp, sxsal , 'T', -1._wp, sysal , 'T', -1._wp & ! ice salinity
- & , sxxsal, 'T', 1._wp, syysal, 'T', 1._wp, sxysal, 'T', 1._wp &
- & , z0ai , 'T', 1._wp, sxa , 'T', -1._wp, sya , 'T', -1._wp & ! ice concentration
- & , sxxa , 'T', 1._wp, syya , 'T', 1._wp, sxya , 'T', 1._wp &
- & , z0oi , 'T', 1._wp, sxage , 'T', -1._wp, syage , 'T', -1._wp & ! ice age
- & , sxxage, 'T', 1._wp, syyage, 'T', 1._wp, sxyage, 'T', 1._wp )
- CALL lbc_lnk( 'icedyn_adv_pra', z0es , 'T', 1._wp, sxc0 , 'T', -1._wp, syc0 , 'T', -1._wp & ! snw enthalpy
- & , sxxc0 , 'T', 1._wp, syyc0 , 'T', 1._wp, sxyc0 , 'T', 1._wp )
- CALL lbc_lnk( 'icedyn_adv_pra', z0ei , 'T', 1._wp, sxe , 'T', -1._wp, sye , 'T', -1._wp & ! ice enthalpy
- & , sxxe , 'T', 1._wp, syye , 'T', 1._wp, sxye , 'T', 1._wp )
- IF ( ln_pnd_LEV .OR. ln_pnd_TOPO ) THEN
- IF( ln_pnd_lids ) THEN
- CALL lbc_lnk( 'icedyn_adv_pra', z0ap , 'T', 1._wp, sxap , 'T', -1._wp, syap , 'T', -1._wp & ! melt pond fraction
- & , sxxap, 'T', 1._wp, syyap, 'T', 1._wp, sxyap, 'T', 1._wp &
- & , z0vp , 'T', 1._wp, sxvp , 'T', -1._wp, syvp , 'T', -1._wp & ! melt pond volume
- & , sxxvp, 'T', 1._wp, syyvp, 'T', 1._wp, sxyvp, 'T', 1._wp &
- & , z0vl , 'T', 1._wp, sxvl , 'T', -1._wp, syvl , 'T', -1._wp & ! melt pond lid volume
- & , sxxvl, 'T', 1._wp, syyvl, 'T', 1._wp, sxyvl, 'T', 1._wp )
- ELSE
- CALL lbc_lnk( 'icedyn_adv_pra', z0ap , 'T', 1._wp, sxap , 'T', -1._wp, syap , 'T', -1._wp & ! melt pond fraction
- & , sxxap, 'T', 1._wp, syyap, 'T', 1._wp, sxyap, 'T', 1._wp &
- & , z0vp , 'T', 1._wp, sxvp , 'T', -1._wp, syvp , 'T', -1._wp & ! melt pond volume
- & , sxxvp, 'T', 1._wp, syyvp, 'T', 1._wp, sxyvp, 'T', 1._wp )
+ ! ----------------------- !
+ ! ==> start advection <== !
+ ! ----------------------- !
+ ! !--------------------------------------------!
+ IF( MOD( (kt - 1) / nn_fsbc , 2 ) == MOD( (jt - 1) , 2 ) ) THEN !== odd ice time step: adv_x then adv_y ==!
+ ! !--------------------------------------------!
+ CALL adv_x( ihls, jl, zdt , zudy , 1._wp , zarea , z0ice , sxice , sxxice , syice , syyice , sxyice ) !--- ice volume
+ CALL adv_y( ihls, jl, zdt , zvdx , 0._wp , zarea , z0ice , sxice , sxxice , syice , syyice , sxyice )
+ CALL adv_x( ihls, jl, zdt , zudy , 1._wp , zarea , z0snw , sxsn , sxxsn , sysn , syysn , sxysn ) !--- snow volume
+ CALL adv_y( ihls, jl, zdt , zvdx , 0._wp , zarea , z0snw , sxsn , sxxsn , sysn , syysn , sxysn )
+ CALL adv_x( ihls, jl, zdt , zudy , 1._wp , zarea , z0smi , sxsal , sxxsal , sysal , syysal , sxysal ) !--- ice salinity
+ CALL adv_y( ihls, jl, zdt , zvdx , 0._wp , zarea , z0smi , sxsal , sxxsal , sysal , syysal , sxysal )
+ CALL adv_x( ihls, jl, zdt , zudy , 1._wp , zarea , z0ai , sxa , sxxa , sya , syya , sxya ) !--- ice concentration
+ CALL adv_y( ihls, jl, zdt , zvdx , 0._wp , zarea , z0ai , sxa , sxxa , sya , syya , sxya )
+ CALL adv_x( ihls, jl, zdt , zudy , 1._wp , zarea , z0oi , sxage , sxxage , syage , syyage , sxyage ) !--- ice age
+ CALL adv_y( ihls, jl, zdt , zvdx , 0._wp , zarea , z0oi , sxage , sxxage , syage , syyage , sxyage )
+ !
+ DO jk = 1, nlay_s !--- snow heat content
+ CALL adv_x( ihls, jl, zdt, zudy, 1._wp, zarea, z0es (:,:,jk) , sxc0(:,:,jk,:), &
+ & sxxc0(:,:,jk,:), syc0(:,:,jk,:), syyc0(:,:,jk,:), sxyc0(:,:,jk,:) )
+ CALL adv_y( ihls, jl, zdt, zvdx, 0._wp, zarea, z0es (:,:,jk) , sxc0(:,:,jk,:), &
+ & sxxc0(:,:,jk,:), syc0(:,:,jk,:), syyc0(:,:,jk,:), sxyc0(:,:,jk,:) )
+ END DO
+ DO jk = 1, nlay_i !--- ice heat content
+ CALL adv_x( ihls, jl, zdt, zudy, 1._wp, zarea, z0ei(:,:,jk) , sxe(:,:,jk,:), &
+ & sxxe(:,:,jk,:), sye(:,:,jk,:), syye(:,:,jk,:), sxye(:,:,jk,:) )
+ CALL adv_y( ihls, jl, zdt, zvdx, 0._wp, zarea, z0ei(:,:,jk) , sxe(:,:,jk,:), &
+ & sxxe(:,:,jk,:), sye(:,:,jk,:), syye(:,:,jk,:), sxye(:,:,jk,:) )
+ END DO
+ !
+ IF ( ln_pnd_LEV .OR. ln_pnd_TOPO ) THEN
+ CALL adv_x( ihls, jl, zdt , zudy , 1._wp , zarea , z0ap , sxap , sxxap , syap , syyap , sxyap ) !--- melt pond fraction
+ CALL adv_y( ihls, jl, zdt , zvdx , 0._wp , zarea , z0ap , sxap , sxxap , syap , syyap , sxyap )
+ CALL adv_x( ihls, jl, zdt , zudy , 1._wp , zarea , z0vp , sxvp , sxxvp , syvp , syyvp , sxyvp ) !--- melt pond volume
+ CALL adv_y( ihls, jl, zdt , zvdx , 0._wp , zarea , z0vp , sxvp , sxxvp , syvp , syyvp , sxyvp )
+ IF ( ln_pnd_lids ) THEN
+ CALL adv_x( ihls, jl, zdt , zudy , 1._wp , zarea , z0vl , sxvl , sxxvl , syvl , syyvl , sxyvl ) !--- melt pond lid volume
+ CALL adv_y( ihls, jl, zdt , zvdx , 0._wp , zarea , z0vl , sxvl , sxxvl , syvl , syyvl , sxyvl )
+ ENDIF
+ ENDIF
+ ! !--------------------------------------------!
+ ELSE !== even ice time step: adv_y then adv_x ==!
+ ! !--------------------------------------------!
+ CALL adv_y( ihls, jl, zdt , zvdx , 1._wp , zarea , z0ice , sxice , sxxice , syice , syyice , sxyice ) !--- ice volume
+ CALL adv_x( ihls, jl, zdt , zudy , 0._wp , zarea , z0ice , sxice , sxxice , syice , syyice , sxyice )
+ CALL adv_y( ihls, jl, zdt , zvdx , 1._wp , zarea , z0snw , sxsn , sxxsn , sysn , syysn , sxysn ) !--- snow volume
+ CALL adv_x( ihls, jl, zdt , zudy , 0._wp , zarea , z0snw , sxsn , sxxsn , sysn , syysn , sxysn )
+ CALL adv_y( ihls, jl, zdt , zvdx , 1._wp , zarea , z0smi , sxsal , sxxsal , sysal , syysal , sxysal ) !--- ice salinity
+ CALL adv_x( ihls, jl, zdt , zudy , 0._wp , zarea , z0smi , sxsal , sxxsal , sysal , syysal , sxysal )
+ CALL adv_y( ihls, jl, zdt , zvdx , 1._wp , zarea , z0ai , sxa , sxxa , sya , syya , sxya ) !--- ice concentration
+ CALL adv_x( ihls, jl, zdt , zudy , 0._wp , zarea , z0ai , sxa , sxxa , sya , syya , sxya )
+ CALL adv_y( ihls, jl, zdt , zvdx , 1._wp , zarea , z0oi , sxage , sxxage , syage , syyage , sxyage ) !--- ice age
+ CALL adv_x( ihls, jl, zdt , zudy , 0._wp , zarea , z0oi , sxage , sxxage , syage , syyage , sxyage )
+ DO jk = 1, nlay_s !--- snow heat content
+ CALL adv_y( ihls, jl, zdt, zvdx, 1._wp, zarea, z0es (:,:,jk) , sxc0(:,:,jk,:), &
+ & sxxc0(:,:,jk,:), syc0(:,:,jk,:), syyc0(:,:,jk,:), sxyc0(:,:,jk,:) )
+ CALL adv_x( ihls, jl, zdt, zudy, 0._wp, zarea, z0es (:,:,jk) , sxc0(:,:,jk,:), &
+ & sxxc0(:,:,jk,:), syc0(:,:,jk,:), syyc0(:,:,jk,:), sxyc0(:,:,jk,:) )
+ END DO
+ DO jk = 1, nlay_i !--- ice heat content
+ CALL adv_y( ihls, jl, zdt, zvdx, 1._wp, zarea, z0ei(:,:,jk) , sxe(:,:,jk,:), &
+ & sxxe(:,:,jk,:), sye(:,:,jk,:), syye(:,:,jk,:), sxye(:,:,jk,:) )
+ CALL adv_x( ihls, jl, zdt, zudy, 0._wp, zarea, z0ei(:,:,jk) , sxe(:,:,jk,:), &
+ & sxxe(:,:,jk,:), sye(:,:,jk,:), syye(:,:,jk,:), sxye(:,:,jk,:) )
+ END DO
+ IF ( ln_pnd_LEV .OR. ln_pnd_TOPO ) THEN
+ CALL adv_y( ihls, jl, zdt , zvdx , 1._wp , zarea , z0ap , sxap , sxxap , syap , syyap , sxyap ) !--- melt pond fraction
+ CALL adv_x( ihls, jl, zdt , zudy , 0._wp , zarea , z0ap , sxap , sxxap , syap , syyap , sxyap )
+ CALL adv_y( ihls, jl, zdt , zvdx , 1._wp , zarea , z0vp , sxvp , sxxvp , syvp , syyvp , sxyvp ) !--- melt pond volume
+ CALL adv_x( ihls, jl, zdt , zudy , 0._wp , zarea , z0vp , sxvp , sxxvp , syvp , syyvp , sxyvp )
+ IF ( ln_pnd_lids ) THEN
+ CALL adv_y( ihls, jl, zdt , zvdx , 1._wp , zarea , z0vl , sxvl , sxxvl , syvl , syyvl , sxyvl ) !--- melt pond lid volume
+ CALL adv_x( ihls, jl, zdt , zudy , 0._wp , zarea , z0vl , sxvl , sxxvl , syvl , syyvl , sxyvl )
+ ENDIF
+ ENDIF
+ !
ENDIF
- ENDIF
- ! --- Recover the properties from their contents --- !
- DO jl = 1, jpl
- pv_i (:,:,jl) = z0ice(:,:,jl) * r1_e1e2t(:,:) * tmask(:,:,1)
- pv_s (:,:,jl) = z0snw(:,:,jl) * r1_e1e2t(:,:) * tmask(:,:,1)
- psv_i(:,:,jl) = z0smi(:,:,jl) * r1_e1e2t(:,:) * tmask(:,:,1)
- poa_i(:,:,jl) = z0oi (:,:,jl) * r1_e1e2t(:,:) * tmask(:,:,1)
- pa_i (:,:,jl) = z0ai (:,:,jl) * r1_e1e2t(:,:) * tmask(:,:,1)
- DO jk = 1, nlay_s
- pe_s(:,:,jk,jl) = z0es(:,:,jk,jl) * r1_e1e2t(:,:) * tmask(:,:,1)
- END DO
- DO jk = 1, nlay_i
- pe_i(:,:,jk,jl) = z0ei(:,:,jk,jl) * r1_e1e2t(:,:) * tmask(:,:,1)
- END DO
+ ! --- Recover the properties from their contents --- !
+ DO_2D( ihls, ihls, ihls, ihls )
+ pv_i (ji,jj,jl) = z0ice(ji,jj) * r1_e1e2t(ji,jj) * tmask(ji,jj,1)
+ pv_s (ji,jj,jl) = z0snw(ji,jj) * r1_e1e2t(ji,jj) * tmask(ji,jj,1)
+ psv_i(ji,jj,jl) = z0smi(ji,jj) * r1_e1e2t(ji,jj) * tmask(ji,jj,1)
+ poa_i(ji,jj,jl) = z0oi (ji,jj) * r1_e1e2t(ji,jj) * tmask(ji,jj,1)
+ pa_i (ji,jj,jl) = z0ai (ji,jj) * r1_e1e2t(ji,jj) * tmask(ji,jj,1)
+ DO jk = 1, nlay_s
+ pe_s(ji,jj,jk,jl) = z0es(ji,jj,jk) * r1_e1e2t(ji,jj) * tmask(ji,jj,1)
+ END DO
+ DO jk = 1, nlay_i
+ pe_i(ji,jj,jk,jl) = z0ei(ji,jj,jk) * r1_e1e2t(ji,jj) * tmask(ji,jj,1)
+ END DO
+ END_2D
IF ( ln_pnd_LEV .OR. ln_pnd_TOPO ) THEN
- pa_ip(:,:,jl) = z0ap(:,:,jl) * r1_e1e2t(:,:) * tmask(:,:,1)
- pv_ip(:,:,jl) = z0vp(:,:,jl) * r1_e1e2t(:,:) * tmask(:,:,1)
+ DO_2D( ihls, ihls, ihls, ihls )
+ pa_ip(ji,jj,jl) = z0ap(ji,jj) * r1_e1e2t(ji,jj) * tmask(ji,jj,1)
+ pv_ip(ji,jj,jl) = z0vp(ji,jj) * r1_e1e2t(ji,jj) * tmask(ji,jj,1)
+ END_2D
IF ( ln_pnd_lids ) THEN
- pv_il(:,:,jl) = z0vl(:,:,jl) * r1_e1e2t(:,:) * tmask(:,:,1)
+ DO_2D( ihls, ihls, ihls, ihls )
+ pv_il(ji,jj,jl) = z0vl(ji,jj) * r1_e1e2t(ji,jj) * tmask(ji,jj,1)
+ END_2D
ENDIF
ENDIF
+
+ ! --- diagnostics --- !
+ DO_2D( 0, 0, 0, 0 )
+ diag_adv_mass(ji,jj) = diag_adv_mass(ji,jj) + ( pv_i (ji,jj,jl) * rhoi + pv_s (ji,jj,jl) * rhos &
+ & + pv_ip(ji,jj,jl) * rhow + pv_il(ji,jj,jl) * rhow &
+ & - zdiag_adv_mass(ji,jj) ) * z1_dt
+ diag_adv_salt(ji,jj) = diag_adv_salt(ji,jj) + ( psv_i(ji,jj,jl) * rhoi &
+ & - zdiag_adv_salt(ji,jj) ) * z1_dt
+ diag_adv_heat(ji,jj) = diag_adv_heat(ji,jj) + ( -SUM( pe_i(ji,jj,1:nlay_i,jl) ) -SUM( pe_s(ji,jj,1:nlay_s,jl) ) &
+ & - zdiag_adv_heat(ji,jj) ) * z1_dt
+ END_2D
+
+ ! --- Make sure ice thickness is not too big --- !
+ ! (because ice thickness can be too large where ice concentration is very small)
+ CALL Hbig_pra( ihls, jl, zdt, zhi_max, zhs_max, zhip_max, zsi_max, zes_max, zei_max, &
+ & pv_i, pv_s, pa_i, pa_ip, pv_ip, psv_i, pe_s, pe_i )
+ !
+ ! --- Ensure snow load is not too big --- !
+ CALL Hsnow_pra( ihls, jl, zdt, pv_i, pv_s, pa_i, pa_ip, pe_s )
+ !
END DO
- !
+ ! ! ================= !
+ ! ! End cat loop here !
+ ! ! ================= !
+
! derive open water from ice concentration
- zati2(:,:) = SUM( pa_i(:,:,:), dim=3 )
- DO_2D( 0, 0, 0, 0 )
- pato_i(ji,jj) = pato_i(ji,jj) - ( zati2(ji,jj) - zati1(ji,jj) ) & !--- open water
- & - ( zudy(ji,jj) - zudy(ji-1,jj) + zvdx(ji,jj) - zvdx(ji,jj-1) ) * r1_e1e2t(ji,jj) * zdt
+ DO_2D( ihls, ihls, ihls, ihls )
+ zati2 = SUM( pa_i(ji,jj,:) )
+ pato_i(ji,jj) = pato_i(ji,jj) - ( zati2 - zati1(ji,jj) ) & !--- open water
+ & - ( ( zudy(ji,jj) - zudy(ji-1,jj) ) & ! add () for NP repro
+ & + ( zvdx(ji,jj) - zvdx(ji,jj-1) ) ) * r1_e1e2t(ji,jj) * zdt
END_2D
- CALL lbc_lnk( 'icedyn_adv_pra', pato_i, 'T', 1.0_wp )
- !
- ! --- diagnostics --- !
- diag_adv_mass(:,:) = diag_adv_mass(:,:) + ( SUM( pv_i (:,:,:) , dim=3 ) * rhoi + SUM( pv_s (:,:,:) , dim=3 ) * rhos &
- & + SUM( pv_ip(:,:,:) , dim=3 ) * rhow + SUM( pv_il(:,:,:) , dim=3 ) * rhow &
- & - zdiag_adv_mass(:,:) ) * z1_dt
- diag_adv_salt(:,:) = diag_adv_salt(:,:) + ( SUM( psv_i(:,:,:) , dim=3 ) * rhoi &
- & - zdiag_adv_salt(:,:) ) * z1_dt
- diag_adv_heat(:,:) = diag_adv_heat(:,:) + ( - SUM(SUM( pe_i(:,:,1:nlay_i,:) , dim=4 ), dim=3 ) &
- & - SUM(SUM( pe_s(:,:,1:nlay_s,:) , dim=4 ), dim=3 ) &
- & - zdiag_adv_heat(:,:) ) * z1_dt
- !
+
! --- Ensure non-negative fields --- !
! Remove negative values (conservation is ensured)
! (because advected fields are not perfectly bounded and tiny negative values can occur, e.g. -1.e-20)
- CALL ice_var_zapneg( zdt, pato_i, pv_i, pv_s, psv_i, poa_i, pa_i, pa_ip, pv_ip, pv_il, pe_s, pe_i )
+ CALL ice_var_zapneg( ihls, zdt, pato_i, pv_i, pv_s, psv_i, poa_i, pa_i, pa_ip, pv_ip, pv_il, pe_s, pe_i )
!
- ! --- Make sure ice thickness is not too big --- !
- ! (because ice thickness can be too large where ice concentration is very small)
- CALL Hbig( zdt, zhi_max, zhs_max, zhip_max, zsi_max, zes_max, zei_max, &
- & pv_i, pv_s, pa_i, pa_ip, pv_ip, psv_i, pe_s, pe_i )
- !
- ! --- Ensure snow load is not too big --- !
- CALL Hsnow( zdt, pv_i, pv_s, pa_i, pa_ip, pe_s )
+ ! --- Lateral boundary conditions --- !
+ ! caution: for gradients (sx and sy) the sign changes
+ ! plus, one needs ldfull=T to deal with the NorthFold
+ IF( ihls == 0 .AND. jt /= icycle ) THEN ! comm. on all fields if ihls=0 and we are only at the 1st iteration (jt=1) over 2 (icycle=2)
+ !
+ CALL lbc_lnk( 'icedyn_adv_pra', pv_i , 'T', 1._wp, sxice , 'T', -1._wp, syice , 'T', -1._wp & ! ice volume
+ & , sxxice, 'T', 1._wp, syyice, 'T', 1._wp, sxyice, 'T', 1._wp &
+ & , pv_s , 'T', 1._wp, sxsn , 'T', -1._wp, sysn , 'T', -1._wp & ! snw volume
+ & , sxxsn , 'T', 1._wp, syysn , 'T', 1._wp, sxysn , 'T', 1._wp &
+ & , psv_i , 'T', 1._wp, sxsal , 'T', -1._wp, sysal , 'T', -1._wp & ! ice salinity
+ & , sxxsal, 'T', 1._wp, syysal, 'T', 1._wp, sxysal, 'T', 1._wp &
+ & , pa_i , 'T', 1._wp, sxa , 'T', -1._wp, sya , 'T', -1._wp & ! ice concentration
+ & , sxxa , 'T', 1._wp, syya , 'T', 1._wp, sxya , 'T', 1._wp &
+ & , poa_i , 'T', 1._wp, sxage , 'T', -1._wp, syage , 'T', -1._wp & ! ice age
+ & , sxxage, 'T', 1._wp, syyage, 'T', 1._wp, sxyage, 'T', 1._wp, ldfull = .TRUE. )
+ CALL lbc_lnk( 'icedyn_adv_pra', pe_s , 'T', 1._wp, sxc0 , 'T', -1._wp, syc0 , 'T', -1._wp & ! snw enthalpy
+ & , sxxc0 , 'T', 1._wp, syyc0 , 'T', 1._wp, sxyc0 , 'T', 1._wp &
+ & , pe_i , 'T', 1._wp, sxe , 'T', -1._wp, sye , 'T', -1._wp & ! ice enthalpy
+ & , sxxe , 'T', 1._wp, syye , 'T', 1._wp, sxye , 'T', 1._wp, ldfull = .TRUE. )
+ IF ( ln_pnd_LEV .OR. ln_pnd_TOPO ) THEN
+ CALL lbc_lnk( 'icedyn_adv_pra', pa_ip, 'T', 1._wp, sxap , 'T', -1._wp, syap , 'T', -1._wp & ! melt pond fraction
+ & , sxxap, 'T', 1._wp, syyap, 'T', 1._wp, sxyap, 'T', 1._wp &
+ & , pv_ip, 'T', 1._wp, sxvp , 'T', -1._wp, syvp , 'T', -1._wp & ! melt pond volume
+ & , sxxvp, 'T', 1._wp, syyvp, 'T', 1._wp, sxyvp, 'T', 1._wp &
+ & , pv_il, 'T', 1._wp, sxvl , 'T', -1._wp, syvl , 'T', -1._wp & ! melt pond lid volume
+ & , sxxvl, 'T', 1._wp, syyvl, 'T', 1._wp, sxyvl, 'T', 1._wp, ldfull = .TRUE. )
+ ENDIF
+ CALL lbc_lnk( 'icedyn_adv_pra', pato_i, 'T', 1.0_wp, ldfull = .TRUE. )
+ !
+ ELSEIF( jt == icycle ) THEN ! comm. on the moments at the end of advection
+ ! ! comm. on the other fields are gathered in icedyn.F90
+ IF ( ln_pnd_LEV .OR. ln_pnd_TOPO ) THEN
+ CALL lbc_lnk( 'icedyn_adv_pra', sxice , 'T', -1._wp, syice , 'T', -1._wp & ! ice volume
+ & , sxxice, 'T', 1._wp, syyice, 'T', 1._wp, sxyice, 'T', 1._wp &
+ & , sxsn , 'T', -1._wp, sysn , 'T', -1._wp & ! snw volume
+ & , sxxsn , 'T', 1._wp, syysn , 'T', 1._wp, sxysn , 'T', 1._wp &
+ & , sxsal , 'T', -1._wp, sysal , 'T', -1._wp & ! ice salinity
+ & , sxxsal, 'T', 1._wp, syysal, 'T', 1._wp, sxysal, 'T', 1._wp &
+ & , sxa , 'T', -1._wp, sya , 'T', -1._wp & ! ice concentration
+ & , sxxa , 'T', 1._wp, syya , 'T', 1._wp, sxya , 'T', 1._wp &
+ & , sxage , 'T', -1._wp, syage , 'T', -1._wp & ! ice age
+ & , sxxage, 'T', 1._wp, syyage, 'T', 1._wp, sxyage, 'T', 1._wp &
+ & , sxap , 'T', -1._wp, syap , 'T', -1._wp & ! melt pond fraction
+ & , sxxap , 'T', 1._wp, syyap , 'T', 1._wp, sxyap , 'T', 1._wp &
+ & , sxvp , 'T', -1._wp, syvp , 'T', -1._wp & ! melt pond volume
+ & , sxxvp , 'T', 1._wp, syyvp , 'T', 1._wp, sxyvp , 'T', 1._wp &
+ & , sxvl , 'T', -1._wp, syvl , 'T', -1._wp & ! melt pond lid volume
+ & , sxxvl , 'T', 1._wp, syyvl , 'T', 1._wp, sxyvl, 'T', 1._wp, ldfull = .TRUE. )
+ ELSE
+ CALL lbc_lnk( 'icedyn_adv_pra', sxice , 'T', -1._wp, syice , 'T', -1._wp & ! ice volume
+ & , sxxice, 'T', 1._wp, syyice, 'T', 1._wp, sxyice, 'T', 1._wp &
+ & , sxsn , 'T', -1._wp, sysn , 'T', -1._wp & ! snw volume
+ & , sxxsn , 'T', 1._wp, syysn , 'T', 1._wp, sxysn , 'T', 1._wp &
+ & , sxsal , 'T', -1._wp, sysal , 'T', -1._wp & ! ice salinity
+ & , sxxsal, 'T', 1._wp, syysal, 'T', 1._wp, sxysal, 'T', 1._wp &
+ & , sxa , 'T', -1._wp, sya , 'T', -1._wp & ! ice concentration
+ & , sxxa , 'T', 1._wp, syya , 'T', 1._wp, sxya , 'T', 1._wp &
+ & , sxage , 'T', -1._wp, syage , 'T', -1._wp & ! ice age
+ & , sxxage, 'T', 1._wp, syyage, 'T', 1._wp, sxyage, 'T', 1._wp, ldfull = .TRUE. )
+ ENDIF
+ CALL lbc_lnk( 'icedyn_adv_pra', sxc0 , 'T', -1._wp, syc0 , 'T', -1._wp & ! snw enthalpy
+ & , sxxc0 , 'T', 1._wp, syyc0 , 'T', 1._wp, sxyc0 , 'T', 1._wp &
+ & , sxe , 'T', -1._wp, sye , 'T', -1._wp & ! ice enthalpy
+ & , sxxe , 'T', 1._wp, syye , 'T', 1._wp, sxye , 'T', 1._wp, ldfull = .TRUE. )
+ !
+ ENDIF
!
- END DO
+ END DO ! jt
!
IF( lrst_ice ) CALL adv_pra_rst( 'WRITE', kt ) !* write Prather fields in the restart file
!
END SUBROUTINE ice_dyn_adv_pra
- SUBROUTINE adv_x( pdt, put , pcrh, psm , ps0 , &
+ SUBROUTINE adv_x( ihls, jcat, pdt, put , pcrh, psm , ps0 , &
& psx, psxx, psy , psyy, psxy )
!!----------------------------------------------------------------------
!! ** routine adv_x **
@@ -362,194 +434,219 @@ CONTAINS
!! ** purpose : Computes and adds the advection trend to sea-ice
!! variable on x axis
!!----------------------------------------------------------------------
- REAL(wp) , INTENT(in ) :: pdt ! the time step
+ INTEGER , INTENT(in ) :: ihls ! loop index
+ INTEGER , INTENT(in ) :: jcat ! category
+ REAL(wp) , INTENT(in ) :: pdt ! time step
REAL(wp) , INTENT(in ) :: pcrh ! call adv_x then adv_y (=1) or the opposite (=0)
REAL(wp), DIMENSION(:,:) , INTENT(in ) :: put ! i-direction ice velocity at U-point [m/s]
- REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: psm ! area
- REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: ps0 ! field to be advected
+ REAL(wp), DIMENSION(:,:) , INTENT(inout) :: psm ! area
+ REAL(wp), DIMENSION(:,:) , INTENT(inout) :: ps0 ! field to be advected
REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: psx , psy ! 1st moments
REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: psxx, psyy, psxy ! 2nd moments
!!
- INTEGER :: ji, jj, jl, jcat ! dummy loop indices
- INTEGER :: jj0 ! dummy loop indices
- REAL(wp) :: zs1max, zslpmax, ztemp ! local scalars
- REAL(wp) :: zs1new, zalf , zalfq , zbt ! - -
- REAL(wp) :: zs2new, zalf1, zalf1q, zbt1 ! - -
+ INTEGER :: ji, jj ! dummy loop indices
+ INTEGER :: ji0, jj0 ! dummy loop indices
+ REAL(wp) :: zs1max, zslpmax ! local scalars
+ REAL(wp) :: zs1new, zalf , zalf2, zalf3 ! - -
+ REAL(wp) :: zs2new, z1malf, z1malf2, z1malf3 ! - -
REAL(wp) :: zpsm, zps0
REAL(wp) :: zpsx, zpsy, zpsxx, zpsyy, zpsxy
- REAL(wp), DIMENSION(jpi,jpj) :: zf0 , zfx , zfy , zbet ! 2D workspace
+ REAL(wp), DIMENSION(jpi,jpj) :: zf0 , zfx , zfy ! 2D workspace
REAL(wp), DIMENSION(jpi,jpj) :: zfm , zfxx , zfyy , zfxy ! - -
- REAL(wp), DIMENSION(jpi,jpj) :: zalg, zalg1, zalg1q ! - -
!-----------------------------------------------------------------------
! in order to avoid lbc_lnk (communications):
! jj loop must be 1:jpj if adv_x is called first
! and 2:jpj-1 if adv_x is called second
- jj0 = NINT(pcrh)
+ ji0 = 1 + ihls
+ jj0 = NINT(pcrh) + ihls
!
- jcat = SIZE( ps0 , 3 ) ! size of input arrays
- !
- DO jl = 1, jcat ! loop on categories
+ ! Limitation of moments.
+ DO_2D( ji0, ji0, jj0, jj0 )
!
- ! Limitation of moments.
- DO jj = Njs0 - jj0, Nje0 + jj0
-
- DO ji = Nis0 - 1, Nie0 + 1
-
- zpsm = psm (ji,jj,jl) ! optimization
- zps0 = ps0 (ji,jj,jl)
- zpsx = psx (ji,jj,jl)
- zpsxx = psxx(ji,jj,jl)
- zpsy = psy (ji,jj,jl)
- zpsyy = psyy(ji,jj,jl)
- zpsxy = psxy(ji,jj,jl)
-
- ! Initialize volumes of boxes (=area if adv_x first called, =psm otherwise)
- zpsm = MAX( pcrh * e1e2t(ji,jj) + ( 1.0 - pcrh ) * zpsm , epsi20 )
- !
- zslpmax = MAX( 0._wp, zps0 )
- zs1max = 1.5 * zslpmax
- zs1new = MIN( zs1max, MAX( -zs1max, zpsx ) )
- zs2new = MIN( 2.0 * zslpmax - 0.3334 * ABS( zs1new ), MAX( ABS( zs1new ) - zslpmax, zpsxx ) )
- rswitch = ( 1.0 - MAX( 0._wp, SIGN( 1._wp, -zslpmax) ) ) * tmask(ji,jj,1) ! Case of empty boxes & Apply mask
+ zpsm = psm (ji,jj) ! optimization
+ zps0 = ps0 (ji,jj)
+ zpsx = psx (ji,jj,jcat)
+ zpsxx = psxx(ji,jj,jcat)
+ zpsy = psy (ji,jj,jcat)
+ zpsyy = psyy(ji,jj,jcat)
+ zpsxy = psxy(ji,jj,jcat)
- zps0 = zslpmax
- zpsx = zs1new * rswitch
- zpsxx = zs2new * rswitch
- zpsy = zpsy * rswitch
- zpsyy = zpsyy * rswitch
- zpsxy = MIN( zslpmax, MAX( -zslpmax, zpsxy ) ) * rswitch
-
- ! Calculate fluxes and moments between boxes i<-->i+1
- ! ! Flux from i to i+1 WHEN u GT 0
- zbet(ji,jj) = MAX( 0._wp, SIGN( 1._wp, put(ji,jj) ) )
- zalf = MAX( 0._wp, put(ji,jj) ) * pdt / zpsm
- zalfq = zalf * zalf
- zalf1 = 1.0 - zalf
- zalf1q = zalf1 * zalf1
- !
- zfm (ji,jj) = zalf * zpsm
- zf0 (ji,jj) = zalf * ( zps0 + zalf1 * ( zpsx + (zalf1 - zalf) * zpsxx ) )
- zfx (ji,jj) = zalfq * ( zpsx + 3.0 * zalf1 * zpsxx )
- zfxx(ji,jj) = zalf * zpsxx * zalfq
- zfy (ji,jj) = zalf * ( zpsy + zalf1 * zpsxy )
- zfxy(ji,jj) = zalfq * zpsxy
- zfyy(ji,jj) = zalf * zpsyy
-
- ! ! Readjust moments remaining in the box.
- zpsm = zpsm - zfm(ji,jj)
- zps0 = zps0 - zf0(ji,jj)
- zpsx = zalf1q * ( zpsx - 3.0 * zalf * zpsxx )
- zpsxx = zalf1 * zalf1q * zpsxx
- zpsy = zpsy - zfy (ji,jj)
- zpsyy = zpsyy - zfyy(ji,jj)
- zpsxy = zalf1q * zpsxy
- !
- psm (ji,jj,jl) = zpsm ! optimization
- ps0 (ji,jj,jl) = zps0
- psx (ji,jj,jl) = zpsx
- psxx(ji,jj,jl) = zpsxx
- psy (ji,jj,jl) = zpsy
- psyy(ji,jj,jl) = zpsyy
- psxy(ji,jj,jl) = zpsxy
- !
- END DO
-
- DO ji = Nis0 - 1, Nie0
- ! ! Flux from i+1 to i when u LT 0.
- zalf = MAX( 0._wp, -put(ji,jj) ) * pdt / psm(ji+1,jj,jl)
- zalg (ji,jj) = zalf
- zalfq = zalf * zalf
- zalf1 = 1.0 - zalf
- zalg1 (ji,jj) = zalf1
- zalf1q = zalf1 * zalf1
- zalg1q(ji,jj) = zalf1q
- !
- zfm (ji,jj) = zfm (ji,jj) + zalf * psm (ji+1,jj,jl)
- zf0 (ji,jj) = zf0 (ji,jj) + zalf * ( ps0 (ji+1,jj,jl) &
- & - zalf1 * ( psx(ji+1,jj,jl) - (zalf1 - zalf ) * psxx(ji+1,jj,jl) ) )
- zfx (ji,jj) = zfx (ji,jj) + zalfq * ( psx (ji+1,jj,jl) - 3.0 * zalf1 * psxx(ji+1,jj,jl) )
- zfxx (ji,jj) = zfxx(ji,jj) + zalf * psxx(ji+1,jj,jl) * zalfq
- zfy (ji,jj) = zfy (ji,jj) + zalf * ( psy (ji+1,jj,jl) - zalf1 * psxy(ji+1,jj,jl) )
- zfxy (ji,jj) = zfxy(ji,jj) + zalfq * psxy(ji+1,jj,jl)
- zfyy (ji,jj) = zfyy(ji,jj) + zalf * psyy(ji+1,jj,jl)
- END DO
+ ! Initialize volumes of boxes (=area if adv_x first called, =psm otherwise)
+ zpsm = MAX( pcrh * e1e2t(ji,jj) + ( 1._wp - pcrh ) * zpsm , epsi20 )
+ !
+ zslpmax = MAX( 0._wp, zps0 )
+ zps0 = zslpmax
+ !
+ IF( zslpmax > 0._wp ) THEN
+ zs1max = 1.5_wp * zslpmax
+ zs1new = MIN( zs1max, MAX( -zs1max, zpsx ) )
+ zs2new = MIN( 2._wp * zslpmax - 0.3334_wp * ABS( zs1new ), MAX( ABS( zs1new ) - zslpmax, zpsxx ) )
+ !
+ zpsx = zs1new * tmask(ji,jj,1)
+ zpsxx = zs2new * tmask(ji,jj,1)
+ zpsy = zpsy * tmask(ji,jj,1)
+ zpsyy = zpsyy * tmask(ji,jj,1)
+ zpsxy = MIN( zslpmax, MAX( -zslpmax, zpsxy ) ) * tmask(ji,jj,1)
+ ELSE
+ zpsx = 0._wp
+ zpsxx = 0._wp
+ zpsy = 0._wp
+ zpsyy = 0._wp
+ zpsxy = 0._wp
+ ENDIF
+ !
+ ! Calculate fluxes and moments between boxes i<-->i+1
+ ! ! Flux from i to i+1 WHEN u GT 0
+ IF( put(ji,jj) >= 0._wp ) THEN
+ !
+ zalf = put(ji,jj) * pdt / zpsm
+ z1malf = 1._wp - zalf
+ !
+ zalf2 = zalf * zalf
+ zalf3 = zalf2 * zalf
+ z1malf2 = z1malf * z1malf
+ z1malf3 = z1malf2 * z1malf
+
+ zfm (ji,jj) = zalf * zpsm
+ zf0 (ji,jj) = zalf * ( zps0 + z1malf * ( zpsx + (z1malf - zalf) * zpsxx ) )
+ zfx (ji,jj) = zalf2 * ( zpsx + 3._wp * z1malf * zpsxx )
+ zfxx(ji,jj) = zalf3 * zpsxx
+ zfy (ji,jj) = zalf * ( zpsy + z1malf * zpsxy )
+ zfyy(ji,jj) = zalf * zpsyy
+ zfxy(ji,jj) = zalf2 * zpsxy
+ ! ! Readjust moments remaining in the box.
+ zpsm = zpsm - zfm (ji,jj)
+ zps0 = zps0 - zf0 (ji,jj)
+ zpsx = z1malf2 * ( zpsx - 3._wp * zalf * zpsxx )
+ zpsxx = z1malf3 * zpsxx
+ zpsy = zpsy - zfy (ji,jj)
+ zpsyy = zpsyy - zfyy(ji,jj)
+ zpsxy = z1malf2 * zpsxy
+ ELSE
+ zfm (ji,jj) = 0._wp
+ zf0 (ji,jj) = 0._wp
+ zfx (ji,jj) = 0._wp
+ zfxx(ji,jj) = 0._wp
+ zfy (ji,jj) = 0._wp
+ zfyy(ji,jj) = 0._wp
+ zfxy(ji,jj) = 0._wp
+ ENDIF
+ !
+ psm (ji,jj) = zpsm ! optimization
+ ps0 (ji,jj) = zps0
+ psx (ji,jj,jcat) = zpsx
+ psxx(ji,jj,jcat) = zpsxx
+ psy (ji,jj,jcat) = zpsy
+ psyy(ji,jj,jcat) = zpsyy
+ psxy(ji,jj,jcat) = zpsxy
+ !
+ END_2D
- DO ji = Nis0, Nie0
- !
- zpsm = psm (ji,jj,jl) ! optimization
- zps0 = ps0 (ji,jj,jl)
- zpsx = psx (ji,jj,jl)
- zpsxx = psxx(ji,jj,jl)
- zpsy = psy (ji,jj,jl)
- zpsyy = psyy(ji,jj,jl)
- zpsxy = psxy(ji,jj,jl)
- ! ! Readjust moments remaining in the box.
- zbt = zbet(ji-1,jj)
- zbt1 = 1.0 - zbet(ji-1,jj)
- !
- zpsm = zbt * zpsm + zbt1 * ( zpsm - zfm(ji-1,jj) )
- zps0 = zbt * zps0 + zbt1 * ( zps0 - zf0(ji-1,jj) )
- zpsx = zalg1q(ji-1,jj) * ( zpsx + 3.0 * zalg(ji-1,jj) * zpsxx )
- zpsxx = zalg1 (ji-1,jj) * zalg1q(ji-1,jj) * zpsxx
- zpsy = zbt * zpsy + zbt1 * ( zpsy - zfy (ji-1,jj) )
- zpsyy = zbt * zpsyy + zbt1 * ( zpsyy - zfyy(ji-1,jj) )
- zpsxy = zalg1q(ji-1,jj) * zpsxy
+ DO_2D( ji0, ji0-1, jj0, jj0 )
+ ! ! Flux from i+1 to i when u LT 0.
+ IF( put(ji,jj) < 0._wp ) THEN
+ !
+ zalf = - put(ji,jj) * pdt / psm(ji+1,jj)
+ z1malf = 1._wp - zalf
+ !
+ zalf2 = zalf * zalf
+ zalf3 = zalf2 * zalf
+
+ zfm (ji,jj) = zfm (ji,jj) + zalf * psm (ji+1,jj)
+ zf0 (ji,jj) = zf0 (ji,jj) + zalf * ( ps0 (ji+1,jj) &
+ & - z1malf * ( psx (ji+1,jj,jcat) - ( z1malf - zalf ) * psxx(ji+1,jj,jcat) ) )
+ zfxx(ji,jj) = zfxx(ji,jj) + zalf3 * psxx(ji+1,jj,jcat)
+ zfy (ji,jj) = zfy (ji,jj) + zalf * ( psy (ji+1,jj,jcat) - z1malf * psxy(ji+1,jj,jcat) )
+ zfyy(ji,jj) = zfyy(ji,jj) + zalf * psyy(ji+1,jj,jcat)
+ zfxy(ji,jj) = zfxy(ji,jj) + zalf2 * psxy(ji+1,jj,jcat)
+ ENDIF
+ !
+ END_2D
- ! Put the temporary moments into appropriate neighboring boxes.
- ! ! Flux from i to i+1 IF u GT 0.
- zbt = zbet(ji-1,jj)
- zbt1 = 1.0 - zbet(ji-1,jj)
- zpsm = zbt * ( zpsm + zfm(ji-1,jj) ) + zbt1 * zpsm
- zalf = zbt * zfm(ji-1,jj) / zpsm
- zalf1 = 1.0 - zalf
- ztemp = zalf * zps0 - zalf1 * zf0(ji-1,jj)
- !
- zps0 = zbt * ( zps0 + zf0(ji-1,jj) ) + zbt1 * zps0
- zpsx = zbt * ( zalf * zfx(ji-1,jj) + zalf1 * zpsx + 3.0 * ztemp ) + zbt1 * zpsx
- zpsxx = zbt * ( zalf * zalf * zfxx(ji-1,jj) + zalf1 * zalf1 * zpsxx &
- & + 5.0 * ( zalf * zalf1 * ( zpsx - zfx(ji-1,jj) ) - ( zalf1 - zalf ) * ztemp ) ) &
- & + zbt1 * zpsxx
- zpsxy = zbt * ( zalf * zfxy(ji-1,jj) + zalf1 * zpsxy &
- & + 3.0 * (- zalf1*zfy(ji-1,jj) + zalf * zpsy ) ) &
- & + zbt1 * zpsxy
- zpsy = zbt * ( zpsy + zfy (ji-1,jj) ) + zbt1 * zpsy
- zpsyy = zbt * ( zpsyy + zfyy(ji-1,jj) ) + zbt1 * zpsyy
+ DO_2D( ji0-1, ji0-1, jj0, jj0 )
+ !
+ zpsm = psm (ji,jj) ! optimization
+ zps0 = ps0 (ji,jj)
+ zpsx = psx (ji,jj,jcat)
+ zpsxx = psxx(ji,jj,jcat)
+ zpsy = psy (ji,jj,jcat)
+ zpsyy = psyy(ji,jj,jcat)
+ zpsxy = psxy(ji,jj,jcat)
+ ! ! Readjust moments remaining in the box.
+ IF( put(ji-1,jj) < 0._wp ) THEN
+ !
+ zalf = - put(ji-1,jj) * pdt / psm(ji,jj)
+ z1malf = 1._wp - zalf
+ !
+ z1malf2 = z1malf * z1malf
+ z1malf3 = z1malf2 * z1malf
+ !
+ zpsm = zpsm - zfm (ji-1,jj)
+ zps0 = zps0 - zf0 (ji-1,jj)
+ zpsx = z1malf2 * ( zpsx + 3._wp * zalf * zpsxx )
+ zpsxx = z1malf3 * zpsxx
+ zpsy = zpsy - zfy (ji-1,jj)
+ zpsyy = zpsyy - zfyy(ji-1,jj)
+ zpsxy = z1malf2 * zpsxy
+ ENDIF
- ! ! Flux from i+1 to i IF u LT 0.
- zbt = zbet(ji,jj)
- zbt1 = 1.0 - zbet(ji,jj)
- zpsm = zbt * zpsm + zbt1 * ( zpsm + zfm(ji,jj) )
- zalf = zbt1 * zfm(ji,jj) / zpsm
- zalf1 = 1.0 - zalf
- ztemp = - zalf * zps0 + zalf1 * zf0(ji,jj)
- !
- zps0 = zbt * zps0 + zbt1 * ( zps0 + zf0(ji,jj) )
- zpsx = zbt * zpsx + zbt1 * ( zalf * zfx(ji,jj) + zalf1 * zpsx + 3.0 * ztemp )
- zpsxx = zbt * zpsxx + zbt1 * ( zalf * zalf * zfxx(ji,jj) + zalf1 * zalf1 * zpsxx &
- & + 5.0 * ( zalf * zalf1 * ( - zpsx + zfx(ji,jj) ) &
- & + ( zalf1 - zalf ) * ztemp ) )
- zpsxy = zbt * zpsxy + zbt1 * ( zalf * zfxy(ji,jj) + zalf1 * zpsxy &
- & + 3.0 * ( zalf1 * zfy(ji,jj) - zalf * zpsy ) )
- zpsy = zbt * zpsy + zbt1 * ( zpsy + zfy (ji,jj) )
- zpsyy = zbt * zpsyy + zbt1 * ( zpsyy + zfyy(ji,jj) )
- !
- psm (ji,jj,jl) = zpsm ! optimization
- ps0 (ji,jj,jl) = zps0
- psx (ji,jj,jl) = zpsx
- psxx(ji,jj,jl) = zpsxx
- psy (ji,jj,jl) = zpsy
- psyy(ji,jj,jl) = zpsyy
- psxy(ji,jj,jl) = zpsxy
- END DO
+ ! Put the temporary moments into appropriate neighboring boxes.
+ ! ! Flux from i to i+1 IF u GT 0.
+ IF( put(ji-1,jj) >= 0._wp ) THEN
!
- END DO
+ zpsm = zpsm + zfm(ji-1,jj)
+ !
+ zalf = zfm(ji-1,jj) / zpsm
+ z1malf = 1._wp - zalf
+ !
+ zalf2 = zalf * zalf
+ z1malf2 = z1malf * z1malf
+ !
+ zps0 = zps0 + zf0 (ji-1,jj)
+ zpsx = ( zalf * zfx (ji-1,jj) + z1malf * zpsx ) + 3._wp * ( zalf * zps0 - z1malf * zf0(ji-1,jj) )
+ zpsxx = ( zalf2 * zfxx(ji-1,jj) + z1malf2 * zpsxx ) &
+ & + 5._wp * ( zalf * z1malf * ( zpsx - zfx(ji-1,jj) ) - (z1malf-zalf) * (zalf * zps0 - z1malf * zf0(ji-1,jj)) )
+ zpsxy = ( zalf * zfxy(ji-1,jj) + z1malf * zpsxy ) & ! do not move this line (it depends on zpsy)
+ & + 3._wp * ( -z1malf * zfy (ji-1,jj) + zalf * zpsy )
+ zpsy = zpsy + zfy (ji-1,jj)
+ zpsyy = zpsyy + zfyy(ji-1,jj)
+ ENDIF
+
+ ! ! Flux from i+1 to i IF u LT 0.
+ IF( put(ji,jj) < 0._wp ) THEN
+ !
+ zpsm = zpsm + zfm(ji,jj)
+ !
+ zalf = zfm(ji,jj) / zpsm
+ z1malf = 1._wp - zalf
+ !
+ zalf2 = zalf * zalf
+ z1malf2 = z1malf * z1malf
+ !
+ zps0 = zps0 + zf0 (ji,jj)
+ zpsx = ( zalf * zfx (ji,jj) + z1malf * zpsx ) + 3._wp * ( -zalf * zps0 + z1malf * zf0(ji,jj) )
+ zpsxx = ( zalf2 * zfxx(ji,jj) + z1malf2 * zpsxx ) &
+ & + 5._wp * ( zalf * z1malf * ( -zpsx + zfx (ji,jj) ) + (z1malf-zalf) * (-zalf * zps0 + z1malf * zf0(ji,jj)) )
+ zpsxy = ( zalf * zfxy(ji,jj) + z1malf * zpsxy ) & ! do not move this line (it depends on zpsy)
+ & + 3._wp * ( z1malf * zfy (ji,jj) - zalf * zpsy )
+ zpsy = zpsy + zfy (ji,jj)
+ zpsyy = zpsyy + zfyy(ji,jj)
+ ENDIF
!
- END DO
+ psm (ji,jj) = zpsm ! optimization
+ ps0 (ji,jj) = zps0
+ psx (ji,jj,jcat) = zpsx
+ psxx(ji,jj,jcat) = zpsxx
+ psy (ji,jj,jcat) = zpsy
+ psyy(ji,jj,jcat) = zpsyy
+ psxy(ji,jj,jcat) = zpsxy
+ !
+ END_2D
!
END SUBROUTINE adv_x
- SUBROUTINE adv_y( pdt, pvt , pcrh, psm , ps0 , &
+ SUBROUTINE adv_y( ihls, jcat, pdt, pvt , pcrh, psm , ps0 , &
& psx, psxx, psy , psyy, psxy )
!!---------------------------------------------------------------------
!! ** routine adv_y **
@@ -557,193 +654,224 @@ CONTAINS
!! ** purpose : Computes and adds the advection trend to sea-ice
!! variable on y axis
!!---------------------------------------------------------------------
+ INTEGER , INTENT(in ) :: ihls ! loop index
+ INTEGER , INTENT(in ) :: jcat ! category
REAL(wp) , INTENT(in ) :: pdt ! time step
REAL(wp) , INTENT(in ) :: pcrh ! call adv_x then adv_y (=1) or the opposite (=0)
REAL(wp), DIMENSION(:,:) , INTENT(in ) :: pvt ! j-direction ice velocity at V-point [m/s]
- REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: psm ! area
- REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: ps0 ! field to be advected
+ REAL(wp), DIMENSION(:,:) , INTENT(inout) :: psm ! area
+ REAL(wp), DIMENSION(:,:) , INTENT(inout) :: ps0 ! field to be advected
REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: psx , psy ! 1st moments
REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: psxx, psyy, psxy ! 2nd moments
!!
- INTEGER :: ji, jj, jl, jcat ! dummy loop indices
- INTEGER :: ji0 ! dummy loop indices
- REAL(wp) :: zs1max, zslpmax, ztemp ! temporary scalars
- REAL(wp) :: zs1new, zalf , zalfq , zbt ! - -
- REAL(wp) :: zs2new, zalf1, zalf1q, zbt1 ! - -
+ INTEGER :: ji, jj ! dummy loop indices
+ INTEGER :: ji0, jj0 ! dummy loop indices
+ REAL(wp) :: zs1max, zslpmax ! local scalars
+ REAL(wp) :: zs1new, zalf , zalf2, zalf3 ! - -
+ REAL(wp) :: zs2new, z1malf, z1malf2, z1malf3 ! - -
REAL(wp) :: zpsm, zps0
REAL(wp) :: zpsx, zpsy, zpsxx, zpsyy, zpsxy
- REAL(wp), DIMENSION(jpi,jpj) :: zf0, zfx , zfy , zbet ! 2D workspace
- REAL(wp), DIMENSION(jpi,jpj) :: zfm, zfxx, zfyy, zfxy ! - -
- REAL(wp), DIMENSION(jpi,jpj) :: zalg, zalg1, zalg1q ! - -
+ REAL(wp), DIMENSION(jpi,jpj) :: zf0 , zfx , zfy ! 2D workspace
+ REAL(wp), DIMENSION(jpi,jpj) :: zfm , zfxx , zfyy , zfxy ! - -
!---------------------------------------------------------------------
! in order to avoid lbc_lnk (communications):
! ji loop must be 1:jpi if adv_y is called first
! and 2:jpi-1 if adv_y is called second
- ji0 = NINT(pcrh)
- !
- jcat = SIZE( ps0 , 3 ) ! size of input arrays
+ ji0 = NINT(pcrh) + ihls
+ jj0 = 1 + ihls
!
- DO jl = 1, jcat ! loop on categories
+ ! Limitation of moments.
+ DO_2D( ji0, ji0, jj0, jj0 )
!
- ! Limitation of moments.
- DO_2D( ji0, ji0, 1, 1 )
- !
- zpsm = psm (ji,jj,jl) ! optimization
- zps0 = ps0 (ji,jj,jl)
- zpsx = psx (ji,jj,jl)
- zpsxx = psxx(ji,jj,jl)
- zpsy = psy (ji,jj,jl)
- zpsyy = psyy(ji,jj,jl)
- zpsxy = psxy(ji,jj,jl)
+ zpsm = psm (ji,jj) ! optimization
+ zps0 = ps0 (ji,jj)
+ zpsx = psx (ji,jj,jcat)
+ zpsxx = psxx(ji,jj,jcat)
+ zpsy = psy (ji,jj,jcat)
+ zpsyy = psyy(ji,jj,jcat)
+ zpsxy = psxy(ji,jj,jcat)
+ !
+ ! Initialize volumes of boxes (=area if adv_y first called, =psm otherwise)
+ zpsm = MAX( pcrh * e1e2t(ji,jj) + ( 1._wp - pcrh ) * zpsm , epsi20 )
+ !
+ zslpmax = MAX( 0._wp, zps0 )
+ zps0 = zslpmax
+ !
+ IF( zslpmax > 0._wp ) THEN
+ zs1max = 1.5_wp * zslpmax
+ zs1new = MIN( zs1max, MAX( -zs1max, zpsy ) )
+ zs2new = MIN( 2._wp * zslpmax - 0.3334_wp * ABS( zs1new ), MAX( ABS( zs1new ) - zslpmax, zpsyy ) )
!
- ! Initialize volumes of boxes (=area if adv_y first called, =psm otherwise)
- zpsm = MAX( pcrh * e1e2t(ji,jj) + ( 1.0 - pcrh ) * zpsm , epsi20 )
+ zpsx = zpsx * tmask(ji,jj,1)
+ zpsxx = zpsxx * tmask(ji,jj,1)
+ zpsy = zs1new * tmask(ji,jj,1)
+ zpsyy = zs2new * tmask(ji,jj,1)
+ zpsxy = MIN( zslpmax, MAX( -zslpmax, zpsxy ) ) * tmask(ji,jj,1)
+ ELSE
+ zpsx = 0._wp
+ zpsxx = 0._wp
+ zpsy = 0._wp
+ zpsyy = 0._wp
+ zpsxy = 0._wp
+ ENDIF
+ !
+ ! Calculate fluxes and moments between boxes j<-->j+1
+ ! ! Flux from j to j+1 WHEN v GT 0
+ IF( pvt(ji,jj) >= 0._wp ) THEN
!
- zslpmax = MAX( 0._wp, zps0 )
- zs1max = 1.5 * zslpmax
- zs1new = MIN( zs1max, MAX( -zs1max, zpsy ) )
- zs2new = MIN( ( 2.0 * zslpmax - 0.3334 * ABS( zs1new ) ), MAX( ABS( zs1new )-zslpmax, zpsyy ) )
- rswitch = ( 1.0 - MAX( 0._wp, SIGN( 1._wp, -zslpmax) ) ) * tmask(ji,jj,1) ! Case of empty boxes & Apply mask
+ zalf = pvt(ji,jj) * pdt / zpsm
+ z1malf = 1._wp - zalf
!
- zps0 = zslpmax
- zpsx = zpsx * rswitch
- zpsxx = zpsxx * rswitch
- zpsy = zs1new * rswitch
- zpsyy = zs2new * rswitch
- zpsxy = MIN( zslpmax, MAX( -zslpmax, zpsxy ) ) * rswitch
-
- ! Calculate fluxes and moments between boxes j<-->j+1
- ! ! Flux from j to j+1 WHEN v GT 0
- zbet(ji,jj) = MAX( 0._wp, SIGN( 1._wp, pvt(ji,jj) ) )
- zalf = MAX( 0._wp, pvt(ji,jj) ) * pdt / zpsm
- zalfq = zalf * zalf
- zalf1 = 1.0 - zalf
- zalf1q = zalf1 * zalf1
+ zalf2 = zalf * zalf
+ zalf3 = zalf2 * zalf
+ z1malf2 = z1malf * z1malf
+ z1malf3 = z1malf2 * z1malf
!
- zfm (ji,jj) = zalf * zpsm
- zf0 (ji,jj) = zalf * ( zps0 + zalf1 * ( zpsy + (zalf1-zalf) * zpsyy ) )
- zfy (ji,jj) = zalfq *( zpsy + 3.0*zalf1*zpsyy )
- zfyy(ji,jj) = zalf * zalfq * zpsyy
- zfx (ji,jj) = zalf * ( zpsx + zalf1 * zpsxy )
- zfxy(ji,jj) = zalfq * zpsxy
- zfxx(ji,jj) = zalf * zpsxx
+ zfm (ji,jj) = zalf * zpsm
+ zf0 (ji,jj) = zalf * ( zps0 + z1malf * ( zpsy + (z1malf - zalf) * zpsyy ) )
+ zfy (ji,jj) = zalf2 * ( zpsy + 3._wp * z1malf * zpsyy )
+ zfyy(ji,jj) = zalf3 * zpsyy
+ zfx (ji,jj) = zalf * ( zpsx + z1malf * zpsxy )
+ zfxx(ji,jj) = zalf * zpsxx
+ zfxy(ji,jj) = zalf2 * zpsxy
!
! ! Readjust moments remaining in the box.
- zpsm = zpsm - zfm(ji,jj)
- zps0 = zps0 - zf0(ji,jj)
- zpsy = zalf1q * ( zpsy -3.0 * zalf * zpsyy )
- zpsyy = zalf1 * zalf1q * zpsyy
- zpsx = zpsx - zfx(ji,jj)
- zpsxx = zpsxx - zfxx(ji,jj)
- zpsxy = zalf1q * zpsxy
- !
- psm (ji,jj,jl) = zpsm ! optimization
- ps0 (ji,jj,jl) = zps0
- psx (ji,jj,jl) = zpsx
- psxx(ji,jj,jl) = zpsxx
- psy (ji,jj,jl) = zpsy
- psyy(ji,jj,jl) = zpsyy
- psxy(ji,jj,jl) = zpsxy
- END_2D
+ zpsm = zpsm - zfm (ji,jj)
+ zps0 = zps0 - zf0 (ji,jj)
+ zpsy = z1malf2 * ( zpsy -3._wp * zalf * zpsyy )
+ zpsyy = z1malf3 * zpsyy
+ zpsx = zpsx - zfx (ji,jj)
+ zpsxx = zpsxx - zfxx(ji,jj)
+ zpsxy = z1malf2 * zpsxy
+ ELSE
+ zfm (ji,jj) = 0._wp
+ zf0 (ji,jj) = 0._wp
+ zfx (ji,jj) = 0._wp
+ zfxx(ji,jj) = 0._wp
+ zfy (ji,jj) = 0._wp
+ zfyy(ji,jj) = 0._wp
+ zfxy(ji,jj) = 0._wp
+ ENDIF
!
- DO_2D( ji0, ji0, 1, 0 )
- ! ! Flux from j+1 to j when v LT 0.
- zalf = MAX( 0._wp, -pvt(ji,jj) ) * pdt / psm(ji,jj+1,jl)
- zalg (ji,jj) = zalf
- zalfq = zalf * zalf
- zalf1 = 1.0 - zalf
- zalg1 (ji,jj) = zalf1
- zalf1q = zalf1 * zalf1
- zalg1q(ji,jj) = zalf1q
+ psm (ji,jj) = zpsm ! optimization
+ ps0 (ji,jj) = zps0
+ psx (ji,jj,jcat) = zpsx
+ psxx(ji,jj,jcat) = zpsxx
+ psy (ji,jj,jcat) = zpsy
+ psyy(ji,jj,jcat) = zpsyy
+ psxy(ji,jj,jcat) = zpsxy
+ !
+ END_2D
+ !
+ DO_2D( ji0, ji0, jj0, jj0-1 )
+ ! ! Flux from j+1 to j when v LT 0.
+ IF( pvt(ji,jj) < 0._wp ) THEN
!
- zfm (ji,jj) = zfm (ji,jj) + zalf * psm (ji,jj+1,jl)
- zf0 (ji,jj) = zf0 (ji,jj) + zalf * ( ps0 (ji,jj+1,jl) &
- & - zalf1 * (psy(ji,jj+1,jl) - (zalf1 - zalf ) * psyy(ji,jj+1,jl) ) )
- zfy (ji,jj) = zfy (ji,jj) + zalfq * ( psy (ji,jj+1,jl) - 3.0 * zalf1 * psyy(ji,jj+1,jl) )
- zfyy (ji,jj) = zfyy(ji,jj) + zalf * psyy(ji,jj+1,jl) * zalfq
- zfx (ji,jj) = zfx (ji,jj) + zalf * ( psx (ji,jj+1,jl) - zalf1 * psxy(ji,jj+1,jl) )
- zfxy (ji,jj) = zfxy(ji,jj) + zalfq * psxy(ji,jj+1,jl)
- zfxx (ji,jj) = zfxx(ji,jj) + zalf * psxx(ji,jj+1,jl)
- END_2D
-
- DO_2D( ji0, ji0, 0, 0 )
- ! ! Readjust moments remaining in the box.
- zbt = zbet(ji,jj-1)
- zbt1 = ( 1.0 - zbet(ji,jj-1) )
+ zalf = - pvt(ji,jj) * pdt / psm(ji,jj+1)
+ z1malf = 1._wp - zalf
!
- zpsm = psm (ji,jj,jl) ! optimization
- zps0 = ps0 (ji,jj,jl)
- zpsx = psx (ji,jj,jl)
- zpsxx = psxx(ji,jj,jl)
- zpsy = psy (ji,jj,jl)
- zpsyy = psyy(ji,jj,jl)
- zpsxy = psxy(ji,jj,jl)
+ zalf2 = zalf * zalf
+ zalf3 = zalf2 * zalf
!
- zpsm = zbt * zpsm + zbt1 * ( zpsm - zfm(ji,jj-1) )
- zps0 = zbt * zps0 + zbt1 * ( zps0 - zf0(ji,jj-1) )
- zpsy = zalg1q(ji,jj-1) * ( zpsy + 3.0 * zalg(ji,jj-1) * zpsyy )
- zpsyy = zalg1 (ji,jj-1) * zalg1q(ji,jj-1) * zpsyy
- zpsx = zbt * zpsx + zbt1 * ( zpsx - zfx (ji,jj-1) )
- zpsxx = zbt * zpsxx + zbt1 * ( zpsxx - zfxx(ji,jj-1) )
- zpsxy = zalg1q(ji,jj-1) * zpsxy
+ zfm (ji,jj) = zfm (ji,jj) + zalf * psm (ji,jj+1)
+ zf0 (ji,jj) = zf0 (ji,jj) + zalf * ( ps0 (ji,jj+1) &
+ & - z1malf * ( psy (ji,jj+1,jcat) - ( z1malf - zalf ) * psyy(ji,jj+1,jcat) ) )
+ zfy (ji,jj) = zfy (ji,jj) + zalf2 * ( psy (ji,jj+1,jcat) - 3._wp * z1malf * psyy(ji,jj+1,jcat) )
+ zfyy(ji,jj) = zfyy(ji,jj) + zalf3 * psyy(ji,jj+1,jcat)
+ zfx (ji,jj) = zfx (ji,jj) + zalf * ( psx (ji,jj+1,jcat) - z1malf * psxy(ji,jj+1,jcat) )
+ zfxx(ji,jj) = zfxx(ji,jj) + zalf * psxx(ji,jj+1,jcat)
+ zfxy(ji,jj) = zfxy(ji,jj) + zalf2 * psxy(ji,jj+1,jcat)
+ ENDIF
+ !
+ END_2D
- ! Put the temporary moments into appropriate neighboring boxes.
- ! ! Flux from j to j+1 IF v GT 0.
- zbt = zbet(ji,jj-1)
- zbt1 = 1.0 - zbet(ji,jj-1)
- zpsm = zbt * ( zpsm + zfm(ji,jj-1) ) + zbt1 * zpsm
- zalf = zbt * zfm(ji,jj-1) / zpsm
- zalf1 = 1.0 - zalf
- ztemp = zalf * zps0 - zalf1 * zf0(ji,jj-1)
+ DO_2D( ji0, ji0, jj0-1, jj0-1 )
+ !
+ zpsm = psm (ji,jj) ! optimization
+ zps0 = ps0 (ji,jj)
+ zpsx = psx (ji,jj,jcat)
+ zpsxx = psxx(ji,jj,jcat)
+ zpsy = psy (ji,jj,jcat)
+ zpsyy = psyy(ji,jj,jcat)
+ zpsxy = psxy(ji,jj,jcat)
+ ! ! Readjust moments remaining in the box.
+ IF( pvt(ji,jj-1) < 0._wp ) THEN
!
- zps0 = zbt * ( zps0 + zf0(ji,jj-1) ) + zbt1 * zps0
- zpsy = zbt * ( zalf * zfy(ji,jj-1) + zalf1 * zpsy + 3.0 * ztemp ) &
- & + zbt1 * zpsy
- zpsyy = zbt * ( zalf * zalf * zfyy(ji,jj-1) + zalf1 * zalf1 * zpsyy &
- & + 5.0 * ( zalf * zalf1 * ( zpsy - zfy(ji,jj-1) ) - ( zalf1 - zalf ) * ztemp ) ) &
- & + zbt1 * zpsyy
- zpsxy = zbt * ( zalf * zfxy(ji,jj-1) + zalf1 * zpsxy &
- & + 3.0 * (- zalf1 * zfx(ji,jj-1) + zalf * zpsx ) ) &
- & + zbt1 * zpsxy
- zpsx = zbt * ( zpsx + zfx (ji,jj-1) ) + zbt1 * zpsx
- zpsxx = zbt * ( zpsxx + zfxx(ji,jj-1) ) + zbt1 * zpsxx
+ zalf = - pvt(ji,jj-1) * pdt / psm(ji,jj)
+ z1malf = 1._wp - zalf
+ !
+ z1malf2 = z1malf * z1malf
+ z1malf3 = z1malf2 * z1malf
+ !
+ zpsm = zpsm - zfm(ji,jj-1)
+ zps0 = zps0 - zf0(ji,jj-1)
+ zpsy = z1malf2 * ( zpsy + 3._wp * zalf * zpsyy )
+ zpsyy = z1malf3 * zpsyy
+ zpsx = zpsx - zfx (ji,jj-1)
+ zpsxx = zpsxx - zfxx(ji,jj-1)
+ zpsxy = z1malf2 * zpsxy
+ ENDIF
- ! ! Flux from j+1 to j IF v LT 0.
- zbt = zbet(ji,jj)
- zbt1 = 1.0 - zbet(ji,jj)
- zpsm = zbt * zpsm + zbt1 * ( zpsm + zfm(ji,jj) )
- zalf = zbt1 * zfm(ji,jj) / zpsm
- zalf1 = 1.0 - zalf
- ztemp = - zalf * zps0 + zalf1 * zf0(ji,jj)
+ ! Put the temporary moments into appropriate neighboring boxes.
+ ! ! Flux from j to j+1 IF v GT 0.
+ IF( pvt(ji,jj-1) >= 0._wp ) THEN
!
- zps0 = zbt * zps0 + zbt1 * ( zps0 + zf0(ji,jj) )
- zpsy = zbt * zpsy + zbt1 * ( zalf * zfy(ji,jj) + zalf1 * zpsy + 3.0 * ztemp )
- zpsyy = zbt * zpsyy + zbt1 * ( zalf * zalf * zfyy(ji,jj) + zalf1 * zalf1 * zpsyy &
- & + 5.0 * ( zalf * zalf1 * ( - zpsy + zfy(ji,jj) ) &
- & + ( zalf1 - zalf ) * ztemp ) )
- zpsxy = zbt * zpsxy + zbt1 * ( zalf * zfxy(ji,jj) + zalf1 * zpsxy &
- & + 3.0 * ( zalf1 * zfx(ji,jj) - zalf * zpsx ) )
- zpsx = zbt * zpsx + zbt1 * ( zpsx + zfx (ji,jj) )
- zpsxx = zbt * zpsxx + zbt1 * ( zpsxx + zfxx(ji,jj) )
+ zpsm = zpsm + zfm(ji,jj-1)
!
- psm (ji,jj,jl) = zpsm ! optimization
- ps0 (ji,jj,jl) = zps0
- psx (ji,jj,jl) = zpsx
- psxx(ji,jj,jl) = zpsxx
- psy (ji,jj,jl) = zpsy
- psyy(ji,jj,jl) = zpsyy
- psxy(ji,jj,jl) = zpsxy
- END_2D
+ zalf = zfm(ji,jj-1) / zpsm
+ z1malf = 1._wp - zalf
+ !
+ zalf2 = zalf * zalf
+ z1malf2 = z1malf * z1malf
+ !
+ zps0 = zps0 + zf0 (ji,jj-1)
+ zpsy = ( zalf * zfy (ji,jj-1) + z1malf * zpsy ) + 3._wp * ( zalf * zps0 - z1malf * zf0(ji,jj-1) )
+ zpsyy = ( zalf2 * zfyy(ji,jj-1) + z1malf2 * zpsyy ) &
+ & + 5._wp * ( zalf * z1malf * ( zpsy - zfy(ji,jj-1) ) - (z1malf-zalf) * (zalf * zps0 - z1malf * zf0(ji,jj-1)) )
+ zpsxy = ( zalf * zfxy(ji,jj-1) + z1malf * zpsxy ) & ! do not move this line (it depends on zpsx)
+ & + 3._wp * ( -z1malf * zfx (ji,jj-1) + zalf * zpsx )
+ zpsx = zpsx + zfx (ji,jj-1)
+ zpsxx = zpsxx + zfxx(ji,jj-1)
+ ENDIF
+
+ ! ! Flux from j+1 to j IF v LT 0.
+ IF( pvt(ji,jj) < 0._wp ) THEN
+ !
+ zpsm = zpsm + zfm(ji,jj)
+ !
+ zalf = zfm(ji,jj) / zpsm
+ z1malf = 1._wp - zalf
+ !
+ zalf2 = zalf * zalf
+ z1malf2 = z1malf * z1malf
+ !
+ zps0 = zps0 + zf0 (ji,jj)
+ zpsy = ( zalf * zfy (ji,jj) + z1malf * zpsy ) + 3._wp * ( -zalf * zps0 + z1malf * zf0(ji,jj) )
+ zpsyy = ( zalf2 * zfyy(ji,jj) + z1malf2 * zpsyy ) &
+ & + 5._wp * ( zalf * z1malf * ( - zpsy + zfy(ji,jj) ) + (z1malf-zalf) * (-zalf * zps0 + z1malf * zf0(ji,jj)) )
+ zpsxy = ( zalf * zfxy(ji,jj) + z1malf * zpsxy ) & ! do not move this line (it depends on zpsx)
+ & + 3._wp * ( z1malf * zfx (ji,jj) - zalf * zpsx )
+ zpsx = zpsx + zfx (ji,jj)
+ zpsxx = zpsxx + zfxx(ji,jj)
+ ENDIF
!
- END DO
+ psm (ji,jj) = zpsm ! optimization
+ ps0 (ji,jj) = zps0
+ psx (ji,jj,jcat) = zpsx
+ psxx(ji,jj,jcat) = zpsxx
+ psy (ji,jj,jcat) = zpsy
+ psyy(ji,jj,jcat) = zpsyy
+ psxy(ji,jj,jcat) = zpsxy
+ !
+ END_2D
!
END SUBROUTINE adv_y
- SUBROUTINE Hbig( pdt, phi_max, phs_max, phip_max, psi_max, pes_max, pei_max, &
+ SUBROUTINE Hbig_pra( ihls, jcat, pdt, phi_max, phs_max, phip_max, psi_max, pes_max, pei_max, &
& pv_i, pv_s, pa_i, pa_ip, pv_ip, psv_i, pe_s, pe_i )
!!-------------------------------------------------------------------
- !! *** ROUTINE Hbig ***
+ !! *** ROUTINE Hbig_pra ***
!!
!! ** Purpose : Thickness correction in case advection scheme creates
!! abnormally tick ice or snow
@@ -755,101 +883,111 @@ CONTAINS
!!
!! ** input : Max thickness of the surrounding 9-points
!!-------------------------------------------------------------------
+ INTEGER , INTENT(in ) :: ihls ! loop index
+ INTEGER , INTENT(in ) :: jcat ! category
REAL(wp) , INTENT(in ) :: pdt ! tracer time-step
- REAL(wp), DIMENSION(:,:,:) , INTENT(in ) :: phi_max, phs_max, phip_max, psi_max ! max ice thick from surrounding 9-pts
- REAL(wp), DIMENSION(:,:,:,:), INTENT(in ) :: pes_max
- REAL(wp), DIMENSION(:,:,:,:), INTENT(in ) :: pei_max
+ REAL(wp), DIMENSION(:,:) , INTENT(in ) :: phi_max, phs_max, phip_max, psi_max ! max ice thick from surrounding 9-pts
+ REAL(wp), DIMENSION(:,:,:) , INTENT(in ) :: pes_max
+ REAL(wp), DIMENSION(:,:,:) , INTENT(in ) :: pei_max
REAL(wp), DIMENSION(:,:,:) , INTENT(inout) :: pv_i, pv_s, pa_i, pa_ip, pv_ip, psv_i
REAL(wp), DIMENSION(:,:,:,:), INTENT(inout) :: pe_s
REAL(wp), DIMENSION(:,:,:,:), INTENT(inout) :: pe_i
!
- INTEGER :: ji, jj, jk, jl ! dummy loop indices
+ INTEGER :: ji, jj, jk ! dummy loop indices
REAL(wp) :: z1_dt, zhip, zhi, zhs, zsi, zes, zei, zfra
+ REAL(wp), DIMENSION(jpi,jpj) :: zwfx_res, zhfx_res, zsfx_res ! needed since loop is not (0,0,0,0)
!!-------------------------------------------------------------------
!
+ DO_2D( ihls, ihls, ihls, ihls )
+ zwfx_res(ji,jj) = 0._wp
+ zhfx_res(ji,jj) = 0._wp
+ zsfx_res(ji,jj) = 0._wp
+ END_2D
+ !
z1_dt = 1._wp / pdt
!
- DO jl = 1, jpl
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
- IF ( pv_i(ji,jj,jl) > 0._wp ) THEN
- !
- ! ! -- check h_ip -- !
- ! if h_ip is larger than the surrounding 9 pts => reduce h_ip and increase a_ip
- IF( ln_pnd_LEV .OR. ln_pnd_TOPO .AND. pv_ip(ji,jj,jl) > 0._wp ) THEN
- zhip = pv_ip(ji,jj,jl) / MAX( epsi20, pa_ip(ji,jj,jl) )
- IF( zhip > phip_max(ji,jj,jl) .AND. pa_ip(ji,jj,jl) < 0.15 ) THEN
- pa_ip(ji,jj,jl) = pv_ip(ji,jj,jl) / phip_max(ji,jj,jl)
- ENDIF
- ENDIF
- !
- ! ! -- check h_i -- !
- ! if h_i is larger than the surrounding 9 pts => reduce h_i and increase a_i
- zhi = pv_i(ji,jj,jl) / pa_i(ji,jj,jl)
- IF( zhi > phi_max(ji,jj,jl) .AND. pa_i(ji,jj,jl) < 0.15 ) THEN
- pa_i(ji,jj,jl) = pv_i(ji,jj,jl) / MIN( phi_max(ji,jj,jl), hi_max(jpl) ) !-- bound h_i to hi_max (99 m)
- ENDIF
- !
- ! ! -- check h_s -- !
- ! if h_s is larger than the surrounding 9 pts => put the snow excess in the ocean
- zhs = pv_s(ji,jj,jl) / pa_i(ji,jj,jl)
- IF( pv_s(ji,jj,jl) > 0._wp .AND. zhs > phs_max(ji,jj,jl) .AND. pa_i(ji,jj,jl) < 0.15 ) THEN
- zfra = phs_max(ji,jj,jl) / MAX( zhs, epsi20 )
- !
- wfx_res(ji,jj) = wfx_res(ji,jj) + ( pv_s(ji,jj,jl) - pa_i(ji,jj,jl) * phs_max(ji,jj,jl) ) * rhos * z1_dt
- hfx_res(ji,jj) = hfx_res(ji,jj) - SUM( pe_s(ji,jj,1:nlay_s,jl) ) * ( 1._wp - zfra ) * z1_dt ! W.m-2 <0
- !
- pe_s(ji,jj,1:nlay_s,jl) = pe_s(ji,jj,1:nlay_s,jl) * zfra
- pv_s(ji,jj,jl) = pa_i(ji,jj,jl) * phs_max(ji,jj,jl)
+ DO_2D( ihls, ihls, ihls, ihls )
+ IF ( pv_i(ji,jj,jcat) > 0._wp ) THEN
+ !
+ ! ! -- check h_ip -- !
+ ! if h_ip is larger than the surrounding 9 pts => reduce h_ip and increase a_ip
+ IF( ln_pnd_LEV .OR. ln_pnd_TOPO .AND. pv_ip(ji,jj,jcat) > 0._wp ) THEN
+ zhip = pv_ip(ji,jj,jcat) / MAX( epsi20, pa_ip(ji,jj,jcat) )
+ IF( zhip > phip_max(ji,jj) .AND. pa_ip(ji,jj,jcat) < 0.15 ) THEN
+ pa_ip(ji,jj,jcat) = pv_ip(ji,jj,jcat) / phip_max(ji,jj)
ENDIF
+ ENDIF
+ !
+ ! ! -- check h_i -- !
+ ! if h_i is larger than the surrounding 9 pts => reduce h_i and increase a_i
+ zhi = pv_i(ji,jj,jcat) / pa_i(ji,jj,jcat)
+ IF( zhi > phi_max(ji,jj) .AND. pa_i(ji,jj,jcat) < 0.15 ) THEN
+ pa_i(ji,jj,jcat) = pv_i(ji,jj,jcat) / MIN( phi_max(ji,jj), hi_max(jpl) ) !-- bound h_i to hi_max (99 m)
+ ENDIF
+ !
+ ! ! -- check h_s -- !
+ ! if h_s is larger than the surrounding 9 pts => put the snow excess in the ocean
+ zhs = pv_s(ji,jj,jcat) / pa_i(ji,jj,jcat)
+ IF( pv_s(ji,jj,jcat) > 0._wp .AND. zhs > phs_max(ji,jj) .AND. pa_i(ji,jj,jcat) < 0.15 ) THEN
+ zfra = phs_max(ji,jj) / MAX( zhs, epsi20 )
!
- ! ! -- check s_i -- !
- ! if s_i is larger than the surrounding 9 pts => put salt excess in the ocean
- zsi = psv_i(ji,jj,jl) / pv_i(ji,jj,jl)
- IF( zsi > psi_max(ji,jj,jl) .AND. pa_i(ji,jj,jl) < 0.15 ) THEN
- zfra = psi_max(ji,jj,jl) / zsi
- sfx_res(ji,jj) = sfx_res(ji,jj) + psv_i(ji,jj,jl) * ( 1._wp - zfra ) * rhoi * z1_dt
- psv_i(ji,jj,jl) = psv_i(ji,jj,jl) * zfra
- ENDIF
+ zwfx_res(ji,jj) = zwfx_res(ji,jj) + ( pv_s(ji,jj,jcat) - pa_i(ji,jj,jcat) * phs_max(ji,jj) ) * rhos * z1_dt
+ zhfx_res(ji,jj) = zhfx_res(ji,jj) - SUM( pe_s(ji,jj,1:nlay_s,jcat) ) * ( 1._wp - zfra ) * z1_dt ! W.m-2 <0
!
+ pe_s(ji,jj,1:nlay_s,jcat) = pe_s(ji,jj,1:nlay_s,jcat) * zfra
+ pv_s(ji,jj,jcat) = pa_i(ji,jj,jcat) * phs_max(ji,jj)
ENDIF
- END_2D
- END DO
+ !
+ ! ! -- check s_i -- !
+ ! if s_i is larger than the surrounding 9 pts => put salt excess in the ocean
+ zsi = psv_i(ji,jj,jcat) / pv_i(ji,jj,jcat)
+ IF( zsi > psi_max(ji,jj) .AND. pa_i(ji,jj,jcat) < 0.15 ) THEN
+ zfra = psi_max(ji,jj) / zsi
+ zsfx_res(ji,jj) = zsfx_res(ji,jj) + psv_i(ji,jj,jcat) * ( 1._wp - zfra ) * rhoi * z1_dt
+ psv_i(ji,jj,jcat) = psv_i(ji,jj,jcat) * zfra
+ ENDIF
+ !
+ ENDIF
+ END_2D
!
! ! -- check e_i/v_i -- !
- DO jl = 1, jpl
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, nlay_i )
- IF ( pv_i(ji,jj,jl) > 0._wp ) THEN
- ! if e_i/v_i is larger than the surrounding 9 pts => put the heat excess in the ocean
- zei = pe_i(ji,jj,jk,jl) / pv_i(ji,jj,jl)
- IF( zei > pei_max(ji,jj,jk,jl) .AND. pa_i(ji,jj,jl) < 0.15 ) THEN
- zfra = pei_max(ji,jj,jk,jl) / zei
- hfx_res(ji,jj) = hfx_res(ji,jj) - pe_i(ji,jj,jk,jl) * ( 1._wp - zfra ) * z1_dt ! W.m-2 <0
- pe_i(ji,jj,jk,jl) = pe_i(ji,jj,jk,jl) * zfra
- ENDIF
+ DO_3D( ihls, ihls, ihls, ihls, 1, nlay_i )
+ IF ( pv_i(ji,jj,jcat) > 0._wp ) THEN
+ ! if e_i/v_i is larger than the surrounding 9 pts => put the heat excess in the ocean
+ zei = pe_i(ji,jj,jk,jcat) / pv_i(ji,jj,jcat)
+ IF( zei > pei_max(ji,jj,jk) .AND. pa_i(ji,jj,jcat) < 0.15 ) THEN
+ zfra = pei_max(ji,jj,jk) / zei
+ zhfx_res(ji,jj) = zhfx_res(ji,jj) - pe_i(ji,jj,jk,jcat) * ( 1._wp - zfra ) * z1_dt ! W.m-2 <0
+ pe_i(ji,jj,jk,jcat) = pe_i(ji,jj,jk,jcat) * zfra
ENDIF
- END_3D
- END DO
+ ENDIF
+ END_3D
! ! -- check e_s/v_s -- !
- DO jl = 1, jpl
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, nlay_s )
- IF ( pv_s(ji,jj,jl) > 0._wp ) THEN
- ! if e_s/v_s is larger than the surrounding 9 pts => put the heat excess in the ocean
- zes = pe_s(ji,jj,jk,jl) / pv_s(ji,jj,jl)
- IF( zes > pes_max(ji,jj,jk,jl) .AND. pa_i(ji,jj,jl) < 0.15 ) THEN
- zfra = pes_max(ji,jj,jk,jl) / zes
- hfx_res(ji,jj) = hfx_res(ji,jj) - pe_s(ji,jj,jk,jl) * ( 1._wp - zfra ) * z1_dt ! W.m-2 <0
- pe_s(ji,jj,jk,jl) = pe_s(ji,jj,jk,jl) * zfra
- ENDIF
+ DO_3D( ihls, ihls, ihls, ihls, 1, nlay_s )
+ IF ( pv_s(ji,jj,jcat) > 0._wp ) THEN
+ ! if e_s/v_s is larger than the surrounding 9 pts => put the heat excess in the ocean
+ zes = pe_s(ji,jj,jk,jcat) / pv_s(ji,jj,jcat)
+ IF( zes > pes_max(ji,jj,jk) .AND. pa_i(ji,jj,jcat) < 0.15 ) THEN
+ zfra = pes_max(ji,jj,jk) / zes
+ zhfx_res(ji,jj) = zhfx_res(ji,jj) - pe_s(ji,jj,jk,jcat) * ( 1._wp - zfra ) * z1_dt ! W.m-2 <0
+ pe_s(ji,jj,jk,jcat) = pe_s(ji,jj,jk,jcat) * zfra
ENDIF
- END_3D
- END DO
+ ENDIF
+ END_3D
!
- END SUBROUTINE Hbig
+ ! record residual fluxes
+ DO_2D( 0, 0, 0, 0 )
+ wfx_res(ji,jj) = wfx_res(ji,jj) + zwfx_res(ji,jj)
+ hfx_res(ji,jj) = hfx_res(ji,jj) + zhfx_res(ji,jj)
+ sfx_res(ji,jj) = sfx_res(ji,jj) + zsfx_res(ji,jj)
+ END_2D
+ !
+ END SUBROUTINE Hbig_pra
- SUBROUTINE Hsnow( pdt, pv_i, pv_s, pa_i, pa_ip, pe_s )
+ SUBROUTINE Hsnow_pra( ihls, jcat, pdt, pv_i, pv_s, pa_i, pa_ip, pe_s )
!!-------------------------------------------------------------------
- !! *** ROUTINE Hsnow ***
+ !! *** ROUTINE Hsnow_pra ***
!!
!! ** Purpose : 1- Check snow load after advection
!! 2- Correct pond concentration to avoid a_ip > a_i
@@ -862,41 +1000,52 @@ CONTAINS
!! make the snow very thick (if concentration decreases drastically)
!! This behavior has been seen in Ultimate-Macho and supposedly it can also be true for Prather
!!-------------------------------------------------------------------
+ INTEGER , INTENT(in ) :: ihls ! loop index
+ INTEGER , INTENT(in ) :: jcat ! category
REAL(wp) , INTENT(in ) :: pdt ! tracer time-step
REAL(wp), DIMENSION(:,:,:) , INTENT(inout) :: pv_i, pv_s, pa_i, pa_ip
REAL(wp), DIMENSION(:,:,:,:), INTENT(inout) :: pe_s
!
- INTEGER :: ji, jj, jl ! dummy loop indices
+ INTEGER :: ji, jj ! dummy loop indices
REAL(wp) :: z1_dt, zvs_excess, zfra
+ REAL(wp), DIMENSION(jpi,jpj) :: zwfx_res, zhfx_res ! needed since loop is not (0,0,0,0)
!!-------------------------------------------------------------------
!
+ DO_2D( ihls, ihls, ihls, ihls )
+ zwfx_res(ji,jj) = 0._wp
+ zhfx_res(ji,jj) = 0._wp
+ END_2D
+ !
z1_dt = 1._wp / pdt
!
! -- check snow load -- !
- DO jl = 1, jpl
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
- IF ( pv_i(ji,jj,jl) > 0._wp ) THEN
- !
- zvs_excess = MAX( 0._wp, pv_s(ji,jj,jl) - pv_i(ji,jj,jl) * (rho0-rhoi) * r1_rhos )
- !
- IF( zvs_excess > 0._wp ) THEN ! snow-ice interface deplets below the ocean surface
- ! put snow excess in the ocean
- zfra = ( pv_s(ji,jj,jl) - zvs_excess ) / MAX( pv_s(ji,jj,jl), epsi20 )
- wfx_res(ji,jj) = wfx_res(ji,jj) + zvs_excess * rhos * z1_dt
- hfx_res(ji,jj) = hfx_res(ji,jj) - SUM( pe_s(ji,jj,1:nlay_s,jl) ) * ( 1._wp - zfra ) * z1_dt ! W.m-2 <0
- ! correct snow volume and heat content
- pe_s(ji,jj,1:nlay_s,jl) = pe_s(ji,jj,1:nlay_s,jl) * zfra
- pv_s(ji,jj,jl) = pv_s(ji,jj,jl) - zvs_excess
- ENDIF
- !
+ DO_2D( ihls, ihls, ihls, ihls )
+ IF ( pv_i(ji,jj,jcat) > 0._wp ) THEN
+ !
+ zvs_excess = MAX( 0._wp, pv_s(ji,jj,jcat) - pv_i(ji,jj,jcat) * (rho0-rhoi) * r1_rhos )
+ !
+ IF( zvs_excess > 0._wp ) THEN ! snow-ice interface deplets below the ocean surface
+ ! put snow excess in the ocean
+ zfra = ( pv_s(ji,jj,jcat) - zvs_excess ) / MAX( pv_s(ji,jj,jcat), epsi20 )
+ zwfx_res(ji,jj) = zwfx_res(ji,jj) + zvs_excess * rhos * z1_dt
+ zhfx_res(ji,jj) = zhfx_res(ji,jj) - SUM( pe_s(ji,jj,1:nlay_s,jcat) ) * ( 1._wp - zfra ) * z1_dt ! W.m-2 <0
+ ! correct snow volume and heat content
+ pe_s(ji,jj,1:nlay_s,jcat) = pe_s(ji,jj,1:nlay_s,jcat) * zfra
+ pv_s(ji,jj,jcat) = pv_s(ji,jj,jcat) - zvs_excess
ENDIF
- END_2D
- END DO
+ !
+ ENDIF
+ !-- correct pond concentration to avoid a_ip > a_i -- !
+ pa_ip(ji,jj,jcat) = MIN( pa_ip(ji,jj,jcat), pa_i(ji,jj,jcat) )
+ END_2D
!
- !-- correct pond concentration to avoid a_ip > a_i -- !
- WHERE( pa_ip(:,:,:) > pa_i(:,:,:) ) pa_ip(:,:,:) = pa_i(:,:,:)
+ ! record residual fluxes
+ DO_2D( 0, 0, 0, 0 )
+ wfx_res(ji,jj) = wfx_res(ji,jj) + zwfx_res(ji,jj)
+ hfx_res(ji,jj) = hfx_res(ji,jj) + zhfx_res(ji,jj)
+ END_2D
!
- END SUBROUTINE Hsnow
+ END SUBROUTINE Hsnow_pra
SUBROUTINE adv_pra_init
@@ -1028,7 +1177,7 @@ CONTAINS
CALL iom_get( numrir, jpdom_auto, 'sxxap', sxxap )
CALL iom_get( numrir, jpdom_auto, 'syyap', syyap )
CALL iom_get( numrir, jpdom_auto, 'sxyap', sxyap )
- ! ! melt pond volume
+ ! ! melt pond volume
CALL iom_get( numrir, jpdom_auto, 'sxvp' , sxvp , psgn = -1._wp )
CALL iom_get( numrir, jpdom_auto, 'syvp' , syvp , psgn = -1._wp )
CALL iom_get( numrir, jpdom_auto, 'sxxvp', sxxvp )
@@ -1039,16 +1188,14 @@ CONTAINS
sxvp = 0._wp ; syvp = 0._wp ; sxxvp = 0._wp ; syyvp = 0._wp ; sxyvp = 0._wp ! melt pond volume
ENDIF
!
- IF ( ln_pnd_lids ) THEN ! melt pond lid volume
- IF( iom_varid( numrir, 'sxvl', ldstop = .FALSE. ) > 0 ) THEN
- CALL iom_get( numrir, jpdom_auto, 'sxvl' , sxvl , psgn = -1._wp )
- CALL iom_get( numrir, jpdom_auto, 'syvl' , syvl , psgn = -1._wp )
- CALL iom_get( numrir, jpdom_auto, 'sxxvl', sxxvl )
- CALL iom_get( numrir, jpdom_auto, 'syyvl', syyvl )
- CALL iom_get( numrir, jpdom_auto, 'sxyvl', sxyvl )
- ELSE
- sxvl = 0._wp; syvl = 0._wp ; sxxvl = 0._wp ; syyvl = 0._wp ; sxyvl = 0._wp ! melt pond lid volume
- ENDIF
+ IF( iom_varid( numrir, 'sxvl', ldstop = .FALSE. ) > 0 ) THEN ! melt pond lid volume
+ CALL iom_get( numrir, jpdom_auto, 'sxvl' , sxvl , psgn = -1._wp )
+ CALL iom_get( numrir, jpdom_auto, 'syvl' , syvl , psgn = -1._wp )
+ CALL iom_get( numrir, jpdom_auto, 'sxxvl', sxxvl )
+ CALL iom_get( numrir, jpdom_auto, 'syyvl', syyvl )
+ CALL iom_get( numrir, jpdom_auto, 'sxyvl', sxyvl )
+ ELSE
+ sxvl = 0._wp ; syvl = 0._wp ; sxxvl = 0._wp ; syyvl = 0._wp ; sxyvl = 0._wp ! melt pond lid volume
ENDIF
ENDIF
!
@@ -1066,9 +1213,7 @@ CONTAINS
IF( ln_pnd_LEV .OR. ln_pnd_TOPO ) THEN
sxap = 0._wp ; syap = 0._wp ; sxxap = 0._wp ; syyap = 0._wp ; sxyap = 0._wp ! melt pond fraction
sxvp = 0._wp ; syvp = 0._wp ; sxxvp = 0._wp ; syyvp = 0._wp ; sxyvp = 0._wp ! melt pond volume
- IF ( ln_pnd_lids ) THEN
- sxvl = 0._wp; syvl = 0._wp ; sxxvl = 0._wp ; syyvl = 0._wp ; sxyvl = 0._wp ! melt pond lid volume
- ENDIF
+ sxvl = 0._wp ; syvl = 0._wp ; sxxvl = 0._wp ; syyvl = 0._wp ; sxyvl = 0._wp ! melt pond lid volume
ENDIF
ENDIF
!
@@ -1141,7 +1286,7 @@ CONTAINS
CALL iom_rstput( iter, nitrst, numriw, znam , z3d )
END DO
!
- IF( ln_pnd_LEV .OR. ln_pnd_TOPO ) THEN ! melt pond fraction
+ IF( ln_pnd_LEV .OR. ln_pnd_TOPO ) THEN ! melt pond fraction
CALL iom_rstput( iter, nitrst, numriw, 'sxap' , sxap )
CALL iom_rstput( iter, nitrst, numriw, 'syap' , syap )
CALL iom_rstput( iter, nitrst, numriw, 'sxxap', sxxap )
@@ -1167,80 +1312,76 @@ CONTAINS
!
END SUBROUTINE adv_pra_rst
- SUBROUTINE icemax3D( pice , pmax )
+ SUBROUTINE icemax2D_pra( ihls, pice , pmax )
!!---------------------------------------------------------------------
- !! *** ROUTINE icemax3D ***
+ !! *** ROUTINE icemax2D_pra ***
!! ** Purpose : compute the max of the 9 points around
!!----------------------------------------------------------------------
- REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: pice ! input
- REAL(wp), DIMENSION(:,:,:), INTENT(out) :: pmax ! output
+ INTEGER , INTENT(in ) :: ihls ! loop index
+ REAL(wp), DIMENSION(:,:), INTENT(in ) :: pice ! input
+ REAL(wp), DIMENSION(:,:), INTENT(out) :: pmax ! output
!
- REAL(wp), DIMENSION(Nis0:Nie0) :: zmax1, zmax2
- REAL(wp) :: zmax3
- INTEGER :: ji, jj, jl ! dummy loop indices
+!!$ REAL(wp), DIMENSION(Nis0-ihls:Nie0+ihls) :: zmax1, zmax2
+ REAL(wp), DIMENSION(1:jpi) :: zmax1, zmax2
+ REAL(wp) :: zmax3
+ INTEGER :: ji, jj ! dummy loop indices
!!----------------------------------------------------------------------
! basic version: get the max of epsi20 + 9 neighbours
-!!$ DO jl = 1, jpl
-!!$ DO_2D( 0, 0, 0, 0 )
-!!$ pmax(ji,jj,jl) = MAX( epsi20, pice(ji-1,jj-1,jl), pice(ji,jj-1,jl), pice(ji+1,jj-1,jl), &
-!!$ & pice(ji-1,jj ,jl), pice(ji,jj ,jl), pice(ji+1,jj ,jl), &
-!!$ & pice(ji-1,jj+1,jl), pice(ji,jj+1,jl), pice(ji+1,jj+1,jl) )
-!!$ END_2D
-!!$ END DO
+!!$ DO_2D( ihls, ihls, ihls, ihls )
+!!$ pmax(ji,jj) = MAX( epsi20, pice(ji-1,jj-1), pice(ji,jj-1), pice(ji+1,jj-1), &
+!!$ & pice(ji-1,jj ), pice(ji,jj ), pice(ji+1,jj ), &
+!!$ & pice(ji-1,jj+1), pice(ji,jj+1), pice(ji+1,jj+1) )
+!!$ END_2D
! optimized version : does a little bit more than 2 max of epsi20 + 3 neighbours
- DO jl = 1, jpl
- DO ji = Nis0, Nie0
- zmax1(ji) = MAX( epsi20, pice(ji,Njs0-1,jl), pice(ji-1,Njs0-1,jl), pice(ji+1,Njs0-1,jl) )
- zmax2(ji) = MAX( epsi20, pice(ji,Njs0 ,jl), pice(ji-1,Njs0 ,jl), pice(ji+1,Njs0 ,jl) )
- END DO
- DO_2D( 0, 0, 0, 0 )
- zmax3 = MAX( epsi20, pice(ji,jj+1,jl), pice(ji-1,jj+1,jl), pice(ji+1,jj+1,jl) )
- pmax(ji,jj,jl) = MAX( epsi20, zmax1(ji), zmax2(ji), zmax3 )
- zmax1(ji) = zmax2(ji)
- zmax2(ji) = zmax3
- END_2D
+ DO ji = Nis0-ihls, Nie0+ihls
+ zmax1(ji) = MAX( epsi20, pice(ji,Njs0-1-ihls), pice(ji-1,Njs0-1-ihls), pice(ji+1,Njs0-1-ihls) )
+ zmax2(ji) = MAX( epsi20, pice(ji,Njs0 -ihls), pice(ji-1,Njs0 -ihls), pice(ji+1,Njs0 -ihls) )
END DO
- END SUBROUTINE icemax3D
+ DO_2D( ihls, ihls, ihls, ihls )
+ zmax3 = MAX( epsi20, pice(ji,jj+1), pice(ji-1,jj+1), pice(ji+1,jj+1) )
+ pmax(ji,jj) = MAX( epsi20, zmax1(ji), zmax2(ji), zmax3 )
+ zmax1(ji) = zmax2(ji)
+ zmax2(ji) = zmax3
+ END_2D
+ END SUBROUTINE icemax2D_pra
- SUBROUTINE icemax4D( pice , pmax )
+ SUBROUTINE icemax3D_pra( ihls, pice , pmax )
!!---------------------------------------------------------------------
- !! *** ROUTINE icemax4D ***
+ !! *** ROUTINE icemax3D_pra ***
!! ** Purpose : compute the max of the 9 points around
!!----------------------------------------------------------------------
- REAL(wp), DIMENSION(:,:,:,:), INTENT(in ) :: pice ! input
- REAL(wp), DIMENSION(:,:,:,:), INTENT(out) :: pmax ! output
+ INTEGER , INTENT(in ) :: ihls ! loop index
+ REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: pice ! input
+ REAL(wp), DIMENSION(:,:,:), INTENT(out) :: pmax ! output
!
- REAL(wp), DIMENSION(Nis0:Nie0) :: zmax1, zmax2
- REAL(wp) :: zmax3
- INTEGER :: jlay, ji, jj, jk, jl ! dummy loop indices
+!!$ REAL(wp), DIMENSION(Nis0-ihls:Nie0+ihls) :: zmax1, zmax2
+ REAL(wp), DIMENSION(1:jpi) :: zmax1, zmax2
+ REAL(wp) :: zmax3
+ INTEGER :: jlay, ji, jj, jk ! dummy loop indices
!!----------------------------------------------------------------------
jlay = SIZE( pice , 3 ) ! size of input arrays
! basic version: get the max of epsi20 + 9 neighbours
-!!$ DO jl = 1, jpl
-!!$ DO jk = 1, jlay
-!!$ DO_2D( 0, 0, 0, 0 )
-!!$ pmax(ji,jj,jk,jl) = MAX( epsi20, pice(ji-1,jj-1,jk,jl), pice(ji,jj-1,jk,jl), pice(ji+1,jj-1,jk,jl), &
-!!$ & pice(ji-1,jj ,jk,jl), pice(ji,jj ,jk,jl), pice(ji+1,jj ,jk,jl), &
-!!$ & pice(ji-1,jj+1,jk,jl), pice(ji,jj+1,jk,jl), pice(ji+1,jj+1,jk,jl) )
-!!$ END_2D
-!!$ END DO
+!!$ DO jk = 1, jlay
+!!$ DO_2D( ihls, ihls, ihls, ihls )
+!!$ pmax(ji,jj,jk) = MAX( epsi20, pice(ji-1,jj-1,jk), pice(ji,jj-1,jk), pice(ji+1,jj-1,jk), &
+!!$ & pice(ji-1,jj ,jk), pice(ji,jj ,jk), pice(ji+1,jj ,jk), &
+!!$ & pice(ji-1,jj+1,jk), pice(ji,jj+1,jk), pice(ji+1,jj+1,jk) )
+!!$ END_2D
!!$ END DO
! optimized version : does a little bit more than 2 max of epsi20 + 3 neighbours
- DO jl = 1, jpl
- DO jk = 1, jlay
- DO ji = Nis0, Nie0
- zmax1(ji) = MAX( epsi20, pice(ji,Njs0-1,jk,jl), pice(ji-1,Njs0-1,jk,jl), pice(ji+1,Njs0-1,jk,jl) )
- zmax2(ji) = MAX( epsi20, pice(ji,Njs0 ,jk,jl), pice(ji-1,Njs0 ,jk,jl), pice(ji+1,Njs0 ,jk,jl) )
- END DO
- DO_2D( 0, 0, 0, 0 )
- zmax3 = MAX( epsi20, pice(ji,jj+1,jk,jl), pice(ji-1,jj+1,jk,jl), pice(ji+1,jj+1,jk,jl) )
- pmax(ji,jj,jk,jl) = MAX( epsi20, zmax1(ji), zmax2(ji), zmax3 )
- zmax1(ji) = zmax2(ji)
- zmax2(ji) = zmax3
- END_2D
+ DO jk = 1, jlay
+ DO ji = Nis0-ihls, Nie0+ihls
+ zmax1(ji) = MAX( epsi20, pice(ji,Njs0-1-ihls,jk), pice(ji-1,Njs0-1-ihls,jk), pice(ji+1,Njs0-1-ihls,jk) )
+ zmax2(ji) = MAX( epsi20, pice(ji,Njs0 -ihls,jk), pice(ji-1,Njs0 -ihls,jk), pice(ji+1,Njs0 -ihls,jk) )
END DO
+ DO_2D( ihls, ihls, ihls, ihls )
+ zmax3 = MAX( epsi20, pice(ji,jj+1,jk), pice(ji-1,jj+1,jk), pice(ji+1,jj+1,jk) )
+ pmax(ji,jj,jk) = MAX( epsi20, zmax1(ji), zmax2(ji), zmax3 )
+ zmax1(ji) = zmax2(ji)
+ zmax2(ji) = zmax3
+ END_2D
END DO
- END SUBROUTINE icemax4D
+ END SUBROUTINE icemax3D_pra
#else
!!----------------------------------------------------------------------
diff --git a/src/ICE/icedyn_adv_umx.F90 b/src/ICE/icedyn_adv_umx.F90
index e5113ac90de67aa1d107f9c1aea3275f2c71f9a2..00f4d58e3b8d2709d5234e9c77b8e13bcb486888 100644
--- a/src/ICE/icedyn_adv_umx.F90
+++ b/src/ICE/icedyn_adv_umx.F90
@@ -32,7 +32,7 @@ MODULE icedyn_adv_umx
PUBLIC ice_dyn_adv_umx ! called by icedyn_adv.F90
!
- INTEGER, PARAMETER :: np_advS = 1 ! advection for S and T: dVS/dt = -div( uVS ) => np_advS = 1
+ INTEGER, PARAMETER :: np_advS = 2 ! advection for S and T: dVS/dt = -div( uVS ) => np_advS = 1
! or dVS/dt = -div( uA * uHS / u ) => np_advS = 2
! or dVS/dt = -div( uV * uS / u ) => np_advS = 3
INTEGER, PARAMETER :: np_limiter = 1 ! limiter: 1 = nonosc
@@ -92,9 +92,10 @@ CONTAINS
INTEGER :: icycle ! number of sub-timestep for the advection
REAL(wp) :: zamsk ! 1 if advection of concentration, 0 if advection of other tracers
REAL(wp) :: zdt, z1_dt, zvi_cen
+ REAL(wp) :: zati2
REAL(wp), DIMENSION(1) :: zcflprv, zcflnow ! for global communication
REAL(wp), DIMENSION(jpi,jpj) :: zudy, zvdx, zcu_box, zcv_box
- REAL(wp), DIMENSION(jpi,jpj) :: zati1, zati2
+ REAL(wp), DIMENSION(jpi,jpj) :: zati1
REAL(wp), DIMENSION(jpi,jpj,jpl) :: zu_cat, zv_cat
REAL(wp), DIMENSION(jpi,jpj,jpl) :: zua_ho, zva_ho, zua_ups, zva_ups
REAL(wp), DIMENSION(jpi,jpj,jpl) :: z1_ai , z1_aip, zhvar
@@ -104,7 +105,7 @@ CONTAINS
!
REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zuv_ho, zvv_ho, zuv_ups, zvv_ups, z1_vi, z1_vs
!! diagnostics
- REAL(wp), DIMENSION(jpi,jpj) :: zdiag_adv_mass, zdiag_adv_salt, zdiag_adv_heat
+ REAL(wp), DIMENSION(A2D(0)) :: zdiag_adv_mass, zdiag_adv_salt, zdiag_adv_heat
!!----------------------------------------------------------------------
!
IF( kt == nit000 .AND. lwp ) WRITE(numout,*) '-- ice_dyn_adv_umx: Ultimate-Macho advection scheme'
@@ -114,10 +115,10 @@ CONTAINS
WHERE( pv_i(:,:,:) >= epsi10 ) ; zs_i(:,:,:) = psv_i(:,:,:) / pv_i(:,:,:)
ELSEWHERE ; zs_i(:,:,:) = 0._wp
END WHERE
- CALL icemax3D( ph_i , zhi_max )
- CALL icemax3D( ph_s , zhs_max )
- CALL icemax3D( ph_ip, zhip_max)
- CALL icemax3D( zs_i , zsi_max )
+ CALL icemax3D_umx( ph_i , zhi_max )
+ CALL icemax3D_umx( ph_s , zhs_max )
+ CALL icemax3D_umx( ph_ip, zhip_max)
+ CALL icemax3D_umx( zs_i , zsi_max )
CALL lbc_lnk( 'icedyn_adv_umx', zhi_max, 'T', 1._wp, zhs_max, 'T', 1._wp, zhip_max, 'T', 1._wp, zsi_max, 'T', 1._wp )
!
! enthalpies
@@ -131,10 +132,9 @@ CONTAINS
ELSEWHERE ; ze_s(:,:,jk,:) = 0._wp
END WHERE
END DO
- CALL icemax4D( ze_i , zei_max )
- CALL icemax4D( ze_s , zes_max )
- CALL lbc_lnk( 'icedyn_adv_umx', zei_max, 'T', 1._wp )
- CALL lbc_lnk( 'icedyn_adv_umx', zes_max, 'T', 1._wp )
+ CALL icemax4D_umx( ze_i , zei_max )
+ CALL icemax4D_umx( ze_s , zes_max )
+ CALL lbc_lnk( 'icedyn_adv_umx', zei_max, 'T', 1._wp, zes_max, 'T', 1._wp )
!
!
! --- If ice drift is too fast, use subtime steps for advection (CFL test for stability) --- !
@@ -146,9 +146,13 @@ CONTAINS
! non-blocking global communication send zcflnow and receive zcflprv
CALL mpp_delay_max( 'icedyn_adv_umx', 'cflice', zcflnow(:), zcflprv(:), kt == nitend - nn_fsbc + 1 )
- IF( zcflprv(1) > .5 ) THEN ; icycle = 2
- ELSE ; icycle = 1
+ IF ( zcflprv(1) > 1.5 ) THEN ; icycle = 3
+ ELSEIF( zcflprv(1) > .5 ) THEN ; icycle = 2
+ ELSE ; icycle = 1
ENDIF
+!!$ !!test clem
+!!$ icycle=3
+!!$ !!test clem
zdt = rDt_ice / REAL(icycle)
z1_dt = 1._wp / zdt
@@ -181,13 +185,6 @@ CONTAINS
!---------------!
DO jt = 1, icycle
- ! diagnostics
- zdiag_adv_mass(:,:) = SUM( pv_i (:,:,:) , dim=3 ) * rhoi + SUM( pv_s (:,:,:) , dim=3 ) * rhos &
- & + SUM( pv_ip(:,:,:) , dim=3 ) * rhow + SUM( pv_il(:,:,:) , dim=3 ) * rhow
- zdiag_adv_salt(:,:) = SUM( psv_i(:,:,:) , dim=3 ) * rhoi
- zdiag_adv_heat(:,:) = - SUM(SUM( pe_i(:,:,1:nlay_i,:) , dim=4 ), dim=3 ) &
- & - SUM(SUM( pe_s(:,:,1:nlay_s,:) , dim=4 ), dim=3 )
-
! record at_i before advection (for open water)
zati1(:,:) = SUM( pa_i(:,:,:), dim=3 )
@@ -217,6 +214,14 @@ CONTAINS
END DO
ENDIF
!
+ ! diagnostics
+ DO_2D( 0, 0, 0, 0 )
+ zdiag_adv_mass(ji,jj) = SUM( pv_i (ji,jj,:) ) * rhoi + SUM( pv_s (ji,jj,:) ) * rhos &
+ & + SUM( pv_ip(ji,jj,:) ) * rhow + SUM( pv_il(ji,jj,:) ) * rhow
+ zdiag_adv_salt(ji,jj) = SUM( psv_i(ji,jj,:) ) * rhoi
+ zdiag_adv_heat(ji,jj) = - SUM( SUM( pe_i(ji,jj,1:nlay_i,:), dim=2 ) ) - SUM( SUM( pe_s(ji,jj,1:nlay_s,:), dim=2 ) )
+ END_2D
+ !
! ----------------------- !
! ==> start advection <== !
! ----------------------- !
@@ -360,49 +365,53 @@ CONTAINS
ENDIF
ENDIF
- ! --- Lateral boundary conditions --- !
- IF ( ( ln_pnd_LEV .OR. ln_pnd_TOPO ) .AND. ln_pnd_lids ) THEN
- CALL lbc_lnk( 'icedyn_adv_umx', pa_i,'T',1._wp, pv_i,'T',1._wp, pv_s,'T',1._wp, psv_i,'T',1._wp, poa_i,'T',1._wp &
- & , pa_ip,'T',1._wp, pv_ip,'T',1._wp, pv_il,'T',1._wp )
- ELSEIF( ( ln_pnd_LEV .OR. ln_pnd_TOPO ) .AND. .NOT.ln_pnd_lids ) THEN
- CALL lbc_lnk( 'icedyn_adv_umx', pa_i,'T',1._wp, pv_i,'T',1._wp, pv_s,'T',1._wp, psv_i,'T',1._wp, poa_i,'T',1._wp &
- & , pa_ip,'T',1._wp, pv_ip,'T',1._wp )
- ELSE
- CALL lbc_lnk( 'icedyn_adv_umx', pa_i,'T',1._wp, pv_i,'T',1._wp, pv_s,'T',1._wp, psv_i,'T',1._wp, poa_i,'T',1._wp )
- ENDIF
- CALL lbc_lnk( 'icedyn_adv_umx', pe_i, 'T', 1._wp )
- CALL lbc_lnk( 'icedyn_adv_umx', pe_s, 'T', 1._wp )
- !
!== Open water area ==!
- zati2(:,:) = SUM( pa_i(:,:,:), dim=3 )
DO_2D( 0, 0, 0, 0 )
- pato_i(ji,jj) = pato_i(ji,jj) - ( zati2(ji,jj) - zati1(ji,jj) ) &
- & - ( zudy(ji,jj) - zudy(ji-1,jj) + zvdx(ji,jj) - zvdx(ji,jj-1) ) * r1_e1e2t(ji,jj) * zdt
+ zati2 = SUM( pa_i(ji,jj,:) )
+ pato_i(ji,jj) = pato_i(ji,jj) - ( zati2 - zati1(ji,jj) ) &
+ & - ( ( zudy(ji,jj) - zudy(ji-1,jj) ) & ! ad () for NP repro
+ & + ( zvdx(ji,jj) - zvdx(ji,jj-1) ) ) * r1_e1e2t(ji,jj) * zdt
END_2D
- CALL lbc_lnk( 'icedyn_adv_umx', pato_i, 'T', 1._wp )
- !
+
! --- diagnostics --- !
- diag_adv_mass(:,:) = diag_adv_mass(:,:) + ( SUM( pv_i (:,:,:) , dim=3 ) * rhoi + SUM( pv_s (:,:,:) , dim=3 ) * rhos &
- & + SUM( pv_ip(:,:,:) , dim=3 ) * rhow + SUM( pv_il(:,:,:) , dim=3 ) * rhow &
- & - zdiag_adv_mass(:,:) ) * z1_dt
- diag_adv_salt(:,:) = diag_adv_salt(:,:) + ( SUM( psv_i(:,:,:) , dim=3 ) * rhoi &
- & - zdiag_adv_salt(:,:) ) * z1_dt
- diag_adv_heat(:,:) = diag_adv_heat(:,:) + ( - SUM(SUM( pe_i(:,:,1:nlay_i,:) , dim=4 ), dim=3 ) &
- & - SUM(SUM( pe_s(:,:,1:nlay_s,:) , dim=4 ), dim=3 ) &
- & - zdiag_adv_heat(:,:) ) * z1_dt
- !
+ DO_2D( 0, 0, 0, 0 )
+ diag_adv_mass(ji,jj) = diag_adv_mass(ji,jj) + ( SUM( pv_i (ji,jj,:) ) * rhoi + SUM( pv_s (ji,jj,:) ) * rhos &
+ & + SUM( pv_ip(ji,jj,:) ) * rhow + SUM( pv_il(ji,jj,:) ) * rhow &
+ & - zdiag_adv_mass(ji,jj) ) * z1_dt
+ diag_adv_salt(ji,jj) = diag_adv_salt(ji,jj) + ( SUM( psv_i(ji,jj,:) ) * rhoi &
+ & - zdiag_adv_salt(ji,jj) ) * z1_dt
+ diag_adv_heat(ji,jj) = diag_adv_heat(ji,jj) + ( - SUM(SUM( pe_i(ji,jj,1:nlay_i,:) , dim=2 ) ) &
+ & - SUM(SUM( pe_s(ji,jj,1:nlay_s,:) , dim=2 ) ) &
+ & - zdiag_adv_heat(ji,jj) ) * z1_dt
+ END_2D
+
! --- Ensure non-negative fields and in-bound thicknesses --- !
! Remove negative values (conservation is ensured)
! (because advected fields are not perfectly bounded and tiny negative values can occur, e.g. -1.e-20)
- CALL ice_var_zapneg( zdt, pato_i, pv_i, pv_s, psv_i, poa_i, pa_i, pa_ip, pv_ip, pv_il, pe_s, pe_i )
+ CALL ice_var_zapneg( 0, zdt, pato_i, pv_i, pv_s, psv_i, poa_i, pa_i, pa_ip, pv_ip, pv_il, pe_s, pe_i )
!
! --- Make sure ice thickness is not too big --- !
! (because ice thickness can be too large where ice concentration is very small)
- CALL Hbig( zdt, zhi_max, zhs_max, zhip_max, zsi_max, zes_max, zei_max, &
+ CALL Hbig_umx( zdt, zhi_max, zhs_max, zhip_max, zsi_max, zes_max, zei_max, &
& pv_i, pv_s, pa_i, pa_ip, pv_ip, psv_i, pe_s, pe_i )
!
! --- Ensure snow load is not too big --- !
- CALL Hsnow( zdt, pv_i, pv_s, pa_i, pa_ip, pe_s )
+ CALL Hsnow_umx( zdt, pv_i, pv_s, pa_i, pa_ip, pe_s )
+ !
+ ! --- Lateral boundary conditions --- !
+ IF( jt /= icycle ) THEN ! only if we have 2 cycles and we are at the 1st one
+ IF( ln_pnd_LEV .OR. ln_pnd_TOPO ) THEN
+ CALL lbc_lnk( 'icedyn_adv_umx', pa_i , 'T', 1._wp, pv_i , 'T', 1._wp, pv_s , 'T', 1._wp, &
+ & psv_i, 'T', 1._wp, poa_i, 'T', 1._wp, &
+ & pa_ip, 'T', 1._wp, pv_ip, 'T', 1._wp, pv_il, 'T', 1._wp )
+ ELSE
+ CALL lbc_lnk( 'icedyn_adv_umx', pa_i , 'T', 1._wp, pv_i , 'T', 1._wp, pv_s , 'T', 1._wp, &
+ & psv_i, 'T', 1._wp, poa_i, 'T', 1._wp )
+ ENDIF
+ CALL lbc_lnk( 'icedyn_adv_umx', pe_i, 'T', 1._wp, pe_s, 'T', 1._wp )
+ CALL lbc_lnk( 'icedyn_adv_umx', pato_i, 'T', 1._wp )
+ ENDIF
+ !
!
END DO
!
@@ -518,7 +527,8 @@ CONTAINS
! thus we calculate the upstream solution and apply a limiter again
DO jl = 1, jpl
DO_2D( 0, 0, 0, 0 )
- ztra = - ( zfu_ups(ji,jj,jl) - zfu_ups(ji-1,jj,jl) + zfv_ups(ji,jj,jl) - zfv_ups(ji,jj-1,jl) )
+ ztra = - ( ( zfu_ups(ji,jj,jl) - zfu_ups(ji-1,jj,jl) ) & ! add () for NP repro
+ & + ( zfv_ups(ji,jj,jl) - zfv_ups(ji,jj-1,jl) ) )
!
zt_ups(ji,jj,jl) = ( ptc(ji,jj,jl) + ztra * r1_e1e2t(ji,jj) * pdt ) * tmask(ji,jj,1)
END_2D
@@ -553,7 +563,8 @@ CONTAINS
! ---------------------------------
DO jl = 1, jpl
DO_2D( 0, 0, 0, 0 )
- ztra = - ( zfu_ho(ji,jj,jl) - zfu_ho(ji-1,jj,jl) + zfv_ho(ji,jj,jl) - zfv_ho(ji,jj-1,jl) )
+ ztra = - ( ( zfu_ho(ji,jj,jl) - zfu_ho(ji-1,jj,jl) ) & ! add () for NP repro
+ & + ( zfv_ho(ji,jj,jl) - zfv_ho(ji,jj-1,jl) ) )
!
ptc(ji,jj,jl) = ( ptc(ji,jj,jl) + ztra * r1_e1e2t(ji,jj) * pdt ) * tmask(ji,jj,1)
END_2D
@@ -645,10 +656,10 @@ CONTAINS
!
DO jl = 1, jpl !-- after tracer with upstream scheme
DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 )
- ztra = - ( pfu_ups(ji,jj,jl) - pfu_ups(ji-1,jj ,jl) &
- & + pfv_ups(ji,jj,jl) - pfv_ups(ji ,jj-1,jl) ) &
- & + ( pu (ji,jj ) - pu (ji-1,jj ) &
- & + pv (ji,jj ) - pv (ji ,jj-1 ) ) * pt(ji,jj,jl) * (1.-pamsk)
+ ztra = - ( ( pfu_ups(ji,jj,jl) - pfu_ups(ji-1,jj ,jl) ) & ! add () for NP repro
+ & + ( pfv_ups(ji,jj,jl) - pfv_ups(ji ,jj-1,jl) ) ) &
+ & + ( ( pu (ji,jj ) - pu (ji-1,jj ) ) &
+ & + ( pv (ji,jj ) - pv (ji ,jj-1 ) ) ) * pt(ji,jj,jl) * (1.-pamsk)
!
pt_ups(ji,jj,jl) = ( pt(ji,jj,jl) + ztra * pdt * r1_e1e2t(ji,jj) ) * tmask(ji,jj,1)
END_2D
@@ -912,7 +923,7 @@ CONTAINS
!
DO jl = 1, jpl
DO_2D( 1, 0, kloop, kloop )
- pt_u(ji,jj,jl) = 0.5_wp * umask(ji,jj,1) * ( pt(ji+1,jj,jl) + pt(ji,jj,jl) &
+ pt_u(ji,jj,jl) = 0.5_wp * umask(ji,jj,1) * ( ( pt(ji+1,jj,jl) + pt(ji,jj,jl) ) &
& - SIGN( 1._wp, pu(ji,jj) ) * ( pt(ji+1,jj,jl) - pt(ji,jj,jl) ) )
END_2D
END DO
@@ -922,7 +933,7 @@ CONTAINS
DO jl = 1, jpl
DO_2D( 1, 0, kloop, kloop )
zcu = pu(ji,jj) * r1_e2u(ji,jj) * pdt * r1_e1u(ji,jj)
- pt_u(ji,jj,jl) = 0.5_wp * umask(ji,jj,1) * ( pt(ji+1,jj,jl) + pt(ji,jj,jl) &
+ pt_u(ji,jj,jl) = 0.5_wp * umask(ji,jj,1) * ( ( pt(ji+1,jj,jl) + pt(ji,jj,jl) ) &
& - zcu * ( pt(ji+1,jj,jl) - pt(ji,jj,jl) ) )
END_2D
END DO
@@ -934,9 +945,9 @@ CONTAINS
zcu = pu(ji,jj) * r1_e2u(ji,jj) * pdt * r1_e1u(ji,jj)
zdx2 = e1u(ji,jj) * e1u(ji,jj)
!!rachid zdx2 = e1u(ji,jj) * e1t(ji,jj)
- pt_u(ji,jj,jl) = 0.5_wp * umask(ji,jj,1) * ( ( pt (ji+1,jj,jl) + pt (ji,jj,jl) &
+ pt_u(ji,jj,jl) = 0.5_wp * umask(ji,jj,1) * ( ( ( pt (ji+1,jj,jl) + pt (ji,jj,jl) ) &
& - zcu * ( pt (ji+1,jj,jl) - pt (ji,jj,jl) ) ) &
- & + r1_6 * zdx2 * ( zcu*zcu - 1._wp ) * ( ztu2(ji+1,jj,jl) + ztu2(ji,jj,jl) &
+ & + r1_6 * zdx2 * ( zcu*zcu - 1._wp ) * ( ( ztu2(ji+1,jj,jl) + ztu2(ji,jj,jl) ) &
& - SIGN( 1._wp, zcu ) * ( ztu2(ji+1,jj,jl) - ztu2(ji,jj,jl) ) ) )
END_2D
END DO
@@ -948,9 +959,9 @@ CONTAINS
zcu = pu(ji,jj) * r1_e2u(ji,jj) * pdt * r1_e1u(ji,jj)
zdx2 = e1u(ji,jj) * e1u(ji,jj)
!!rachid zdx2 = e1u(ji,jj) * e1t(ji,jj)
- pt_u(ji,jj,jl) = 0.5_wp * umask(ji,jj,1) * ( ( pt (ji+1,jj,jl) + pt (ji,jj,jl) &
+ pt_u(ji,jj,jl) = 0.5_wp * umask(ji,jj,1) * ( ( ( pt (ji+1,jj,jl) + pt (ji,jj,jl) ) &
& - zcu * ( pt (ji+1,jj,jl) - pt (ji,jj,jl) ) ) &
- & + r1_6 * zdx2 * ( zcu*zcu - 1._wp ) * ( ztu2(ji+1,jj,jl) + ztu2(ji,jj,jl) &
+ & + r1_6 * zdx2 * ( zcu*zcu - 1._wp ) * ( ( ztu2(ji+1,jj,jl) + ztu2(ji,jj,jl) ) &
& - 0.5_wp * zcu * ( ztu2(ji+1,jj,jl) - ztu2(ji,jj,jl) ) ) )
END_2D
END DO
@@ -965,11 +976,11 @@ CONTAINS
zdx2 = e1u(ji,jj) * e1u(ji,jj)
!!rachid zdx2 = e1u(ji,jj) * e1t(ji,jj)
zdx4 = zdx2 * zdx2
- pt_u(ji,jj,jl) = 0.5_wp * umask(ji,jj,1) * ( ( pt (ji+1,jj,jl) + pt (ji,jj,jl) &
+ pt_u(ji,jj,jl) = 0.5_wp * umask(ji,jj,1) * ( ( ( pt (ji+1,jj,jl) + pt (ji,jj,jl) ) &
& - zcu * ( pt (ji+1,jj,jl) - pt (ji,jj,jl) ) ) &
- & + r1_6 * zdx2 * ( zcu*zcu - 1._wp ) * ( ztu2(ji+1,jj,jl) + ztu2(ji,jj,jl) &
+ & + r1_6 * zdx2 * ( zcu*zcu - 1._wp ) * ( ( ztu2(ji+1,jj,jl) + ztu2(ji,jj,jl) ) &
& - 0.5_wp * zcu * ( ztu2(ji+1,jj,jl) - ztu2(ji,jj,jl) ) ) &
- & + r1_120 * zdx4 * ( zcu*zcu - 1._wp ) * ( zcu*zcu - 4._wp ) * ( ztu4(ji+1,jj,jl) + ztu4(ji,jj,jl) &
+ & + r1_120 * zdx4 * ( zcu*zcu - 1._wp ) * ( zcu*zcu - 4._wp ) * ((ztu4(ji+1,jj,jl) + ztu4(ji,jj,jl) ) &
& - SIGN( 1._wp, zcu ) * ( ztu4(ji+1,jj,jl) - ztu4(ji,jj,jl) ) ) )
END_2D
END DO
@@ -983,7 +994,7 @@ CONTAINS
DO jl = 1, jpl
DO_2D( 1, 0, kloop, kloop )
IF( pt_u(ji,jj,jl) < 0._wp .OR. ( imsk_small(ji,jj,jl) == 0 .AND. pamsk == 0. ) ) THEN
- pt_u(ji,jj,jl) = 0.5_wp * umask(ji,jj,1) * ( pt(ji+1,jj,jl) + pt(ji,jj,jl) &
+ pt_u(ji,jj,jl) = 0.5_wp * umask(ji,jj,1) * ( ( pt(ji+1,jj,jl) + pt(ji,jj,jl) ) &
& - SIGN( 1._wp, pu(ji,jj) ) * ( pt(ji+1,jj,jl) - pt(ji,jj,jl) ) )
ENDIF
END_2D
@@ -1050,7 +1061,7 @@ CONTAINS
CASE( 1 ) !== 1st order central TIM ==! (Eq. 21)
DO jl = 1, jpl
DO_2D( kloop, kloop, 1, 0 )
- pt_v(ji,jj,jl) = 0.5_wp * vmask(ji,jj,1) * ( pt(ji,jj+1,jl) + pt(ji,jj,jl) &
+ pt_v(ji,jj,jl) = 0.5_wp * vmask(ji,jj,1) * ( ( pt(ji,jj+1,jl) + pt(ji,jj,jl) ) &
& - SIGN( 1._wp, pv(ji,jj) ) * ( pt(ji,jj+1,jl) - pt(ji,jj,jl) ) )
END_2D
END DO
@@ -1059,7 +1070,7 @@ CONTAINS
DO jl = 1, jpl
DO_2D( kloop, kloop, 1, 0 )
zcv = pv(ji,jj) * r1_e1v(ji,jj) * pdt * r1_e2v(ji,jj)
- pt_v(ji,jj,jl) = 0.5_wp * vmask(ji,jj,1) * ( pt(ji,jj+1,jl) + pt(ji,jj,jl) &
+ pt_v(ji,jj,jl) = 0.5_wp * vmask(ji,jj,1) * ( ( pt(ji,jj+1,jl) + pt(ji,jj,jl) ) &
& - zcv * ( pt(ji,jj+1,jl) - pt(ji,jj,jl) ) )
END_2D
END DO
@@ -1070,9 +1081,9 @@ CONTAINS
zcv = pv(ji,jj) * r1_e1v(ji,jj) * pdt * r1_e2v(ji,jj)
zdy2 = e2v(ji,jj) * e2v(ji,jj)
!!rachid zdy2 = e2v(ji,jj) * e2t(ji,jj)
- pt_v(ji,jj,jl) = 0.5_wp * vmask(ji,jj,1) * ( ( pt (ji,jj+1,jl) + pt (ji,jj,jl) &
+ pt_v(ji,jj,jl) = 0.5_wp * vmask(ji,jj,1) * ( ( ( pt (ji,jj+1,jl) + pt (ji,jj,jl) ) &
& - zcv * ( pt (ji,jj+1,jl) - pt (ji,jj,jl) ) ) &
- & + r1_6 * zdy2 * ( zcv*zcv - 1._wp ) * ( ztv2(ji,jj+1,jl) + ztv2(ji,jj,jl) &
+ & + r1_6 * zdy2 * ( zcv*zcv - 1._wp ) * ( ( ztv2(ji,jj+1,jl) + ztv2(ji,jj,jl) ) &
& - SIGN( 1._wp, zcv ) * ( ztv2(ji,jj+1,jl) - ztv2(ji,jj,jl) ) ) )
END_2D
END DO
@@ -1083,9 +1094,9 @@ CONTAINS
zcv = pv(ji,jj) * r1_e1v(ji,jj) * pdt * r1_e2v(ji,jj)
zdy2 = e2v(ji,jj) * e2v(ji,jj)
!!rachid zdy2 = e2v(ji,jj) * e2t(ji,jj)
- pt_v(ji,jj,jl) = 0.5_wp * vmask(ji,jj,1) * ( ( pt (ji,jj+1,jl) + pt (ji,jj,jl) &
+ pt_v(ji,jj,jl) = 0.5_wp * vmask(ji,jj,1) * ( ( ( pt (ji,jj+1,jl) + pt (ji,jj,jl) ) &
& - zcv * ( pt (ji,jj+1,jl) - pt (ji,jj,jl) ) ) &
- & + r1_6 * zdy2 * ( zcv*zcv - 1._wp ) * ( ztv2(ji,jj+1,jl) + ztv2(ji,jj,jl) &
+ & + r1_6 * zdy2 * ( zcv*zcv - 1._wp ) * ( ( ztv2(ji,jj+1,jl) + ztv2(ji,jj,jl) ) &
& - 0.5_wp * zcv * ( ztv2(ji,jj+1,jl) - ztv2(ji,jj,jl) ) ) )
END_2D
END DO
@@ -1100,11 +1111,11 @@ CONTAINS
zdy2 = e2v(ji,jj) * e2v(ji,jj)
!!rachid zdy2 = e2v(ji,jj) * e2t(ji,jj)
zdy4 = zdy2 * zdy2
- pt_v(ji,jj,jl) = 0.5_wp * vmask(ji,jj,1) * ( ( pt (ji,jj+1,jl) + pt (ji,jj,jl) &
+ pt_v(ji,jj,jl) = 0.5_wp * vmask(ji,jj,1) * ( ( ( pt (ji,jj+1,jl) + pt (ji,jj,jl) ) &
& - zcv * ( pt (ji,jj+1,jl) - pt (ji,jj,jl) ) ) &
- & + r1_6 * zdy2 * ( zcv*zcv - 1._wp ) * ( ztv2(ji,jj+1,jl) + ztv2(ji,jj,jl) &
+ & + r1_6 * zdy2 * ( zcv*zcv - 1._wp ) * ( ( ztv2(ji,jj+1,jl) + ztv2(ji,jj,jl) ) &
& - 0.5_wp * zcv * ( ztv2(ji,jj+1,jl) - ztv2(ji,jj,jl) ) ) &
- & + r1_120 * zdy4 * ( zcv*zcv - 1._wp ) * ( zcv*zcv - 4._wp ) * ( ztv4(ji,jj+1,jl) + ztv4(ji,jj,jl) &
+ & + r1_120 * zdy4 * ( zcv*zcv - 1._wp ) * ( zcv*zcv - 4._wp ) * ((ztv4(ji,jj+1,jl) + ztv4(ji,jj,jl) ) &
& - SIGN( 1._wp, zcv ) * ( ztv4(ji,jj+1,jl) - ztv4(ji,jj,jl) ) ) )
END_2D
END DO
@@ -1244,10 +1255,10 @@ CONTAINS
zneg = MAX( 0._wp, pfu_ho(ji ,jj ,jl) ) - MIN( 0._wp, pfu_ho(ji-1,jj ,jl) ) &
& + MAX( 0._wp, pfv_ho(ji ,jj ,jl) ) - MIN( 0._wp, pfv_ho(ji ,jj-1,jl) )
!
- zpos = zpos - (pt(ji,jj,jl) * MIN( 0., pu(ji,jj) - pu(ji-1,jj) ) + pt(ji,jj,jl) * MIN( 0., pv(ji,jj) - pv(ji,jj-1) ) &
- & ) * ( 1. - pamsk )
- zneg = zneg + (pt(ji,jj,jl) * MAX( 0., pu(ji,jj) - pu(ji-1,jj) ) + pt(ji,jj,jl) * MAX( 0., pv(ji,jj) - pv(ji,jj-1) ) &
- & ) * ( 1. - pamsk )
+ zpos = zpos - ( pt(ji,jj,jl) * MIN( 0., pu(ji,jj) - pu(ji-1,jj) ) &
+ & + pt(ji,jj,jl) * MIN( 0., pv(ji,jj) - pv(ji,jj-1) ) ) * ( 1. - pamsk )
+ zneg = zneg + ( pt(ji,jj,jl) * MAX( 0., pu(ji,jj) - pu(ji-1,jj) ) &
+ & + pt(ji,jj,jl) * MAX( 0., pv(ji,jj) - pv(ji,jj-1) ) ) * ( 1. - pamsk )
!
! ! up & down beta terms
! clem: zbetup and zbetdo must be 0 for zpos>1.e-10 & zneg>1.e-10 (do not put 0 instead of 1.e-10 !!!)
@@ -1481,10 +1492,10 @@ CONTAINS
END SUBROUTINE limiter_y
- SUBROUTINE Hbig( pdt, phi_max, phs_max, phip_max, psi_max, pes_max, pei_max, &
+ SUBROUTINE Hbig_umx( pdt, phi_max, phs_max, phip_max, psi_max, pes_max, pei_max, &
& pv_i, pv_s, pa_i, pa_ip, pv_ip, psv_i, pe_s, pe_i )
!!-------------------------------------------------------------------
- !! *** ROUTINE Hbig ***
+ !! *** ROUTINE Hbig_umx ***
!!
!! ** Purpose : Thickness correction in case advection scheme creates
!! abnormally tick ice or snow
@@ -1511,7 +1522,7 @@ CONTAINS
z1_dt = 1._wp / pdt
!
DO jl = 1, jpl
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
IF ( pv_i(ji,jj,jl) > 0._wp ) THEN
!
! ! -- check h_ip -- !
@@ -1558,7 +1569,7 @@ CONTAINS
!
! ! -- check e_i/v_i -- !
DO jl = 1, jpl
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, nlay_i )
+ DO_3D( 0, 0, 0, 0, 1, nlay_i )
IF ( pv_i(ji,jj,jl) > 0._wp ) THEN
! if e_i/v_i is larger than the surrounding 9 pts => put the heat excess in the ocean
zei = pe_i(ji,jj,jk,jl) / pv_i(ji,jj,jl)
@@ -1572,7 +1583,7 @@ CONTAINS
END DO
! ! -- check e_s/v_s -- !
DO jl = 1, jpl
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, nlay_s )
+ DO_3D( 0, 0, 0, 0, 1, nlay_s )
IF ( pv_s(ji,jj,jl) > 0._wp ) THEN
! if e_s/v_s is larger than the surrounding 9 pts => put the heat excess in the ocean
zes = pe_s(ji,jj,jk,jl) / pv_s(ji,jj,jl)
@@ -1585,12 +1596,12 @@ CONTAINS
END_3D
END DO
!
- END SUBROUTINE Hbig
+ END SUBROUTINE Hbig_umx
- SUBROUTINE Hsnow( pdt, pv_i, pv_s, pa_i, pa_ip, pe_s )
+ SUBROUTINE Hsnow_umx( pdt, pv_i, pv_s, pa_i, pa_ip, pe_s )
!!-------------------------------------------------------------------
- !! *** ROUTINE Hsnow ***
+ !! *** ROUTINE Hsnow_umx ***
!!
!! ** Purpose : 1- Check snow load after advection
!! 2- Correct pond concentration to avoid a_ip > a_i
@@ -1615,7 +1626,7 @@ CONTAINS
!
! -- check snow load -- !
DO jl = 1, jpl
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
IF ( pv_i(ji,jj,jl) > 0._wp ) THEN
!
zvs_excess = MAX( 0._wp, pv_s(ji,jj,jl) - pv_i(ji,jj,jl) * (rho0-rhoi) * r1_rhos )
@@ -1637,11 +1648,11 @@ CONTAINS
!-- correct pond concentration to avoid a_ip > a_i -- !
WHERE( pa_ip(:,:,:) > pa_i(:,:,:) ) pa_ip(:,:,:) = pa_i(:,:,:)
!
- END SUBROUTINE Hsnow
+ END SUBROUTINE Hsnow_umx
- SUBROUTINE icemax3D( pice , pmax )
+ SUBROUTINE icemax3D_umx( pice , pmax )
!!---------------------------------------------------------------------
- !! *** ROUTINE icemax3D ***
+ !! *** ROUTINE icemax3D_umx ***
!! ** Purpose : compute the max of the 9 points around
!!----------------------------------------------------------------------
REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: pice ! input
@@ -1672,11 +1683,11 @@ CONTAINS
zmax2(ji) = zmax3
END_2D
END DO
- END SUBROUTINE icemax3D
+ END SUBROUTINE icemax3D_umx
- SUBROUTINE icemax4D( pice , pmax )
+ SUBROUTINE icemax4D_umx( pice , pmax )
!!---------------------------------------------------------------------
- !! *** ROUTINE icemax4D ***
+ !! *** ROUTINE icemax4D_umx ***
!! ** Purpose : compute the max of the 9 points around
!!----------------------------------------------------------------------
REAL(wp), DIMENSION(:,:,:,:), INTENT(in ) :: pice ! input
@@ -1712,7 +1723,7 @@ CONTAINS
END_2D
END DO
END DO
- END SUBROUTINE icemax4D
+ END SUBROUTINE icemax4D_umx
#else
!!----------------------------------------------------------------------
diff --git a/src/ICE/icedyn_rdgrft.F90 b/src/ICE/icedyn_rdgrft.F90
index 661748ea3b97e4f5e25f5780c8d29da6149ddc4d..ad7d1de81c22ea810c7dc50eb8257aa2b7da1db2 100644
--- a/src/ICE/icedyn_rdgrft.F90
+++ b/src/ICE/icedyn_rdgrft.F90
@@ -56,8 +56,6 @@ MODULE icedyn_rdgrft
REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: hi_hrdg ! thickness of ridging ice / mean ridge thickness
REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: aridge ! participating ice ridging
REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: araft ! participating ice rafting
- REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: ze_i_2d
- REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: ze_s_2d
!
REAL(wp), PARAMETER :: hrdg_hi_min = 1.1_wp ! min ridge thickness multiplier: min(hrdg/hi)
REAL(wp), PARAMETER :: hi_hrft = 0.5_wp ! rafting multiplier: (hi/hraft)
@@ -103,7 +101,7 @@ CONTAINS
ALLOCATE( closing_net(jpij) , opning(jpij) , closing_gross(jpij), &
& apartf(jpij,0:jpl), hrmin (jpij,jpl), hraft(jpij,jpl) , aridge(jpij,jpl), &
& hrmax (jpij,jpl) , hrexp (jpij,jpl), hi_hrdg(jpij,jpl) , araft(jpij,jpl) , &
- & ze_i_2d(jpij,nlay_i,jpl), ze_s_2d(jpij,nlay_s,jpl), STAT=ice_dyn_rdgrft_alloc )
+ & STAT=ice_dyn_rdgrft_alloc )
CALL mpp_sum ( 'icedyn_rdgrft', ice_dyn_rdgrft_alloc )
IF( ice_dyn_rdgrft_alloc /= 0 ) CALL ctl_stop( 'STOP', 'ice_dyn_rdgrft_alloc: failed to allocate arrays' )
@@ -170,11 +168,11 @@ CONTAINS
!--------------------------------
! 0) Identify grid cells with ice
!--------------------------------
- at_i(:,:) = SUM( a_i, dim=3 )
+ at_i(A2D(0)) = SUM( a_i(A2D(0),:), dim=3 )
!
npti = 0 ; nptidx(:) = 0
ipti = 0 ; iptidx(:) = 0
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
IF ( at_i(ji,jj) > epsi10 ) THEN
npti = npti + 1
nptidx( npti ) = (jj - 1) * jpi + ji
@@ -187,13 +185,13 @@ CONTAINS
IF( npti > 0 ) THEN
! just needed here
- CALL tab_2d_1d( npti, nptidx(1:npti), zdelt (1:npti) , delta_i )
- CALL tab_2d_1d( npti, nptidx(1:npti), zconv (1:npti) , rdg_conv )
+ CALL tab_2d_1d( npti, nptidx(1:npti), zdelt (1:npti) , delta_i )
+ CALL tab_2d_1d( npti, nptidx(1:npti), zconv (1:npti) , rdg_conv )
! needed here and in the iteration loop
- CALL tab_2d_1d( npti, nptidx(1:npti), zdivu (1:npti) , divu_i) ! zdivu is used as a work array here (no change in divu_i)
- CALL tab_3d_2d( npti, nptidx(1:npti), a_i_2d (1:npti,1:jpl), a_i )
- CALL tab_3d_2d( npti, nptidx(1:npti), v_i_2d (1:npti,1:jpl), v_i )
- CALL tab_2d_1d( npti, nptidx(1:npti), ato_i_1d(1:npti) , ato_i )
+ CALL tab_2d_1d( npti, nptidx(1:npti), zdivu (1:npti) , divu_i) ! zdivu is used as a work array here (no change in divu_i)
+ CALL tab_3d_2d( npti, nptidx(1:npti), a_i_2d (1:npti,:), a_i )
+ CALL tab_3d_2d( npti, nptidx(1:npti), v_i_2d (1:npti,:), v_i )
+ CALL tab_2d_1d( npti, nptidx(1:npti), ato_i_1d(1:npti) , ato_i )
DO ji = 1, npti
! closing_net = rate at which open water area is removed + ice area removed by ridging
@@ -280,8 +278,10 @@ CONTAINS
CALL ice_dyn_1d2d( 2 ) ! --- Move to 2D arrays --- !
ENDIF
+ ! clem: those fields must be updated on the halos: ato_i, a_i, v_i, v_s, sv_i, oa_i, a_ip, v_ip, v_il, e_i, e_s
- CALL ice_var_agg( 1 )
+ ! clem: I think we can comment this line but I am not sure it does not change results
+!!$ CALL ice_var_agg( 1 )
! controls
IF( sn_cfctl%l_prtctl ) CALL ice_prt3D('icedyn_rdgrft') ! prints
@@ -302,8 +302,9 @@ CONTAINS
!! ** Method : Compute the thickness distribution of the ice and open water
!! participating in ridging and of the resulting ridges.
!!-------------------------------------------------------------------
- REAL(wp), DIMENSION(:) , INTENT(in) :: pato_i, pclosing_net
- REAL(wp), DIMENSION(:,:), INTENT(in) :: pa_i, pv_i
+ REAL(wp), DIMENSION(:,:), INTENT(in) :: pa_i, pv_i
+ REAL(wp), DIMENSION(:) , INTENT(in) :: pato_i
+ REAL(wp), DIMENSION(:) , INTENT(in), OPTIONAL :: pclosing_net
!!
INTEGER :: ji, jl ! dummy loop indices
REAL(wp) :: z1_gstar, z1_astar, zhmean, zfac ! local scalar
@@ -504,39 +505,43 @@ CONTAINS
END DO
END DO
!
- ! 3) closing_gross
- !-----------------
- ! Based on the ITD of ridging and ridged ice, convert the net closing rate to a gross closing rate.
- ! NOTE: 0 < aksum <= 1
- WHERE( zaksum(1:npti) > epsi10 ) ; closing_gross(1:npti) = pclosing_net(1:npti) / zaksum(1:npti)
- ELSEWHERE ; closing_gross(1:npti) = 0._wp
- END WHERE
-
- ! correction to closing rate if excessive ice removal
- !----------------------------------------------------
- ! Reduce the closing rate if more than 100% of any ice category would be removed
- ! Reduce the opening rate in proportion
- DO jl = 1, jpl
+ IF( PRESENT( pclosing_net ) ) THEN
+ !
+ ! 3) closing_gross
+ !-----------------
+ ! Based on the ITD of ridging and ridged ice, convert the net closing rate to a gross closing rate.
+ ! NOTE: 0 < aksum <= 1
+ WHERE( zaksum(1:npti) > epsi10 ) ; closing_gross(1:npti) = pclosing_net(1:npti) / zaksum(1:npti)
+ ELSEWHERE ; closing_gross(1:npti) = 0._wp
+ END WHERE
+
+ ! correction to closing rate if excessive ice removal
+ !----------------------------------------------------
+ ! Reduce the closing rate if more than 100% of any ice category would be removed
+ ! Reduce the opening rate in proportion
+ DO jl = 1, jpl
+ DO ji = 1, npti
+ zfac = apartf(ji,jl) * closing_gross(ji) * rDt_ice
+ IF( zfac > pa_i(ji,jl) .AND. apartf(ji,jl) /= 0._wp ) THEN
+ closing_gross(ji) = pa_i(ji,jl) / apartf(ji,jl) * r1_Dt_ice
+ ENDIF
+ END DO
+ END DO
+
+ ! 4) correction to opening if excessive open water removal
+ !---------------------------------------------------------
+ ! Reduce the closing rate if more than 100% of the open water would be removed
+ ! Reduce the opening rate in proportion
DO ji = 1, npti
- zfac = apartf(ji,jl) * closing_gross(ji) * rDt_ice
- IF( zfac > pa_i(ji,jl) .AND. apartf(ji,jl) /= 0._wp ) THEN
- closing_gross(ji) = pa_i(ji,jl) / apartf(ji,jl) * r1_Dt_ice
+ zfac = pato_i(ji) + ( opning(ji) - apartf(ji,0) * closing_gross(ji) ) * rDt_ice
+ IF( zfac < 0._wp ) THEN ! would lead to negative ato_i
+ opning(ji) = apartf(ji,0) * closing_gross(ji) - pato_i(ji) * r1_Dt_ice
+ ELSEIF( zfac > zasum(ji) ) THEN ! would lead to ato_i > asum
+ opning(ji) = apartf(ji,0) * closing_gross(ji) + ( zasum(ji) - pato_i(ji) ) * r1_Dt_ice
ENDIF
END DO
- END DO
-
- ! 4) correction to opening if excessive open water removal
- !---------------------------------------------------------
- ! Reduce the closing rate if more than 100% of the open water would be removed
- ! Reduce the opening rate in proportion
- DO ji = 1, npti
- zfac = pato_i(ji) + ( opning(ji) - apartf(ji,0) * closing_gross(ji) ) * rDt_ice
- IF( zfac < 0._wp ) THEN ! would lead to negative ato_i
- opning(ji) = apartf(ji,0) * closing_gross(ji) - pato_i(ji) * r1_Dt_ice
- ELSEIF( zfac > zasum(ji) ) THEN ! would lead to ato_i > asum
- opning(ji) = apartf(ji,0) * closing_gross(ji) + ( zasum(ji) - pato_i(ji) ) * r1_Dt_ice
- ENDIF
- END DO
+ !
+ ENDIF
!
END SUBROUTINE rdgrft_prep
@@ -561,9 +566,9 @@ CONTAINS
REAL(wp), DIMENSION(jpij) :: airdg2, oirdg2, aprdg2, virdg2, sirdg2, vsrdg, vprdg, vlrdg ! area etc of new ridges
REAL(wp), DIMENSION(jpij) :: airft2, oirft2, aprft2, virft , sirft , vsrft, vprft, vlrft ! area etc of rafted ice
!
- REAL(wp), DIMENSION(jpij) :: ersw ! enth of water trapped into ridges
- REAL(wp), DIMENSION(jpij) :: zswitch, fvol ! new ridge volume going to jl2
- REAL(wp), DIMENSION(jpij) :: z1_ai ! 1 / a
+ REAL(wp) :: ersw ! enthalpy of water trapped into ridges
+ REAL(wp) :: zswitch, fvol ! new ridge volume going to jl2
+ REAL(wp) :: z1_ai ! 1 / a
REAL(wp), DIMENSION(jpij) :: zvti ! sum(v_i)
!
REAL(wp), DIMENSION(jpij,nlay_s) :: esrft ! snow energy of rafting ice
@@ -585,11 +590,11 @@ CONTAINS
! 2) compute categories in which ice is removed (jl1)
!----------------------------------------------------
- DO jl1 = 1, jpl
+ IF( nn_icesal /= 2 ) THEN
+ CALL tab_3d_2d( npti, nptidx(1:npti), s_i_2d(1:npti,:), s_i(:,:,:) )
+ ENDIF
- IF( nn_icesal /= 2 ) THEN
- CALL tab_2d_1d( npti, nptidx(1:npti), s_i_1d(1:npti), s_i(:,:,jl1) )
- ENDIF
+ DO jl1 = 1, jpl
DO ji = 1, npti
@@ -600,8 +605,8 @@ CONTAINS
IF( ll_shift(ji) ) THEN ! only if ice is ridging
- IF( a_i_2d(ji,jl1) > epsi10 ) THEN ; z1_ai(ji) = 1._wp / a_i_2d(ji,jl1)
- ELSE ; z1_ai(ji) = 0._wp
+ IF( a_i_2d(ji,jl1) > epsi10 ) THEN ; z1_ai = 1._wp / a_i_2d(ji,jl1)
+ ELSE ; z1_ai = 0._wp
ENDIF
! area of ridging / rafting ice (airdg1) and of new ridge (airdg2)
@@ -612,15 +617,15 @@ CONTAINS
airft2(ji) = airft1 * hi_hrft
! ridging /rafting fractions
- afrdg = airdg1 * z1_ai(ji)
- afrft = airft1 * z1_ai(ji)
+ afrdg = airdg1 * z1_ai
+ afrft = airft1 * z1_ai
! volume and enthalpy (J/m2, >0) of seawater trapped into ridges
IF ( zvti(ji) <= 10. ) THEN ; vsw = v_i_2d(ji,jl1) * afrdg * rn_porordg ! v <= 10m then porosity = rn_porordg
ELSEIF( zvti(ji) >= 20. ) THEN ; vsw = 0._wp ! v >= 20m then porosity = 0
ELSE ; vsw = v_i_2d(ji,jl1) * afrdg * rn_porordg * MAX( 0._wp, 2._wp - 0.1_wp * zvti(ji) ) ! v > 10m and v < 20m then porosity = linear transition to 0
ENDIF
- ersw(ji) = -rhoi * vsw * rcp * sst_1d(ji) ! clem: if sst>0, then ersw <0 (is that possible?)
+ ersw = -rhoi * vsw * rcp * sst_1d(ji) ! clem: if sst>0, then ersw <0 (is that possible?)
! volume etc of ridging / rafting ice and new ridges (vi, vs, sm, oi, es, ei)
virdg1 = v_i_2d (ji,jl1) * afrdg
@@ -649,22 +654,35 @@ CONTAINS
vlrft (ji) = v_il_2d(ji,jl1) * afrft
ENDIF
ENDIF
+
+ DO jk = 1, nlay_s
+ esrdg(ji,jk) = e_s_2d (ji,jk,jl1) * afrdg
+ esrft(ji,jk) = e_s_2d (ji,jk,jl1) * afrft
+ END DO
+ DO jk = 1, nlay_i
+ eirdg(ji,jk) = e_i_2d (ji,jk,jl1) * afrdg + ersw * r1_nlay_i
+ eirft(ji,jk) = e_i_2d (ji,jk,jl1) * afrft
+ END DO
! Ice-ocean exchanges associated with ice porosity
wfx_dyn_1d(ji) = wfx_dyn_1d(ji) - vsw * rhoi * r1_Dt_ice ! increase in ice volume due to seawater frozen in voids
sfx_dyn_1d(ji) = sfx_dyn_1d(ji) - vsw * sss_1d(ji) * rhoi * r1_Dt_ice
- hfx_dyn_1d(ji) = hfx_dyn_1d(ji) + ersw(ji) * r1_Dt_ice ! > 0 [W.m-2]
+ hfx_dyn_1d(ji) = hfx_dyn_1d(ji) + ersw * r1_Dt_ice ! > 0 [W.m-2]
! Put the snow lost by ridging into the ocean
! Note that esrdg > 0; the ocean must cool to melt snow. If the ocean temp = Tf already, new ice must grow.
wfx_snw_dyn_1d(ji) = wfx_snw_dyn_1d(ji) + ( rhos * vsrdg(ji) * ( 1._wp - rn_fsnwrdg ) & ! fresh water source for ocean
& + rhos * vsrft(ji) * ( 1._wp - rn_fsnwrft ) ) * r1_Dt_ice
+ DO jk = 1, nlay_s
+ hfx_dyn_1d(ji) = hfx_dyn_1d(ji) + ( - esrdg(ji,jk) * ( 1._wp - rn_fsnwrdg ) & ! heat sink for ocean (<0, W.m-2)
+ & - esrft(ji,jk) * ( 1._wp - rn_fsnwrft ) ) * r1_Dt_ice
+ END DO
! virtual salt flux to keep salinity constant
IF( nn_icesal /= 2 ) THEN
- sirdg2(ji) = sirdg2(ji) - vsw * ( sss_1d(ji) - s_i_1d(ji) ) ! ridge salinity = s_i
- sfx_bri_1d(ji) = sfx_bri_1d(ji) + sss_1d(ji) * vsw * rhoi * r1_Dt_ice & ! put back sss_m into the ocean
- & - s_i_1d(ji) * vsw * rhoi * r1_Dt_ice ! and get s_i from the ocean
+ sirdg2(ji) = sirdg2(ji) - ( sss_1d(ji) - s_i_2d(ji,jl1) ) * vsw ! ridge salinity = s_i
+ sfx_bri_1d(ji) = sfx_bri_1d(ji) + ( sss_1d(ji) - s_i_2d(ji,jl1) ) * vsw * rhoi * r1_Dt_ice ! put back sss_m into the ocean
+ ! ! and get s_i from the ocean
ENDIF
! Remove area, volume of new ridge to each category jl1
@@ -681,49 +699,18 @@ CONTAINS
v_il_2d(ji,jl1) = v_il_2d(ji,jl1) - vlrdg(ji) - vlrft(ji)
ENDIF
ENDIF
+ DO jk = 1, nlay_s
+ e_s_2d(ji,jk,jl1) = e_s_2d(ji,jk,jl1) * ( 1._wp - afrdg - afrft )
+ END DO
+ DO jk = 1, nlay_i
+ e_i_2d(ji,jk,jl1) = e_i_2d(ji,jk,jl1) * ( 1._wp - afrdg - afrft )
+ END DO
+
ENDIF
-
+
END DO ! ji
-
- ! special loop for e_s because of layers jk
- DO jk = 1, nlay_s
- DO ji = 1, npti
- IF( ll_shift(ji) ) THEN
- ! Compute ridging /rafting fractions
- afrdg = aridge(ji,jl1) * closing_gross(ji) * rDt_ice * z1_ai(ji)
- afrft = araft (ji,jl1) * closing_gross(ji) * rDt_ice * z1_ai(ji)
- ! Compute ridging /rafting ice and new ridges for es
- esrdg(ji,jk) = ze_s_2d (ji,jk,jl1) * afrdg
- esrft(ji,jk) = ze_s_2d (ji,jk,jl1) * afrft
- ! Put the snow lost by ridging into the ocean
- hfx_dyn_1d(ji) = hfx_dyn_1d(ji) + ( - esrdg(ji,jk) * ( 1._wp - rn_fsnwrdg ) & ! heat sink for ocean (<0, W.m-2)
- & - esrft(ji,jk) * ( 1._wp - rn_fsnwrft ) ) * r1_Dt_ice
- !
- ! Remove energy of new ridge to each category jl1
- !-------------------------------------------------
- ze_s_2d(ji,jk,jl1) = ze_s_2d(ji,jk,jl1) * ( 1._wp - afrdg - afrft )
- ENDIF
- END DO
- END DO
-
- ! special loop for e_i because of layers jk
- DO jk = 1, nlay_i
- DO ji = 1, npti
- IF( ll_shift(ji) ) THEN
- ! Compute ridging /rafting fractions
- afrdg = aridge(ji,jl1) * closing_gross(ji) * rDt_ice * z1_ai(ji)
- afrft = araft (ji,jl1) * closing_gross(ji) * rDt_ice * z1_ai(ji)
- ! Compute ridging ice and new ridges for ei
- eirdg(ji,jk) = ze_i_2d (ji,jk,jl1) * afrdg + ersw(ji) * r1_nlay_i
- eirft(ji,jk) = ze_i_2d (ji,jk,jl1) * afrft
- !
- ! Remove energy of new ridge to each category jl1
- !-------------------------------------------------
- ze_i_2d(ji,jk,jl1) = ze_i_2d(ji,jk,jl1) * ( 1._wp - afrdg - afrft )
- ENDIF
- END DO
- END DO
-
+
+
! 3) compute categories in which ice is added (jl2)
!--------------------------------------------------
itest_rdg(1:npti) = 0
@@ -740,13 +727,13 @@ CONTAINS
IF( hrmin(ji,jl1) <= hi_max(jl2) .AND. hrmax(ji,jl1) > hi_max(jl2-1) ) THEN
hL = MAX( hrmin(ji,jl1), hi_max(jl2-1) )
hR = MIN( hrmax(ji,jl1), hi_max(jl2) )
- farea = ( hR - hL ) / ( hrmax(ji,jl1) - hrmin(ji,jl1) )
- fvol(ji) = ( hR * hR - hL * hL ) / ( hrmax(ji,jl1) * hrmax(ji,jl1) - hrmin(ji,jl1) * hrmin(ji,jl1) )
+ farea = ( hR - hL ) / ( hrmax(ji,jl1) - hrmin(ji,jl1) )
+ fvol = ( hR * hR - hL * hL ) / ( hrmax(ji,jl1) * hrmax(ji,jl1) - hrmin(ji,jl1) * hrmin(ji,jl1) )
!
itest_rdg(ji) = 1 ! test for conservation
ELSE
- farea = 0._wp
- fvol(ji) = 0._wp
+ farea = 0._wp
+ fvol = 0._wp
ENDIF
!
ELSEIF( ln_distf_exp ) THEN ! Lipscomb et al. (2007) exponential formulation
@@ -754,24 +741,24 @@ CONTAINS
IF( jl2 < jpl ) THEN
!
IF( hrmin(ji,jl1) <= hi_max(jl2) ) THEN
- hL = MAX( hrmin(ji,jl1), hi_max(jl2-1) )
- hR = hi_max(jl2)
- expL = EXP( -( hL - hrmin(ji,jl1) ) / hrexp(ji,jl1) )
- expR = EXP( -( hR - hrmin(ji,jl1) ) / hrexp(ji,jl1) )
- farea = expL - expR
- fvol(ji) = ( ( hL + hrexp(ji,jl1) ) * expL &
- - ( hR + hrexp(ji,jl1) ) * expR ) / ( hrmin(ji,jl1) + hrexp(ji,jl1) )
+ hL = MAX( hrmin(ji,jl1), hi_max(jl2-1) )
+ hR = hi_max(jl2)
+ expL = EXP( -( hL - hrmin(ji,jl1) ) / hrexp(ji,jl1) )
+ expR = EXP( -( hR - hrmin(ji,jl1) ) / hrexp(ji,jl1) )
+ farea = expL - expR
+ fvol = ( ( hL + hrexp(ji,jl1) ) * expL &
+ & - ( hR + hrexp(ji,jl1) ) * expR ) / ( hrmin(ji,jl1) + hrexp(ji,jl1) )
ELSE
- farea = 0._wp
- fvol(ji) = 0._wp
+ farea = 0._wp
+ fvol = 0._wp
END IF
!
ELSE ! jl2 = jpl
!
- hL = MAX( hrmin(ji,jl1), hi_max(jl2-1) )
- expL = EXP(-( hL - hrmin(ji,jl1) ) / hrexp(ji,jl1) )
- farea = expL
- fvol(ji) = ( hL + hrexp(ji,jl1) ) * expL / ( hrmin(ji,jl1) + hrexp(ji,jl1) )
+ hL = MAX( hrmin(ji,jl1), hi_max(jl2-1) )
+ expL = EXP(-( hL - hrmin(ji,jl1) ) / hrexp(ji,jl1) )
+ farea = expL
+ fvol = ( hL + hrexp(ji,jl1) ) * expL / ( hrmin(ji,jl1) + hrexp(ji,jl1) )
!
END IF ! jl2 < jpl
!
@@ -781,59 +768,49 @@ CONTAINS
! Compute the fraction of rafted ice area and volume going to thickness category jl2
IF( hraft(ji,jl1) <= hi_max(jl2) .AND. hraft(ji,jl1) > hi_max(jl2-1) ) THEN
- zswitch(ji) = 1._wp
+ zswitch = 1._wp
!
itest_rft(ji) = 1 ! test for conservation
ELSE
- zswitch(ji) = 0._wp
+ zswitch = 0._wp
ENDIF
!
! Patch to ensure perfect conservation if ice thickness goes mad
! Sometimes thickness is larger than hi_max(jpl) because of advection scheme (for very small areas)
! Then ice volume is removed from one category but the ridging/rafting scheme
! does not know where to move it, leading to a conservation issue.
- IF( itest_rdg(ji) == 0 .AND. jl2 == jpl ) THEN ; farea = 1._wp ; fvol(ji) = 1._wp ; ENDIF
- IF( itest_rft(ji) == 0 .AND. jl2 == jpl ) zswitch(ji) = 1._wp
+ IF( itest_rdg(ji) == 0 .AND. jl2 == jpl ) THEN ; farea = 1._wp ; fvol = 1._wp ; ENDIF
+ IF( itest_rft(ji) == 0 .AND. jl2 == jpl ) zswitch = 1._wp
!
! Add area, volume of new ridge to category jl2
!----------------------------------------------
- a_i_2d (ji,jl2) = a_i_2d (ji,jl2) + ( airdg2(ji) * farea + airft2(ji) * zswitch(ji) )
- oa_i_2d(ji,jl2) = oa_i_2d(ji,jl2) + ( oirdg2(ji) * farea + oirft2(ji) * zswitch(ji) )
- v_i_2d (ji,jl2) = v_i_2d (ji,jl2) + ( virdg2(ji) * fvol(ji) + virft (ji) * zswitch(ji) )
- sv_i_2d(ji,jl2) = sv_i_2d(ji,jl2) + ( sirdg2(ji) * fvol(ji) + sirft (ji) * zswitch(ji) )
- v_s_2d (ji,jl2) = v_s_2d (ji,jl2) + ( vsrdg (ji) * rn_fsnwrdg * fvol(ji) + &
- & vsrft (ji) * rn_fsnwrft * zswitch(ji) )
+ a_i_2d (ji,jl2) = a_i_2d (ji,jl2) + ( airdg2(ji) * farea + airft2(ji) * zswitch )
+ oa_i_2d(ji,jl2) = oa_i_2d(ji,jl2) + ( oirdg2(ji) * farea + oirft2(ji) * zswitch )
+ v_i_2d (ji,jl2) = v_i_2d (ji,jl2) + ( virdg2(ji) * fvol + virft (ji) * zswitch )
+ sv_i_2d(ji,jl2) = sv_i_2d(ji,jl2) + ( sirdg2(ji) * fvol + sirft (ji) * zswitch )
+ v_s_2d (ji,jl2) = v_s_2d (ji,jl2) + ( vsrdg (ji) * rn_fsnwrdg * fvol + &
+ & vsrft (ji) * rn_fsnwrft * zswitch )
IF ( ln_pnd_LEV .OR. ln_pnd_TOPO ) THEN
- v_ip_2d (ji,jl2) = v_ip_2d(ji,jl2) + ( vprdg (ji) * rn_fpndrdg * fvol (ji) &
- & + vprft (ji) * rn_fpndrft * zswitch(ji) )
- a_ip_2d (ji,jl2) = a_ip_2d(ji,jl2) + ( aprdg2(ji) * rn_fpndrdg * farea &
- & + aprft2(ji) * rn_fpndrft * zswitch(ji) )
+ v_ip_2d (ji,jl2) = v_ip_2d(ji,jl2) + ( vprdg (ji) * rn_fpndrdg * fvol &
+ & + vprft (ji) * rn_fpndrft * zswitch )
+ a_ip_2d (ji,jl2) = a_ip_2d(ji,jl2) + ( aprdg2(ji) * rn_fpndrdg * farea &
+ & + aprft2(ji) * rn_fpndrft * zswitch )
IF ( ln_pnd_lids ) THEN
- v_il_2d (ji,jl2) = v_il_2d(ji,jl2) + ( vlrdg(ji) * rn_fpndrdg * fvol (ji) &
- & + vlrft(ji) * rn_fpndrft * zswitch(ji) )
+ v_il_2d (ji,jl2) = v_il_2d(ji,jl2) + ( vlrdg(ji) * rn_fpndrdg * fvol &
+ & + vlrft(ji) * rn_fpndrft * zswitch )
ENDIF
ENDIF
-
+ DO jk = 1, nlay_s
+ e_s_2d(ji,jk,jl2) = e_s_2d(ji,jk,jl2) + ( esrdg(ji,jk) * rn_fsnwrdg * fvol + &
+ & esrft(ji,jk) * rn_fsnwrft * zswitch )
+ END DO
+ DO jk = 1, nlay_i
+ e_i_2d(ji,jk,jl2) = e_i_2d(ji,jk,jl2) + eirdg(ji,jk) * fvol + eirft(ji,jk) * zswitch
+ END DO
+
ENDIF
END DO
- ! Add snow energy of new ridge to category jl2
- !---------------------------------------------
- DO jk = 1, nlay_s
- DO ji = 1, npti
- IF( ll_shift(ji) ) &
- & ze_s_2d(ji,jk,jl2) = ze_s_2d(ji,jk,jl2) + ( esrdg(ji,jk) * rn_fsnwrdg * fvol(ji) + &
- & esrft(ji,jk) * rn_fsnwrft * zswitch(ji) )
- END DO
- END DO
- ! Add ice energy of new ridge to category jl2
- !--------------------------------------------
- DO jk = 1, nlay_i
- DO ji = 1, npti
- IF( ll_shift(ji) ) &
- & ze_i_2d(ji,jk,jl2) = ze_i_2d(ji,jk,jl2) + eirdg(ji,jk) * fvol(ji) + eirft(ji,jk) * zswitch(ji)
- END DO
- END DO
!
END DO ! jl2
!
@@ -842,7 +819,7 @@ CONTAINS
! roundoff errors
!----------------
! In case ridging/rafting lead to very small negative values (sometimes it happens)
- CALL ice_var_roundoff( a_i_2d, v_i_2d, v_s_2d, sv_i_2d, oa_i_2d, a_ip_2d, v_ip_2d, v_il_2d, ze_s_2d, ze_i_2d )
+ CALL ice_var_roundoff( a_i_2d, v_i_2d, v_s_2d, sv_i_2d, oa_i_2d, a_ip_2d, v_ip_2d, v_il_2d, e_s_2d, e_i_2d )
!
END SUBROUTINE rdgrft_shift
@@ -861,7 +838,7 @@ CONTAINS
!!----------------------------------------------------------------------
INTEGER :: ji, jj, jl ! dummy loop indices
REAL(wp) :: z1_3 ! local scalars
- REAL(wp), DIMENSION(jpi,jpj) :: zmsk, zworka ! temporary array used here
+ REAL(wp), DIMENSION(A2D(0)) :: zworka ! temporary array used here
!!
LOGICAL :: ln_str_R75
REAL(wp) :: zhi, zcp
@@ -869,11 +846,8 @@ CONTAINS
REAL(wp), PARAMETER :: zmax_strength = 200.e3_wp ! Richter-Menge and Elder (1998) estimate maximum in Beaufort Sea in wintertime of the order 150 kN/m
REAL(wp), DIMENSION(jpij) :: zstrength, zaksum ! strength in 1D
!!----------------------------------------------------------------------
- ! prepare the mask
+ ! at_i needed for strength
at_i(:,:) = SUM( a_i, dim=3 )
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
- zmsk(ji,jj) = MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) - epsi10 ) ) ! 1 if ice , 0 if no ice
- END_2D
!
SELECT CASE( nice_str ) !--- Set which ice strength is chosen
@@ -886,7 +860,7 @@ CONTAINS
!
! Identify grid cells with ice
npti = 0 ; nptidx(:) = 0
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
IF ( at_i(ji,jj) > epsi10 ) THEN
npti = npti + 1
nptidx( npti ) = (jj - 1) * jpi + ji
@@ -894,12 +868,12 @@ CONTAINS
END_2D
IF( npti > 0 ) THEN
- CALL tab_3d_2d( npti, nptidx(1:npti), a_i_2d (1:npti,1:jpl), a_i )
- CALL tab_3d_2d( npti, nptidx(1:npti), v_i_2d (1:npti,1:jpl), v_i )
- CALL tab_2d_1d( npti, nptidx(1:npti), ato_i_1d(1:npti) , ato_i )
- CALL tab_2d_1d( npti, nptidx(1:npti), zstrength(1:npti) , strength )
+ CALL tab_3d_2d( npti, nptidx(1:npti), a_i_2d (1:npti,:), a_i )
+ CALL tab_3d_2d( npti, nptidx(1:npti), v_i_2d (1:npti,:), v_i )
+ CALL tab_2d_1d( npti, nptidx(1:npti), ato_i_1d(1:npti) , ato_i )
+ CALL tab_2d_1d( npti, nptidx(1:npti), zstrength(1:npti) , strength )
- CALL rdgrft_prep( a_i_2d, v_i_2d, ato_i_1d, closing_net )
+ CALL rdgrft_prep( a_i_2d, v_i_2d, ato_i_1d )
!
zaksum(1:npti) = apartf(1:npti,0) !clem: aksum should be defined in the header => local to module
DO jl = 1, jpl
@@ -956,21 +930,37 @@ CONTAINS
CALL tab_1d_2d( npti, nptidx(1:npti), zstrength(1:npti), strength )
!
ENDIF
+ CALL lbc_lnk( 'icedyn_rdgrft', strength, 'T', 1.0_wp ) ! this call could be removed if calculations were done on the full domain
+ ! ! but we decided it is more efficient this way
!
CASE ( np_strh79 ) !== Hibler(1979)'s method ==!
- strength(:,:) = rn_pstar * SUM( v_i(:,:,:), dim=3 ) * EXP( -rn_crhg * ( 1._wp - at_i(:,:) ) ) * zmsk(:,:)
+ !
+ DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ IF( at_i(ji,jj) > epsi10 ) THEN
+ strength(ji,jj) = rn_pstar * SUM( v_i(ji,jj,:) ) * EXP( -rn_crhg * ( 1._wp - at_i(ji,jj) ) )
+ ELSE
+ strength(ji,jj) = 0._wp
+ ENDIF
+ END_2D
!
CASE ( np_strcst ) !== Constant strength ==!
- strength(:,:) = rn_str * zmsk(:,:)
+ !
+ DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ IF( at_i(ji,jj) > epsi10 ) THEN
+ strength(ji,jj) = rn_str
+ ELSE
+ strength(ji,jj) = 0._wp
+ ENDIF
+ END_2D
!
END SELECT
!
IF( ln_str_smooth ) THEN !--- Spatial smoothing
DO_2D( 0, 0, 0, 0 )
- IF ( SUM( a_i(ji,jj,:) ) > 0._wp ) THEN
+ IF( at_i(ji,jj) > epsi10 ) THEN
zworka(ji,jj) = ( 4._wp * strength(ji,jj) &
- & + strength(ji-1,jj) * tmask(ji-1,jj,1) + strength(ji+1,jj) * tmask(ji+1,jj,1) &
- & + strength(ji,jj-1) * tmask(ji,jj-1,1) + strength(ji,jj+1) * tmask(ji,jj+1,1) &
+ & + ( ( strength(ji-1,jj) * tmask(ji-1,jj,1) + strength(ji+1,jj) * tmask(ji+1,jj,1) ) &
+ & + ( strength(ji,jj-1) * tmask(ji,jj-1,1) + strength(ji,jj+1) * tmask(ji,jj+1,1) ) ) &
& ) / ( 4._wp + tmask(ji-1,jj,1) + tmask(ji+1,jj,1) + tmask(ji,jj-1,1) + tmask(ji,jj+1,1) )
ELSE
zworka(ji,jj) = 0._wp
@@ -978,7 +968,7 @@ CONTAINS
END_2D
DO_2D( 0, 0, 0, 0 )
- strength(ji,jj) = zworka(ji,jj) * zmsk(ji,jj)
+ strength(ji,jj) = zworka(ji,jj)
END_2D
CALL lbc_lnk( 'icedyn_rdgrft', strength, 'T', 1.0_wp )
!
@@ -1007,22 +997,16 @@ CONTAINS
CALL tab_2d_1d( npti, nptidx(1:npti), sst_1d(1:npti), sst_m(:,:) )
! the following fields are modified in this routine
!!CALL tab_2d_1d( npti, nptidx(1:npti), ato_i_1d(1:npti), ato_i(:,:) )
- !!CALL tab_3d_2d( npti, nptidx(1:npti), a_i_2d(1:npti,1:jpl), a_i(:,:,:) )
- !!CALL tab_3d_2d( npti, nptidx(1:npti), v_i_2d (1:npti,1:jpl), v_i (:,:,:) )
- CALL tab_3d_2d( npti, nptidx(1:npti), v_s_2d (1:npti,1:jpl), v_s (:,:,:) )
- CALL tab_3d_2d( npti, nptidx(1:npti), sv_i_2d(1:npti,1:jpl), sv_i(:,:,:) )
- CALL tab_3d_2d( npti, nptidx(1:npti), oa_i_2d(1:npti,1:jpl), oa_i(:,:,:) )
- CALL tab_3d_2d( npti, nptidx(1:npti), a_ip_2d(1:npti,1:jpl), a_ip(:,:,:) )
- CALL tab_3d_2d( npti, nptidx(1:npti), v_ip_2d(1:npti,1:jpl), v_ip(:,:,:) )
- CALL tab_3d_2d( npti, nptidx(1:npti), v_il_2d(1:npti,1:jpl), v_il(:,:,:) )
- DO jl = 1, jpl
- DO jk = 1, nlay_s
- CALL tab_2d_1d( npti, nptidx(1:npti), ze_s_2d(1:npti,jk,jl), e_s(:,:,jk,jl) )
- END DO
- DO jk = 1, nlay_i
- CALL tab_2d_1d( npti, nptidx(1:npti), ze_i_2d(1:npti,jk,jl), e_i(:,:,jk,jl) )
- END DO
- END DO
+ !!CALL tab_3d_2d( npti, nptidx(1:npti), a_i_2d(1:npti,:), a_i(:,:,:) )
+ !!CALL tab_3d_2d( npti, nptidx(1:npti), v_i_2d (1:npti,:), v_i (:,:,:) )
+ CALL tab_3d_2d( npti, nptidx(1:npti), v_s_2d (1:npti,:) , v_s (:,:,:) )
+ CALL tab_3d_2d( npti, nptidx(1:npti), sv_i_2d(1:npti,:) , sv_i(:,:,:) )
+ CALL tab_3d_2d( npti, nptidx(1:npti), oa_i_2d(1:npti,:) , oa_i(:,:,:) )
+ CALL tab_3d_2d( npti, nptidx(1:npti), a_ip_2d(1:npti,:) , a_ip(:,:,:) )
+ CALL tab_3d_2d( npti, nptidx(1:npti), v_ip_2d(1:npti,:) , v_ip(:,:,:) )
+ CALL tab_3d_2d( npti, nptidx(1:npti), v_il_2d(1:npti,:) , v_il(:,:,:) )
+ CALL tab_4d_3d( npti, nptidx(1:npti), e_s_2d (1:npti,:,:), e_s )
+ CALL tab_4d_3d( npti, nptidx(1:npti), e_i_2d (1:npti,:,:), e_i )
CALL tab_2d_1d( npti, nptidx(1:npti), sfx_dyn_1d (1:npti), sfx_dyn (:,:) )
CALL tab_2d_1d( npti, nptidx(1:npti), sfx_bri_1d (1:npti), sfx_bri (:,:) )
CALL tab_2d_1d( npti, nptidx(1:npti), wfx_dyn_1d (1:npti), wfx_dyn (:,:) )
@@ -1033,23 +1017,17 @@ CONTAINS
! !---------------------!
CASE( 2 ) !== from 1D to 2D ==!
! !---------------------!
- CALL tab_1d_2d( npti, nptidx(1:npti), ato_i_1d(1:npti), ato_i(:,:) )
- CALL tab_2d_3d( npti, nptidx(1:npti), a_i_2d (1:npti,1:jpl), a_i (:,:,:) )
- CALL tab_2d_3d( npti, nptidx(1:npti), v_i_2d (1:npti,1:jpl), v_i (:,:,:) )
- CALL tab_2d_3d( npti, nptidx(1:npti), v_s_2d (1:npti,1:jpl), v_s (:,:,:) )
- CALL tab_2d_3d( npti, nptidx(1:npti), sv_i_2d(1:npti,1:jpl), sv_i(:,:,:) )
- CALL tab_2d_3d( npti, nptidx(1:npti), oa_i_2d(1:npti,1:jpl), oa_i(:,:,:) )
- CALL tab_2d_3d( npti, nptidx(1:npti), a_ip_2d(1:npti,1:jpl), a_ip(:,:,:) )
- CALL tab_2d_3d( npti, nptidx(1:npti), v_ip_2d(1:npti,1:jpl), v_ip(:,:,:) )
- CALL tab_2d_3d( npti, nptidx(1:npti), v_il_2d(1:npti,1:jpl), v_il(:,:,:) )
- DO jl = 1, jpl
- DO jk = 1, nlay_s
- CALL tab_1d_2d( npti, nptidx(1:npti), ze_s_2d(1:npti,jk,jl), e_s(:,:,jk,jl) )
- END DO
- DO jk = 1, nlay_i
- CALL tab_1d_2d( npti, nptidx(1:npti), ze_i_2d(1:npti,jk,jl), e_i(:,:,jk,jl) )
- END DO
- END DO
+ CALL tab_1d_2d( npti, nptidx(1:npti), ato_i_1d(1:npti) , ato_i(:,:) )
+ CALL tab_2d_3d( npti, nptidx(1:npti), a_i_2d (1:npti,:) , a_i (:,:,:) )
+ CALL tab_2d_3d( npti, nptidx(1:npti), v_i_2d (1:npti,:) , v_i (:,:,:) )
+ CALL tab_2d_3d( npti, nptidx(1:npti), v_s_2d (1:npti,:) , v_s (:,:,:) )
+ CALL tab_2d_3d( npti, nptidx(1:npti), sv_i_2d(1:npti,:) , sv_i(:,:,:) )
+ CALL tab_2d_3d( npti, nptidx(1:npti), oa_i_2d(1:npti,:) , oa_i(:,:,:) )
+ CALL tab_2d_3d( npti, nptidx(1:npti), a_ip_2d(1:npti,:) , a_ip(:,:,:) )
+ CALL tab_2d_3d( npti, nptidx(1:npti), v_ip_2d(1:npti,:) , v_ip(:,:,:) )
+ CALL tab_2d_3d( npti, nptidx(1:npti), v_il_2d(1:npti,:) , v_il(:,:,:) )
+ CALL tab_3d_4d( npti, nptidx(1:npti), e_s_2d (1:npti,:,:), e_s )
+ CALL tab_3d_4d( npti, nptidx(1:npti), e_i_2d (1:npti,:,:), e_i )
CALL tab_1d_2d( npti, nptidx(1:npti), sfx_dyn_1d (1:npti), sfx_dyn (:,:) )
CALL tab_1d_2d( npti, nptidx(1:npti), sfx_bri_1d (1:npti), sfx_bri (:,:) )
CALL tab_1d_2d( npti, nptidx(1:npti), wfx_dyn_1d (1:npti), wfx_dyn (:,:) )
@@ -1129,17 +1107,15 @@ CONTAINS
IF( ln_str_CST ) THEN ; ioptio = ioptio + 1 ; nice_str = np_strcst ; ENDIF
IF( ioptio /= 1 ) CALL ctl_stop( 'ice_dyn_rdgrft_init: one and only one ice strength option has to be defined ' )
!
- IF ( ( ln_str_H79 .AND. ln_str_R75 ) .OR. ( .NOT.ln_str_H79 .AND. .NOT.ln_str_R75 ) ) THEN
- CALL ctl_stop( 'ice_dyn_rdgrft_init: choose one and only one ice strength formulation (ln_str_H79 or ln_str_R75)' )
- ENDIF
- !
- IF ( ( ln_distf_lin .AND. ln_distf_exp ) .OR. ( .NOT.ln_distf_lin .AND. .NOT.ln_distf_exp ) ) THEN
- CALL ctl_stop( 'ice_dyn_rdgrft_init: choose one and only one redistribution function (ln_distf_lin or ln_distf_exp)' )
- ENDIF
+ ioptio = 0
+ IF( ln_distf_lin ) THEN ; ioptio = ioptio + 1 ; ENDIF
+ IF( ln_distf_exp ) THEN ; ioptio = ioptio + 1 ; ENDIF
+ IF( ioptio /= 1 ) CALL ctl_stop( 'ice_dyn_rdgrft_init: choose one and only one redistribution function (ln_distf_lin or ln_distf_exp)' )
!
- IF ( ( ln_partf_lin .AND. ln_partf_exp ) .OR. ( .NOT.ln_partf_lin .AND. .NOT.ln_partf_exp ) ) THEN
- CALL ctl_stop( 'ice_dyn_rdgrft_init: choose one and only one participation function (ln_partf_lin or ln_partf_exp)' )
- ENDIF
+ ioptio = 0
+ IF( ln_partf_lin ) THEN ; ioptio = ioptio + 1 ; ENDIF
+ IF( ln_partf_exp ) THEN ; ioptio = ioptio + 1 ; ENDIF
+ IF( ioptio /= 1 ) CALL ctl_stop( 'ice_dyn_rdgrft_init: choose one and only one participation function (ln_partf_lin or ln_partf_exp)' )
!
IF( .NOT. ln_icethd ) THEN
rn_porordg = 0._wp
diff --git a/src/ICE/icedyn_rhg_eap.F90 b/src/ICE/icedyn_rhg_eap.F90
index 2dcfc57595b72ea417470e89f16baeeae274f7f1..7ab1d2ccaa87405badb326ea43e27584fea3b3b0 100644
--- a/src/ICE/icedyn_rhg_eap.F90
+++ b/src/ICE/icedyn_rhg_eap.F90
@@ -125,12 +125,12 @@ CONTAINS
!! Bouillon et al., Ocean Modelling 2013
!! Kimmritz et al., Ocean Modelling 2016 & 2017
!!-------------------------------------------------------------------
- INTEGER , INTENT(in ) :: kt ! time step
- INTEGER , INTENT(in ) :: Kmm ! ocean time level index
- REAL(wp), DIMENSION(:,:), INTENT(inout) :: pstress1_i, pstress2_i, pstress12_i !
- REAL(wp), DIMENSION(:,:), INTENT( out) :: pshear_i , pdivu_i , pdelta_i !
- REAL(wp), DIMENSION(:,:), INTENT(inout) :: paniso_11 , paniso_12 ! structure tensor components
- REAL(wp), DIMENSION(:,:), INTENT(inout) :: prdg_conv ! for ridging
+ INTEGER , INTENT(in ) :: kt ! time step
+ INTEGER , INTENT(in ) :: Kmm ! ocean time level index
+ REAL(wp), DIMENSION(:,:) , INTENT(inout) :: pstress1_i, pstress2_i, pstress12_i !
+ REAL(wp), DIMENSION(A2D(0)), INTENT( out) :: pshear_i , pdivu_i , pdelta_i !
+ REAL(wp), DIMENSION(:,:) , INTENT(inout) :: paniso_11 , paniso_12 ! structure tensor components
+ REAL(wp), DIMENSION(:,:) , INTENT(inout) :: prdg_conv ! for ridging
!!
INTEGER :: ji, jj ! dummy loop indices
INTEGER :: jter ! local integers
@@ -148,15 +148,17 @@ CONTAINS
!
REAL(wp) :: zintb, zintn ! dummy argument
REAL(wp) :: zfac_x, zfac_y
- REAL(wp) :: zshear, zdum1, zdum2
+ REAL(wp) :: zdum1, zdum2
REAL(wp) :: zstressptmp, zstressmtmp, zstress12tmpF ! anisotropic stress tensor components
REAL(wp) :: zalphar, zalphas ! for mechanical redistribution
REAL(wp) :: zmresult11, zmresult12, z1dtevpkth, zp5kth, z1_dtevp_A ! for structure tensor evolution
!
+ REAL(wp) :: zswitch
+ !
REAL(wp), DIMENSION(jpi,jpj) :: zstress12tmp ! anisotropic stress tensor component for regridding
- REAL(wp), DIMENSION(jpi,jpj) :: zyield11, zyield22, zyield12 ! yield surface tensor for history
+ REAL(wp), DIMENSION(A2D(0)) :: zyield11, zyield22, zyield12 ! yield surface tensor for history
REAL(wp), DIMENSION(jpi,jpj) :: zdelta, zp_delt ! delta and P/delta at T points
- REAL(wp), DIMENSION(jpi,jpj) :: zten_i ! tension
+ REAL(wp), DIMENSION(A2D(0)) :: zten_i, zshear ! tension, shear
REAL(wp), DIMENSION(jpi,jpj) :: zbeta ! beta coef from Kimmritz 2017
!
REAL(wp), DIMENSION(jpi,jpj) :: zdt_m ! (dt / ice-snow_mass) on T points
@@ -178,7 +180,6 @@ CONTAINS
REAL(wp), DIMENSION(jpi,jpj) :: ztaux_bi, ztauy_bi ! ice-OceanBottom stress at U-V points (landfast)
REAL(wp), DIMENSION(jpi,jpj) :: ztaux_base, ztauy_base ! ice-bottom stress at U-V points (landfast)
!
- REAL(wp), DIMENSION(jpi,jpj) :: zmsk00, zmsk15
REAL(wp), DIMENSION(jpi,jpj) :: zmsk01x, zmsk01y ! dummy arrays
REAL(wp), DIMENSION(jpi,jpj) :: zmsk00x, zmsk00y ! mask for ice presence
@@ -186,7 +187,8 @@ CONTAINS
REAL(wp), PARAMETER :: zmmin = 1._wp ! ice mass (kg/m2) below which ice velocity becomes very small
REAL(wp), PARAMETER :: zamin = 0.001_wp ! ice concentration below which ice velocity becomes very small
!! --- check convergence
- REAL(wp), DIMENSION(jpi,jpj) :: zu_ice, zv_ice
+ REAL(wp), DIMENSION(A2D(0)) :: zmsk00, zmsk15
+ REAL(wp), DIMENSION(A2D(0)) :: zu_ice, zv_ice
!! --- diags
REAL(wp) :: zsig1, zsig2, zsig12, zfac, z1_strength
REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zsig_I, zsig_II, zsig1_p, zsig2_p
@@ -202,11 +204,11 @@ CONTAINS
IF( kt == nit000 .AND. lwp ) WRITE(numout,*) '-- ice_dyn_rhg_eap: EAP sea-ice rheology'
!
! for diagnostics and convergence tests
- DO_2D( 1, 1, 1, 1 )
+ DO_2D( 0, 0, 0, 0 )
zmsk00(ji,jj) = MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) - epsi06 ) ) ! 1 if ice , 0 if no ice
END_2D
IF( nn_rhg_chkcvg > 0 ) THEN
- DO_2D( 1, 1, 1, 1 )
+ DO_2D( 0, 0, 0, 0 )
zmsk15(ji,jj) = MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) - 0.15_wp ) ) ! 1 if 15% ice, 0 if less
END_2D
ENDIF
@@ -283,7 +285,14 @@ CONTAINS
! non-embedded sea ice: use ocean surface for slope calculation
zsshdyn(:,:) = ice_var_sshdyn( ssh_m, snwice_mass, snwice_mass_b)
- DO_2D( 0, 0, 0, 0 )
+ DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ zm1 = ( rhos * vt_s(ji,jj) + rhoi * vt_i(ji,jj) ) ! Ice/snow mass at U-V points
+!!$ zm1 = ( rhos * vt_s(ji,jj) + rhoi * vt_i(ji,jj) + rhow * (vt_ip(ji,jj) + vt_il(ji,jj)) ) ! clem: this should replace the above
+ zmf (ji,jj) = zm1 * ff_t(ji,jj) ! Coriolis at T points (m*f)
+ zdt_m(ji,jj) = zdtevp / MAX( zm1, zmmin ) ! dt/m at T points (for alpha and beta coefficients)
+ END_2D
+
+ DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 )
! ice fraction at U-V points
zaU(ji,jj) = 0.5_wp * ( at_i(ji,jj) * e1e2t(ji,jj) + at_i(ji+1,jj) * e1e2t(ji+1,jj) ) * r1_e1e2u(ji,jj) * umask(ji,jj,1)
@@ -291,28 +300,29 @@ CONTAINS
! Ice/snow mass at U-V points
zm1 = ( rhos * vt_s(ji ,jj ) + rhoi * vt_i(ji ,jj ) )
+!!$ zm1 = ( rhos * vt_s(ji ,jj ) + rhoi * vt_i(ji ,jj ) + rhow * (vt_ip(ji ,jj ) + vt_il(ji ,jj )) ) ! clem: this should replace the above
zm2 = ( rhos * vt_s(ji+1,jj ) + rhoi * vt_i(ji+1,jj ) )
+!!$ zm2 = ( rhos * vt_s(ji+1,jj ) + rhoi * vt_i(ji+1,jj ) + rhow * (vt_ip(ji+1,jj ) + vt_il(ji+1,jj )) ) ! clem: this should replace the above
zm3 = ( rhos * vt_s(ji ,jj+1) + rhoi * vt_i(ji ,jj+1) )
+!!$ zm3 = ( rhos * vt_s(ji ,jj+1) + rhoi * vt_i(ji ,jj+1) + rhow * (vt_ip(ji ,jj+1) + vt_il(ji ,jj+1)) ) ! clem: this should replace the above
zmassU = 0.5_wp * ( zm1 * e1e2t(ji,jj) + zm2 * e1e2t(ji+1,jj) ) * r1_e1e2u(ji,jj) * umask(ji,jj,1)
zmassV = 0.5_wp * ( zm1 * e1e2t(ji,jj) + zm3 * e1e2t(ji,jj+1) ) * r1_e1e2v(ji,jj) * vmask(ji,jj,1)
- ! Ocean currents at U-V points
- v_oceU(ji,jj) = 0.25_wp * ( v_oce(ji,jj) + v_oce(ji,jj-1) + v_oce(ji+1,jj) + v_oce(ji+1,jj-1) ) * umask(ji,jj,1)
- u_oceV(ji,jj) = 0.25_wp * ( u_oce(ji,jj) + u_oce(ji-1,jj) + u_oce(ji,jj+1) + u_oce(ji-1,jj+1) ) * vmask(ji,jj,1)
-
- ! Coriolis at T points (m*f)
- zmf(ji,jj) = zm1 * ff_t(ji,jj)
-
- ! dt/m at T points (for alpha and beta coefficients)
- zdt_m(ji,jj) = zdtevp / MAX( zm1, zmmin )
+ ! Ocean currents at U-V point, warning: add () for the North Pole reproducibility
+ v_oceU(ji,jj) = 0.25_wp * ( ( v_oce(ji,jj) + v_oce(ji,jj-1) ) + ( v_oce(ji+1,jj) + v_oce(ji+1,jj-1) ) ) * umask(ji,jj,1)
+ u_oceV(ji,jj) = 0.25_wp * ( ( u_oce(ji,jj) + u_oce(ji-1,jj) ) + ( u_oce(ji,jj+1) + u_oce(ji-1,jj+1) ) ) * vmask(ji,jj,1)
! m/dt
zmU_t(ji,jj) = zmassU * z1_dtevp
zmV_t(ji,jj) = zmassV * z1_dtevp
! Drag ice-atm.
- ztaux_ai(ji,jj) = zaU(ji,jj) * utau_ice(ji,jj)
- ztauy_ai(ji,jj) = zaV(ji,jj) * vtau_ice(ji,jj)
+ ! Note the use of 0.5*(2-umask) in order to unmask the stress along coastlines
+ ! and the use of MAX(tmask(i,j),tmask(i+1,j) is to mask tau over ice shelves
+ ztaux_ai(ji,jj) = zaU(ji,jj) * 0.5_wp * ( utau_ice(ji,jj) + utau_ice(ji+1,jj) ) * &
+ & ( 2. - umask(ji,jj,1) ) * MAX( tmask(ji,jj,1), tmask(ji+1,jj,1) )
+ ztauy_ai(ji,jj) = zaV(ji,jj) * 0.5_wp * ( vtau_ice(ji,jj) + vtau_ice(ji,jj+1) ) * &
+ & ( 2. - vmask(ji,jj,1) ) * MAX( tmask(ji,jj,1), tmask(ji,jj+1,1) )
! Surface pressure gradient (- m*g*GRAD(ssh)) at U-V points
zspgU(ji,jj) = - zmassU * grav * ( zsshdyn(ji+1,jj) - zsshdyn(ji,jj) ) * r1_e1u(ji,jj)
@@ -329,12 +339,11 @@ CONTAINS
ELSE ; zmsk01y(ji,jj) = 1._wp ; ENDIF
END_2D
- CALL lbc_lnk( 'icedyn_rhg_eap', zmf, 'T', 1.0_wp, zdt_m, 'T', 1.0_wp )
!
! !== Landfast ice parameterization ==!
!
IF( ln_landfast_L16 ) THEN !-- Lemieux 2016
- DO_2D( 0, 0, 0, 0 )
+ DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 )
! ice thickness at U-V points
zvU = 0.5_wp * ( vt_i(ji,jj) * e1e2t(ji,jj) + vt_i(ji+1,jj) * e1e2t(ji+1,jj) ) * r1_e1e2u(ji,jj) * umask(ji,jj,1)
zvV = 0.5_wp * ( vt_i(ji,jj) * e1e2t(ji,jj) + vt_i(ji,jj+1) * e1e2t(ji,jj+1) ) * r1_e1e2v(ji,jj) * vmask(ji,jj,1)
@@ -345,13 +354,12 @@ CONTAINS
zvCr = zaV(ji,jj) * rn_lf_depfra * hv(ji,jj,Kmm) * ( 1._wp - icb_mask(ji,jj) ) ! if grounded icebergs are read: ocean depth = 0
ztauy_base(ji,jj) = - rn_lf_bfr * MAX( 0._wp, zvV - zvCr ) * EXP( -rn_crhg * ( 1._wp - zaV(ji,jj) ) )
! ice_bottom stress at T points
- zvCr = at_i(ji,jj) * rn_lf_depfra * ht(ji,jj) * ( 1._wp - icb_mask(ji,jj) ) ! if grounded icebergs are read: ocean depth = 0
+ zvCr = at_i(ji,jj) * rn_lf_depfra * ht(ji,jj,Kmm) * ( 1._wp - icb_mask(ji,jj) ) ! if grounded icebergs are read: ocean depth = 0
tau_icebfr(ji,jj) = - rn_lf_bfr * MAX( 0._wp, vt_i(ji,jj) - zvCr ) * EXP( -rn_crhg * ( 1._wp - at_i(ji,jj) ) )
END_2D
- CALL lbc_lnk( 'icedyn_rhg_eap', tau_icebfr(:,:), 'T', 1.0_wp )
!
ELSE !-- no landfast
- DO_2D( 0, 0, 0, 0 )
+ DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 )
ztaux_base(ji,jj) = 0._wp
ztauy_base(ji,jj) = 0._wp
END_2D
@@ -364,18 +372,16 @@ CONTAINS
! ! ==================== !
DO jter = 1 , nn_nevp ! loop over jter !
! ! ==================== !
- l_full_nf_update = jter == nn_nevp ! false: disable full North fold update (performances) for iter = 1 to nn_nevp-1
- !
! convergence test
IF( nn_rhg_chkcvg == 1 .OR. nn_rhg_chkcvg == 2 ) THEN
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
zu_ice(ji,jj) = u_ice(ji,jj) * umask(ji,jj,1) ! velocity at previous time step
zv_ice(ji,jj) = v_ice(ji,jj) * vmask(ji,jj,1)
END_2D
ENDIF
! --- divergence, tension & shear (Appendix B of Hunke & Dukowicz, 2002) --- !
- DO_2D( 1, 0, 1, 0 )
+ DO_2D( nn_hls, nn_hls-1, nn_hls, nn_hls-1 )
! shear at F points
zds(ji,jj) = ( ( u_ice(ji,jj+1) * r1_e1u(ji,jj+1) - u_ice(ji,jj) * r1_e1u(ji,jj) ) * e1f(ji,jj) * e1f(ji,jj) &
@@ -386,14 +392,14 @@ CONTAINS
DO_2D( 0, 0, 0, 0 )
- ! shear**2 at T points (doc eq. A16)
- zds2 = ( zds(ji,jj ) * zds(ji,jj ) * e1e2f(ji,jj ) + zds(ji-1,jj ) * zds(ji-1,jj ) * e1e2f(ji-1,jj ) &
- & + zds(ji,jj-1) * zds(ji,jj-1) * e1e2f(ji,jj-1) + zds(ji-1,jj-1) * zds(ji-1,jj-1) * e1e2f(ji-1,jj-1) &
+ ! shear**2 at T points (doc eq. A16), warning: add () for the North Pole reproducibility
+ zds2 = ( ( zds(ji,jj ) * zds(ji,jj ) * e1e2f(ji,jj ) + zds(ji-1,jj ) * zds(ji-1,jj ) * e1e2f(ji-1,jj ) ) &
+ & + ( zds(ji,jj-1) * zds(ji,jj-1) * e1e2f(ji,jj-1) + zds(ji-1,jj-1) * zds(ji-1,jj-1) * e1e2f(ji-1,jj-1) ) &
& ) * 0.25_wp * r1_e1e2t(ji,jj)
- ! divergence at T points
- zdiv = ( e2u(ji,jj) * u_ice(ji,jj) - e2u(ji-1,jj) * u_ice(ji-1,jj) &
- & + e1v(ji,jj) * v_ice(ji,jj) - e1v(ji,jj-1) * v_ice(ji,jj-1) &
+ ! divergence at T points, warning: add () for the North Pole reproducibility
+ zdiv = ( ( e2u(ji,jj) * u_ice(ji,jj) - e2u(ji-1,jj) * u_ice(ji-1,jj) ) &
+ & + ( e1v(ji,jj) * v_ice(ji,jj) - e1v(ji,jj-1) * v_ice(ji,jj-1) ) &
& ) * r1_e1e2t(ji,jj)
zdiv2 = zdiv * zdiv
@@ -406,24 +412,22 @@ CONTAINS
! delta at T points
zdelta(ji,jj) = SQRT( zdiv2 + ( zdt2 + zds2 ) * z1_ecc2 )
- END_2D
- CALL lbc_lnk( 'icedyn_rhg_eap', zdelta, 'T', 1.0_wp )
-
- ! P/delta at T points
- DO_2D( 1, 1, 1, 1 )
+ ! P/delta at T points
zp_delt(ji,jj) = strength(ji,jj) / ( zdelta(ji,jj) + rn_creepl )
+
END_2D
+ CALL lbc_lnk( 'icedyn_rhg_eap', zdelta, 'T', 1.0_wp, zp_delt, 'T', 1.0_wp )
- DO_2D( 0, 1, 0, 1 ) ! loop ends at jpi,jpj so that no lbc_lnk are needed for zs1 and zs2
+ DO_2D( 0, 0, 0, 0 )
- ! shear at T points
- zdsT = ( zds(ji,jj ) * e1e2f(ji,jj ) + zds(ji-1,jj ) * e1e2f(ji-1,jj ) &
- & + zds(ji,jj-1) * e1e2f(ji,jj-1) + zds(ji-1,jj-1) * e1e2f(ji-1,jj-1) &
+ ! shear at T points, warning: add () for the North Pole reproducibility
+ zdsT = ( ( zds(ji,jj ) * e1e2f(ji,jj ) + zds(ji-1,jj ) * e1e2f(ji-1,jj ) ) &
+ & + ( zds(ji,jj-1) * e1e2f(ji,jj-1) + zds(ji-1,jj-1) * e1e2f(ji-1,jj-1) ) &
& ) * 0.25_wp * r1_e1e2t(ji,jj)
- ! divergence at T points (duplication to avoid communications)
- zdiv = ( e2u(ji,jj) * u_ice(ji,jj) - e2u(ji-1,jj) * u_ice(ji-1,jj) &
- & + e1v(ji,jj) * v_ice(ji,jj) - e1v(ji,jj-1) * v_ice(ji,jj-1) &
+ ! divergence at T points (duplication to avoid communications), warning: add () for the North Pole reproducibility
+ zdiv = ( ( e2u(ji,jj) * u_ice(ji,jj) - e2u(ji-1,jj) * u_ice(ji-1,jj) ) &
+ & + ( e1v(ji,jj) * v_ice(ji,jj) - e1v(ji,jj-1) * v_ice(ji,jj-1) ) &
& ) * r1_e1e2t(ji,jj)
! tension at T points (duplication to avoid communications)
@@ -467,16 +471,17 @@ CONTAINS
zs1(ji,jj) = ( zs1(ji,jj) * zalph1 + zstressptmp ) * z1_alph1
zs2(ji,jj) = ( zs2(ji,jj) * zalph1 + zstressmtmp ) * z1_alph1
END_2D
- CALL lbc_lnk( 'icedyn_rhg_eap', zstress12tmp, 'T', 1.0_wp , paniso_11, 'T', 1.0_wp , paniso_12, 'T', 1.0_wp)
+ CALL lbc_lnk( 'icedyn_rhg_eap', zstress12tmp, 'T', 1.0_wp , paniso_11, 'T', 1.0_wp , paniso_12, 'T', 1.0_wp, &
+ & zs1, 'T', 1.0_wp, zs2, 'T', 1.0_wp )
! Save beta at T-points for further computations
IF( ln_aEVP ) THEN
- DO_2D( 1, 1, 1, 1 )
+ DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
zbeta(ji,jj) = MAX( 50._wp, rpi * SQRT( 0.5_wp * zp_delt(ji,jj) * r1_e1e2t(ji,jj) * zdt_m(ji,jj) ) )
END_2D
ENDIF
- DO_2D( 1, 0, 1, 0 )
+ DO_2D( nn_hls, nn_hls-1, nn_hls, nn_hls-1 )
! stress12tmp at F points
zstress12tmpF = ( zstress12tmp(ji,jj+1) * e1e2t(ji,jj+1) + zstress12tmp(ji+1,jj+1) * e1e2t(ji+1,jj+1) &
& + zstress12tmp(ji,jj ) * e1e2t(ji,jj ) + zstress12tmp(ji+1,jj ) * e1e2t(ji+1,jj ) &
@@ -495,10 +500,9 @@ CONTAINS
zs12(ji,jj) = ( zs12(ji,jj) * zalph1 + zstress12tmpF ) * z1_alph1
END_2D
- CALL lbc_lnk( 'icedyn_rhg_eap', zs1, 'T', 1.0_wp, zs2, 'T', 1.0_wp, zs12, 'F', 1.0_wp )
! --- Ice internal stresses (Appendix C of Hunke and Dukowicz, 2002) --- !
- DO_2D( 0, 0, 0, 0 )
+ DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 )
! !--- U points
zfU(ji,jj) = 0.5_wp * ( ( zs1(ji+1,jj) - zs1(ji,jj) ) * e2u(ji,jj) &
& + ( zs2(ji+1,jj) * e2t(ji+1,jj) * e2t(ji+1,jj) - zs2(ji,jj) * e2t(ji,jj) * e2t(ji,jj) &
@@ -526,7 +530,7 @@ CONTAINS
! Bouillon et al. 2009 (eq 34-35) => stable
IF( MOD(jter,2) == 0 ) THEN ! even iterations
!
- DO_2D( 0, 0, 0, 0 )
+ DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 )
! !--- tau_io/(v_oce - v_ice)
zTauO = zaV(ji,jj) * zrhoco * SQRT( ( v_ice (ji,jj) - v_oce (ji,jj) ) * ( v_ice (ji,jj) - v_oce (ji,jj) ) &
& + ( u_iceV(ji,jj) - u_oceV(ji,jj) ) * ( u_iceV(ji,jj) - u_oceV(ji,jj) ) )
@@ -549,34 +553,28 @@ CONTAINS
!
! !--- landfast switch => 0 = static friction : TauB > RHS & sign(TauB) /= sign(RHS)
! 1 = sliding friction : TauB < RHS
- rswitch = 1._wp - MIN( 1._wp, ABS( SIGN( 1._wp, zRHS + ztauy_base(ji,jj) ) - SIGN( 1._wp, zRHS ) ) )
+ zswitch = 1._wp - MIN( 1._wp, ABS( SIGN( 1._wp, zRHS + ztauy_base(ji,jj) ) - SIGN( 1._wp, zRHS ) ) )
!
IF( ln_aEVP ) THEN !--- ice velocity using aEVP (Kimmritz et al 2016 & 2017)
zbetav = MAX( zbeta(ji,jj), zbeta(ji,jj+1) )
- v_ice(ji,jj) = ( ( rswitch * ( zmV_t(ji,jj) * ( zbetav * v_ice(ji,jj) + v_ice_b(ji,jj) ) & ! previous velocity
+ v_ice(ji,jj) = ( ( zswitch * ( zmV_t(ji,jj) * ( zbetav * v_ice(ji,jj) + v_ice_b(ji,jj) ) & ! previous velocity
& + zRHS + zTauO * v_ice(ji,jj) & ! F + tau_ia + Coriolis + spg + tau_io(only ocean part)
& ) / MAX( zepsi, zmV_t(ji,jj) * ( zbetav + 1._wp ) + zTauO - zTauB ) & ! m/dt + tau_io(only ice part) + landfast
- & + ( 1._wp - rswitch ) * ( v_ice_b(ji,jj) &
+ & + ( 1._wp - zswitch ) * ( v_ice_b(ji,jj) &
& + v_ice (ji,jj) * MAX( 0._wp, zbetav - zdtevp * rn_lf_relax ) & ! static friction => slow decrease to v=0
& ) / ( zbetav + 1._wp ) &
& ) * zmsk01y(ji,jj) + v_oce(ji,jj) * 0.01_wp * ( 1._wp - zmsk01y(ji,jj) ) & ! v_ice = v_oce/100 if mass < zmmin & conc < zamin
& ) * zmsk00y(ji,jj)
ELSE !--- ice velocity using EVP implicit formulation (cf Madec doc & Bouillon 2009)
- v_ice(ji,jj) = ( ( rswitch * ( zmV_t(ji,jj) * v_ice(ji,jj) & ! previous velocity
+ v_ice(ji,jj) = ( ( zswitch * ( zmV_t(ji,jj) * v_ice(ji,jj) & ! previous velocity
& + zRHS + zTauO * v_ice(ji,jj) & ! F + tau_ia + Coriolis + spg + tau_io(only ocean part)
& ) / MAX( zepsi, zmV_t(ji,jj) + zTauO - zTauB ) & ! m/dt + tau_io(only ice part) + landfast
- & + ( 1._wp - rswitch ) * v_ice(ji,jj) * MAX( 0._wp, 1._wp - zdtevp * rn_lf_relax ) & ! static friction => slow decrease to v=0
+ & + ( 1._wp - zswitch ) * v_ice(ji,jj) * MAX( 0._wp, 1._wp - zdtevp * rn_lf_relax ) & ! static friction => slow decrease to v=0
& ) * zmsk01y(ji,jj) + v_oce(ji,jj) * 0.01_wp * ( 1._wp - zmsk01y(ji,jj) ) & ! v_ice = v_oce/100 if mass < zmmin & conc < zamin
& ) * zmsk00y(ji,jj)
ENDIF
END_2D
- CALL lbc_lnk( 'icedyn_rhg_eap', v_ice, 'V', -1.0_wp )
- !
-#if defined key_agrif
-!! CALL agrif_interp_ice( 'V', jter, nn_nevp )
- CALL agrif_interp_ice( 'V' )
-#endif
- IF( ln_bdy ) CALL bdy_ice_dyn( 'V' )
+ IF( nn_hls == 1 ) CALL lbc_lnk( 'icedyn_rhg_eap', v_ice, 'V', -1.0_wp )
!
DO_2D( 0, 0, 0, 0 )
! !--- tau_io/(u_oce - u_ice)
@@ -601,38 +599,34 @@ CONTAINS
!
! !--- landfast switch => 0 = static friction : TauB > RHS & sign(TauB) /= sign(RHS)
! 1 = sliding friction : TauB < RHS
- rswitch = 1._wp - MIN( 1._wp, ABS( SIGN( 1._wp, zRHS + ztaux_base(ji,jj) ) - SIGN( 1._wp, zRHS ) ) )
+ zswitch = 1._wp - MIN( 1._wp, ABS( SIGN( 1._wp, zRHS + ztaux_base(ji,jj) ) - SIGN( 1._wp, zRHS ) ) )
!
IF( ln_aEVP ) THEN !--- ice velocity using aEVP (Kimmritz et al 2016 & 2017)
zbetau = MAX( zbeta(ji,jj), zbeta(ji+1,jj) )
- u_ice(ji,jj) = ( ( rswitch * ( zmU_t(ji,jj) * ( zbetau * u_ice(ji,jj) + u_ice_b(ji,jj) ) & ! previous velocity
+ u_ice(ji,jj) = ( ( zswitch * ( zmU_t(ji,jj) * ( zbetau * u_ice(ji,jj) + u_ice_b(ji,jj) ) & ! previous velocity
& + zRHS + zTauO * u_ice(ji,jj) & ! F + tau_ia + Coriolis + spg + tau_io(only ocean part)
& ) / MAX( zepsi, zmU_t(ji,jj) * ( zbetau + 1._wp ) + zTauO - zTauB ) & ! m/dt + tau_io(only ice part) + landfast
- & + ( 1._wp - rswitch ) * ( u_ice_b(ji,jj) &
+ & + ( 1._wp - zswitch ) * ( u_ice_b(ji,jj) &
& + u_ice (ji,jj) * MAX( 0._wp, zbetau - zdtevp * rn_lf_relax ) & ! static friction => slow decrease to v=0
& ) / ( zbetau + 1._wp ) &
& ) * zmsk01x(ji,jj) + u_oce(ji,jj) * 0.01_wp * ( 1._wp - zmsk01x(ji,jj) ) & ! v_ice = v_oce/100 if mass < zmmin & conc < zamin
& ) * zmsk00x(ji,jj)
ELSE !--- ice velocity using EVP implicit formulation (cf Madec doc & Bouillon 2009)
- u_ice(ji,jj) = ( ( rswitch * ( zmU_t(ji,jj) * u_ice(ji,jj) & ! previous velocity
+ u_ice(ji,jj) = ( ( zswitch * ( zmU_t(ji,jj) * u_ice(ji,jj) & ! previous velocity
& + zRHS + zTauO * u_ice(ji,jj) & ! F + tau_ia + Coriolis + spg + tau_io(only ocean part)
& ) / MAX( zepsi, zmU_t(ji,jj) + zTauO - zTauB ) & ! m/dt + tau_io(only ice part) + landfast
- & + ( 1._wp - rswitch ) * u_ice(ji,jj) * MAX( 0._wp, 1._wp - zdtevp * rn_lf_relax ) & ! static friction => slow decrease to v=0
+ & + ( 1._wp - zswitch ) * u_ice(ji,jj) * MAX( 0._wp, 1._wp - zdtevp * rn_lf_relax ) & ! static friction => slow decrease to v=0
& ) * zmsk01x(ji,jj) + u_oce(ji,jj) * 0.01_wp * ( 1._wp - zmsk01x(ji,jj) ) & ! v_ice = v_oce/100 if mass < zmmin & conc < zamin
& ) * zmsk00x(ji,jj)
ENDIF
END_2D
- CALL lbc_lnk( 'icedyn_rhg_eap', u_ice, 'U', -1.0_wp )
- !
-#if defined key_agrif
-!! CALL agrif_interp_ice( 'U', jter, nn_nevp )
- CALL agrif_interp_ice( 'U' )
-#endif
- IF( ln_bdy ) CALL bdy_ice_dyn( 'U' )
+ IF( nn_hls == 1 ) THEN ; CALL lbc_lnk( 'icedyn_rhg_eap', u_ice, 'U', -1.0_wp )
+ ELSE ; CALL lbc_lnk( 'icedyn_rhg_eap', u_ice, 'U', -1.0_wp, v_ice, 'V', -1.0_wp )
+ ENDIF
!
ELSE ! odd iterations
!
- DO_2D( 0, 0, 0, 0 )
+ DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 )
! !--- tau_io/(u_oce - u_ice)
zTauO = zaU(ji,jj) * zrhoco * SQRT( ( u_ice (ji,jj) - u_oce (ji,jj) ) * ( u_ice (ji,jj) - u_oce (ji,jj) ) &
& + ( v_iceU(ji,jj) - v_oceU(ji,jj) ) * ( v_iceU(ji,jj) - v_oceU(ji,jj) ) )
@@ -655,34 +649,28 @@ CONTAINS
!
! !--- landfast switch => 0 = static friction : TauB > RHS & sign(TauB) /= sign(RHS)
! 1 = sliding friction : TauB < RHS
- rswitch = 1._wp - MIN( 1._wp, ABS( SIGN( 1._wp, zRHS + ztaux_base(ji,jj) ) - SIGN( 1._wp, zRHS ) ) )
+ zswitch = 1._wp - MIN( 1._wp, ABS( SIGN( 1._wp, zRHS + ztaux_base(ji,jj) ) - SIGN( 1._wp, zRHS ) ) )
!
IF( ln_aEVP ) THEN !--- ice velocity using aEVP (Kimmritz et al 2016 & 2017)
zbetau = MAX( zbeta(ji,jj), zbeta(ji+1,jj) )
- u_ice(ji,jj) = ( ( rswitch * ( zmU_t(ji,jj) * ( zbetau * u_ice(ji,jj) + u_ice_b(ji,jj) ) & ! previous velocity
+ u_ice(ji,jj) = ( ( zswitch * ( zmU_t(ji,jj) * ( zbetau * u_ice(ji,jj) + u_ice_b(ji,jj) ) & ! previous velocity
& + zRHS + zTauO * u_ice(ji,jj) & ! F + tau_ia + Coriolis + spg + tau_io(only ocean part)
& ) / MAX( zepsi, zmU_t(ji,jj) * ( zbetau + 1._wp ) + zTauO - zTauB ) & ! m/dt + tau_io(only ice part) + landfast
- & + ( 1._wp - rswitch ) * ( u_ice_b(ji,jj) &
+ & + ( 1._wp - zswitch ) * ( u_ice_b(ji,jj) &
& + u_ice (ji,jj) * MAX( 0._wp, zbetau - zdtevp * rn_lf_relax ) & ! static friction => slow decrease to v=0
& ) / ( zbetau + 1._wp ) &
& ) * zmsk01x(ji,jj) + u_oce(ji,jj) * 0.01_wp * ( 1._wp - zmsk01x(ji,jj) ) & ! v_ice = v_oce/100 if mass < zmmin & conc < zamin
& ) * zmsk00x(ji,jj)
ELSE !--- ice velocity using EVP implicit formulation (cf Madec doc & Bouillon 2009)
- u_ice(ji,jj) = ( ( rswitch * ( zmU_t(ji,jj) * u_ice(ji,jj) & ! previous velocity
+ u_ice(ji,jj) = ( ( zswitch * ( zmU_t(ji,jj) * u_ice(ji,jj) & ! previous velocity
& + zRHS + zTauO * u_ice(ji,jj) & ! F + tau_ia + Coriolis + spg + tau_io(only ocean part)
& ) / MAX( zepsi, zmU_t(ji,jj) + zTauO - zTauB ) & ! m/dt + tau_io(only ice part) + landfast
- & + ( 1._wp - rswitch ) * u_ice(ji,jj) * MAX( 0._wp, 1._wp - zdtevp * rn_lf_relax ) & ! static friction => slow decrease to v=0
+ & + ( 1._wp - zswitch ) * u_ice(ji,jj) * MAX( 0._wp, 1._wp - zdtevp * rn_lf_relax ) & ! static friction => slow decrease to v=0
& ) * zmsk01x(ji,jj) + u_oce(ji,jj) * 0.01_wp * ( 1._wp - zmsk01x(ji,jj) ) & ! v_ice = v_oce/100 if mass < zmmin & conc < zamin
& ) * zmsk00x(ji,jj)
ENDIF
END_2D
- CALL lbc_lnk( 'icedyn_rhg_eap', u_ice, 'U', -1.0_wp )
- !
-#if defined key_agrif
-!! CALL agrif_interp_ice( 'U', jter, nn_nevp )
- CALL agrif_interp_ice( 'U' )
-#endif
- IF( ln_bdy ) CALL bdy_ice_dyn( 'U' )
+ IF( nn_hls == 1 ) CALL lbc_lnk( 'icedyn_rhg_eap', u_ice, 'U', -1.0_wp )
!
DO_2D( 0, 0, 0, 0 )
! !--- tau_io/(v_oce - v_ice)
@@ -707,36 +695,40 @@ CONTAINS
!
! !--- landfast switch => 0 = static friction : TauB > RHS & sign(TauB) /= sign(RHS)
! 1 = sliding friction : TauB < RHS
- rswitch = 1._wp - MIN( 1._wp, ABS( SIGN( 1._wp, zRHS + ztauy_base(ji,jj) ) - SIGN( 1._wp, zRHS ) ) )
+ zswitch = 1._wp - MIN( 1._wp, ABS( SIGN( 1._wp, zRHS + ztauy_base(ji,jj) ) - SIGN( 1._wp, zRHS ) ) )
!
IF( ln_aEVP ) THEN !--- ice velocity using aEVP (Kimmritz et al 2016 & 2017)
zbetav = MAX( zbeta(ji,jj), zbeta(ji,jj+1) )
- v_ice(ji,jj) = ( ( rswitch * ( zmV_t(ji,jj) * ( zbetav * v_ice(ji,jj) + v_ice_b(ji,jj) ) & ! previous velocity
+ v_ice(ji,jj) = ( ( zswitch * ( zmV_t(ji,jj) * ( zbetav * v_ice(ji,jj) + v_ice_b(ji,jj) ) & ! previous velocity
& + zRHS + zTauO * v_ice(ji,jj) & ! F + tau_ia + Coriolis + spg + tau_io(only ocean part)
& ) / MAX( zepsi, zmV_t(ji,jj) * ( zbetav + 1._wp ) + zTauO - zTauB ) & ! m/dt + tau_io(only ice part) + landfast
- & + ( 1._wp - rswitch ) * ( v_ice_b(ji,jj) &
+ & + ( 1._wp - zswitch ) * ( v_ice_b(ji,jj) &
& + v_ice (ji,jj) * MAX( 0._wp, zbetav - zdtevp * rn_lf_relax ) & ! static friction => slow decrease to v=0
& ) / ( zbetav + 1._wp ) &
& ) * zmsk01y(ji,jj) + v_oce(ji,jj) * 0.01_wp * ( 1._wp - zmsk01y(ji,jj) ) & ! v_ice = v_oce/100 if mass < zmmin & conc < zamin
& ) * zmsk00y(ji,jj)
ELSE !--- ice velocity using EVP implicit formulation (cf Madec doc & Bouillon 2009)
- v_ice(ji,jj) = ( ( rswitch * ( zmV_t(ji,jj) * v_ice(ji,jj) & ! previous velocity
+ v_ice(ji,jj) = ( ( zswitch * ( zmV_t(ji,jj) * v_ice(ji,jj) & ! previous velocity
& + zRHS + zTauO * v_ice(ji,jj) & ! F + tau_ia + Coriolis + spg + tau_io(only ocean part)
& ) / MAX( zepsi, zmV_t(ji,jj) + zTauO - zTauB ) & ! m/dt + tau_io(only ice part) + landfast
- & + ( 1._wp - rswitch ) * v_ice(ji,jj) * MAX( 0._wp, 1._wp - zdtevp * rn_lf_relax ) & ! static friction => slow decrease to v=0
+ & + ( 1._wp - zswitch ) * v_ice(ji,jj) * MAX( 0._wp, 1._wp - zdtevp * rn_lf_relax ) & ! static friction => slow decrease to v=0
& ) * zmsk01y(ji,jj) + v_oce(ji,jj) * 0.01_wp * ( 1._wp - zmsk01y(ji,jj) ) & ! v_ice = v_oce/100 if mass < zmmin & conc < zamin
& ) * zmsk00y(ji,jj)
ENDIF
END_2D
- CALL lbc_lnk( 'icedyn_rhg_eap', v_ice, 'V', -1.0_wp )
+ IF( nn_hls == 1 ) THEN ; CALL lbc_lnk( 'icedyn_rhg_eap', v_ice, 'V', -1.0_wp )
+ ELSE ; CALL lbc_lnk( 'icedyn_rhg_eap', u_ice, 'U', -1.0_wp, v_ice, 'V', -1.0_wp )
+ ENDIF
!
+ ENDIF
#if defined key_agrif
-!! CALL agrif_interp_ice( 'V', jter, nn_nevp )
- CALL agrif_interp_ice( 'V' )
+!! CALL agrif_interp_ice( 'U', jter, nn_nevp )
+!! CALL agrif_interp_ice( 'V', jter, nn_nevp )
+ CALL agrif_interp_ice( 'U' )
+ CALL agrif_interp_ice( 'V' )
#endif
- IF( ln_bdy ) CALL bdy_ice_dyn( 'V' )
- !
- ENDIF
+ IF( ln_bdy ) CALL bdy_ice_dyn( 'U' )
+ IF( ln_bdy ) CALL bdy_ice_dyn( 'V' )
! convergence test
IF( nn_rhg_chkcvg == 2 ) CALL rhg_cvg_eap( kt, jter, nn_nevp, u_ice, v_ice, zu_ice, zv_ice, zmsk15 )
@@ -751,7 +743,7 @@ CONTAINS
!------------------------------------------------------------------------------!
! 4) Recompute delta, shear and div (inputs for mechanical redistribution)
!------------------------------------------------------------------------------!
- DO_2D( 1, 0, 1, 0 )
+ DO_2D( nn_hls, nn_hls-1, nn_hls, nn_hls-1 )
! shear at F points
zds(ji,jj) = ( ( u_ice(ji,jj+1) * r1_e1u(ji,jj+1) - u_ice(ji,jj) * r1_e1u(ji,jj) ) * e1f(ji,jj) * e1f(ji,jj) &
@@ -770,27 +762,35 @@ CONTAINS
zten_i(ji,jj) = zdt
- ! shear**2 at T points (doc eq. A16)
- zds2 = ( zds(ji,jj ) * zds(ji,jj ) * e1e2f(ji,jj ) + zds(ji-1,jj ) * zds(ji-1,jj ) * e1e2f(ji-1,jj ) &
- & + zds(ji,jj-1) * zds(ji,jj-1) * e1e2f(ji,jj-1) + zds(ji-1,jj-1) * zds(ji-1,jj-1) * e1e2f(ji-1,jj-1) &
+ ! shear**2 at T points (doc eq. A16), warning: add () for the North Pole reproducibility
+ zds2 = ( ( zds(ji,jj ) * zds(ji,jj ) * e1e2f(ji,jj ) + zds(ji-1,jj ) * zds(ji-1,jj ) * e1e2f(ji-1,jj ) ) &
+ & + ( zds(ji,jj-1) * zds(ji,jj-1) * e1e2f(ji,jj-1) + zds(ji-1,jj-1) * zds(ji-1,jj-1) * e1e2f(ji-1,jj-1) ) &
& ) * 0.25_wp * r1_e1e2t(ji,jj)
- ! shear at T points
+ ! maximum shear rate at T points (includes tension, output only)
pshear_i(ji,jj) = SQRT( zdt2 + zds2 )
- ! divergence at T points
- pdivu_i(ji,jj) = ( e2u(ji,jj) * u_ice(ji,jj) - e2u(ji-1,jj) * u_ice(ji-1,jj) &
- & + e1v(ji,jj) * v_ice(ji,jj) - e1v(ji,jj-1) * v_ice(ji,jj-1) &
+ ! shear at T-points
+ zshear(ji,jj) = SQRT( zds2 )
+
+ ! divergence at T points, warning: add () for the North Pole reproducibility
+ pdivu_i(ji,jj) = ( ( e2u(ji,jj) * u_ice(ji,jj) - e2u(ji-1,jj) * u_ice(ji-1,jj) ) &
+ & + ( e1v(ji,jj) * v_ice(ji,jj) - e1v(ji,jj-1) * v_ice(ji,jj-1) ) &
& ) * r1_e1e2t(ji,jj)
! delta at T points
- zfac = SQRT( pdivu_i(ji,jj) * pdivu_i(ji,jj) + ( zdt2 + zds2 ) * z1_ecc2 ) ! delta
- rswitch = 1._wp - MAX( 0._wp, SIGN( 1._wp, -zfac ) ) ! 0 if delta=0
- pdelta_i(ji,jj) = zfac + rn_creepl * rswitch ! delta+creepl
+ zdelta(ji,jj) = SQRT( pdivu_i(ji,jj) * pdivu_i(ji,jj) + ( zdt2 + zds2 ) * z1_ecc2 ) ! delta
+
+ ! delta at T points
+ zswitch = 1._wp - MAX( 0._wp, SIGN( 1._wp, -zdelta(ji,jj) ) ) ! 0 if delta=0
+ pdelta_i(ji,jj) = zdelta(ji,jj) + rn_creepl * zswitch
+ ! it seems that deformation used for advection and mech redistribution is delta*
+ ! MV in principle adding creep limit is a regularization for viscosity not for delta
+ ! delta_star should not (in my view) be used in a replacement for delta
END_2D
CALL lbc_lnk( 'icedyn_rhg_eap', pshear_i, 'T', 1.0_wp, pdivu_i, 'T', 1.0_wp, pdelta_i, 'T', 1.0_wp, &
- & zten_i, 'T', 1.0_wp, zs1 , 'T', 1.0_wp, zs2 , 'T', 1.0_wp, &
+ & zs1, 'T', 1.0_wp, zs2 , 'T', 1.0_wp, &
& zs12, 'F', 1.0_wp )
! --- Store the stress tensor for the next time step --- !
@@ -803,45 +803,38 @@ CONTAINS
! 5) diagnostics
!------------------------------------------------------------------------------!
! --- ice-ocean, ice-atm. & ice-oceanbottom(landfast) stresses --- !
- IF( iom_use('utau_oi') .OR. iom_use('vtau_oi') .OR. iom_use('utau_ai') .OR. iom_use('vtau_ai') .OR. &
- & iom_use('utau_bi') .OR. iom_use('vtau_bi') ) THEN
- !
- CALL lbc_lnk( 'icedyn_rhg_eap', ztaux_oi, 'U', -1.0_wp, ztauy_oi, 'V', -1.0_wp, ztaux_ai, 'U', -1.0_wp, &
- & ztauy_ai, 'V', -1.0_wp, ztaux_bi, 'U', -1.0_wp, ztauy_bi, 'V', -1.0_wp )
- !
- CALL iom_put( 'utau_oi' , ztaux_oi * zmsk00 )
- CALL iom_put( 'vtau_oi' , ztauy_oi * zmsk00 )
- CALL iom_put( 'utau_ai' , ztaux_ai * zmsk00 )
- CALL iom_put( 'vtau_ai' , ztauy_ai * zmsk00 )
- CALL iom_put( 'utau_bi' , ztaux_bi * zmsk00 )
- CALL iom_put( 'vtau_bi' , ztauy_bi * zmsk00 )
- ENDIF
+ IF( iom_use('utau_oi') ) CALL iom_put( 'utau_oi' , ztaux_oi(A2D(0)) * zmsk00 )
+ IF( iom_use('vtau_oi') ) CALL iom_put( 'vtau_oi' , ztauy_oi(A2D(0)) * zmsk00 )
+ IF( iom_use('utau_ai') ) CALL iom_put( 'utau_ai' , ztaux_ai(A2D(0)) * zmsk00 )
+ IF( iom_use('vtau_ai') ) CALL iom_put( 'vtau_ai' , ztauy_ai(A2D(0)) * zmsk00 )
+ IF( iom_use('utau_bi') ) CALL iom_put( 'utau_bi' , ztaux_bi(A2D(0)) * zmsk00 )
+ IF( iom_use('vtau_bi') ) CALL iom_put( 'vtau_bi' , ztauy_bi(A2D(0)) * zmsk00 )
! --- divergence, shear and strength --- !
- IF( iom_use('icediv') ) CALL iom_put( 'icediv' , pdivu_i * zmsk00 ) ! divergence
- IF( iom_use('iceshe') ) CALL iom_put( 'iceshe' , pshear_i * zmsk00 ) ! shear
- IF( iom_use('icedlt') ) CALL iom_put( 'icedlt' , pdelta_i * zmsk00 ) ! delta
- IF( iom_use('icestr') ) CALL iom_put( 'icestr' , strength * zmsk00 ) ! strength
+ IF( iom_use('icediv') ) CALL iom_put( 'icediv' , pdivu_i (A2D(0)) * zmsk00 ) ! divergence
+ IF( iom_use('iceshe') ) CALL iom_put( 'iceshe' , pshear_i(A2D(0)) * zmsk00 ) ! shear
+ IF( iom_use('icestr') ) CALL iom_put( 'icestr' , strength(A2D(0)) * zmsk00 ) ! strength
+ IF( iom_use('icedlt') ) CALL iom_put( 'icedlt' , zdelta (A2D(0)) * zmsk00 ) ! delta
! --- Stress tensor invariants (SIMIP diags) --- !
IF( iom_use('normstr') .OR. iom_use('sheastr') ) THEN
!
- ALLOCATE( zsig_I(jpi,jpj) , zsig_II(jpi,jpj) )
+ ALLOCATE( zsig_I(A2D(0)) , zsig_II(A2D(0)) )
!
- DO_2D( 1, 1, 1, 1 )
+ DO_2D( 0, 0, 0, 0 )
! Ice stresses
! sigma1, sigma2, sigma12 are some useful recombination of the stresses (Hunke and Dukowicz MWR 2002, Bouillon et al., OM2013)
! These are NOT stress tensor components, neither stress invariants, neither stress principal components
! I know, this can be confusing...
- zfac = strength(ji,jj) / ( pdelta_i(ji,jj) + rn_creepl )
- zsig1 = zfac * ( pdivu_i(ji,jj) - pdelta_i(ji,jj) )
+ zfac = strength(ji,jj) / ( zdelta(ji,jj) + rn_creepl ) ! viscosity
+ zsig1 = zfac * ( pdivu_i(ji,jj) - zdelta(ji,jj) )
zsig2 = zfac * z1_ecc2 * zten_i(ji,jj)
- zsig12 = zfac * z1_ecc2 * pshear_i(ji,jj)
+ zsig12 = zfac * z1_ecc2 * zshear(ji,jj) * 0.5_wp
! Stress invariants (sigma_I, sigma_II, Coon 1974, Feltham 2008)
- zsig_I (ji,jj) = zsig1 * 0.5_wp ! 1st stress invariant, aka average normal stress, aka negative pressure
- zsig_II(ji,jj) = SQRT ( zsig2 * zsig2 * 0.25_wp + zsig12 * zsig12 ) ! 2nd '' '' , aka maximum shear stress
+ zsig_I (ji,jj) = 0.5_wp * zsig1
+ zsig_II(ji,jj) = 0.5_wp * SQRT ( zsig2 * zsig2 + 4._wp * zsig12 * zsig12 )
END_2D
!
@@ -859,21 +852,20 @@ CONTAINS
! Recommendation 2 : need to use deformations at PREVIOUS iterate for viscosities
IF( iom_use('sig1_pnorm') .OR. iom_use('sig2_pnorm') ) THEN
!
- ALLOCATE( zsig1_p(jpi,jpj) , zsig2_p(jpi,jpj) , zsig_I(jpi,jpj) , zsig_II(jpi,jpj) )
+ ALLOCATE( zsig1_p(A2D(0)) , zsig2_p(A2D(0)) , zsig_I(A2D(0)) , zsig_II(A2D(0)) )
!
- DO_2D( 1, 1, 1, 1 )
+ DO_2D( 0, 0, 0, 0 )
- ! Ice stresses computed with **viscosities** (delta, p/delta) at **previous** iterates
- ! and **deformations** at current iterates
+ ! For EVP solvers, ice stresses at current iterates can be used
! following Lemieux & Dupont (2020)
- zfac = zp_delt(ji,jj)
- zsig1 = zfac * ( pdivu_i(ji,jj) - ( zdelta(ji,jj) + rn_creepl ) )
+ zfac = strength(ji,jj) / ( zdelta(ji,jj) + rn_creepl )
+ zsig1 = zfac * ( pdivu_i(ji,jj) - zdelta(ji,jj) )
zsig2 = zfac * z1_ecc2 * zten_i(ji,jj)
- zsig12 = zfac * z1_ecc2 * pshear_i(ji,jj)
+ zsig12 = zfac * z1_ecc2 * zshear(ji,jj) * 0.5_wp
! Stress invariants (sigma_I, sigma_II, Coon 1974, Feltham 2008), T-point
- zsig_I(ji,jj) = zsig1 * 0.5_wp ! 1st stress invariant, aka average normal stress, aka negative pressure
- zsig_II(ji,jj) = SQRT ( zsig2 * zsig2 * 0.25_wp + zsig12 * zsig12 ) ! 2nd '' '' , aka maximum shear stress
+ zsig_I(ji,jj) = 0.5_wp * zsig1 ! normal stress
+ zsig_II(ji,jj) = 0.5_wp * SQRT ( zsig2 * zsig2 + 4._wp * zsig12 * zsig12 ) ! max shear stress
! Normalized principal stresses (used to display the ellipse)
z1_strength = 1._wp / MAX( 1._wp, strength(ji,jj) )
@@ -881,8 +873,8 @@ CONTAINS
zsig2_p(ji,jj) = ( zsig_I(ji,jj) - zsig_II(ji,jj) ) * z1_strength
END_2D
!
- CALL iom_put( 'sig1_pnorm' , zsig1_p )
- CALL iom_put( 'sig2_pnorm' , zsig2_p )
+ CALL iom_put( 'sig1_pnorm' , zsig1_p(:,:) * zmsk00 )
+ CALL iom_put( 'sig2_pnorm' , zsig2_p(:,:) * zmsk00 )
DEALLOCATE( zsig1_p , zsig2_p , zsig_I, zsig_II )
@@ -890,9 +882,6 @@ CONTAINS
! --- yieldcurve --- !
IF( iom_use('yield11') .OR. iom_use('yield12') .OR. iom_use('yield22')) THEN
-
- CALL lbc_lnk( 'icedyn_rhg_eap', zyield11, 'T', 1.0_wp, zyield22, 'T', 1.0_wp, zyield12, 'T', 1.0_wp )
-
CALL iom_put( 'yield11', zyield11 * zmsk00 )
CALL iom_put( 'yield22', zyield22 * zmsk00 )
CALL iom_put( 'yield12', zyield12 * zmsk00 )
@@ -900,31 +889,22 @@ CONTAINS
! --- anisotropy tensor --- !
IF( iom_use('aniso') ) THEN
- CALL lbc_lnk( 'icedyn_rhg_eap', paniso_11, 'T', 1.0_wp )
CALL iom_put( 'aniso' , paniso_11 * zmsk00 )
ENDIF
! --- SIMIP --- !
- IF( iom_use('dssh_dx') .OR. iom_use('dssh_dy') .OR. &
- & iom_use('corstrx') .OR. iom_use('corstry') .OR. iom_use('intstrx') .OR. iom_use('intstry') ) THEN
- !
- CALL lbc_lnk( 'icedyn_rhg_eap', zspgU, 'U', -1.0_wp, zspgV, 'V', -1.0_wp, &
- & zCorU, 'U', -1.0_wp, zCorV, 'V', -1.0_wp, &
- & zfU, 'U', -1.0_wp, zfV, 'V', -1.0_wp )
-
- CALL iom_put( 'dssh_dx' , zspgU * zmsk00 ) ! Sea-surface tilt term in force balance (x)
- CALL iom_put( 'dssh_dy' , zspgV * zmsk00 ) ! Sea-surface tilt term in force balance (y)
- CALL iom_put( 'corstrx' , zCorU * zmsk00 ) ! Coriolis force term in force balance (x)
- CALL iom_put( 'corstry' , zCorV * zmsk00 ) ! Coriolis force term in force balance (y)
- CALL iom_put( 'intstrx' , zfU * zmsk00 ) ! Internal force term in force balance (x)
- CALL iom_put( 'intstry' , zfV * zmsk00 ) ! Internal force term in force balance (y)
- ENDIF
+ IF( iom_use('dssh_dx') ) CALL iom_put( 'dssh_dx' , zspgU(A2D(0)) * zmsk00 ) ! Sea-surface tilt term in force balance (x)
+ IF( iom_use('dssh_dy') ) CALL iom_put( 'dssh_dy' , zspgV(A2D(0)) * zmsk00 ) ! Sea-surface tilt term in force balance (y)
+ IF( iom_use('corstrx') ) CALL iom_put( 'corstrx' , zCorU(A2D(0)) * zmsk00 ) ! Coriolis force term in force balance (x)
+ IF( iom_use('corstry') ) CALL iom_put( 'corstry' , zCorV(A2D(0)) * zmsk00 ) ! Coriolis force term in force balance (y)
+ IF( iom_use('intstrx') ) CALL iom_put( 'intstrx' , zfU (A2D(0)) * zmsk00 ) ! Internal force term in force balance (x)
+ IF( iom_use('intstry') ) CALL iom_put( 'intstry' , zfV (A2D(0)) * zmsk00 ) ! Internal force term in force balance (y)
IF( iom_use('xmtrpice') .OR. iom_use('ymtrpice') .OR. &
& iom_use('xmtrpsnw') .OR. iom_use('ymtrpsnw') .OR. iom_use('xatrp') .OR. iom_use('yatrp') ) THEN
!
- ALLOCATE( zdiag_xmtrp_ice(jpi,jpj) , zdiag_ymtrp_ice(jpi,jpj) , &
- & zdiag_xmtrp_snw(jpi,jpj) , zdiag_ymtrp_snw(jpi,jpj) , zdiag_xatrp(jpi,jpj) , zdiag_yatrp(jpi,jpj) )
+ ALLOCATE( zdiag_xmtrp_ice(A2D(0)) , zdiag_ymtrp_ice(A2D(0)) , &
+ & zdiag_xmtrp_snw(A2D(0)) , zdiag_ymtrp_snw(A2D(0)) , zdiag_xatrp(A2D(0)) , zdiag_yatrp(A2D(0)) )
!
DO_2D( 0, 0, 0, 0 )
! 2D ice mass, snow mass, area transport arrays (X, Y)
@@ -942,10 +922,6 @@ CONTAINS
END_2D
- CALL lbc_lnk( 'icedyn_rhg_eap', zdiag_xmtrp_ice, 'U', -1.0_wp, zdiag_ymtrp_ice, 'V', -1.0_wp, &
- & zdiag_xmtrp_snw, 'U', -1.0_wp, zdiag_ymtrp_snw, 'V', -1.0_wp, &
- & zdiag_xatrp , 'U', -1.0_wp, zdiag_yatrp , 'V', -1.0_wp )
-
CALL iom_put( 'xmtrpice' , zdiag_xmtrp_ice ) ! X-component of sea-ice mass transport (kg/s)
CALL iom_put( 'ymtrpice' , zdiag_ymtrp_ice ) ! Y-component of sea-ice mass transport
CALL iom_put( 'xmtrpsnw' , zdiag_xmtrp_snw ) ! X-component of snow mass transport (kg/s)
@@ -962,11 +938,11 @@ CONTAINS
IF( nn_rhg_chkcvg == 1 .OR. nn_rhg_chkcvg == 2 ) THEN
IF( iom_use('uice_cvg') ) THEN
IF( ln_aEVP ) THEN ! output: beta * ( u(t=nn_nevp) - u(t=nn_nevp-1) )
- CALL iom_put( 'uice_cvg', MAX( ABS( u_ice(:,:) - zu_ice(:,:) ) * zbeta(:,:) * umask(:,:,1) , &
- & ABS( v_ice(:,:) - zv_ice(:,:) ) * zbeta(:,:) * vmask(:,:,1) ) * zmsk15(:,:) )
+ CALL iom_put( 'uice_cvg', MAX( ABS( u_ice(A2D(0)) - zu_ice(:,:) ) * zbeta(A2D(0)) * umask(A2D(0),1) , &
+ & ABS( v_ice(A2D(0)) - zv_ice(:,:) ) * zbeta(A2D(0)) * vmask(A2D(0),1) ) * zmsk15(:,:) )
ELSE ! output: nn_nevp * ( u(t=nn_nevp) - u(t=nn_nevp-1) )
- CALL iom_put( 'uice_cvg', REAL( nn_nevp ) * MAX( ABS( u_ice(:,:) - zu_ice(:,:) ) * umask(:,:,1) , &
- & ABS( v_ice(:,:) - zv_ice(:,:) ) * vmask(:,:,1) ) * zmsk15(:,:) )
+ CALL iom_put( 'uice_cvg', REAL( nn_nevp ) * MAX( ABS( u_ice(A2D(0)) - zu_ice(:,:) ) * umask(A2D(0),1) , &
+ & ABS( v_ice(A2D(0)) - zv_ice(:,:) ) * vmask(A2D(0),1) ) * zmsk15(:,:) )
ENDIF
ENDIF
ENDIF
@@ -987,22 +963,27 @@ CONTAINS
!!
!! ** Note : for the first sub-iteration, uice_cvg is set to 0 (too large otherwise)
!!----------------------------------------------------------------------
- INTEGER , INTENT(in) :: kt, kiter, kitermax ! ocean time-step index
- REAL(wp), DIMENSION(:,:), INTENT(in) :: pu, pv, pub, pvb ! now and before velocities
- REAL(wp), DIMENSION(:,:), INTENT(in) :: pmsk15
+ INTEGER , INTENT(in) :: kt, kiter, kitermax ! ocean time-step index
+ REAL(wp), DIMENSION(:,:) , INTENT(in) :: pu, pv ! now velocities
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pub, pvb ! before velocities
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pmsk15
!!
INTEGER :: it, idtime, istatus
INTEGER :: ji, jj ! dummy loop indices
REAL(wp) :: zresm ! local real
CHARACTER(len=20) :: clname
+ LOGICAL :: ll_maxcvg
+ REAL(wp), DIMENSION(A2D(0),2) :: zres
+ REAL(wp), DIMENSION(2) :: ztmp
!!----------------------------------------------------------------------
-
+ ll_maxcvg = .FALSE.
+ !
! create file
IF( kt == nit000 .AND. kiter == 1 ) THEN
!
IF( lwp ) THEN
WRITE(numout,*)
- WRITE(numout,*) 'rhg_cvg_eap : ice rheology convergence control'
+ WRITE(numout,*) 'rhg_cvg : ice rheology convergence control'
WRITE(numout,*) '~~~~~~~'
ENDIF
!
@@ -1011,7 +992,7 @@ CONTAINS
IF( .NOT. Agrif_Root() ) clname = TRIM(Agrif_CFixed())//"_"//TRIM(clname)
istatus = NF90_CREATE( TRIM(clname), NF90_CLOBBER, ncvgid )
istatus = NF90_DEF_DIM( ncvgid, 'time' , NF90_UNLIMITED, idtime )
- istatus = NF90_DEF_VAR( ncvgid, 'uice_cvg', NF90_DOUBLE , (/ idtime /), nvarid )
+ istatus = NF90_DEF_VAR( ncvgid, 'uice_cvg', NF90_DOUBLE , (/ idtime /), nvarid )
istatus = NF90_ENDDEF(ncvgid)
ENDIF
!
@@ -1025,11 +1006,21 @@ CONTAINS
zresm = 0._wp
ELSE
zresm = 0._wp
- DO_2D( 0, 0, 0, 0 )
- zresm = MAX( zresm, MAX( ABS( pu(ji,jj) - pub(ji,jj) ) * umask(ji,jj,1), &
- & ABS( pv(ji,jj) - pvb(ji,jj) ) * vmask(ji,jj,1) ) * pmsk15(ji,jj) )
- END_2D
- CALL mpp_max( 'icedyn_rhg_evp', zresm ) ! max over the global domain
+ IF( ll_maxcvg ) THEN ! error max over the domain
+ DO_2D( 0, 0, 0, 0 )
+ zresm = MAX( zresm, MAX( ABS( pu(ji,jj) - pub(ji,jj) ) * umask(ji,jj,1), &
+ & ABS( pv(ji,jj) - pvb(ji,jj) ) * vmask(ji,jj,1) ) * pmsk15(ji,jj) )
+ END_2D
+ CALL mpp_max( 'icedyn_rhg_eap', zresm )
+ ELSE ! error averaged over the domain
+ DO_2D( 0, 0, 0, 0 )
+ zres(ji,jj,1) = MAX( ABS( pu(ji,jj) - pub(ji,jj) ) * umask(ji,jj,1), &
+ & ABS( pv(ji,jj) - pvb(ji,jj) ) * vmask(ji,jj,1) ) * pmsk15(ji,jj)
+ zres(ji,jj,2) = pmsk15(ji,jj)
+ END_2D
+ ztmp(:) = glob_sum_vec( 'icedyn_rhg_eap', zres )
+ IF( ztmp(2) /= 0._wp ) zresm = ztmp(1) / ztmp(2)
+ ENDIF
ENDIF
IF( lwm ) THEN
diff --git a/src/ICE/icedyn_rhg_evp.F90 b/src/ICE/icedyn_rhg_evp.F90
index 52f15aae8612760424ab298201a0a89508e67d59..46898cf6b8f307dca435c2832a99035f3c50bcdf 100644
--- a/src/ICE/icedyn_rhg_evp.F90
+++ b/src/ICE/icedyn_rhg_evp.F90
@@ -114,10 +114,10 @@ CONTAINS
!! Bouillon et al., Ocean Modelling 2013
!! Kimmritz et al., Ocean Modelling 2016 & 2017
!!-------------------------------------------------------------------
- INTEGER , INTENT(in ) :: kt ! time step
- INTEGER , INTENT(in ) :: Kmm ! ocean time level index
- REAL(wp), DIMENSION(:,:), INTENT(inout) :: pstress1_i, pstress2_i, pstress12_i !
- REAL(wp), DIMENSION(:,:), INTENT( out) :: pshear_i , pdivu_i , pdelta_i !
+ INTEGER , INTENT(in ) :: kt ! time step
+ INTEGER , INTENT(in ) :: Kmm ! ocean time level index
+ REAL(wp), DIMENSION(:,:) , INTENT(inout) :: pstress1_i, pstress2_i, pstress12_i !
+ REAL(wp), DIMENSION(A2D(0)), INTENT( out) :: pshear_i , pdivu_i , pdelta_i !
!!
INTEGER :: ji, jj ! dummy loop indices
INTEGER :: jter ! local integers
@@ -135,38 +135,39 @@ CONTAINS
!
REAL(wp) :: zfac_x, zfac_y
!
- REAL(wp), DIMENSION(jpi,jpj) :: zdelta, zp_delt ! delta and P/delta at T points
- REAL(wp), DIMENSION(jpi,jpj) :: zbeta ! beta coef from Kimmritz 2017
+ REAL(wp), DIMENSION(jpi,jpj) :: zdelta, zp_delt ! delta, P/delta at T points
+ REAL(wp), DIMENSION(jpi,jpj) :: zbeta ! beta coef from Kimmritz 2017
!
- REAL(wp), DIMENSION(jpi,jpj) :: zdt_m ! (dt / ice-snow_mass) on T points
- REAL(wp), DIMENSION(jpi,jpj) :: zaU , zaV ! ice fraction on U/V points
- REAL(wp), DIMENSION(jpi,jpj) :: zmU_t, zmV_t ! (ice-snow_mass / dt) on U/V points
- REAL(wp), DIMENSION(jpi,jpj) :: zmf ! coriolis parameter at T points
- REAL(wp), DIMENSION(jpi,jpj) :: v_oceU, u_oceV, v_iceU, u_iceV ! ocean/ice u/v component on V/U points
+ REAL(wp), DIMENSION(jpi,jpj) :: zdt_m ! (dt / ice-snow_mass) on T points
+ REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zaU , zaV ! ice fraction on U/V points
+ REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zmU_t, zmV_t ! (ice-snow_mass / dt) on U/V points
+ REAL(wp), DIMENSION(jpi,jpj) :: zmf ! coriolis parameter at T points
+ REAL(wp), DIMENSION(A2D(nn_hls-1)) :: v_oceU, u_oceV, v_iceU, u_iceV ! ocean/ice u/v component on V/U points
!
- REAL(wp), DIMENSION(jpi,jpj) :: zds ! shear
- REAL(wp), DIMENSION(jpi,jpj) :: zten_i, zshear ! tension, shear
- REAL(wp), DIMENSION(jpi,jpj) :: zs1, zs2, zs12 ! stress tensor components
- REAL(wp), DIMENSION(jpi,jpj) :: zsshdyn ! array used for the calculation of ice surface slope:
- ! ! ocean surface (ssh_m) if ice is not embedded
- ! ! ice bottom surface if ice is embedded
- REAL(wp), DIMENSION(jpi,jpj) :: zfU , zfV ! internal stresses
- REAL(wp), DIMENSION(jpi,jpj) :: zspgU, zspgV ! surface pressure gradient at U/V points
- REAL(wp), DIMENSION(jpi,jpj) :: zCorU, zCorV ! Coriolis stress array
- REAL(wp), DIMENSION(jpi,jpj) :: ztaux_ai, ztauy_ai ! ice-atm. stress at U-V points
- REAL(wp), DIMENSION(jpi,jpj) :: ztaux_oi, ztauy_oi ! ice-ocean stress at U-V points
- REAL(wp), DIMENSION(jpi,jpj) :: ztaux_bi, ztauy_bi ! ice-OceanBottom stress at U-V points (landfast)
- REAL(wp), DIMENSION(jpi,jpj) :: ztaux_base, ztauy_base ! ice-bottom stress at U-V points (landfast)
+ REAL(wp), DIMENSION(jpi,jpj) :: zds ! shear
+ REAL(wp), DIMENSION(A2D(0)) :: zten_i, zshear ! tension, shear
+ REAL(wp), DIMENSION(jpi,jpj) :: zs1, zs2, zs12 ! stress tensor components
+ REAL(wp), DIMENSION(jpi,jpj) :: zsshdyn ! array used for the calculation of ice surface slope:
+ ! ! ocean surface (ssh_m) if ice is not embedded
+ ! ! ice bottom surface if ice is embedded
+ REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zfU , zfV ! internal stresses
+ REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zspgU, zspgV ! surface pressure gradient at U/V points
+ REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zCorU, zCorV ! Coriolis stress array
+ REAL(wp), DIMENSION(A2D(nn_hls-1)) :: ztaux_ai, ztauy_ai ! ice-atm. stress at U-V points
+ REAL(wp), DIMENSION(A2D(nn_hls-1)) :: ztaux_oi, ztauy_oi ! ice-ocean stress at U-V points
+ REAL(wp), DIMENSION(A2D(nn_hls-1)) :: ztaux_bi, ztauy_bi ! ice-OceanBottom stress at U-V points (landfast)
+ REAL(wp), DIMENSION(A2D(nn_hls-1)) :: ztaux_base, ztauy_base ! ice-bottom stress at U-V points (landfast)
!
- REAL(wp), DIMENSION(jpi,jpj) :: zmsk, zmsk00, zmsk15
- REAL(wp), DIMENSION(jpi,jpj) :: zmsk01x, zmsk01y ! dummy arrays
- REAL(wp), DIMENSION(jpi,jpj) :: zmsk00x, zmsk00y ! mask for ice presence
+ REAL(wp), DIMENSION(jpi,jpj) :: zmsk
+ REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zmsk01x, zmsk01y ! dummy arrays
+ REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zmsk00x, zmsk00y ! mask for ice presence
REAL(wp), PARAMETER :: zepsi = 1.0e-20_wp ! tolerance parameter
REAL(wp), PARAMETER :: zmmin = 1._wp ! ice mass (kg/m2) below which ice velocity becomes very small
REAL(wp), PARAMETER :: zamin = 0.001_wp ! ice concentration below which ice velocity becomes very small
!! --- check convergence
- REAL(wp), DIMENSION(jpi,jpj) :: zu_ice, zv_ice
+ REAL(wp), DIMENSION(A2D(0)) :: zmsk00, zmsk15
+ REAL(wp), DIMENSION(A2D(0)) :: zu_ice, zv_ice
!! --- diags
REAL(wp) :: zsig1, zsig2, zsig12, zfac, z1_strength
REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zsig_I, zsig_II, zsig1_p, zsig2_p
@@ -186,14 +187,19 @@ CONTAINS
IF( kt == nit000 .AND. lwp ) WRITE(numout,*) '-- ice_dyn_rhg_evp: EVP sea-ice rheology'
!
- ! for diagnostics and convergence tests
DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
- zmsk00(ji,jj) = MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) - epsi06 ) ) ! 1 if ice , 0 if no ice
- zmsk (ji,jj) = MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) - epsi10 ) ) ! 1 if ice , 0 if no ice
+ IF( at_i(ji,jj) < epsi10 ) THEN ; zmsk(ji,jj) = 0._wp
+ ELSE ; zmsk(ji,jj) = 1._wp ; ENDIF
+ END_2D
+ ! for diagnostics and convergence tests
+ DO_2D( 0, 0, 0, 0 )
+ IF( at_i(ji,jj) < epsi06 ) THEN ; zmsk00(ji,jj) = 0._wp
+ ELSE ; zmsk00(ji,jj) = 1._wp ; ENDIF
END_2D
IF( nn_rhg_chkcvg > 0 ) THEN
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
- zmsk15(ji,jj) = MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) - 0.15_wp ) ) ! 1 if 15% ice, 0 if less
+ DO_2D( 0, 0, 0, 0 )
+ IF( at_i(ji,jj) < 0.15_wp ) THEN ; zmsk15(ji,jj) = 0._wp
+ ELSE ; zmsk15(ji,jj) = 1._wp ; ENDIF
END_2D
ENDIF
!
@@ -265,6 +271,7 @@ CONTAINS
DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
zm1 = ( rhos * vt_s(ji,jj) + rhoi * vt_i(ji,jj) ) ! Ice/snow mass at U-V points
+!!$ zm1 = ( rhos * vt_s(ji,jj) + rhoi * vt_i(ji,jj) + rhow * (vt_ip(ji,jj) + vt_il(ji,jj)) ) ! clem: this should replace the above
zmf (ji,jj) = zm1 * ff_t(ji,jj) ! Coriolis at T points (m*f)
zdt_m(ji,jj) = zdtevp / MAX( zm1, zmmin ) ! dt/m at T points (for alpha and beta coefficients)
END_2D
@@ -277,13 +284,16 @@ CONTAINS
! Ice/snow mass at U-V points
zm1 = ( rhos * vt_s(ji ,jj ) + rhoi * vt_i(ji ,jj ) )
+!!$ zm1 = ( rhos * vt_s(ji ,jj ) + rhoi * vt_i(ji ,jj ) + rhow * (vt_ip(ji ,jj ) + vt_il(ji ,jj )) ) ! clem: this should replace the above
zm2 = ( rhos * vt_s(ji+1,jj ) + rhoi * vt_i(ji+1,jj ) )
+!!$ zm2 = ( rhos * vt_s(ji+1,jj ) + rhoi * vt_i(ji+1,jj ) + rhow * (vt_ip(ji+1,jj ) + vt_il(ji+1,jj )) ) ! clem: this should replace the above
zm3 = ( rhos * vt_s(ji ,jj+1) + rhoi * vt_i(ji ,jj+1) )
+!!$ zm3 = ( rhos * vt_s(ji ,jj+1) + rhoi * vt_i(ji ,jj+1) + rhow * (vt_ip(ji ,jj+1) + vt_il(ji ,jj+1)) ) ! clem: this should replace the above
zmassU = 0.5_wp * ( zm1 * e1e2t(ji,jj) + zm2 * e1e2t(ji+1,jj) ) * r1_e1e2u(ji,jj) * umask(ji,jj,1)
zmassV = 0.5_wp * ( zm1 * e1e2t(ji,jj) + zm3 * e1e2t(ji,jj+1) ) * r1_e1e2v(ji,jj) * vmask(ji,jj,1)
! Ocean currents at U-V points
- ! (brackets added to fix the order of floating point operations for halo 1 - halo 2 compatibility)
+ ! (brackets added to fix the order of floating point operations for the North Pole reproducibility)
v_oceU(ji,jj) = 0.25_wp * ( (v_oce(ji,jj) + v_oce(ji,jj-1)) + (v_oce(ji+1,jj) + v_oce(ji+1,jj-1)) ) * umask(ji,jj,1)
u_oceV(ji,jj) = 0.25_wp * ( (u_oce(ji,jj) + u_oce(ji-1,jj)) + (u_oce(ji,jj+1) + u_oce(ji-1,jj+1)) ) * vmask(ji,jj,1)
@@ -292,17 +302,23 @@ CONTAINS
zmV_t(ji,jj) = zmassV * z1_dtevp
! Drag ice-atm.
- ztaux_ai(ji,jj) = zaU(ji,jj) * utau_ice(ji,jj)
- ztauy_ai(ji,jj) = zaV(ji,jj) * vtau_ice(ji,jj)
+ ! Note the use of 0.5*(2-umask) in order to unmask the stress along coastlines
+ ! and the use of MAX(tmask(i,j),tmask(i+1,j) is to mask tau over ice shelves
+ ztaux_ai(ji,jj) = zaU(ji,jj) * 0.5_wp * ( utau_ice(ji,jj) + utau_ice(ji+1,jj) ) * &
+ & ( 2. - umask(ji,jj,1) ) * MAX( tmask(ji,jj,1), tmask(ji+1,jj,1) )
+ ztauy_ai(ji,jj) = zaV(ji,jj) * 0.5_wp * ( vtau_ice(ji,jj) + vtau_ice(ji,jj+1) ) * &
+ & ( 2. - vmask(ji,jj,1) ) * MAX( tmask(ji,jj,1), tmask(ji,jj+1,1) )
! Surface pressure gradient (- m*g*GRAD(ssh)) at U-V points
zspgU(ji,jj) = - zmassU * grav * ( zsshdyn(ji+1,jj) - zsshdyn(ji,jj) ) * r1_e1u(ji,jj)
zspgV(ji,jj) = - zmassV * grav * ( zsshdyn(ji,jj+1) - zsshdyn(ji,jj) ) * r1_e2v(ji,jj)
! masks
- zmsk00x(ji,jj) = 1._wp - MAX( 0._wp, SIGN( 1._wp, -zmassU ) ) ! 0 if no ice
- zmsk00y(ji,jj) = 1._wp - MAX( 0._wp, SIGN( 1._wp, -zmassV ) ) ! 0 if no ice
-
+ IF( zmassU > 0._wp ) THEN ; zmsk00x(ji,jj) = 1._wp
+ ELSE ; zmsk00x(ji,jj) = 0._wp ; ENDIF
+ IF( zmassV > 0._wp ) THEN ; zmsk00y(ji,jj) = 1._wp
+ ELSE ; zmsk00y(ji,jj) = 0._wp ; ENDIF
+
! switches
IF( zmassU <= zmmin .AND. zaU(ji,jj) <= zamin ) THEN ; zmsk01x(ji,jj) = 0._wp
ELSE ; zmsk01x(ji,jj) = 1._wp ; ENDIF
@@ -324,11 +340,12 @@ CONTAINS
! ice-bottom stress at V points
zvCr = zaV(ji,jj) * rn_lf_depfra * hv(ji,jj,Kmm) * ( 1._wp - icb_mask(ji,jj) ) ! if grounded icebergs are read: ocean depth = 0
ztauy_base(ji,jj) = - rn_lf_bfr * MAX( 0._wp, zvV - zvCr ) * EXP( -rn_crhg * ( 1._wp - zaV(ji,jj) ) )
+ END_2D
+ DO_2D( 0, 0, 0, 0 )
! ice_bottom stress at T points
- zvCr = at_i(ji,jj) * rn_lf_depfra * ht(ji,jj) * ( 1._wp - icb_mask(ji,jj) ) ! if grounded icebergs are read: ocean depth = 0
+ zvCr = at_i(ji,jj) * rn_lf_depfra * ht(ji,jj,Kmm) * ( 1._wp - icb_mask(ji,jj) ) ! if grounded icebergs are read: ocean depth = 0
tau_icebfr(ji,jj) = - rn_lf_bfr * MAX( 0._wp, vt_i(ji,jj) - zvCr ) * EXP( -rn_crhg * ( 1._wp - at_i(ji,jj) ) )
END_2D
- CALL lbc_lnk( 'icedyn_rhg_evp', tau_icebfr(:,:), 'T', 1.0_wp )
!
ELSE !-- no landfast
DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 )
@@ -344,11 +361,9 @@ CONTAINS
! ! ==================== !
DO jter = 1 , nn_nevp ! loop over jter !
! ! ==================== !
- l_full_nf_update = jter == nn_nevp ! false: disable full North fold update (performances) for iter = 1 to nn_nevp-1
- !
! convergence test
IF( nn_rhg_chkcvg == 1 .OR. nn_rhg_chkcvg == 2 ) THEN
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
zu_ice(ji,jj) = u_ice(ji,jj) * umask(ji,jj,1) ! velocity at previous time step
zv_ice(ji,jj) = v_ice(ji,jj) * vmask(ji,jj,1)
END_2D
@@ -367,13 +382,13 @@ CONTAINS
DO_2D( 0, 0, 0, 0 )
! shear**2 at T points (doc eq. A16)
- zds2 = ( zds(ji,jj ) * zds(ji,jj ) * e1e2f(ji,jj ) + zds(ji-1,jj ) * zds(ji-1,jj ) * e1e2f(ji-1,jj ) &
- & + zds(ji,jj-1) * zds(ji,jj-1) * e1e2f(ji,jj-1) + zds(ji-1,jj-1) * zds(ji-1,jj-1) * e1e2f(ji-1,jj-1) &
+ zds2 = ( ( zds(ji,jj )*zds(ji,jj )*e1e2f(ji,jj ) + zds(ji-1,jj )*zds(ji-1,jj )*e1e2f(ji-1,jj ) ) & ! add () for
+ & + ( zds(ji,jj-1)*zds(ji,jj-1)*e1e2f(ji,jj-1) + zds(ji-1,jj-1)*zds(ji-1,jj-1)*e1e2f(ji-1,jj-1) ) & ! NP repro
& ) * 0.25_wp * r1_e1e2t(ji,jj)
! divergence at T points
- zdiv = ( e2u(ji,jj) * u_ice(ji,jj) - e2u(ji-1,jj) * u_ice(ji-1,jj) &
- & + e1v(ji,jj) * v_ice(ji,jj) - e1v(ji,jj-1) * v_ice(ji,jj-1) &
+ zdiv = ( ( e2u(ji,jj) * u_ice(ji,jj) - e2u(ji-1,jj) * u_ice(ji-1,jj) ) & ! add () for
+ & + ( e1v(ji,jj) * v_ice(ji,jj) - e1v(ji,jj-1) * v_ice(ji,jj-1) ) & ! NP repro
& ) * r1_e1e2t(ji,jj)
zdiv2 = zdiv * zdiv
@@ -396,9 +411,8 @@ CONTAINS
DO_2D( nn_hls-1, nn_hls, nn_hls-1, nn_hls ) ! loop ends at jpi,jpj so that no lbc_lnk are needed for zs1 and zs2
! divergence at T points (duplication to avoid communications)
- ! (brackets added to fix the order of floating point operations for halo 1 - halo 2 compatibility)
- zdiv = ( (e2u(ji,jj) * u_ice(ji,jj) - e2u(ji-1,jj) * u_ice(ji-1,jj)) &
- & + (e1v(ji,jj) * v_ice(ji,jj) - e1v(ji,jj-1) * v_ice(ji,jj-1)) &
+ zdiv = ( ( e2u(ji,jj) * u_ice(ji,jj) - e2u(ji-1,jj) * u_ice(ji-1,jj) ) & ! add () for
+ & + ( e1v(ji,jj) * v_ice(ji,jj) - e1v(ji,jj-1) * v_ice(ji,jj-1) ) & ! NP repro
& ) * r1_e1e2t(ji,jj)
! tension at T points (duplication to avoid communications)
@@ -448,8 +462,8 @@ CONTAINS
ENDIF
! P/delta at F points
- ! (brackets added to fix the order of floating point operations for halo 1 - halo 2 compatibility)
- zp_delf = 0.25_wp * ( (zp_delt(ji,jj) + zp_delt(ji+1,jj)) + (zp_delt(ji,jj+1) + zp_delt(ji+1,jj+1)) )
+ ! (brackets added to fix the order of floating point operations for the North Pole reproducibility)
+ zp_delf = 0.25_wp * ( ( zp_delt(ji,jj) + zp_delt(ji+1,jj) ) + ( zp_delt(ji,jj+1) + zp_delt(ji+1,jj+1) ) )
! stress at F points (zkt/=0 if landfast)
zs12(ji,jj)= ( zs12(ji,jj) * zalph2 + zp_delf * ( zds(ji,jj) * z1_ecc2 * (1._wp + zkt) ) * 0.5_wp ) &
@@ -461,30 +475,39 @@ CONTAINS
! (brackets added to fix the order of floating point operations for halo 1 - halo 2 compatibility)
DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 )
! !--- U points
- zfU(ji,jj) = 0.5_wp * ( (( zs1(ji+1,jj) - zs1(ji,jj) ) * e2u(ji,jj) &
- & + ( zs2(ji+1,jj) * e2t(ji+1,jj) * e2t(ji+1,jj) - zs2(ji,jj) * e2t(ji,jj) * e2t(ji,jj) &
- & ) * r1_e2u(ji,jj)) &
+ zfU(ji,jj) = 0.5_wp * ( ( ( zs1(ji+1,jj) - zs1(ji,jj) ) * e2u(ji,jj) &
+ & + ( zs2(ji+1,jj) * e2t(ji+1,jj) * e2t(ji+1,jj) - zs2(ji,jj) * e2t(ji,jj) * e2t(ji,jj) &
+ & ) * r1_e2u(ji,jj) ) &
& + ( zs12(ji,jj) * e1f(ji,jj) * e1f(ji,jj) - zs12(ji,jj-1) * e1f(ji,jj-1) * e1f(ji,jj-1) &
& ) * 2._wp * r1_e1u(ji,jj) &
& ) * r1_e1e2u(ji,jj)
!
! !--- V points
- zfV(ji,jj) = 0.5_wp * ( (( zs1(ji,jj+1) - zs1(ji,jj) ) * e1v(ji,jj) &
- & - ( zs2(ji,jj+1) * e1t(ji,jj+1) * e1t(ji,jj+1) - zs2(ji,jj) * e1t(ji,jj) * e1t(ji,jj) &
- & ) * r1_e1v(ji,jj)) &
+ zfV(ji,jj) = 0.5_wp * ( ( ( zs1(ji,jj+1) - zs1(ji,jj) ) * e1v(ji,jj) &
+ & - ( zs2(ji,jj+1) * e1t(ji,jj+1) * e1t(ji,jj+1) - zs2(ji,jj) * e1t(ji,jj) * e1t(ji,jj) &
+ & ) * r1_e1v(ji,jj) ) &
& + ( zs12(ji,jj) * e2f(ji,jj) * e2f(ji,jj) - zs12(ji-1,jj) * e2f(ji-1,jj) * e2f(ji-1,jj) &
& ) * 2._wp * r1_e2v(ji,jj) &
& ) * r1_e1e2v(ji,jj)
!
- ! !--- ice currents at U-V point
- v_iceU(ji,jj) = 0.25_wp * ( (v_ice(ji,jj) + v_ice(ji,jj-1)) + (v_ice(ji+1,jj) + v_ice(ji+1,jj-1)) ) * umask(ji,jj,1)
- u_iceV(ji,jj) = 0.25_wp * ( (u_ice(ji,jj) + u_ice(ji-1,jj)) + (u_ice(ji,jj+1) + u_ice(ji-1,jj+1)) ) * vmask(ji,jj,1)
+ ! !--- ice currents at U-V point, warning: add () for NP repro
+ v_iceU(ji,jj) = 0.25_wp * ( ( v_ice(ji,jj) + v_ice(ji,jj-1) ) + ( v_ice(ji+1,jj) + v_ice(ji+1,jj-1) ) ) * umask(ji,jj,1)
+ u_iceV(ji,jj) = 0.25_wp * ( ( u_ice(ji,jj) + u_ice(ji-1,jj) ) + ( u_ice(ji,jj+1) + u_ice(ji-1,jj+1) ) ) * vmask(ji,jj,1)
!
END_2D
!
! --- Computation of ice velocity --- !
! Bouillon et al. 2013 (eq 47-48) => unstable unless alpha, beta vary as in Kimmritz 2016 & 2017
! Bouillon et al. 2009 (eq 34-35) => stable
+ !
+ ! aEVP formulation given by eq.6 from Kimmritz et al. 2016, but taken the last term implicitly (as in eq. 8)
+ ! u(p+1) - u(p) = 1/beta * ( dt/m * RHS(p+1) + u(n) - u(p+1) )
+ ! with RHS = tau_ai + tau_oi + tau_bi + Coriolis + Spg
+ ! and tau_oi = ztau0 * ( uoce - u(p+1) )
+ ! tau_bi = ztauB * u(p+1)
+ ! Hence:
+ ! u(p+1) = 1/(m/dt*(beta+1)+ztauO-ztauB) * (m/dt*(beta*u(p)+u(n))+RHS+ztauO*u(p))
+ !
IF( MOD(jter,2) == 0 ) THEN ! even iterations
!
DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 )
@@ -508,29 +531,32 @@ CONTAINS
! !--- Sum of external forces (explicit solution) = F + tau_ia + Coriolis + spg + tau_io
zRHS = zfV(ji,jj) + ztauy_ai(ji,jj) + zCorV(ji,jj) + zspgV(ji,jj) + ztauy_oi(ji,jj)
!
- ! !--- landfast switch => 0 = static friction : TauB > RHS & sign(TauB) /= sign(RHS)
- ! 1 = sliding friction : TauB < RHS
- rswitch = 1._wp - MIN( 1._wp, ABS( SIGN( 1._wp, zRHS + ztauy_base(ji,jj) ) - SIGN( 1._wp, zRHS ) ) )
- !
- IF( ln_aEVP ) THEN !--- ice velocity using aEVP (Kimmritz et al 2016 & 2017)
+ IF( ln_aEVP ) THEN !--- ice velocity using aEVP (Kimmritz et al 2016 & 2017)
+ !
zbetav = MAX( zbeta(ji,jj), zbeta(ji,jj+1) )
- v_ice(ji,jj) = ( ( rswitch * ( zmV_t(ji,jj) * ( zbetav * v_ice(ji,jj) + v_ice_b(ji,jj) ) & ! previous velocity
- & + zRHS + zTauO * v_ice(ji,jj) & ! F + tau_ia + Coriolis + spg + tau_io(only ocean part)
- & ) / MAX( zepsi, zmV_t(ji,jj) * ( zbetav + 1._wp ) + zTauO - zTauB ) & ! m/dt + tau_io(only ice part) + landfast
- & + ( 1._wp - rswitch ) * ( v_ice_b(ji,jj) &
- & + v_ice (ji,jj) * MAX( 0._wp, zbetav - zdtevp * rn_lf_relax ) & ! static friction => slow decrease to v=0
- & ) / ( zbetav + 1._wp ) &
- & ) * zmsk01y(ji,jj) + v_oce(ji,jj) * 0.01_wp * ( 1._wp - zmsk01y(ji,jj) ) & ! v_ice = v_oce/100 if mass < zmmin & conc < zamin
- & ) * zmsk00y(ji,jj)
- ELSE !--- ice velocity using EVP implicit formulation (cf Madec doc & Bouillon 2009)
- v_ice(ji,jj) = ( ( rswitch * ( zmV_t(ji,jj) * v_ice(ji,jj) & ! previous velocity
- & + zRHS + zTauO * v_ice(ji,jj) & ! F + tau_ia + Coriolis + spg + tau_io(only ocean part)
- & ) / MAX( zepsi, zmV_t(ji,jj) + zTauO - zTauB ) & ! m/dt + tau_io(only ice part) + landfast
- & + ( 1._wp - rswitch ) * v_ice(ji,jj) * MAX( 0._wp, 1._wp - zdtevp * rn_lf_relax ) & ! static friction => slow decrease to v=0
- & ) * zmsk01y(ji,jj) + v_oce(ji,jj) * 0.01_wp * ( 1._wp - zmsk01y(ji,jj) ) & ! v_ice = v_oce/100 if mass < zmmin & conc < zamin
- & ) * zmsk00y(ji,jj)
+ !
+ IF( ( zRHS + ztauy_base(ji,jj) ) < 0._wp .AND. zRHS >= 0._wp ) THEN ! static friction => slow decrease to v=0
+ v_ice(ji,jj) = ( v_ice_b(ji,jj) + v_ice(ji,jj) * MAX( 0._wp, zbetav - zdtevp*rn_lf_relax ) ) / (zbetav+1._wp)
+ ELSE
+ v_ice(ji,jj) = ( zmV_t(ji,jj) * ( zbetav * v_ice(ji,jj) + v_ice_b(ji,jj) ) + zRHS + zTauO * v_ice(ji,jj) ) &
+ & / MAX( zepsi, zmV_t(ji,jj) * ( zbetav + 1._wp ) + zTauO - zTauB )
+ ENDIF
+ !
+ ELSE !--- ice velocity using EVP implicit formulation (cf Madec doc & Bouillon 2009)
+ !
+ IF( ( zRHS + ztauy_base(ji,jj) ) < 0._wp .AND. zRHS >= 0._wp ) THEN ! static friction => slow decrease to v=0
+ v_ice(ji,jj) = v_ice(ji,jj) * MAX( 0._wp, 1._wp - zdtevp * rn_lf_relax )
+ ELSE
+ v_ice(ji,jj) = ( zmV_t(ji,jj) * v_ice(ji,jj) + zRHS + zTauO * v_ice(ji,jj) ) &
+ & / MAX( zepsi, zmV_t(ji,jj) + zTauO - zTauB )
+ ENDIF
+ !
ENDIF
+ ! v_ice = v_oce/100 if mass < zmmin & conc < zamin
+ v_ice(ji,jj) = ( v_ice(ji,jj)*zmsk01y(ji,jj) + v_oce(ji,jj) * 0.01_wp * (1._wp - zmsk01y(ji,jj)) ) * zmsk00y(ji,jj)
+ !
END_2D
+ !
IF( nn_hls == 1 ) CALL lbc_lnk( 'icedyn_rhg_evp', v_ice, 'V', -1.0_wp )
!
DO_2D( 0, 0, 0, 0 )
@@ -554,29 +580,32 @@ CONTAINS
! !--- Sum of external forces (explicit solution) = F + tau_ia + Coriolis + spg + tau_io
zRHS = zfU(ji,jj) + ztaux_ai(ji,jj) + zCorU(ji,jj) + zspgU(ji,jj) + ztaux_oi(ji,jj)
!
- ! !--- landfast switch => 0 = static friction : TauB > RHS & sign(TauB) /= sign(RHS)
- ! 1 = sliding friction : TauB < RHS
- rswitch = 1._wp - MIN( 1._wp, ABS( SIGN( 1._wp, zRHS + ztaux_base(ji,jj) ) - SIGN( 1._wp, zRHS ) ) )
- !
IF( ln_aEVP ) THEN !--- ice velocity using aEVP (Kimmritz et al 2016 & 2017)
+ !
zbetau = MAX( zbeta(ji,jj), zbeta(ji+1,jj) )
- u_ice(ji,jj) = ( ( rswitch * ( zmU_t(ji,jj) * ( zbetau * u_ice(ji,jj) + u_ice_b(ji,jj) ) & ! previous velocity
- & + zRHS + zTauO * u_ice(ji,jj) & ! F + tau_ia + Coriolis + spg + tau_io(only ocean part)
- & ) / MAX( zepsi, zmU_t(ji,jj) * ( zbetau + 1._wp ) + zTauO - zTauB ) & ! m/dt + tau_io(only ice part) + landfast
- & + ( 1._wp - rswitch ) * ( u_ice_b(ji,jj) &
- & + u_ice (ji,jj) * MAX( 0._wp, zbetau - zdtevp * rn_lf_relax ) & ! static friction => slow decrease to v=0
- & ) / ( zbetau + 1._wp ) &
- & ) * zmsk01x(ji,jj) + u_oce(ji,jj) * 0.01_wp * ( 1._wp - zmsk01x(ji,jj) ) & ! v_ice = v_oce/100 if mass < zmmin & conc < zamin
- & ) * zmsk00x(ji,jj)
+ !
+ IF( ( zRHS + ztaux_base(ji,jj) ) < 0._wp .AND. zRHS >= 0._wp ) THEN ! static friction => slow decrease to v=0
+ u_ice(ji,jj) = ( u_ice_b(ji,jj) + u_ice(ji,jj) * MAX( 0._wp, zbetau - zdtevp*rn_lf_relax ) ) / (zbetau+1._wp)
+ ELSE
+ u_ice(ji,jj) = ( zmU_t(ji,jj) * ( zbetau * u_ice(ji,jj) + u_ice_b(ji,jj) ) + zRHS + zTauO * u_ice(ji,jj) ) &
+ & / MAX( zepsi, zmU_t(ji,jj) * ( zbetau + 1._wp ) + zTauO - zTauB )
+ ENDIF
+ !
ELSE !--- ice velocity using EVP implicit formulation (cf Madec doc & Bouillon 2009)
- u_ice(ji,jj) = ( ( rswitch * ( zmU_t(ji,jj) * u_ice(ji,jj) & ! previous velocity
- & + zRHS + zTauO * u_ice(ji,jj) & ! F + tau_ia + Coriolis + spg + tau_io(only ocean part)
- & ) / MAX( zepsi, zmU_t(ji,jj) + zTauO - zTauB ) & ! m/dt + tau_io(only ice part) + landfast
- & + ( 1._wp - rswitch ) * u_ice(ji,jj) * MAX( 0._wp, 1._wp - zdtevp * rn_lf_relax ) & ! static friction => slow decrease to v=0
- & ) * zmsk01x(ji,jj) + u_oce(ji,jj) * 0.01_wp * ( 1._wp - zmsk01x(ji,jj) ) & ! v_ice = v_oce/100 if mass < zmmin & conc < zamin
- & ) * zmsk00x(ji,jj)
+ !
+ IF( ( zRHS + ztaux_base(ji,jj) ) < 0._wp .AND. zRHS >= 0._wp ) THEN ! static friction => slow decrease to v=0
+ u_ice(ji,jj) = u_ice(ji,jj) * MAX( 0._wp, 1._wp - zdtevp * rn_lf_relax )
+ ELSE
+ u_ice(ji,jj) = ( zmU_t(ji,jj) * u_ice(ji,jj) + zRHS + zTauO * u_ice(ji,jj) ) &
+ & / MAX( zepsi, zmU_t(ji,jj) + zTauO - zTauB )
+ ENDIF
+ !
ENDIF
+ ! u_ice = u_oce/100 if mass < zmmin & conc < zamin
+ u_ice(ji,jj) = ( u_ice(ji,jj)*zmsk01x(ji,jj) + u_oce(ji,jj) * 0.01_wp * (1._wp - zmsk01x(ji,jj)) ) * zmsk00x(ji,jj)
+ !
END_2D
+ !
IF( nn_hls == 1 ) THEN ; CALL lbc_lnk( 'icedyn_rhg_evp', u_ice, 'U', -1.0_wp )
ELSE ; CALL lbc_lnk( 'icedyn_rhg_evp', u_ice, 'U', -1.0_wp, v_ice, 'V', -1.0_wp )
ENDIF
@@ -604,29 +633,32 @@ CONTAINS
! !--- Sum of external forces (explicit solution) = F + tau_ia + Coriolis + spg + tau_io
zRHS = zfU(ji,jj) + ztaux_ai(ji,jj) + zCorU(ji,jj) + zspgU(ji,jj) + ztaux_oi(ji,jj)
!
- ! !--- landfast switch => 0 = static friction : TauB > RHS & sign(TauB) /= sign(RHS)
- ! 1 = sliding friction : TauB < RHS
- rswitch = 1._wp - MIN( 1._wp, ABS( SIGN( 1._wp, zRHS + ztaux_base(ji,jj) ) - SIGN( 1._wp, zRHS ) ) )
- !
IF( ln_aEVP ) THEN !--- ice velocity using aEVP (Kimmritz et al 2016 & 2017)
+ !
zbetau = MAX( zbeta(ji,jj), zbeta(ji+1,jj) )
- u_ice(ji,jj) = ( ( rswitch * ( zmU_t(ji,jj) * ( zbetau * u_ice(ji,jj) + u_ice_b(ji,jj) ) & ! previous velocity
- & + zRHS + zTauO * u_ice(ji,jj) & ! F + tau_ia + Coriolis + spg + tau_io(only ocean part)
- & ) / MAX( zepsi, zmU_t(ji,jj) * ( zbetau + 1._wp ) + zTauO - zTauB ) & ! m/dt + tau_io(only ice part) + landfast
- & + ( 1._wp - rswitch ) * ( u_ice_b(ji,jj) &
- & + u_ice (ji,jj) * MAX( 0._wp, zbetau - zdtevp * rn_lf_relax ) & ! static friction => slow decrease to v=0
- & ) / ( zbetau + 1._wp ) &
- & ) * zmsk01x(ji,jj) + u_oce(ji,jj) * 0.01_wp * ( 1._wp - zmsk01x(ji,jj) ) & ! v_ice = v_oce/100 if mass < zmmin & conc < zamin
- & ) * zmsk00x(ji,jj)
+ !
+ IF( ( zRHS + ztaux_base(ji,jj) ) < 0._wp .AND. zRHS >= 0._wp ) THEN ! static friction => slow decrease to v=0
+ u_ice(ji,jj) = ( u_ice_b(ji,jj) + u_ice(ji,jj) * MAX( 0._wp, zbetau - zdtevp*rn_lf_relax ) ) / (zbetau+1._wp)
+ ELSE
+ u_ice(ji,jj) = ( zmU_t(ji,jj) * ( zbetau * u_ice(ji,jj) + u_ice_b(ji,jj) ) + zRHS + zTauO * u_ice(ji,jj) ) &
+ & / MAX( zepsi, zmU_t(ji,jj) * ( zbetau + 1._wp ) + zTauO - zTauB )
+ ENDIF
+ !
ELSE !--- ice velocity using EVP implicit formulation (cf Madec doc & Bouillon 2009)
- u_ice(ji,jj) = ( ( rswitch * ( zmU_t(ji,jj) * u_ice(ji,jj) & ! previous velocity
- & + zRHS + zTauO * u_ice(ji,jj) & ! F + tau_ia + Coriolis + spg + tau_io(only ocean part)
- & ) / MAX( zepsi, zmU_t(ji,jj) + zTauO - zTauB ) & ! m/dt + tau_io(only ice part) + landfast
- & + ( 1._wp - rswitch ) * u_ice(ji,jj) * MAX( 0._wp, 1._wp - zdtevp * rn_lf_relax ) & ! static friction => slow decrease to v=0
- & ) * zmsk01x(ji,jj) + u_oce(ji,jj) * 0.01_wp * ( 1._wp - zmsk01x(ji,jj) ) & ! v_ice = v_oce/100 if mass < zmmin & conc < zamin
- & ) * zmsk00x(ji,jj)
+ !
+ IF( ( zRHS + ztaux_base(ji,jj) ) < 0._wp .AND. zRHS >= 0._wp ) THEN ! static friction => slow decrease to v=0
+ u_ice(ji,jj) = u_ice(ji,jj) * MAX( 0._wp, 1._wp - zdtevp * rn_lf_relax )
+ ELSE
+ u_ice(ji,jj) = ( zmU_t(ji,jj) * u_ice(ji,jj) + zRHS + zTauO * u_ice(ji,jj) ) &
+ & / MAX( zepsi, zmU_t(ji,jj) + zTauO - zTauB )
+ ENDIF
+ !
ENDIF
+ ! u_ice = u_oce/100 if mass < zmmin & conc < zamin
+ u_ice(ji,jj) = ( u_ice(ji,jj)*zmsk01x(ji,jj) + u_oce(ji,jj) * 0.01_wp * (1._wp - zmsk01x(ji,jj)) ) * zmsk00x(ji,jj)
+ !
END_2D
+ !
IF( nn_hls == 1 ) CALL lbc_lnk( 'icedyn_rhg_evp', u_ice, 'U', -1.0_wp )
!
DO_2D( 0, 0, 0, 0 )
@@ -650,29 +682,32 @@ CONTAINS
! !--- Sum of external forces (explicit solution) = F + tau_ia + Coriolis + spg + tau_io
zRHS = zfV(ji,jj) + ztauy_ai(ji,jj) + zCorV(ji,jj) + zspgV(ji,jj) + ztauy_oi(ji,jj)
!
- ! !--- landfast switch => 0 = static friction : TauB > RHS & sign(TauB) /= sign(RHS)
- ! 1 = sliding friction : TauB < RHS
- rswitch = 1._wp - MIN( 1._wp, ABS( SIGN( 1._wp, zRHS + ztauy_base(ji,jj) ) - SIGN( 1._wp, zRHS ) ) )
- !
IF( ln_aEVP ) THEN !--- ice velocity using aEVP (Kimmritz et al 2016 & 2017)
+ !
zbetav = MAX( zbeta(ji,jj), zbeta(ji,jj+1) )
- v_ice(ji,jj) = ( ( rswitch * ( zmV_t(ji,jj) * ( zbetav * v_ice(ji,jj) + v_ice_b(ji,jj) ) & ! previous velocity
- & + zRHS + zTauO * v_ice(ji,jj) & ! F + tau_ia + Coriolis + spg + tau_io(only ocean part)
- & ) / MAX( zepsi, zmV_t(ji,jj) * ( zbetav + 1._wp ) + zTauO - zTauB ) & ! m/dt + tau_io(only ice part) + landfast
- & + ( 1._wp - rswitch ) * ( v_ice_b(ji,jj) &
- & + v_ice (ji,jj) * MAX( 0._wp, zbetav - zdtevp * rn_lf_relax ) & ! static friction => slow decrease to v=0
- & ) / ( zbetav + 1._wp ) &
- & ) * zmsk01y(ji,jj) + v_oce(ji,jj) * 0.01_wp * ( 1._wp - zmsk01y(ji,jj) ) & ! v_ice = v_oce/100 if mass < zmmin & conc < zamin
- & ) * zmsk00y(ji,jj)
+ !
+ IF( ( zRHS + ztauy_base(ji,jj) ) < 0._wp .AND. zRHS >= 0._wp ) THEN ! static friction => slow decrease to v=0
+ v_ice(ji,jj) = ( v_ice_b(ji,jj) + v_ice(ji,jj) * MAX( 0._wp, zbetav - zdtevp*rn_lf_relax ) ) / (zbetav+1._wp)
+ ELSE
+ v_ice(ji,jj) = ( zmV_t(ji,jj) * ( zbetav * v_ice(ji,jj) + v_ice_b(ji,jj) ) + zRHS + zTauO * v_ice(ji,jj) ) &
+ & / MAX( zepsi, zmV_t(ji,jj) * ( zbetav + 1._wp ) + zTauO - zTauB )
+ ENDIF
+ !
ELSE !--- ice velocity using EVP implicit formulation (cf Madec doc & Bouillon 2009)
- v_ice(ji,jj) = ( ( rswitch * ( zmV_t(ji,jj) * v_ice(ji,jj) & ! previous velocity
- & + zRHS + zTauO * v_ice(ji,jj) & ! F + tau_ia + Coriolis + spg + tau_io(only ocean part)
- & ) / MAX( zepsi, zmV_t(ji,jj) + zTauO - zTauB ) & ! m/dt + tau_io(only ice part) + landfast
- & + ( 1._wp - rswitch ) * v_ice(ji,jj) * MAX( 0._wp, 1._wp - zdtevp * rn_lf_relax ) & ! static friction => slow decrease to v=0
- & ) * zmsk01y(ji,jj) + v_oce(ji,jj) * 0.01_wp * ( 1._wp - zmsk01y(ji,jj) ) & ! v_ice = v_oce/100 if mass < zmmin & conc < zamin
- & ) * zmsk00y(ji,jj)
+ !
+ IF( ( zRHS + ztauy_base(ji,jj) ) < 0._wp .AND. zRHS >= 0._wp ) THEN ! static friction => slow decrease to v=0
+ v_ice(ji,jj) = v_ice(ji,jj) * MAX( 0._wp, 1._wp - zdtevp * rn_lf_relax )
+ ELSE
+ v_ice(ji,jj) = ( zmV_t(ji,jj) * v_ice(ji,jj) + zRHS + zTauO * v_ice(ji,jj) ) &
+ & / MAX( zepsi, zmV_t(ji,jj) + zTauO - zTauB )
+ ENDIF
+ !
ENDIF
+ ! v_ice = v_oce/100 if mass < zmmin & conc < zamin
+ v_ice(ji,jj) = ( v_ice(ji,jj)*zmsk01y(ji,jj) + v_oce(ji,jj) * 0.01_wp * (1._wp - zmsk01y(ji,jj)) ) * zmsk00y(ji,jj)
+ !
END_2D
+ !
IF( nn_hls == 1 ) THEN ; CALL lbc_lnk( 'icedyn_rhg_evp', v_ice, 'V', -1.0_wp )
ELSE ; CALL lbc_lnk( 'icedyn_rhg_evp', u_ice, 'U', -1.0_wp, v_ice, 'V', -1.0_wp )
ENDIF
@@ -745,8 +780,8 @@ CONTAINS
zten_i(ji,jj) = zdt
! shear**2 at T points (doc eq. A16)
- zds2 = ( zds(ji,jj ) * zds(ji,jj ) * e1e2f(ji,jj ) + zds(ji-1,jj ) * zds(ji-1,jj ) * e1e2f(ji-1,jj ) &
- & + zds(ji,jj-1) * zds(ji,jj-1) * e1e2f(ji,jj-1) + zds(ji-1,jj-1) * zds(ji-1,jj-1) * e1e2f(ji-1,jj-1) &
+ zds2 = ( ( zds(ji,jj ) * zds(ji,jj ) * e1e2f(ji,jj ) + zds(ji-1,jj ) * zds(ji-1,jj ) * e1e2f(ji-1,jj ) ) & ! add ()
+ & + ( zds(ji,jj-1) * zds(ji,jj-1) * e1e2f(ji,jj-1) + zds(ji-1,jj-1) * zds(ji-1,jj-1) * e1e2f(ji-1,jj-1) ) & ! NP rep
& ) * 0.25_wp * r1_e1e2t(ji,jj)
! maximum shear rate at T points (includes tension, output only)
@@ -756,24 +791,23 @@ CONTAINS
zshear(ji,jj) = SQRT( zds2 ) * zmsk(ji,jj)
! divergence at T points
- pdivu_i(ji,jj) = ( e2u(ji,jj) * u_ice(ji,jj) - e2u(ji-1,jj) * u_ice(ji-1,jj) &
- & + e1v(ji,jj) * v_ice(ji,jj) - e1v(ji,jj-1) * v_ice(ji,jj-1) &
+ pdivu_i(ji,jj) = ( ( e2u(ji,jj) * u_ice(ji,jj) - e2u(ji-1,jj) * u_ice(ji-1,jj) ) & ! add () for NP repro
+ & + ( e1v(ji,jj) * v_ice(ji,jj) - e1v(ji,jj-1) * v_ice(ji,jj-1) ) &
& ) * r1_e1e2t(ji,jj) * zmsk(ji,jj)
! delta at T points
zdelta(ji,jj) = SQRT( pdivu_i(ji,jj) * pdivu_i(ji,jj) + ( zdt2 + zds2 ) * z1_ecc2 ) * zmsk(ji,jj) ! delta
! delta* at T points (pdelta_i)
- rswitch = 1._wp - MAX( 0._wp, SIGN( 1._wp, -zdelta(ji,jj) ) ) ! 0 if delta=0
- pdelta_i(ji,jj) = zdelta(ji,jj) + rn_creepl * rswitch
+ IF( zdelta(ji,jj) > 0._wp ) THEN ; pdelta_i(ji,jj) = zdelta(ji,jj) + rn_creepl
+ ELSE ; pdelta_i(ji,jj) = 0._wp
+ ENDIF
! it seems that deformation used for advection and mech redistribution is delta*
! MV in principle adding creep limit is a regularization for viscosity not for delta
! delta_star should not (in my view) be used in a replacement for delta
-
END_2D
- CALL lbc_lnk( 'icedyn_rhg_evp', pshear_i, 'T', 1._wp, pdivu_i, 'T', 1._wp, pdelta_i, 'T', 1._wp, zten_i, 'T', 1._wp, &
- & zshear , 'T', 1._wp, zdelta , 'T', 1._wp, zs1 , 'T', 1._wp, zs2 , 'T', 1._wp, zs12, 'F', 1._wp )
+ CALL lbc_lnk( 'icedyn_rhg_evp', zs1 , 'T', 1._wp, zs2 , 'T', 1._wp, zs12 , 'F', 1._wp )
! --- Store the stress tensor for the next time step --- !
pstress1_i (:,:) = zs1 (:,:)
@@ -783,34 +817,25 @@ CONTAINS
! 5) diagnostics
!------------------------------------------------------------------------------!
! --- ice-ocean, ice-atm. & ice-oceanbottom(landfast) stresses --- !
- IF( iom_use('utau_oi') .OR. iom_use('vtau_oi') .OR. iom_use('utau_ai') .OR. iom_use('vtau_ai') .OR. &
- & iom_use('utau_bi') .OR. iom_use('vtau_bi') ) THEN
- !
- CALL lbc_lnk( 'icedyn_rhg_evp', ztaux_oi, 'U', -1.0_wp, ztauy_oi, 'V', -1.0_wp, &
- & ztaux_ai, 'U', -1.0_wp, ztauy_ai, 'V', -1.0_wp, &
- & ztaux_bi, 'U', -1.0_wp, ztauy_bi, 'V', -1.0_wp )
- !
- CALL iom_put( 'utau_oi' , ztaux_oi * zmsk00 )
- CALL iom_put( 'vtau_oi' , ztauy_oi * zmsk00 )
- CALL iom_put( 'utau_ai' , ztaux_ai * zmsk00 )
- CALL iom_put( 'vtau_ai' , ztauy_ai * zmsk00 )
- CALL iom_put( 'utau_bi' , ztaux_bi * zmsk00 )
- CALL iom_put( 'vtau_bi' , ztauy_bi * zmsk00 )
- ENDIF
+ IF( iom_use('utau_oi') ) CALL iom_put( 'utau_oi' , ztaux_oi(A2D(0)) * zmsk00 )
+ IF( iom_use('vtau_oi') ) CALL iom_put( 'vtau_oi' , ztauy_oi(A2D(0)) * zmsk00 )
+ IF( iom_use('utau_ai') ) CALL iom_put( 'utau_ai' , ztaux_ai(A2D(0)) * zmsk00 )
+ IF( iom_use('vtau_ai') ) CALL iom_put( 'vtau_ai' , ztauy_ai(A2D(0)) * zmsk00 )
+ IF( iom_use('utau_bi') ) CALL iom_put( 'utau_bi' , ztaux_bi(A2D(0)) * zmsk00 )
+ IF( iom_use('vtau_bi') ) CALL iom_put( 'vtau_bi' , ztauy_bi(A2D(0)) * zmsk00 )
! --- divergence, shear and strength --- !
- IF( iom_use('icediv') ) CALL iom_put( 'icediv' , pdivu_i * zmsk00 ) ! divergence
- IF( iom_use('iceshe') ) CALL iom_put( 'iceshe' , pshear_i * zmsk00 ) ! shear
- IF( iom_use('icestr') ) CALL iom_put( 'icestr' , strength * zmsk00 ) ! strength
- IF( iom_use('icedlt') ) CALL iom_put( 'icedlt' , zdelta * zmsk00 ) ! delta
+ IF( iom_use('icediv') ) CALL iom_put( 'icediv' , pdivu_i (A2D(0)) * zmsk00 ) ! divergence
+ IF( iom_use('iceshe') ) CALL iom_put( 'iceshe' , pshear_i(A2D(0)) * zmsk00 ) ! shear
+ IF( iom_use('icestr') ) CALL iom_put( 'icestr' , strength(A2D(0)) * zmsk00 ) ! strength
+ IF( iom_use('icedlt') ) CALL iom_put( 'icedlt' , zdelta (A2D(0)) * zmsk00 ) ! delta
! --- Stress tensor invariants (SIMIP diags) --- !
IF( iom_use('normstr') .OR. iom_use('sheastr') ) THEN
!
- ALLOCATE( zsig_I(jpi,jpj) , zsig_II(jpi,jpj) )
+ ALLOCATE( zsig_I(A2D(0)) , zsig_II(A2D(0)) )
!
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
-
+ DO_2D( 0, 0, 0, 0 )
! Ice stresses
! sigma1, sigma2, sigma12 are some recombination of the stresses (HD MWR002, Bouillon et al., OM2013)
! not to be confused with stress tensor components, stress invariants, or stress principal components
@@ -825,8 +850,8 @@ CONTAINS
END_2D
!
- IF( iom_use('normstr') ) CALL iom_put( 'normstr', zsig_I (:,:) * zmsk00(:,:) ) ! Normal stress
- IF( iom_use('sheastr') ) CALL iom_put( 'sheastr', zsig_II(:,:) * zmsk00(:,:) ) ! Maximum shear stress
+ IF( iom_use('normstr') ) CALL iom_put( 'normstr', zsig_I (:,:) * zmsk00 ) ! Normal stress
+ IF( iom_use('sheastr') ) CALL iom_put( 'sheastr', zsig_II(:,:) * zmsk00 ) ! Maximum shear stress
DEALLOCATE ( zsig_I, zsig_II )
@@ -838,9 +863,9 @@ CONTAINS
! Recommendation 2 : for EVP, no need to use viscosities at last iteration (stress is properly iterated)
IF( iom_use('sig1_pnorm') .OR. iom_use('sig2_pnorm') ) THEN
!
- ALLOCATE( zsig1_p(jpi,jpj) , zsig2_p(jpi,jpj) , zsig_I(jpi,jpj) , zsig_II(jpi,jpj) )
+ ALLOCATE( zsig1_p(A2D(0)) , zsig2_p(A2D(0)) , zsig_I(A2D(0)) , zsig_II(A2D(0)) )
!
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
! For EVP solvers, ice stresses at current iterates can be used
! following Lemieux & Dupont (2020)
@@ -859,33 +884,26 @@ CONTAINS
zsig2_p(ji,jj) = ( zsig_I(ji,jj) - zsig_II(ji,jj) ) * z1_strength
END_2D
!
- CALL iom_put( 'sig1_pnorm' , zsig1_p * zmsk00 )
- CALL iom_put( 'sig2_pnorm' , zsig2_p * zmsk00 )
+ CALL iom_put( 'sig1_pnorm' , zsig1_p(:,:) * zmsk00 )
+ CALL iom_put( 'sig2_pnorm' , zsig2_p(:,:) * zmsk00 )
DEALLOCATE( zsig1_p , zsig2_p , zsig_I, zsig_II )
ENDIF
! --- SIMIP --- !
- IF( iom_use('dssh_dx') .OR. iom_use('dssh_dy') .OR. &
- & iom_use('corstrx') .OR. iom_use('corstry') .OR. iom_use('intstrx') .OR. iom_use('intstry') ) THEN
- !
- CALL lbc_lnk( 'icedyn_rhg_evp', zspgU, 'U', -1.0_wp, zspgV, 'V', -1.0_wp, &
- & zCorU, 'U', -1.0_wp, zCorV, 'V', -1.0_wp, zfU, 'U', -1.0_wp, zfV, 'V', -1.0_wp )
-
- CALL iom_put( 'dssh_dx' , zspgU * zmsk00 ) ! Sea-surface tilt term in force balance (x)
- CALL iom_put( 'dssh_dy' , zspgV * zmsk00 ) ! Sea-surface tilt term in force balance (y)
- CALL iom_put( 'corstrx' , zCorU * zmsk00 ) ! Coriolis force term in force balance (x)
- CALL iom_put( 'corstry' , zCorV * zmsk00 ) ! Coriolis force term in force balance (y)
- CALL iom_put( 'intstrx' , zfU * zmsk00 ) ! Internal force term in force balance (x)
- CALL iom_put( 'intstry' , zfV * zmsk00 ) ! Internal force term in force balance (y)
- ENDIF
+ IF( iom_use('dssh_dx') ) CALL iom_put( 'dssh_dx' , zspgU(A2D(0)) * zmsk00 ) ! Sea-surface tilt term in force balance (x)
+ IF( iom_use('dssh_dy') ) CALL iom_put( 'dssh_dy' , zspgV(A2D(0)) * zmsk00 ) ! Sea-surface tilt term in force balance (y)
+ IF( iom_use('corstrx') ) CALL iom_put( 'corstrx' , zCorU(A2D(0)) * zmsk00 ) ! Coriolis force term in force balance (x)
+ IF( iom_use('corstry') ) CALL iom_put( 'corstry' , zCorV(A2D(0)) * zmsk00 ) ! Coriolis force term in force balance (y)
+ IF( iom_use('intstrx') ) CALL iom_put( 'intstrx' , zfU (A2D(0)) * zmsk00 ) ! Internal force term in force balance (x)
+ IF( iom_use('intstry') ) CALL iom_put( 'intstry' , zfV (A2D(0)) * zmsk00 ) ! Internal force term in force balance (y)
IF( iom_use('xmtrpice') .OR. iom_use('ymtrpice') .OR. &
& iom_use('xmtrpsnw') .OR. iom_use('ymtrpsnw') .OR. iom_use('xatrp') .OR. iom_use('yatrp') ) THEN
!
- ALLOCATE( zdiag_xmtrp_ice(jpi,jpj) , zdiag_ymtrp_ice(jpi,jpj) , &
- & zdiag_xmtrp_snw(jpi,jpj) , zdiag_ymtrp_snw(jpi,jpj) , zdiag_xatrp(jpi,jpj) , zdiag_yatrp(jpi,jpj) )
+ ALLOCATE( zdiag_xmtrp_ice(A2D(0)) , zdiag_ymtrp_ice(A2D(0)) , &
+ & zdiag_xmtrp_snw(A2D(0)) , zdiag_ymtrp_snw(A2D(0)) , zdiag_xatrp(A2D(0)) , zdiag_yatrp(A2D(0)) )
!
DO_2D( 0, 0, 0, 0 )
! 2D ice mass, snow mass, area transport arrays (X, Y)
@@ -903,10 +921,6 @@ CONTAINS
END_2D
- CALL lbc_lnk( 'icedyn_rhg_evp', zdiag_xmtrp_ice, 'U', -1.0_wp, zdiag_ymtrp_ice, 'V', -1.0_wp, &
- & zdiag_xmtrp_snw, 'U', -1.0_wp, zdiag_ymtrp_snw, 'V', -1.0_wp, &
- & zdiag_xatrp , 'U', -1.0_wp, zdiag_yatrp , 'V', -1.0_wp )
-
CALL iom_put( 'xmtrpice' , zdiag_xmtrp_ice ) ! X-component of sea-ice mass transport (kg/s)
CALL iom_put( 'ymtrpice' , zdiag_ymtrp_ice ) ! Y-component of sea-ice mass transport
CALL iom_put( 'xmtrpsnw' , zdiag_xmtrp_snw ) ! X-component of snow mass transport (kg/s)
@@ -923,11 +937,11 @@ CONTAINS
IF( nn_rhg_chkcvg == 1 .OR. nn_rhg_chkcvg == 2 ) THEN
IF( iom_use('uice_cvg') ) THEN
IF( ln_aEVP ) THEN ! output: beta * ( u(t=nn_nevp) - u(t=nn_nevp-1) )
- CALL iom_put( 'uice_cvg', MAX( ABS( u_ice(:,:) - zu_ice(:,:) ) * zbeta(:,:) * umask(:,:,1) , &
- & ABS( v_ice(:,:) - zv_ice(:,:) ) * zbeta(:,:) * vmask(:,:,1) ) * zmsk15(:,:) )
+ CALL iom_put( 'uice_cvg', MAX( ABS( u_ice(A2D(0)) - zu_ice(:,:) ) * zbeta(A2D(0)) * umask(A2D(0),1) , &
+ & ABS( v_ice(A2D(0)) - zv_ice(:,:) ) * zbeta(A2D(0)) * vmask(A2D(0),1) ) * zmsk15(:,:) )
ELSE ! output: nn_nevp * ( u(t=nn_nevp) - u(t=nn_nevp-1) )
- CALL iom_put( 'uice_cvg', REAL( nn_nevp ) * MAX( ABS( u_ice(:,:) - zu_ice(:,:) ) * umask(:,:,1) , &
- & ABS( v_ice(:,:) - zv_ice(:,:) ) * vmask(:,:,1) ) * zmsk15(:,:) )
+ CALL iom_put( 'uice_cvg', REAL( nn_nevp ) * MAX( ABS( u_ice(A2D(0)) - zu_ice(:,:) ) * umask(A2D(0),1) , &
+ & ABS( v_ice(A2D(0)) - zv_ice(:,:) ) * vmask(A2D(0),1) ) * zmsk15(:,:) )
ENDIF
ENDIF
ENDIF
@@ -948,17 +962,18 @@ CONTAINS
!!
!! ** Note : for the first sub-iteration, uice_cvg is set to 0 (too large otherwise)
!!----------------------------------------------------------------------
- INTEGER , INTENT(in) :: kt, kiter, kitermax ! ocean time-step index
- REAL(wp), DIMENSION(:,:), INTENT(in) :: pu, pv, pub, pvb ! now and before velocities
- REAL(wp), DIMENSION(:,:), INTENT(in) :: pmsk15
+ INTEGER , INTENT(in) :: kt, kiter, kitermax ! ocean time-step index
+ REAL(wp), DIMENSION(:,:) , INTENT(in) :: pu, pv ! now velocities
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pub, pvb ! before velocities
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pmsk15
!!
INTEGER :: it, idtime, istatus
INTEGER :: ji, jj ! dummy loop indices
REAL(wp) :: zresm ! local real
CHARACTER(len=20) :: clname
LOGICAL :: ll_maxcvg
- REAL(wp), DIMENSION(jpi,jpj,2) :: zres
- REAL(wp), DIMENSION(2) :: ztmp
+ REAL(wp), DIMENSION(A2D(0),2) :: zres
+ REAL(wp), DIMENSION(2) :: ztmp
!!----------------------------------------------------------------------
ll_maxcvg = .FALSE.
!
@@ -1137,7 +1152,8 @@ CONTAINS
ENDIF
!
DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 )
- ztra = - ( zfu_ups(ji,jj) - zfu_ups(ji-1,jj) + zfv_ups(ji,jj) - zfv_ups(ji,jj-1) )
+ ztra = - ( ( zfu_ups(ji,jj) - zfu_ups(ji-1,jj) ) & ! add () for NP repro
+ & + ( zfv_ups(ji,jj) - zfv_ups(ji,jj-1) ) )
pt(ji,jj,jl) = ( pt(ji,jj,jl) + ztra * pdt * r1_e1e2t(ji,jj) ) * tmask(ji,jj,1)
END_2D
END DO
diff --git a/src/ICE/icedyn_rhg_vp.F90 b/src/ICE/icedyn_rhg_vp.F90
index c087f97a8c2cad4cd03c234b646906e34eeaf515..53073a428a35e5f8dd37e56e7b26db449c3353ff 100644
--- a/src/ICE/icedyn_rhg_vp.F90
+++ b/src/ICE/icedyn_rhg_vp.F90
@@ -142,6 +142,7 @@ CONTAINS
INTEGER :: nn_zebra_vp ! number of zebra steps
!
+ REAL(wp) :: zswitch
REAL(wp) :: zrhoco ! rho0 * rn_cio
REAL(wp) :: ecc2, z1_ecc2 ! square of yield ellipse eccenticity
REAL(wp) :: zglob_area ! global ice area for diagnostics
@@ -328,11 +329,14 @@ CONTAINS
zmU_t(ji,jj) = zmassU_t(ji,jj) * u_ice(ji,jj)
! Ocean currents at U-V points
- ! (brackets added to fix the order of floating point operations for halo 1 - halo 2 compatibility)
+ ! (brackets added to fix the order of floating point operations for the North Pole reproducibility
v_oceU(ji,jj) = 0.25_wp * ( (v_oce(ji,jj) + v_oce(ji,jj-1)) + (v_oce(ji+1,jj) + v_oce(ji+1,jj-1)) ) * umask(ji,jj,1)
! Wind stress
- ztaux_ai(ji,jj) = za_iU(ji,jj) * utau_ice(ji,jj)
+ ! Note the use of 0.5*(2-umask) in order to unmask the stress along coastlines
+ ! and the use of MAX(tmask(i,j),tmask(i+1,j) is to mask tau over ice shelves
+ ztaux_ai(ji,jj) = za_iU(ji,jj) * 0.5_wp * ( utau_ice(ji,jj) + utau_ice(ji+1,jj) ) * &
+ & ( 2. - umask(ji,jj,1) ) * MAX( tmask(ji,jj,1), tmask(ji+1,jj,1) )
! Force due to sea surface tilt(- m*g*GRAD(ssh))
zspgU(ji,jj) = - zmassU * grav * ( zsshdyn(ji+1,jj) - zsshdyn(ji,jj) ) * r1_e1u(ji,jj)
@@ -365,11 +369,14 @@ CONTAINS
zmV_t(ji,jj) = zmassV_t(ji,jj) * v_ice(ji,jj)
! Ocean currents at U-V points
- ! (brackets added to fix the order of floating point operations for halo 1 - halo 2 compatibility)
+ ! (brackets added to fix the order of floating point operations for the North Pole reproducibility
u_oceV(ji,jj) = 0.25_wp * ( (u_oce(ji,jj) + u_oce(ji-1,jj)) + (u_oce(ji,jj+1) + u_oce(ji-1,jj+1)) ) * vmask(ji,jj,1)
! Wind stress
- ztauy_ai(ji,jj) = za_iV(ji,jj) * vtau_ice(ji,jj)
+ ! Note the use of 0.5*(2-umask) in order to unmask the stress along coastlines
+ ! and the use of MAX(tmask(i,j),tmask(i+1,j) is to mask tau over ice shelves
+ ztauy_ai(ji,jj) = za_iV(ji,jj) * 0.5_wp * ( vtau_ice(ji,jj) + vtau_ice(ji,jj+1) ) * &
+ & ( 2. - vmask(ji,jj,1) ) * MAX( tmask(ji,jj,1), tmask(ji,jj+1,1) )
! Force due to sea surface tilt(- m*g*GRAD(ssh))
zspgV(ji,jj) = - zmassV * grav * ( zsshdyn(ji,jj+1) - zsshdyn(ji,jj) ) * r1_e2v(ji,jj)
@@ -430,14 +437,15 @@ CONTAINS
! loop to jpi,jpj to avoid making a communication for zs1,zs2,zs12
! shear**2 at T points (doc eq. A16)
- zds2 = ( zds(ji,jj ) * zds(ji,jj ) * e1e2f(ji,jj ) + zds(ji-1,jj ) * zds(ji-1,jj ) * e1e2f(ji-1,jj ) &
- & + zds(ji,jj-1) * zds(ji,jj-1) * e1e2f(ji,jj-1) + zds(ji-1,jj-1) * zds(ji-1,jj-1) * e1e2f(ji-1,jj-1) &
+ ! (brackets added to fix the order of floating point operations for the North Pole reproducibility
+ zds2 = ( ( zds(ji,jj ) * zds(ji,jj ) * e1e2f(ji,jj ) + zds(ji-1,jj ) * zds(ji-1,jj ) * e1e2f(ji-1,jj ) ) &
+ & + ( zds(ji,jj-1) * zds(ji,jj-1) * e1e2f(ji,jj-1) + zds(ji-1,jj-1) * zds(ji-1,jj-1) * e1e2f(ji-1,jj-1) ) &
& ) * 0.25_wp * r1_e1e2t(ji,jj)
! divergence at T points
- ! (brackets added to fix the order of floating point operations for halo 1 - halo 2 compatibility)
- zdiv = ( (e2u(ji,jj) * zu_c(ji,jj) - e2u(ji-1,jj) * zu_c(ji-1,jj)) &
- & + (e1v(ji,jj) * zv_c(ji,jj) - e1v(ji,jj-1) * zv_c(ji,jj-1)) &
+ ! (brackets added to fix the order of floating point operations for the North Pole reproducibility
+ zdiv = ( ( e2u(ji,jj) * zu_c(ji,jj) - e2u(ji-1,jj) * zu_c(ji-1,jj) ) &
+ & + ( e1v(ji,jj) * zv_c(ji,jj) - e1v(ji,jj-1) * zv_c(ji,jj-1) ) &
& ) * r1_e1e2t(ji,jj)
zdiv2 = zdiv * zdiv
@@ -468,7 +476,7 @@ CONTAINS
DO_2D( nn_hls, nn_hls-1, nn_hls, nn_hls-1 )! 1-> jpj-1; 1->jpi-1
! P/delta* at F points
- ! (brackets added to fix the order of floating point operations for halo 1 - halo 2 compatibility)
+ ! (brackets added to fix the order of floating point operations for the North Pole reproducibility
zvisc_f = 0.25_wp * ( (zvisc_t(ji,jj) + zvisc_t(ji+1,jj)) + (zvisc_t(ji,jj+1) + zvisc_t(ji+1,jj+1)) )
! Temporary zef factor at F-point
@@ -483,7 +491,7 @@ CONTAINS
DO_2D( nn_hls, nn_hls-1, nn_hls-1, nn_hls )
!--- ice u-velocity @V points, v-velocity @U points (for non-linear drag computation)
- ! (brackets added to fix the order of floating point operations for halo 1 - halo 2 compatibility)
+ ! (brackets added to fix the order of floating point operations for the North Pole reproducibility
zv_cU = 0.25_wp * ( (zv_c(ji,jj) + zv_c(ji,jj-1)) + (zv_c(ji+1,jj) + zv_c(ji+1,jj-1)) ) * umask(ji,jj,1)
!--- non-linear drag coefficients (need to be updated at each outer loop, see Lemieux and Tremblay JGR09, p.3, beginning of Section 3)
@@ -503,7 +511,7 @@ CONTAINS
DO_2D( nn_hls-1, nn_hls, nn_hls, nn_hls-1 )
!--- ice u-velocity @V points, v-velocity @U points (for non-linear drag computation)
- ! (brackets added to fix the order of floating point operations for halo 1 - halo 2 compatibility)
+ ! (brackets added to fix the order of floating point operations for the North Pole reproducibility
zu_cV = 0.25_wp * ( (zu_c(ji,jj) + zu_c(ji-1,jj)) + (zu_c(ji,jj+1) + zu_c(ji-1,jj+1)) ) * vmask(ji,jj,1)
!--- non-linear drag coefficients (need to be updated at each outer loop, see Lemieux and Tremblay JGR09, p.3, beginning of Section 3)
@@ -727,7 +735,6 @@ CONTAINS
!--- mitgcm computes initial value of residual here...
i_inn_tot = i_inn_tot + 1
- ! l_full_nf_update = i_inn_tot == nn_nvp ! false: disable full North fold update (performances) for iter = 1 to nn_nevp-1
zu_b(:,:) = u_ice(:,:) ! velocity at previous inner-iterate
zv_b(:,:) = v_ice(:,:)
@@ -1061,8 +1068,9 @@ CONTAINS
DO_2D( 0, 0, 0, 0 ) ! 2->jpj-1; 2->jpi-1
! shear**2 at T points (doc eq. A16)
- zds2 = ( zds(ji,jj ) * zds(ji,jj ) * e1e2f(ji,jj ) + zds(ji-1,jj ) * zds(ji-1,jj ) * e1e2f(ji-1,jj ) &
- & + zds(ji,jj-1) * zds(ji,jj-1) * e1e2f(ji,jj-1) + zds(ji-1,jj-1) * zds(ji-1,jj-1) * e1e2f(ji-1,jj-1) &
+ ! (brackets added to fix the order of floating point operations for the North Pole reproducibility
+ zds2 = ( ( zds(ji,jj ) * zds(ji,jj ) * e1e2f(ji,jj ) + zds(ji-1,jj ) * zds(ji-1,jj ) * e1e2f(ji-1,jj ) ) &
+ & + ( zds(ji,jj-1) * zds(ji,jj-1) * e1e2f(ji,jj-1) + zds(ji-1,jj-1) * zds(ji-1,jj-1) * e1e2f(ji-1,jj-1) ) &
& ) * 0.25_wp * r1_e1e2t(ji,jj)
! tension**2 at T points
@@ -1080,8 +1088,9 @@ CONTAINS
zshear(ji,jj) = SQRT( zds2 ) * zmsk(ji,jj)
! divergence at T points
- pdivu_i(ji,jj) = ( e2u(ji,jj) * u_ice(ji,jj) - e2u(ji-1,jj) * u_ice(ji-1,jj) &
- & + e1v(ji,jj) * v_ice(ji,jj) - e1v(ji,jj-1) * v_ice(ji,jj-1) &
+ ! (brackets added to fix the order of floating point operations for the North Pole reproducibility
+ pdivu_i(ji,jj) = ( ( e2u(ji,jj) * u_ice(ji,jj) - e2u(ji-1,jj) * u_ice(ji-1,jj) ) &
+ & + ( e1v(ji,jj) * v_ice(ji,jj) - e1v(ji,jj-1) * v_ice(ji,jj-1) ) &
& ) * r1_e1e2t(ji,jj) * zmsk(ji,jj)
! delta at T points
@@ -1089,8 +1098,8 @@ CONTAINS
zdelta(ji,jj) = zfac
! delta* at T points
- rswitch = 1._wp - MAX( 0._wp, SIGN( 1._wp, -zfac ) ) ! 0 if delta=0
- pdelta_i(ji,jj) = zfac + rn_creepl ! * rswitch
+ zswitch = 1._wp - MAX( 0._wp, SIGN( 1._wp, -zfac ) ) ! 0 if delta=0
+ pdelta_i(ji,jj) = zfac + rn_creepl ! * zswitch
END_2D
@@ -1152,22 +1161,22 @@ CONTAINS
!--- Recalculate oceanic stress at last inner iteration
DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) ! 2->jpj-1; 2->jpi-1
- !--- ice u-velocity @V points, v-velocity @U points (for non-linear drag computation)
- zu_cV = 0.25_wp * ( u_ice(ji,jj) + u_ice(ji-1,jj) + u_ice(ji,jj+1) + u_ice(ji-1,jj+1) ) * vmask(ji,jj,1)
- zv_cU = 0.25_wp * ( v_ice(ji,jj) + v_ice(ji,jj-1) + v_ice(ji+1,jj) + v_ice(ji+1,jj-1) ) * umask(ji,jj,1)
-
- !--- non-linear drag coefficients (need to be updated at each outer loop, see Lemieux and Tremblay JGR09, p.3, beginning of Section 3)
- zCwU(ji,jj) = za_iU(ji,jj) * zrhoco * SQRT( ( u_ice(ji,jj) - u_oce (ji,jj) ) * ( u_ice(ji,jj) - u_oce (ji,jj) ) &
- & + ( zv_cU - v_oceU(ji,jj) ) * ( zv_cU - v_oceU(ji,jj) ) )
- zCwV(ji,jj) = za_iV(ji,jj) * zrhoco * SQRT( ( v_ice(ji,jj) - v_oce (ji,jj) ) * ( v_ice(ji,jj) - v_oce (ji,jj) ) &
- & + ( zu_cV - u_oceV(ji,jj) ) * ( zu_cV - u_oceV(ji,jj) ) )
-
- !--- Ocean-ice stress
- ztaux_oi(ji,jj) = zCwU(ji,jj) * ( u_oce(ji,jj) - u_ice(ji,jj) )
- ztauy_oi(ji,jj) = zCwV(ji,jj) * ( v_oce(ji,jj) - v_ice(ji,jj) )
-
+ !--- ice u-velocity @V points, v-velocity @U points (for non-linear drag computation)
+ ! (brackets added to fix the order of floating point operations for the North Pole reproducibility
+ zu_cV = 0.25_wp * ( ( u_ice(ji,jj) + u_ice(ji-1,jj) ) + ( u_ice(ji,jj+1) + u_ice(ji-1,jj+1) ) ) * vmask(ji,jj,1)
+ zv_cU = 0.25_wp * ( ( v_ice(ji,jj) + v_ice(ji,jj-1) ) + ( v_ice(ji+1,jj) + v_ice(ji+1,jj-1) ) ) * umask(ji,jj,1)
+
+ !--- non-linear drag coefficients (need to be updated at each outer loop, see Lemieux and Tremblay JGR09, p.3, beginning of Section 3)
+ zCwU(ji,jj) = za_iU(ji,jj) * zrhoco * SQRT( ( u_ice(ji,jj) - u_oce (ji,jj) ) * ( u_ice(ji,jj) - u_oce (ji,jj) ) &
+ & + ( zv_cU - v_oceU(ji,jj) ) * ( zv_cU - v_oceU(ji,jj) ) )
+ zCwV(ji,jj) = za_iV(ji,jj) * zrhoco * SQRT( ( v_ice(ji,jj) - v_oce (ji,jj) ) * ( v_ice(ji,jj) - v_oce (ji,jj) ) &
+ & + ( zu_cV - u_oceV(ji,jj) ) * ( zu_cV - u_oceV(ji,jj) ) )
+
+ !--- Ocean-ice stress
+ ztaux_oi(ji,jj) = zCwU(ji,jj) * ( u_oce(ji,jj) - u_ice(ji,jj) )
+ ztauy_oi(ji,jj) = zCwV(ji,jj) * ( v_oce(ji,jj) - v_ice(ji,jj) )
+
END_2D
-
!
CALL lbc_lnk( 'icedyn_rhg_vp', ztaux_oi, 'U', -1., ztauy_oi, 'V', -1., ztaux_ai, 'U', -1., ztauy_ai, 'V', -1. ) !, &
! & ztaux_bi, 'U', -1., ztauy_bi, 'V', -1. )
@@ -1562,17 +1571,18 @@ CONTAINS
DO_2D( 0, 0, 0, 0 ) !clem check bounds
- zu_res(ji,jj) = ( prhsu(ji,jj) + pDU(ji,jj) * pu(ji,jj-1) + pEU(ji,jj) * pu(ji,jj+1) &
- & - pAU(ji,jj) * pu(ji-1,jj) - pBU(ji,jj) * pu(ji,jj) - pCU(ji,jj) * pu(ji+1,jj) )
- zv_res(ji,jj) = ( prhsv(ji,jj) + pDV(ji,jj) * pv(ji-1,jj) + pEV(ji,jj) * pv(ji+1,jj) &
- & - pAV(ji,jj) * pv(ji,jj-1) - pBV(ji,jj) * pv(ji,jj) - pCV(ji,jj) * pv(ji,jj+1) )
-
-! zu_res(ji,jj) = pFU(ji,jj) - pAU(ji,jj) * pu(ji-1,jj) - pBU(ji,jj) * pu(ji,jj) - pCU(ji,jj) * pu(ji+1,jj)
-! zv_res(ji,jj) = pFV(ji,jj) - pAV(ji,jj) * pv(ji,jj-1) - pBV(ji,jj) * pv(ji,jj) - pCV(ji,jj) * pv(ji,jj+1)
-
- zu_res(ji,jj) = SQRT( zu_res(ji,jj) * zu_res(ji,jj) ) * umask(ji,jj,1) * pat_iu(ji,jj) * e1e2u(ji,jj) * z1_pglob_area
- zv_res(ji,jj) = SQRT( zv_res(ji,jj) * zv_res(ji,jj) ) * vmask(ji,jj,1) * pat_iv(ji,jj) * e1e2v(ji,jj) * z1_pglob_area
-
+ ! (brackets added to fix the order of floating point operations for the North Pole reproducibility
+ zu_res(ji,jj) = prhsu(ji,jj) + ( pDU(ji,jj) * pu(ji ,jj-1) + pEU(ji,jj) * pu(ji ,jj+1) ) &
+ & - pBU(ji,jj) * pu(ji,jj) - ( pAU(ji,jj) * pu(ji-1,jj ) + pCU(ji,jj) * pu(ji+1,jj ) )
+ zv_res(ji,jj) = prhsv(ji,jj) + ( pDV(ji,jj) * pv(ji-1,jj ) + pEV(ji,jj) * pv(ji+1,jj ) ) &
+ & - pBV(ji,jj) * pv(ji,jj) - ( pAV(ji,jj) * pv(ji ,jj-1) + pCV(ji,jj) * pv(ji ,jj+1) )
+
+ ! zu_res(ji,jj) = pFU(ji,jj) - pAU(ji,jj) * pu(ji-1,jj) - pBU(ji,jj) * pu(ji,jj) - pCU(ji,jj) * pu(ji+1,jj)
+ ! zv_res(ji,jj) = pFV(ji,jj) - pAV(ji,jj) * pv(ji,jj-1) - pBV(ji,jj) * pv(ji,jj) - pCV(ji,jj) * pv(ji,jj+1)
+
+ zu_res(ji,jj) = SQRT( zu_res(ji,jj) * zu_res(ji,jj) ) * umask(ji,jj,1) * pat_iu(ji,jj) * e1e2u(ji,jj) * z1_pglob_area
+ zv_res(ji,jj) = SQRT( zv_res(ji,jj) * zv_res(ji,jj) ) * vmask(ji,jj,1) * pat_iv(ji,jj) * e1e2v(ji,jj) * z1_pglob_area
+
END_2D
! Global ice-concentration, grid-cell-area weighted mean
@@ -1602,21 +1612,22 @@ CONTAINS
DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 )
- zu_res(ji,jj) = ( prhsu(ji,jj) + pDU(ji,jj) * pu(ji,jj-1) + pEU(ji,jj) * pu(ji,jj+1) &
- & - pAU(ji,jj) * pu(ji-1,jj) - pBU(ji,jj) * pu(ji,jj) - pCU(ji,jj) * pu(ji+1,jj) )
- zv_res(ji,jj) = ( prhsv(ji,jj) + pDV(ji,jj) * pv(ji-1,jj) + pEV(ji,jj) * pv(ji+1,jj) &
- & - pAV(ji,jj) * pv(ji,jj-1) - pBV(ji,jj) * pv(ji,jj) - pCV(ji,jj) * pv(ji,jj+1) )
-
- zu_res(ji,jj) = SQRT( zu_res(ji,jj) * zu_res(ji,jj) ) * umask(ji,jj,1)
- zv_res(ji,jj) = SQRT( zv_res(ji,jj) * zv_res(ji,jj) ) * vmask(ji,jj,1)
-
+ ! (brackets added to fix the order of floating point operations for the North Pole reproducibility
+ zu_res(ji,jj) = prhsu(ji,jj) + ( pDU(ji,jj) * pu(ji ,jj-1) + pEU(ji,jj) * pu(ji ,jj+1) ) &
+ & - pBU(ji,jj) * pu(ji,jj) - ( pAU(ji,jj) * pu(ji-1,jj ) + pCU(ji,jj) * pu(ji+1,jj ) )
+ zv_res(ji,jj) = prhsv(ji,jj) + ( pDV(ji,jj) * pv(ji-1,jj ) + pEV(ji,jj) * pv(ji+1,jj ) ) &
+ & - pBV(ji,jj) * pv(ji,jj) - ( pAV(ji,jj) * pv(ji ,jj-1) + pCV(ji,jj) * pv(ji ,jj+1) )
+
+ zu_res(ji,jj) = SQRT( zu_res(ji,jj) * zu_res(ji,jj) ) * umask(ji,jj,1)
+ zv_res(ji,jj) = SQRT( zv_res(ji,jj) * zv_res(ji,jj) ) * vmask(ji,jj,1)
+
END_2D
IF( nn_hls == 1 ) CALL lbc_lnk( 'icedyn_rhg_cvg_vp', zu_res, 'U', 1., zv_res , 'V', 1. )
DO_2D( 0, 0, 0, 0 ) !clem check bounds
- pvel_res(ji,jj) = 0.25_wp * ( zu_res(ji-1,jj) + zu_res(ji,jj) + zv_res(ji,jj-1) + zv_res(ji,jj) )
+ pvel_res(ji,jj) = 0.25_wp * ( ( zu_res(ji-1,jj) + zu_res(ji,jj) ) + ( zv_res(ji,jj-1) + zv_res(ji,jj) ) )
END_2D
CALL lbc_lnk( 'icedyn_rhg_cvg_vp', pvel_res, 'T', 1. )
diff --git a/src/ICE/iceistate.F90 b/src/ICE/iceistate.F90
index 97c783148d78866bec1bf7f9aa9e240e91d1ed7a..dfba3873bfadde6c3c11c8de860642bdcc5d361b 100644
--- a/src/ICE/iceistate.F90
+++ b/src/ICE/iceistate.F90
@@ -22,10 +22,6 @@ MODULE iceistate
USE eosbn2 ! equation of state
# if defined key_qco
USE domqco ! Quasi-Eulerian coord.
-# elif defined key_linssh
- ! ! Fix in time coord.
-# else
- USE domvvl ! Variable volume
# endif
USE ice ! sea-ice: variables
USE ice1D ! sea-ice: thermodynamics variables
@@ -37,6 +33,7 @@ MODULE iceistate
USE lib_mpp ! MPP library
USE lib_fortran ! fortran utilities (glob_sum + no signed zero)
USE fldread ! read input fields
+ USE lbclnk ! ocean lateral boundary conditions (or mpp link)
# if defined key_agrif
USE agrif_oce
@@ -113,11 +110,11 @@ CONTAINS
INTEGER :: ji, jj, jk, jl ! dummy loop indices
REAL(wp) :: ztmelts, zsshadj, area
INTEGER , DIMENSION(4) :: itest
- REAL(wp), DIMENSION(jpi,jpj) :: z2d
REAL(wp), DIMENSION(jpi,jpj) :: zswitch ! ice indicator
- REAL(wp), DIMENSION(jpi,jpj) :: zht_i_ini, zat_i_ini, ztm_s_ini !data from namelist or nc file
- REAL(wp), DIMENSION(jpi,jpj) :: zt_su_ini, zht_s_ini, zsm_i_ini, ztm_i_ini !data from namelist or nc file
- REAL(wp), DIMENSION(jpi,jpj) :: zapnd_ini, zhpnd_ini, zhlid_ini !data from namelist or nc file
+ REAL(wp), DIMENSION(A2D(0)) :: zmsk ! ice indicator
+ REAL(wp), DIMENSION(A2D(0)) :: zht_i_ini, zat_i_ini, ztm_s_ini !data from namelist or nc file
+ REAL(wp), DIMENSION(A2D(0)) :: zt_su_ini, zht_s_ini, zsm_i_ini, ztm_i_ini !data from namelist or nc file
+ REAL(wp), DIMENSION(A2D(0)) :: zapnd_ini, zhpnd_ini, zhlid_ini !data from namelist or nc file
REAL(wp), DIMENSION(jpi,jpj,jpl) :: zti_3d , zts_3d !temporary arrays
!!
REAL(wp), DIMENSION(:,:), ALLOCATABLE :: zhi_2d, zhs_2d, zai_2d, zti_2d, zts_2d, ztsu_2d, zsi_2d, zaip_2d, zhip_2d, zhil_2d
@@ -132,56 +129,62 @@ CONTAINS
!---------------------------
!
! basal temperature (considered at freezing point) [Kelvin]
- CALL eos_fzp( sss_m(:,:), t_bo(:,:) )
- t_bo(:,:) = ( t_bo(:,:) + rt0 ) * tmask(:,:,1)
+ CALL eos_fzp( sss_m(:,:), t_bo(:,:), kbnd=0 )
+ t_bo(:,:) = ( t_bo(:,:) + rt0 ) * smask0(:,:)
!
- ! surface temperature and conductivity
DO jl = 1, jpl
- t_su (:,:,jl) = rt0 * tmask(:,:,1) ! temp at the surface
- cnd_ice(:,:,jl) = 0._wp ! initialisation of the effective conductivity at the top of ice/snow (ln_cndflx=T)
- END DO
- !
- ! ice and snw temperatures
- DO jl = 1, jpl
- DO jk = 1, nlay_i
- t_i(:,:,jk,jl) = rt0 * tmask(:,:,1)
- END DO
- DO jk = 1, nlay_s
- t_s(:,:,jk,jl) = rt0 * tmask(:,:,1)
- END DO
- END DO
- !
- ! specific temperatures for coupled runs
- tn_ice (:,:,:) = t_i (:,:,1,:)
- t1_ice (:,:,:) = t_i (:,:,1,:)
-
- ! heat contents
- e_i (:,:,:,:) = 0._wp
- e_s (:,:,:,:) = 0._wp
-
- ! general fields
- a_i (:,:,:) = 0._wp
- v_i (:,:,:) = 0._wp
- v_s (:,:,:) = 0._wp
- sv_i(:,:,:) = 0._wp
- oa_i(:,:,:) = 0._wp
- !
- h_i (:,:,:) = 0._wp
- h_s (:,:,:) = 0._wp
- s_i (:,:,:) = 0._wp
- o_i (:,:,:) = 0._wp
- !
- ! melt ponds
- a_ip (:,:,:) = 0._wp
- v_ip (:,:,:) = 0._wp
- v_il (:,:,:) = 0._wp
- a_ip_eff (:,:,:) = 0._wp
- h_ip (:,:,:) = 0._wp
- h_il (:,:,:) = 0._wp
+ ! == reduced arrays == !
+ DO_2D( 0, 0, 0, 0 )
+ !
+ cnd_ice(ji,jj,jl) = 0._wp ! conductivity at the ice top
+ !
+ tn_ice(ji,jj,jl) = t_i (ji,jj,1,jl) ! temp for coupled runs
+ t1_ice(ji,jj,jl) = t_i (ji,jj,1,jl) ! temp for coupled runs
+ !
+ a_ip_eff(ji,jj,jl) = 0._wp ! melt pond effective fraction
+ END_2D
+ !
+ ! == full arrays == !
+ DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ !
+ ! heat contents
+ DO jk = 1, nlay_i
+ e_i(ji,jj,jk,jl) = 0._wp
+ t_i(ji,jj,jk,jl) = rt0 * tmask(ji,jj,1) ! ice temp
+ ENDDO
+ DO jk = 1, nlay_s
+ e_s(ji,jj,jk,jl) = 0._wp
+ t_s(ji,jj,jk,jl) = rt0 * tmask(ji,jj,1) ! snw temp
+ ENDDO
+ !
+ ! general fields
+ a_i (ji,jj,jl) = 0._wp
+ v_i (ji,jj,jl) = 0._wp
+ v_s (ji,jj,jl) = 0._wp
+ sv_i(ji,jj,jl) = 0._wp
+ oa_i(ji,jj,jl) = 0._wp
+ h_i (ji,jj,jl) = 0._wp
+ h_s (ji,jj,jl) = 0._wp
+ s_i (ji,jj,jl) = 0._wp
+ o_i (ji,jj,jl) = 0._wp
+ t_su(ji,jj,jl) = rt0 * tmask(ji,jj,1)
+ !
+ ! melt ponds
+ a_ip(ji,jj,jl) = 0._wp
+ v_ip(ji,jj,jl) = 0._wp
+ v_il(ji,jj,jl) = 0._wp
+ h_ip(ji,jj,jl) = 0._wp
+ h_il(ji,jj,jl) = 0._wp
+ !
+ END_2D
+ !
+ ENDDO
!
! ice velocities
- u_ice (:,:) = 0._wp
- v_ice (:,:) = 0._wp
+ DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ u_ice(ji,jj) = 0._wp
+ v_ice(ji,jj) = 0._wp
+ END_2D
!
!------------------------------------------------------------------------
! 2) overwrite some of the fields with namelist parameters or netcdf file
@@ -194,30 +197,30 @@ CONTAINS
! !---------------!
IF( nn_iceini_file == 1 )THEN ! Read a file !
! !---------------!
- WHERE( ff_t(:,:) >= 0._wp ) ; zswitch(:,:) = 1._wp
- ELSEWHERE ; zswitch(:,:) = 0._wp
+ WHERE( ff_t(A2D(0)) >= 0._wp ) ; zmsk(:,:) = 1._wp
+ ELSEWHERE ; zmsk(:,:) = 0._wp
END WHERE
!
CALL fld_read( kt, 1, si ) ! input fields provided at the current time-step
!
! -- mandatory fields -- !
- zht_i_ini(:,:) = si(jp_hti)%fnow(:,:,1) * tmask(:,:,1)
- zht_s_ini(:,:) = si(jp_hts)%fnow(:,:,1) * tmask(:,:,1)
- zat_i_ini(:,:) = si(jp_ati)%fnow(:,:,1) * tmask(:,:,1)
+ zht_i_ini(:,:) = si(jp_hti)%fnow(:,:,1) * smask0(:,:)
+ zht_s_ini(:,:) = si(jp_hts)%fnow(:,:,1) * smask0(:,:)
+ zat_i_ini(:,:) = si(jp_ati)%fnow(:,:,1) * smask0(:,:)
! -- optional fields -- !
! if fields do not exist then set them to the values present in the namelist (except for temperatures)
!
! ice salinity
IF( TRIM(si(jp_smi)%clrootname) == 'NOT USED' ) &
- & si(jp_smi)%fnow(:,:,1) = ( rn_smi_ini_n * zswitch + rn_smi_ini_s * (1._wp - zswitch) ) * tmask(:,:,1)
+ & si(jp_smi)%fnow(:,:,1) = ( rn_smi_ini_n * zmsk + rn_smi_ini_s * (1._wp - zmsk) ) * smask0(:,:)
!
! temperatures
IF ( TRIM(si(jp_tmi)%clrootname) == 'NOT USED' .AND. TRIM(si(jp_tsu)%clrootname) == 'NOT USED' .AND. &
& TRIM(si(jp_tms)%clrootname) == 'NOT USED' ) THEN
- si(jp_tmi)%fnow(:,:,1) = ( rn_tmi_ini_n * zswitch + rn_tmi_ini_s * (1._wp - zswitch) ) * tmask(:,:,1)
- si(jp_tsu)%fnow(:,:,1) = ( rn_tsu_ini_n * zswitch + rn_tsu_ini_s * (1._wp - zswitch) ) * tmask(:,:,1)
- si(jp_tms)%fnow(:,:,1) = ( rn_tms_ini_n * zswitch + rn_tms_ini_s * (1._wp - zswitch) ) * tmask(:,:,1)
+ si(jp_tmi)%fnow(:,:,1) = ( rn_tmi_ini_n * zmsk + rn_tmi_ini_s * (1._wp - zmsk) ) * smask0(:,:)
+ si(jp_tsu)%fnow(:,:,1) = ( rn_tsu_ini_n * zmsk + rn_tsu_ini_s * (1._wp - zmsk) ) * smask0(:,:)
+ si(jp_tms)%fnow(:,:,1) = ( rn_tms_ini_n * zmsk + rn_tms_ini_s * (1._wp - zmsk) ) * smask0(:,:)
ENDIF
IF( TRIM(si(jp_tmi)%clrootname) == 'NOT USED' .AND. TRIM(si(jp_tms)%clrootname) /= 'NOT USED' ) & ! if T_s is read and not T_i, set T_i = (T_s + T_freeze)/2
& si(jp_tmi)%fnow(:,:,1) = 0.5_wp * ( si(jp_tms)%fnow(:,:,1) + 271.15 )
@@ -234,67 +237,60 @@ CONTAINS
!
! pond concentration
IF( TRIM(si(jp_apd)%clrootname) == 'NOT USED' ) &
- & si(jp_apd)%fnow(:,:,1) = ( rn_apd_ini_n * zswitch + rn_apd_ini_s * (1._wp - zswitch) ) * tmask(:,:,1) & ! rn_apd = pond fraction => rn_apnd * a_i = pond conc.
+ & si(jp_apd)%fnow(:,:,1) = ( rn_apd_ini_n * zmsk + rn_apd_ini_s * (1._wp - zmsk) ) * smask0(:,:) & ! rn_apd = pond fraction => rn_apnd * a_i = pond conc.
& * si(jp_ati)%fnow(:,:,1)
!
! pond depth
IF( TRIM(si(jp_hpd)%clrootname) == 'NOT USED' ) &
- & si(jp_hpd)%fnow(:,:,1) = ( rn_hpd_ini_n * zswitch + rn_hpd_ini_s * (1._wp - zswitch) ) * tmask(:,:,1)
+ & si(jp_hpd)%fnow(:,:,1) = ( rn_hpd_ini_n * zmsk + rn_hpd_ini_s * (1._wp - zmsk) ) * smask0(:,:)
!
! pond lid depth
IF( TRIM(si(jp_hld)%clrootname) == 'NOT USED' ) &
- & si(jp_hld)%fnow(:,:,1) = ( rn_hld_ini_n * zswitch + rn_hld_ini_s * (1._wp - zswitch) ) * tmask(:,:,1)
+ & si(jp_hld)%fnow(:,:,1) = ( rn_hld_ini_n * zmsk + rn_hld_ini_s * (1._wp - zmsk) ) * smask0(:,:)
!
- zsm_i_ini(:,:) = si(jp_smi)%fnow(:,:,1) * tmask(:,:,1)
- ztm_i_ini(:,:) = si(jp_tmi)%fnow(:,:,1) * tmask(:,:,1)
- zt_su_ini(:,:) = si(jp_tsu)%fnow(:,:,1) * tmask(:,:,1)
- ztm_s_ini(:,:) = si(jp_tms)%fnow(:,:,1) * tmask(:,:,1)
- zapnd_ini(:,:) = si(jp_apd)%fnow(:,:,1) * tmask(:,:,1)
- zhpnd_ini(:,:) = si(jp_hpd)%fnow(:,:,1) * tmask(:,:,1)
- zhlid_ini(:,:) = si(jp_hld)%fnow(:,:,1) * tmask(:,:,1)
+ zsm_i_ini(:,:) = si(jp_smi)%fnow(:,:,1) * smask0(:,:)
+ ztm_i_ini(:,:) = si(jp_tmi)%fnow(:,:,1) * smask0(:,:)
+ zt_su_ini(:,:) = si(jp_tsu)%fnow(:,:,1) * smask0(:,:)
+ ztm_s_ini(:,:) = si(jp_tms)%fnow(:,:,1) * smask0(:,:)
+ zapnd_ini(:,:) = si(jp_apd)%fnow(:,:,1) * smask0(:,:)
+ zhpnd_ini(:,:) = si(jp_hpd)%fnow(:,:,1) * smask0(:,:)
+ zhlid_ini(:,:) = si(jp_hld)%fnow(:,:,1) * smask0(:,:)
!
- ! change the switch for the following
- WHERE( zat_i_ini(:,:) > 0._wp ) ; zswitch(:,:) = tmask(:,:,1)
- ELSEWHERE ; zswitch(:,:) = 0._wp
- END WHERE
-
! !---------------!
ELSE ! Read namelist !
! !---------------!
! no ice if (sst - Tfreez) >= thresold
- WHERE( ( sst_m(:,:) - (t_bo(:,:) - rt0) ) * tmask(:,:,1) >= rn_thres_sst ) ; zswitch(:,:) = 0._wp
- ELSEWHERE ; zswitch(:,:) = tmask(:,:,1)
+ WHERE( ( sst_m(A2D(0)) - (t_bo(:,:) - rt0) ) * smask0(:,:) >= rn_thres_sst ) ; zmsk(:,:) = 0._wp
+ ELSEWHERE ; zmsk(:,:) = smask0(:,:)
END WHERE
!
! assign initial thickness, concentration, snow depth and salinity to an hemisphere-dependent array
- WHERE( ff_t(:,:) >= 0._wp )
- zht_i_ini(:,:) = rn_hti_ini_n * zswitch(:,:)
- zht_s_ini(:,:) = rn_hts_ini_n * zswitch(:,:)
- zat_i_ini(:,:) = rn_ati_ini_n * zswitch(:,:)
- zsm_i_ini(:,:) = rn_smi_ini_n * zswitch(:,:)
- ztm_i_ini(:,:) = rn_tmi_ini_n * zswitch(:,:)
- zt_su_ini(:,:) = rn_tsu_ini_n * zswitch(:,:)
- ztm_s_ini(:,:) = rn_tms_ini_n * zswitch(:,:)
- zapnd_ini(:,:) = rn_apd_ini_n * zswitch(:,:) * zat_i_ini(:,:) ! rn_apd = pond fraction => rn_apd * a_i = pond conc.
- zhpnd_ini(:,:) = rn_hpd_ini_n * zswitch(:,:)
- zhlid_ini(:,:) = rn_hld_ini_n * zswitch(:,:)
+ WHERE( ff_t(A2D(0)) >= 0._wp )
+ zht_i_ini(:,:) = rn_hti_ini_n * zmsk(:,:)
+ zht_s_ini(:,:) = rn_hts_ini_n * zmsk(:,:)
+ zat_i_ini(:,:) = rn_ati_ini_n * zmsk(:,:)
+ zsm_i_ini(:,:) = rn_smi_ini_n * zmsk(:,:)
+ ztm_i_ini(:,:) = rn_tmi_ini_n * zmsk(:,:)
+ zt_su_ini(:,:) = rn_tsu_ini_n * zmsk(:,:)
+ ztm_s_ini(:,:) = rn_tms_ini_n * zmsk(:,:)
+ zapnd_ini(:,:) = rn_apd_ini_n * zmsk(:,:) * zat_i_ini(:,:) ! rn_apd = pond fraction => rn_apd * a_i = pond conc.
+ zhpnd_ini(:,:) = rn_hpd_ini_n * zmsk(:,:)
+ zhlid_ini(:,:) = rn_hld_ini_n * zmsk(:,:)
ELSEWHERE
- zht_i_ini(:,:) = rn_hti_ini_s * zswitch(:,:)
- zht_s_ini(:,:) = rn_hts_ini_s * zswitch(:,:)
- zat_i_ini(:,:) = rn_ati_ini_s * zswitch(:,:)
- zsm_i_ini(:,:) = rn_smi_ini_s * zswitch(:,:)
- ztm_i_ini(:,:) = rn_tmi_ini_s * zswitch(:,:)
- zt_su_ini(:,:) = rn_tsu_ini_s * zswitch(:,:)
- ztm_s_ini(:,:) = rn_tms_ini_s * zswitch(:,:)
- zapnd_ini(:,:) = rn_apd_ini_s * zswitch(:,:) * zat_i_ini(:,:) ! rn_apd = pond fraction => rn_apd * a_i = pond conc.
- zhpnd_ini(:,:) = rn_hpd_ini_s * zswitch(:,:)
- zhlid_ini(:,:) = rn_hld_ini_s * zswitch(:,:)
+ zht_i_ini(:,:) = rn_hti_ini_s * zmsk(:,:)
+ zht_s_ini(:,:) = rn_hts_ini_s * zmsk(:,:)
+ zat_i_ini(:,:) = rn_ati_ini_s * zmsk(:,:)
+ zsm_i_ini(:,:) = rn_smi_ini_s * zmsk(:,:)
+ ztm_i_ini(:,:) = rn_tmi_ini_s * zmsk(:,:)
+ zt_su_ini(:,:) = rn_tsu_ini_s * zmsk(:,:)
+ ztm_s_ini(:,:) = rn_tms_ini_s * zmsk(:,:)
+ zapnd_ini(:,:) = rn_apd_ini_s * zmsk(:,:) * zat_i_ini(:,:) ! rn_apd = pond fraction => rn_apd * a_i = pond conc.
+ zhpnd_ini(:,:) = rn_hpd_ini_s * zmsk(:,:)
+ zhlid_ini(:,:) = rn_hld_ini_s * zmsk(:,:)
END WHERE
!
ENDIF
-
-
! make sure ponds = 0 if no ponds scheme
IF ( .NOT.ln_pnd ) THEN
zapnd_ini(:,:) = 0._wp
@@ -311,7 +307,7 @@ CONTAINS
!----------------!
! select ice covered grid points
npti = 0 ; nptidx(:) = 0
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
IF ( zht_i_ini(ji,jj) > 0._wp ) THEN
npti = npti + 1
nptidx(npti) = (jj - 1) * jpi + ji
@@ -363,6 +359,16 @@ CONTAINS
DEALLOCATE( zhi_2d, zhs_2d, zai_2d , &
& zti_2d, zts_2d, ztsu_2d, zsi_2d, zaip_2d, zhip_2d, zhil_2d )
+ ! this call is needed because of the calculations above that are done only in the interior
+ CALL lbc_lnk( 'iceistate', a_i , 'T', 1._wp, h_i , 'T', 1._wp, h_s , 'T', 1._wp, &
+ & zti_3d, 'T', 1._wp, zts_3d, 'T', 1._wp, t_su, 'T', 1._wp, &
+ & s_i , 'T', 1._wp, a_ip , 'T', 1._wp, h_ip, 'T', 1._wp, h_il, 'T', 1._wp )
+
+ ! switch for the following
+ WHERE( SUM(a_i(:,:,:),dim=3) > 0._wp ) ; zswitch(:,:) = tmask(:,:,1)
+ ELSEWHERE ; zswitch(:,:) = 0._wp
+ END WHERE
+
! calculate extensive and intensive variables
CALL ice_var_salprof ! for sz_i
DO jl = 1, jpl
@@ -398,15 +404,17 @@ CONTAINS
ENDIF
#endif
! Melt ponds
- WHERE( a_i > epsi10 ) ; a_ip_eff(:,:,:) = a_ip(:,:,:) / a_i(:,:,:)
- ELSEWHERE ; a_ip_eff(:,:,:) = 0._wp
+ WHERE( a_i(A2D(0),:) > epsi10 ) ; a_ip_eff(:,:,:) = a_ip(A2D(0),:) / a_i(A2D(0),:)
+ ELSEWHERE ; a_ip_eff(:,:,:) = 0._wp
END WHERE
v_ip(:,:,:) = h_ip(:,:,:) * a_ip(:,:,:)
v_il(:,:,:) = h_il(:,:,:) * a_ip(:,:,:)
! specific temperatures for coupled runs
- tn_ice(:,:,:) = t_su(:,:,:)
- t1_ice(:,:,:) = t_i (:,:,1,:)
+ DO_2D( 0, 0, 0, 0 )
+ tn_ice(ji,jj,:) = t_su(ji,jj,:)
+ t1_ice(ji,jj,:) = t_i (ji,jj,1,:)
+ END_2D
!
! ice concentration should not exceed amax
at_i(:,:) = SUM( a_i, dim=3 )
@@ -456,17 +464,6 @@ CONTAINS
CALL dom_qco_zgr( Kbb, Kmm ) ! upadte of r3=ssh/h0 ratios
#elif defined key_linssh
! ! Fix in time : key_linssh case, set through domzgr_substitute.h90
-#else
- DO jk = 1, jpk
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls)
-! IF( snwice_mass(ji,jj) /= 0._wp ) THEN
- e3t(ji,jj,jk,Kmm) = e3t_0(ji,jj,jk) * ( 1._wp + ssh(ji,jj,Kmm) * r1_ht_0(ji,jj) * tmask(ji,jj,jk) )
- e3t(ji,jj,jk,Kbb) = e3t_0(ji,jj,jk) * ( 1._wp + ssh(ji,jj,Kbb) * r1_ht_0(ji,jj) * tmask(ji,jj,jk) )
-! ENDIF
- END_2D
- END DO
- !
- CALL dom_vvl_zgr( Kbb, Kmm, Kaa ) ! interpolation of scale factor, depth and water column
#endif
ENDIF
!
@@ -546,8 +543,8 @@ CONTAINS
ENDIF
!
DO ifpr = 1, jpfldi
- ALLOCATE( si(ifpr)%fnow(jpi,jpj,1) )
- IF( slf_i(ifpr)%ln_tint ) ALLOCATE( si(ifpr)%fdta(jpi,jpj,1,2) )
+ ALLOCATE( si(ifpr)%fnow(A2D(0),1) )
+ IF( slf_i(ifpr)%ln_tint ) ALLOCATE( si(ifpr)%fdta(A2D(0),1,2) )
END DO
!
! fill si with slf_i and control print
diff --git a/src/ICE/iceitd.F90 b/src/ICE/iceitd.F90
index f3e662748ae988a2ee5388c3085fb297b05b9efa..796c0bf03dfa2bea8254d26994a17c0fb252c11a 100644
--- a/src/ICE/iceitd.F90
+++ b/src/ICE/iceitd.F90
@@ -97,10 +97,10 @@ CONTAINS
!-----------------------------------------------------------------------------------------------
! 1) Identify grid cells with ice
!-----------------------------------------------------------------------------------------------
- at_i(:,:) = SUM( a_i, dim=3 )
+ at_i(A2D(0)) = SUM( a_i(A2D(0),:), dim=3 )
!
npti = 0 ; nptidx(:) = 0
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
IF ( at_i(ji,jj) > epsi10 ) THEN
npti = npti + 1
nptidx( npti ) = (jj - 1) * jpi + ji
@@ -115,10 +115,10 @@ CONTAINS
zdhice(:,:) = 0._wp
zhbnew(:,:) = 0._wp
!
- CALL tab_3d_2d( npti, nptidx(1:npti), h_i_2d (1:npti,1:jpl), h_i )
- CALL tab_3d_2d( npti, nptidx(1:npti), h_ib_2d(1:npti,1:jpl), h_i_b )
- CALL tab_3d_2d( npti, nptidx(1:npti), a_i_2d (1:npti,1:jpl), a_i )
- CALL tab_3d_2d( npti, nptidx(1:npti), a_ib_2d(1:npti,1:jpl), a_i_b )
+ CALL tab_3d_2d( npti, nptidx(1:npti), h_i_2d (1:npti,:), h_i )
+ CALL tab_3d_2d( npti, nptidx(1:npti), h_ib_2d(1:npti,:), h_i_b )
+ CALL tab_3d_2d( npti, nptidx(1:npti), a_i_2d (1:npti,:), a_i )
+ CALL tab_3d_2d( npti, nptidx(1:npti), a_ib_2d(1:npti,:), a_i_b )
!
DO jl = 1, jpl
! Compute thickness change in each ice category
@@ -305,28 +305,12 @@ CONTAINS
! 6) Shift ice between categories
!----------------------------------------------------------------------------------------------
CALL itd_shiftice ( jdonor(1:npti,:), zdaice(1:npti,:), zdvice(1:npti,:) )
-
- !----------------------------------------------------------------------------------------------
- ! 7) Make sure h_i >= minimum ice thickness hi_min
- !----------------------------------------------------------------------------------------------
- CALL tab_2d_1d( npti, nptidx(1:npti), h_i_1d (1:npti), h_i (:,:,1) )
- CALL tab_2d_1d( npti, nptidx(1:npti), a_i_1d (1:npti), a_i (:,:,1) )
- CALL tab_2d_1d( npti, nptidx(1:npti), a_ip_1d(1:npti), a_ip(:,:,1) )
- !
- DO ji = 1, npti
- IF ( a_i_1d(ji) > epsi10 .AND. h_i_1d(ji) < rn_himin ) THEN
- a_i_1d(ji) = a_i_1d(ji) * h_i_1d(ji) / rn_himin
- IF( ln_pnd_LEV .OR. ln_pnd_TOPO ) a_ip_1d(ji) = a_ip_1d(ji) * h_i_1d(ji) / rn_himin
- h_i_1d(ji) = rn_himin
- ENDIF
- END DO
- !
- CALL tab_1d_2d( npti, nptidx(1:npti), h_i_1d (1:npti), h_i (:,:,1) )
- CALL tab_1d_2d( npti, nptidx(1:npti), a_i_1d (1:npti), a_i (:,:,1) )
- CALL tab_1d_2d( npti, nptidx(1:npti), a_ip_1d(1:npti), a_ip(:,:,1) )
!
ENDIF
!
+ ! the following fields need to be updated in the halos (done afterwards):
+ ! a_i, v_i, v_s, sv_i, oa_i, h_i, a_ip, v_ip, v_il, t_su, e_i, e_s
+ !
IF( ln_icediachk ) CALL ice_cons_hsm(1, 'iceitd_rem', rdiag_v, rdiag_s, rdiag_t, rdiag_fv, rdiag_fs, rdiag_ft)
IF( ln_icediachk ) CALL ice_cons2D (1, 'iceitd_rem', diag_v, diag_s, diag_t, diag_fv, diag_fs, diag_ft)
IF( ln_timing ) CALL timing_stop ('iceitd_rem')
@@ -411,31 +395,23 @@ CONTAINS
!
INTEGER :: ji, jl, jk ! dummy loop indices
INTEGER :: jl2, jl1 ! local integers
- REAL(wp) :: ztrans ! ice/snow transferred
- REAL(wp), DIMENSION(jpij) :: zworka, zworkv ! workspace
+ REAL(wp) :: zworka, zworkv, ztrans ! ice/snow transferred
+ REAL(wp), DIMENSION(jpij) :: ztmp ! workspace
REAL(wp), DIMENSION(jpij,jpl) :: zaTsfn ! - -
- REAL(wp), DIMENSION(jpij,nlay_i,jpl) :: ze_i_2d
- REAL(wp), DIMENSION(jpij,nlay_s,jpl) :: ze_s_2d
!!------------------------------------------------------------------
- CALL tab_3d_2d( npti, nptidx(1:npti), h_i_2d (1:npti,1:jpl), h_i )
- CALL tab_3d_2d( npti, nptidx(1:npti), a_i_2d (1:npti,1:jpl), a_i )
- CALL tab_3d_2d( npti, nptidx(1:npti), v_i_2d (1:npti,1:jpl), v_i )
- CALL tab_3d_2d( npti, nptidx(1:npti), v_s_2d (1:npti,1:jpl), v_s )
- CALL tab_3d_2d( npti, nptidx(1:npti), oa_i_2d(1:npti,1:jpl), oa_i )
- CALL tab_3d_2d( npti, nptidx(1:npti), sv_i_2d(1:npti,1:jpl), sv_i )
- CALL tab_3d_2d( npti, nptidx(1:npti), a_ip_2d(1:npti,1:jpl), a_ip )
- CALL tab_3d_2d( npti, nptidx(1:npti), v_ip_2d(1:npti,1:jpl), v_ip )
- CALL tab_3d_2d( npti, nptidx(1:npti), v_il_2d(1:npti,1:jpl), v_il )
- CALL tab_3d_2d( npti, nptidx(1:npti), t_su_2d(1:npti,1:jpl), t_su )
- DO jl = 1, jpl
- DO jk = 1, nlay_s
- CALL tab_2d_1d( npti, nptidx(1:npti), ze_s_2d(1:npti,jk,jl), e_s(:,:,jk,jl) )
- END DO
- DO jk = 1, nlay_i
- CALL tab_2d_1d( npti, nptidx(1:npti), ze_i_2d(1:npti,jk,jl), e_i(:,:,jk,jl) )
- END DO
- END DO
+ CALL tab_3d_2d( npti, nptidx(1:npti), h_i_2d (1:npti,:) , h_i )
+ CALL tab_3d_2d( npti, nptidx(1:npti), a_i_2d (1:npti,:) , a_i )
+ CALL tab_3d_2d( npti, nptidx(1:npti), v_i_2d (1:npti,:) , v_i )
+ CALL tab_3d_2d( npti, nptidx(1:npti), v_s_2d (1:npti,:) , v_s )
+ CALL tab_3d_2d( npti, nptidx(1:npti), oa_i_2d(1:npti,:) , oa_i )
+ CALL tab_3d_2d( npti, nptidx(1:npti), sv_i_2d(1:npti,:) , sv_i )
+ CALL tab_3d_2d( npti, nptidx(1:npti), a_ip_2d(1:npti,:) , a_ip )
+ CALL tab_3d_2d( npti, nptidx(1:npti), v_ip_2d(1:npti,:) , v_ip )
+ CALL tab_3d_2d( npti, nptidx(1:npti), v_il_2d(1:npti,:) , v_il )
+ CALL tab_3d_2d( npti, nptidx(1:npti), t_su_2d(1:npti,:) , t_su )
+ CALL tab_4d_3d( npti, nptidx(1:npti), e_s_2d (1:npti,:,:), e_s )
+ CALL tab_4d_3d( npti, nptidx(1:npti), e_i_2d (1:npti,:,:), e_i )
! to correct roundoff errors on a_i
CALL tab_2d_1d( npti, nptidx(1:npti), rn_amax_1d(1:npti), rn_amax_2d )
@@ -462,11 +438,11 @@ CONTAINS
ELSE ; jl2 = jl
ENDIF
!
- IF( v_i_2d(ji,jl1) >= epsi10 ) THEN ; zworkv(ji) = pdvice(ji,jl) / v_i_2d(ji,jl1)
- ELSE ; zworkv(ji) = 0._wp
+ IF( v_i_2d(ji,jl1) >= epsi10 ) THEN ; zworkv = pdvice(ji,jl) / v_i_2d(ji,jl1)
+ ELSE ; zworkv = 0._wp
ENDIF
- IF( a_i_2d(ji,jl1) >= epsi10 ) THEN ; zworka(ji) = pdaice(ji,jl) / a_i_2d(ji,jl1)
- ELSE ; zworka(ji) = 0._wp
+ IF( a_i_2d(ji,jl1) >= epsi10 ) THEN ; zworka = pdaice(ji,jl) / a_i_2d(ji,jl1)
+ ELSE ; zworka = 0._wp
ENDIF
!
a_i_2d(ji,jl1) = a_i_2d(ji,jl1) - pdaice(ji,jl) ! Ice areas
@@ -475,71 +451,50 @@ CONTAINS
v_i_2d(ji,jl1) = v_i_2d(ji,jl1) - pdvice(ji,jl) ! Ice volumes
v_i_2d(ji,jl2) = v_i_2d(ji,jl2) + pdvice(ji,jl)
!
- ztrans = v_s_2d(ji,jl1) * zworkv(ji) ! Snow volumes
+ ztrans = v_s_2d(ji,jl1) * zworkv ! Snow volumes
v_s_2d(ji,jl1) = v_s_2d(ji,jl1) - ztrans
v_s_2d(ji,jl2) = v_s_2d(ji,jl2) + ztrans
!
- ztrans = oa_i_2d(ji,jl1) * zworka(ji) ! Ice age
+ ztrans = oa_i_2d(ji,jl1) * zworka ! Ice age
oa_i_2d(ji,jl1) = oa_i_2d(ji,jl1) - ztrans
oa_i_2d(ji,jl2) = oa_i_2d(ji,jl2) + ztrans
!
- ztrans = sv_i_2d(ji,jl1) * zworkv(ji) ! Ice salinity
+ ztrans = sv_i_2d(ji,jl1) * zworkv ! Ice salinity
sv_i_2d(ji,jl1) = sv_i_2d(ji,jl1) - ztrans
sv_i_2d(ji,jl2) = sv_i_2d(ji,jl2) + ztrans
!
- ztrans = zaTsfn(ji,jl1) * zworka(ji) ! Surface temperature
+ ztrans = zaTsfn(ji,jl1) * zworka ! Surface temperature
zaTsfn(ji,jl1) = zaTsfn(ji,jl1) - ztrans
zaTsfn(ji,jl2) = zaTsfn(ji,jl2) + ztrans
!
IF ( ln_pnd_LEV .OR. ln_pnd_TOPO ) THEN
- ztrans = a_ip_2d(ji,jl1) * zworka(ji) ! Pond fraction
+ ztrans = a_ip_2d(ji,jl1) * zworka ! Pond fraction
a_ip_2d(ji,jl1) = a_ip_2d(ji,jl1) - ztrans
a_ip_2d(ji,jl2) = a_ip_2d(ji,jl2) + ztrans
!
- ztrans = v_ip_2d(ji,jl1) * zworkv(ji) ! Pond volume
+ ztrans = v_ip_2d(ji,jl1) * zworkv ! Pond volume
v_ip_2d(ji,jl1) = v_ip_2d(ji,jl1) - ztrans
v_ip_2d(ji,jl2) = v_ip_2d(ji,jl2) + ztrans
!
IF ( ln_pnd_lids ) THEN ! Pond lid volume
- ztrans = v_il_2d(ji,jl1) * zworkv(ji)
+ ztrans = v_il_2d(ji,jl1) * zworkv
v_il_2d(ji,jl1) = v_il_2d(ji,jl1) - ztrans
v_il_2d(ji,jl2) = v_il_2d(ji,jl2) + ztrans
ENDIF
ENDIF
!
- ENDIF ! jl1 >0
- END DO
- !
- DO jk = 1, nlay_s !--- Snow heat content
- DO ji = 1, npti
- !
- jl1 = kdonor(ji,jl)
+ DO jk = 1, nlay_s ! Snow heat content
+ ztrans = e_s_2d(ji,jk,jl1) * zworkv
+ e_s_2d(ji,jk,jl1) = e_s_2d(ji,jk,jl1) - ztrans
+ e_s_2d(ji,jk,jl2) = e_s_2d(ji,jk,jl2) + ztrans
+ ENDDO
+ DO jk = 1, nlay_i ! Ice heat content
+ ztrans = e_i_2d(ji,jk,jl1) * zworkv
+ e_i_2d(ji,jk,jl1) = e_i_2d(ji,jk,jl1) - ztrans
+ e_i_2d(ji,jk,jl2) = e_i_2d(ji,jk,jl2) + ztrans
+ ENDDO
!
- IF( jl1 > 0 ) THEN
- IF(jl1 == jl) THEN ; jl2 = jl+1
- ELSE ; jl2 = jl
- ENDIF
- ztrans = ze_s_2d(ji,jk,jl1) * zworkv(ji)
- ze_s_2d(ji,jk,jl1) = ze_s_2d(ji,jk,jl1) - ztrans
- ze_s_2d(ji,jk,jl2) = ze_s_2d(ji,jk,jl2) + ztrans
- ENDIF
- END DO
- END DO
- !
- DO jk = 1, nlay_i !--- Ice heat content
- DO ji = 1, npti
- !
- jl1 = kdonor(ji,jl)
- !
- IF( jl1 > 0 ) THEN
- IF(jl1 == jl) THEN ; jl2 = jl+1
- ELSE ; jl2 = jl
- ENDIF
- ztrans = ze_i_2d(ji,jk,jl1) * zworkv(ji)
- ze_i_2d(ji,jk,jl1) = ze_i_2d(ji,jk,jl1) - ztrans
- ze_i_2d(ji,jk,jl2) = ze_i_2d(ji,jk,jl2) + ztrans
- ENDIF
- END DO
+ ENDIF ! jl1 >0
END DO
!
END DO ! boundaries, 1 to jpl-1
@@ -549,13 +504,13 @@ CONTAINS
!-------------------
! clem: The transfer between one category to another can lead to very small negative values (-1.e-20)
! because of truncation error ( i.e. 1. - 1. /= 0 )
- CALL ice_var_roundoff( a_i_2d, v_i_2d, v_s_2d, sv_i_2d, oa_i_2d, a_ip_2d, v_ip_2d, v_il_2d, ze_s_2d, ze_i_2d )
+ CALL ice_var_roundoff( a_i_2d, v_i_2d, v_s_2d, sv_i_2d, oa_i_2d, a_ip_2d, v_ip_2d, v_il_2d, e_s_2d, e_i_2d )
! at_i must be <= rn_amax
- zworka(1:npti) = SUM( a_i_2d(1:npti,:), dim=2 )
+ ztmp(1:npti) = SUM( a_i_2d(1:npti,:), dim=2 )
DO jl = 1, jpl
- WHERE( zworka(1:npti) > rn_amax_1d(1:npti) ) &
- & a_i_2d(1:npti,jl) = a_i_2d(1:npti,jl) * rn_amax_1d(1:npti) / zworka(1:npti)
+ WHERE( ztmp(1:npti) > rn_amax_1d(1:npti) ) &
+ & a_i_2d(1:npti,jl) = a_i_2d(1:npti,jl) * rn_amax_1d(1:npti) / ztmp(1:npti)
END DO
!-------------------------------------------------------------------------------
@@ -573,24 +528,18 @@ CONTAINS
t_su_2d(1:npti,:) = rt0
END WHERE
!
- CALL tab_2d_3d( npti, nptidx(1:npti), h_i_2d (1:npti,1:jpl), h_i )
- CALL tab_2d_3d( npti, nptidx(1:npti), a_i_2d (1:npti,1:jpl), a_i )
- CALL tab_2d_3d( npti, nptidx(1:npti), v_i_2d (1:npti,1:jpl), v_i )
- CALL tab_2d_3d( npti, nptidx(1:npti), v_s_2d (1:npti,1:jpl), v_s )
- CALL tab_2d_3d( npti, nptidx(1:npti), oa_i_2d(1:npti,1:jpl), oa_i )
- CALL tab_2d_3d( npti, nptidx(1:npti), sv_i_2d(1:npti,1:jpl), sv_i )
- CALL tab_2d_3d( npti, nptidx(1:npti), a_ip_2d(1:npti,1:jpl), a_ip )
- CALL tab_2d_3d( npti, nptidx(1:npti), v_ip_2d(1:npti,1:jpl), v_ip )
- CALL tab_2d_3d( npti, nptidx(1:npti), v_il_2d(1:npti,1:jpl), v_il )
- CALL tab_2d_3d( npti, nptidx(1:npti), t_su_2d(1:npti,1:jpl), t_su )
- DO jl = 1, jpl
- DO jk = 1, nlay_s
- CALL tab_1d_2d( npti, nptidx(1:npti), ze_s_2d(1:npti,jk,jl), e_s(:,:,jk,jl) )
- END DO
- DO jk = 1, nlay_i
- CALL tab_1d_2d( npti, nptidx(1:npti), ze_i_2d(1:npti,jk,jl), e_i(:,:,jk,jl) )
- END DO
- END DO
+ CALL tab_2d_3d( npti, nptidx(1:npti), h_i_2d (1:npti,:) , h_i )
+ CALL tab_2d_3d( npti, nptidx(1:npti), a_i_2d (1:npti,:) , a_i )
+ CALL tab_2d_3d( npti, nptidx(1:npti), v_i_2d (1:npti,:) , v_i )
+ CALL tab_2d_3d( npti, nptidx(1:npti), v_s_2d (1:npti,:) , v_s )
+ CALL tab_2d_3d( npti, nptidx(1:npti), oa_i_2d(1:npti,:) , oa_i )
+ CALL tab_2d_3d( npti, nptidx(1:npti), sv_i_2d(1:npti,:) , sv_i )
+ CALL tab_2d_3d( npti, nptidx(1:npti), a_ip_2d(1:npti,:) , a_ip )
+ CALL tab_2d_3d( npti, nptidx(1:npti), v_ip_2d(1:npti,:) , v_ip )
+ CALL tab_2d_3d( npti, nptidx(1:npti), v_il_2d(1:npti,:) , v_il )
+ CALL tab_2d_3d( npti, nptidx(1:npti), t_su_2d(1:npti,:) , t_su )
+ CALL tab_3d_4d( npti, nptidx(1:npti), e_s_2d (1:npti,:,:), e_s )
+ CALL tab_3d_4d( npti, nptidx(1:npti), e_i_2d (1:npti,:,:), e_i )
!
END SUBROUTINE itd_shiftice
@@ -626,7 +575,7 @@ CONTAINS
DO jl = 1, jpl-1 ! identify thicknesses that are too big
! !---------------------------------------
npti = 0 ; nptidx(:) = 0
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
IF( a_i(ji,jj,jl) > 0._wp .AND. v_i(ji,jj,jl) > (a_i(ji,jj,jl) * hi_max(jl)) ) THEN
npti = npti + 1
nptidx( npti ) = (jj - 1) * jpi + ji
@@ -662,7 +611,7 @@ CONTAINS
DO jl = jpl-1, 1, -1 ! Identify thicknesses that are too small
! !-----------------------------------------
npti = 0 ; nptidx(:) = 0
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
IF( a_i(ji,jj,jl+1) > 0._wp .AND. v_i(ji,jj,jl+1) <= (a_i(ji,jj,jl+1) * hi_max(jl)) ) THEN
npti = npti + 1
nptidx( npti ) = (jj - 1) * jpi + ji
@@ -687,6 +636,10 @@ CONTAINS
!
END DO
!
+ ! clem: those fields must be updated on the halos: a_i, v_i, v_s, sv_i, oa_i, h_i, t_su, a_ip, v_ip, v_il, e_i, e_s
+ ! note: ice_itd_reb is called in icedyn
+ ! and in icethd (but once the arrays are already updated on the boundaries)
+ !
IF( ln_icediachk ) CALL ice_cons_hsm(1, 'iceitd_reb', rdiag_v, rdiag_s, rdiag_t, rdiag_fv, rdiag_fs, rdiag_ft)
IF( ln_icediachk ) CALL ice_cons2D (1, 'iceitd_reb', diag_v, diag_s, diag_t, diag_fv, diag_fs, diag_ft)
IF( ln_timing ) CALL timing_stop ('iceitd_reb')
diff --git a/src/ICE/icerst.F90 b/src/ICE/icerst.F90
index 291ff09cad1608b961e586f336fc1ef55096bd66..5fb37070f6213f17a94c3d95129d1653ec40aacb 100644
--- a/src/ICE/icerst.F90
+++ b/src/ICE/icerst.F90
@@ -328,7 +328,7 @@ CONTAINS
IF( nn_components == jp_iam_sas ) THEN ! SAS case: ss[st]_m were not initialized by sbc_ssm_init
!
IF(lwp) WRITE(numout,*) ' SAS: default initialisation of ss[st]_m arrays used in ice_istate'
- IF( l_useCT ) THEN ; sst_m(:,:) = eos_pt_from_ct( ts(:,:,1,jp_tem, Kmm), ts(:,:,1,jp_sal, Kmm) )
+ IF( l_useCT ) THEN ; CALL eos_pt_from_ct( ts(:,:,1,jp_tem, Kmm), ts(:,:,1,jp_sal, Kmm), sst_m(:,:) )
ELSE ; sst_m(:,:) = ts(:,:,1,jp_tem, Kmm)
ENDIF
sss_m(:,:) = ts(:,:,1,jp_sal, Kmm)
diff --git a/src/ICE/icesbc.F90 b/src/ICE/icesbc.F90
index 8191540529a5316c0de590c7ab89e60b916d4af5..2e8baf6bfd57958bd25494734351129a59c86954 100644
--- a/src/ICE/icesbc.F90
+++ b/src/ICE/icesbc.F90
@@ -58,7 +58,7 @@ CONTAINS
REAL(wp), DIMENSION(jpi,jpj), INTENT( out) :: utau_ice, vtau_ice ! air-ice stress [N/m2]
!!
INTEGER :: ji, jj ! dummy loop index
- REAL(wp), DIMENSION(jpi,jpj) :: zutau_ice, zvtau_ice
+ REAL(wp), DIMENSION(A2D(0)) :: zutau_ice, zvtau_ice
!!-------------------------------------------------------------------
!
IF( ln_timing ) CALL timing_start('icesbc')
@@ -70,25 +70,38 @@ CONTAINS
ENDIF
!
SELECT CASE( ksbc )
- CASE( jp_usr ) ; CALL usrdef_sbc_ice_tau( kt ) ! user defined formulation
- CASE( jp_blk )
- CALL blk_ice_1( sf(jp_wndi)%fnow(:,:,1), sf(jp_wndj)%fnow(:,:,1), &
- & theta_air_zt(:,:), q_air_zt(:,:), & ! #LB: known from "sbc_oce" module...
- & sf(jp_slp )%fnow(:,:,1), u_ice, v_ice, tm_su , & ! inputs
- & putaui = utau_ice, pvtaui = vtau_ice ) ! outputs
- ! CASE( jp_abl ) utau_ice & vtau_ice are computed in ablmod
- CASE( jp_purecpl ) ; CALL sbc_cpl_ice_tau( utau_ice , vtau_ice ) ! Coupled formulation
+ !
+ CASE( jp_usr ) !--- User defined formulation
+ !
+ CALL usrdef_sbc_ice_tau( kt )
+ !
+ CASE( jp_blk ) !--- Forced formulation
+ !
+ CALL blk_ice_1( sf(jp_wndi)%fnow(:,:,1), sf(jp_wndj)%fnow(:,:,1), theta_air_zt(:,:), q_air_zt(:,:), & ! <<== in
+ & sf(jp_slp )%fnow(:,:,1), tm_su(:,:), & ! <<== in
+ & putaui=utau_ice(A2D(0)), pvtaui=vtau_ice(A2D(0)) ) ! ==>> out
+ !
+ !CASE( jp_abl ) !--- ABL formulation (utau_ice & vtau_ice are computed in ablmod)
+ !
+ CASE( jp_purecpl ) !--- Coupled formulation
+ !
+ CALL sbc_cpl_ice_tau( utau_ice(A2D(0)) , vtau_ice(A2D(0)) )
+ !
END SELECT
!
- IF( ln_mixcpl) THEN ! Case of a mixed Bulk/Coupled formulation
- CALL sbc_cpl_ice_tau( zutau_ice , zvtau_ice )
+ IF( ln_mixcpl) THEN !--- Case of a mixed Bulk/Coupled formulation
+ !
+ CALL sbc_cpl_ice_tau( zutau_ice , zvtau_ice )
+ !
DO_2D( 0, 0, 0, 0 )
utau_ice(ji,jj) = utau_ice(ji,jj) * xcplmask(ji,jj,0) + zutau_ice(ji,jj) * ( 1. - xcplmask(ji,jj,0) )
vtau_ice(ji,jj) = vtau_ice(ji,jj) * xcplmask(ji,jj,0) + zvtau_ice(ji,jj) * ( 1. - xcplmask(ji,jj,0) )
END_2D
- CALL lbc_lnk( 'icesbc', utau_ice, 'U', -1.0_wp, vtau_ice, 'V', -1.0_wp )
+ !
ENDIF
!
+ CALL lbc_lnk( 'icesbc', utau_ice, 'T', -1.0_wp, vtau_ice, 'T', -1.0_wp )
+ !
IF( ln_timing ) CALL timing_stop('icesbc')
!
END SUBROUTINE ice_sbc_tau
@@ -129,26 +142,49 @@ CONTAINS
WRITE(numout,*)'~~~~~~~~~~~~~~~'
ENDIF
! !== ice albedo ==!
- CALL ice_alb( t_su, h_i, h_s, ln_pnd_alb, a_ip_eff, h_ip, cloud_fra, alb_ice )
+ CALL ice_alb( ln_pnd_alb, t_su(A2D(0),:), h_i(A2D(0),:), h_s(A2D(0),:), a_ip_eff(:,:,:), h_ip(A2D(0),:), cloud_fra(:,:), & ! <<== in
+ & alb_ice(:,:,:) ) ! ==>> out
!
SELECT CASE( ksbc ) !== fluxes over sea ice ==!
!
CASE( jp_usr ) !--- user defined formulation
+ !
CALL usrdef_sbc_ice_flx( kt, h_s, h_i )
+ !
CASE( jp_blk, jp_abl ) !--- bulk formulation & ABL formulation
- CALL blk_ice_2 ( t_su, h_s, h_i, alb_ice, &
- & theta_air_zt(:,:), q_air_zt(:,:), & ! #LB: known from "sbc_oce" module...
- & sf(jp_slp)%fnow(:,:,1), sf(jp_qlw)%fnow(:,:,1), &
- & sf(jp_prec)%fnow(:,:,1), sf(jp_snow)%fnow(:,:,1) )
- IF( ln_mixcpl ) CALL sbc_cpl_ice_flx( kt, picefr=at_i_b, palbi=alb_ice, psst=sst_m, pist=t_su, phs=h_s, phi=h_i )
- IF( nn_flxdist /= -1 ) CALL ice_flx_dist ( t_su, alb_ice, qns_ice, qsr_ice, dqns_ice, evap_ice, devap_ice, nn_flxdist )
+ !
+ CALL blk_ice_2( t_su(A2D(0),:), h_s(A2D(0),:), h_i(A2D(0),:), & ! <<== in
+ & alb_ice(:,:,:), theta_air_zt(:,:), q_air_zt(:,:), & ! <<== in
+ & sf(jp_slp)%fnow(:,:,1), sf(jp_qlw)%fnow(:,:,1), & ! <<== in
+ & sf(jp_prec)%fnow(:,:,1), sf(jp_snow)%fnow(:,:,1) ) ! <<== in
+ !
+ IF( ln_mixcpl ) CALL sbc_cpl_ice_flx( kt, picefr=at_i_b(:,:), palbi=alb_ice(:,:,:), &
+ & psst=sst_m(A2D(0)), pist=t_su(A2D(0),:), &
+ & phs=h_s(A2D(0),:), phi=h_i(A2D(0),:) )
+ !
+ IF( nn_flxdist /= -1 ) CALL ice_flx_dist( nn_flxdist, at_i(A2D(0)), a_i(A2D(0),:), t_su(A2D(0),:), alb_ice(:,:,:), & ! <<== in
+ & qns_ice(:,:,:), qsr_ice(:,:,:), dqns_ice(:,:,:), & ! ==>> inout
+ & evap_ice(:,:,:), devap_ice(:,:,:) ) ! ==>> inout
+ !
! ! compute conduction flux and surface temperature (as in Jules surface module)
- IF( ln_cndflx .AND. .NOT.ln_cndemulate ) &
- & CALL blk_ice_qcn ( ln_virtual_itd, t_su, t_bo, h_s, h_i )
+ IF( ln_cndflx .AND. .NOT.ln_cndemulate ) THEN
+ CALL blk_ice_qcn( ln_virtual_itd, t_bo(:,:), h_s(A2D(0),:), h_i(A2D(0),:), & ! <<== in
+ & qcn_ice(:,:,:), qml_ice(:,:,:), & ! ==>> out
+ & qns_ice(:,:,:), t_su(A2D(0),:) ) ! ==>> inout
+ ENDIF
+ !
CASE ( jp_purecpl ) !--- coupled formulation
- CALL sbc_cpl_ice_flx( kt, picefr=at_i_b, palbi=alb_ice, psst=sst_m, pist=t_su, phs=h_s, phi=h_i )
- IF( nn_flxdist /= -1 ) CALL ice_flx_dist ( t_su, alb_ice, qns_ice, qsr_ice, dqns_ice, evap_ice, devap_ice, nn_flxdist )
+ !
+ CALL sbc_cpl_ice_flx( kt, picefr=at_i_b(:,:), palbi=alb_ice(:,:,:), psst=sst_m(A2D(0)), &
+ & pist=t_su(A2D(0),:), phs=h_s(A2D(0),:), phi=h_i(A2D(0),:) )
+ !
+ IF( nn_flxdist /= -1 ) CALL ice_flx_dist( nn_flxdist, at_i(A2D(0)), a_i(A2D(0),:), t_su(A2D(0),:), alb_ice(:,:,:), & ! <<== in
+ & qns_ice(:,:,:), qsr_ice(:,:,:), dqns_ice(:,:,:), & ! ==>> inout
+ & evap_ice(:,:,:), devap_ice(:,:,:) ) ! ==>> inout
+ !
END SELECT
+!!$ CALL lbc_lnk( 'icesbc', t_su, 'T', 1.0_wp ) ! clem: t_su is needed for Met-Office only => necessary?
+ !
! !== some fluxes at the ice-ocean interface and in the leads
CALL ice_flx_other
!
@@ -157,7 +193,8 @@ CONTAINS
END SUBROUTINE ice_sbc_flx
- SUBROUTINE ice_flx_dist( ptn_ice, palb_ice, pqns_ice, pqsr_ice, pdqn_ice, pevap_ice, pdevap_ice, k_flxdist )
+ SUBROUTINE ice_flx_dist( k_flxdist, pat_i, pa_i, ptn_ice, palb_ice, &
+ & pqns_ice, pqsr_ice, pdqn_ice, pevap_ice, pdevap_ice )
!!-------------------------------------------------------------------
!! *** ROUTINE ice_flx_dist ***
!!
@@ -173,18 +210,20 @@ CONTAINS
!! using T-ice and albedo sensitivity
!! = 2 Redistribute a single flux over categories
!!-------------------------------------------------------------------
- INTEGER , INTENT(in ) :: k_flxdist ! redistributor
- REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: ptn_ice ! ice surface temperature
- REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: palb_ice ! ice albedo
- REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: pqns_ice ! non solar flux
- REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: pqsr_ice ! net solar flux
- REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: pdqn_ice ! non solar flux sensitivity
- REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: pevap_ice ! sublimation
- REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: pdevap_ice ! sublimation sensitivity
+ INTEGER , INTENT(in ) :: k_flxdist ! redistributor
+ REAL(wp), DIMENSION(A2D(0)) , INTENT(in ) :: pat_i ! ice concentration
+ REAL(wp), DIMENSION(A2D(0),jpl), INTENT(in ) :: pa_i ! ice concentration
+ REAL(wp), DIMENSION(A2D(0),jpl), INTENT(in ) :: ptn_ice ! ice surface temperature
+ REAL(wp), DIMENSION(A2D(0),jpl), INTENT(in ) :: palb_ice ! ice albedo
+ REAL(wp), DIMENSION(A2D(0),jpl), INTENT(inout) :: pqns_ice ! non solar flux
+ REAL(wp), DIMENSION(A2D(0),jpl), INTENT(inout) :: pqsr_ice ! net solar flux
+ REAL(wp), DIMENSION(A2D(0),jpl), INTENT(inout) :: pdqn_ice ! non solar flux sensitivity
+ REAL(wp), DIMENSION(A2D(0),jpl), INTENT(inout) :: pevap_ice ! sublimation
+ REAL(wp), DIMENSION(A2D(0),jpl), INTENT(inout) :: pdevap_ice ! sublimation sensitivity
!
INTEGER :: jl ! dummy loop index
!
- REAL(wp), DIMENSION(jpi,jpj) :: z1_at_i ! inverse of concentration
+ REAL(wp), DIMENSION(A2D(0)) :: z1_at_i ! inverse of concentration
!
REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: z_qsr_m ! Mean solar heat flux over all categories
REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: z_qns_m ! Mean non solar heat flux over all categories
@@ -195,7 +234,7 @@ CONTAINS
REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: ztem_m ! Mean temperature over all categories
!!----------------------------------------------------------------------
!
- WHERE ( at_i (:,:) > 0._wp ) ; z1_at_i(:,:) = 1._wp / at_i (:,:)
+ WHERE ( pat_i(:,:) > 0._wp ) ; z1_at_i(:,:) = 1._wp / pat_i(:,:)
ELSEWHERE ; z1_at_i(:,:) = 0._wp
END WHERE
@@ -203,13 +242,13 @@ CONTAINS
!
CASE( 0 , 1 )
!
- ALLOCATE( z_qns_m(jpi,jpj), z_qsr_m(jpi,jpj), z_dqn_m(jpi,jpj), z_evap_m(jpi,jpj), z_devap_m(jpi,jpj) )
+ ALLOCATE( z_qns_m(A2D(0)), z_qsr_m(A2D(0)), z_dqn_m(A2D(0)), z_evap_m(A2D(0)), z_devap_m(A2D(0)) )
!
- z_qns_m (:,:) = SUM( a_i(:,:,:) * pqns_ice (:,:,:) , dim=3 ) * z1_at_i(:,:)
- z_qsr_m (:,:) = SUM( a_i(:,:,:) * pqsr_ice (:,:,:) , dim=3 ) * z1_at_i(:,:)
- z_dqn_m (:,:) = SUM( a_i(:,:,:) * pdqn_ice (:,:,:) , dim=3 ) * z1_at_i(:,:)
- z_evap_m (:,:) = SUM( a_i(:,:,:) * pevap_ice (:,:,:) , dim=3 ) * z1_at_i(:,:)
- z_devap_m(:,:) = SUM( a_i(:,:,:) * pdevap_ice(:,:,:) , dim=3 ) * z1_at_i(:,:)
+ z_qns_m (:,:) = SUM( pa_i(:,:,:) * pqns_ice (:,:,:) , dim=3 ) * z1_at_i(:,:)
+ z_qsr_m (:,:) = SUM( pa_i(:,:,:) * pqsr_ice (:,:,:) , dim=3 ) * z1_at_i(:,:)
+ z_dqn_m (:,:) = SUM( pa_i(:,:,:) * pdqn_ice (:,:,:) , dim=3 ) * z1_at_i(:,:)
+ z_evap_m (:,:) = SUM( pa_i(:,:,:) * pevap_ice (:,:,:) , dim=3 ) * z1_at_i(:,:)
+ z_devap_m(:,:) = SUM( pa_i(:,:,:) * pdevap_ice(:,:,:) , dim=3 ) * z1_at_i(:,:)
DO jl = 1, jpl
pqns_ice (:,:,jl) = z_qns_m (:,:)
pqsr_ice (:,:,jl) = z_qsr_m (:,:)
@@ -226,10 +265,10 @@ CONTAINS
!
CASE( 1 , 2 )
!
- ALLOCATE( zalb_m(jpi,jpj), ztem_m(jpi,jpj) )
+ ALLOCATE( zalb_m(A2D(0)), ztem_m(A2D(0)) )
!
- zalb_m(:,:) = SUM( a_i(:,:,:) * palb_ice(:,:,:) , dim=3 ) * z1_at_i(:,:)
- ztem_m(:,:) = SUM( a_i(:,:,:) * ptn_ice (:,:,:) , dim=3 ) * z1_at_i(:,:)
+ zalb_m(:,:) = SUM( pa_i(:,:,:) * palb_ice(:,:,:) , dim=3 ) * z1_at_i(:,:)
+ ztem_m(:,:) = SUM( pa_i(:,:,:) * ptn_ice (:,:,:) , dim=3 ) * z1_at_i(:,:)
DO jl = 1, jpl
pqns_ice (:,:,jl) = pqns_ice (:,:,jl) + pdqn_ice (:,:,jl) * ( ptn_ice(:,:,jl) - ztem_m(:,:) )
pevap_ice(:,:,jl) = pevap_ice(:,:,jl) + pdevap_ice(:,:,jl) * ( ptn_ice(:,:,jl) - ztem_m(:,:) )
@@ -255,9 +294,10 @@ CONTAINS
!!-----------------------------------------------------------------------
INTEGER :: ji, jj ! dummy loop indices
REAL(wp) :: zfric_u, zqld, zqfr, zqfr_neg, zqfr_pos, zu_io, zv_io, zu_iom1, zv_iom1
+ REAL(wp) :: zswitch
REAL(wp), PARAMETER :: zfric_umin = 0._wp ! lower bound for the friction velocity (cice value=5.e-04)
REAL(wp), PARAMETER :: zch = 0.0057_wp ! heat transfer coefficient
- REAL(wp), DIMENSION(jpi,jpj) :: zfric, zvel ! ice-ocean velocity (m/s) and frictional velocity (m2/s2)
+ REAL(wp), DIMENSION(A2D(0)) :: zfric, zvel ! ice-ocean velocity (m/s) and frictional velocity (m2/s2)
!!-----------------------------------------------------------------------
!
! computation of friction velocity at T points
@@ -268,47 +308,47 @@ CONTAINS
zv_io = v_ice(ji ,jj ) - ssv_m(ji ,jj )
zv_iom1 = v_ice(ji ,jj-1) - ssv_m(ji ,jj-1)
!
- zfric(ji,jj) = rn_cio * ( 0.5_wp * ( zu_io*zu_io + zu_iom1*zu_iom1 + zv_io*zv_io + zv_iom1*zv_iom1 ) ) * tmask(ji,jj,1)
+ zfric(ji,jj) = rn_cio * ( 0.5_wp * ( ( zu_io*zu_io + zu_iom1*zu_iom1 ) & ! add () for NP repro
+ & + ( zv_io*zv_io + zv_iom1*zv_iom1 ) ) ) * smask0(ji,jj)
zvel (ji,jj) = 0.5_wp * SQRT( ( u_ice(ji-1,jj ) + u_ice(ji,jj) ) * ( u_ice(ji-1,jj ) + u_ice(ji,jj) ) + &
& ( v_ice(ji ,jj-1) + v_ice(ji,jj) ) * ( v_ice(ji ,jj-1) + v_ice(ji,jj) ) )
END_2D
ELSE ! if no ice dynamics => transfer directly the atmospheric stress to the ocean
DO_2D( 0, 0, 0, 0 )
- zfric(ji,jj) = r1_rho0 * SQRT( 0.5_wp * &
- & ( utau(ji,jj) * utau(ji,jj) + utau(ji-1,jj) * utau(ji-1,jj) &
- & + vtau(ji,jj) * vtau(ji,jj) + vtau(ji,jj-1) * vtau(ji,jj-1) ) ) * tmask(ji,jj,1)
- zvel(ji,jj) = 0._wp
+ zfric(ji,jj) = r1_rho0 * SQRT( utau(ji,jj)*utau(ji,jj) + vtau(ji,jj)*vtau(ji,jj) ) * smask0(ji,jj)
+ zvel (ji,jj) = 0._wp
END_2D
ENDIF
- CALL lbc_lnk( 'icesbc', zfric, 'T', 1.0_wp, zvel, 'T', 1.0_wp )
!
!--------------------------------------------------------------------!
! Partial computation of forcing for the thermodynamic sea ice model
!--------------------------------------------------------------------!
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) ! needed for qlead
- rswitch = tmask(ji,jj,1) * MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) - epsi10 ) ) ! 0 if no ice
+ DO_2D( 0, 0, 0, 0 ) ! needed for qlead
+ IF( at_i(ji,jj) >= epsi10 ) THEN ; zswitch = smask0(ji,jj)
+ ELSE ; zswitch = 0._wp
+ ENDIF
!
! --- Energy received in the lead from atm-oce exchanges, zqld is defined everywhere (J.m-2) --- !
- zqld = tmask(ji,jj,1) * rDt_ice * &
+ zqld = smask0(ji,jj) * rDt_ice * &
& ( ( 1._wp - at_i_b(ji,jj) ) * qsr_oce(ji,jj) * frq_m(ji,jj) + &
& ( 1._wp - at_i_b(ji,jj) ) * qns_oce(ji,jj) + qemp_oce(ji,jj) )
! --- Energy needed to bring ocean surface layer until its freezing, zqfr is defined everywhere (J.m-2) --- !
! (mostly<0 but >0 if supercooling)
- zqfr = rho0 * rcp * e3t_m(ji,jj) * ( t_bo(ji,jj) - ( sst_m(ji,jj) + rt0 ) ) * tmask(ji,jj,1) ! both < 0 (t_bo < sst) and > 0 (t_bo > sst)
- zqfr_neg = MIN( zqfr , 0._wp ) ! only < 0
- zqfr_pos = MAX( zqfr , 0._wp ) ! only > 0
+ zqfr = rho0 * rcp * e3t_m(ji,jj) * ( t_bo(ji,jj) - ( sst_m(ji,jj) + rt0 ) ) * smask0(ji,jj) ! both < 0 (t_bo < sst) and > 0 (t_bo > sst)
+ zqfr_neg = MIN( zqfr , 0._wp ) ! only < 0
+ zqfr_pos = MAX( zqfr , 0._wp ) ! only > 0
! --- Sensible ocean-to-ice heat flux (W/m2) --- !
! (mostly>0 but <0 if supercooling)
zfric_u = MAX( SQRT( zfric(ji,jj) ), zfric_umin )
- qsb_ice_bot(ji,jj) = rswitch * rho0 * rcp * zch * zfric_u * ( ( sst_m(ji,jj) + rt0 ) - t_bo(ji,jj) )
+ qsb_ice_bot(ji,jj) = zswitch * rho0 * rcp * zch * zfric_u * ( ( sst_m(ji,jj) + rt0 ) - t_bo(ji,jj) )
! upper bound for qsb_ice_bot: the heat retrieved from the ocean must be smaller than the heat necessary to reach
! the freezing point, so that we do not have SST < T_freeze
! This implies: qsb_ice_bot(ji,jj) * at_i(ji,jj) * rtdice <= - zqfr_neg
! The following formulation is ok for both normal conditions and supercooling
- qsb_ice_bot(ji,jj) = rswitch * MIN( qsb_ice_bot(ji,jj), - zqfr_neg * r1_Dt_ice / MAX( at_i(ji,jj), epsi10 ) )
+ qsb_ice_bot(ji,jj) = zswitch * MIN( qsb_ice_bot(ji,jj), - zqfr_neg * r1_Dt_ice / MAX( at_i(ji,jj), epsi10 ) )
! If conditions are always supercooled (such as at the mouth of ice-shelves), then ice grows continuously
! ==> stop ice formation by artificially setting up the turbulent fluxes to 0 when volume > 20m (arbitrary)
@@ -327,7 +367,7 @@ CONTAINS
! but we have to make sure that this heat will not make the sst drop below the freezing point
! so the max heat that can be pulled out of the ocean is zqld - qsb - zqfr_pos
! The following formulation is ok for both normal conditions and supercooling
- fhld (ji,jj) = rswitch * MAX( 0._wp, ( zqld - zqfr_pos ) * r1_Dt_ice / MAX( at_i(ji,jj), epsi10 ) & ! divided by at_i since this is (re)multiplied by a_i in icethd_dh.F90
+ fhld (ji,jj) = zswitch * MAX( 0._wp, ( zqld - zqfr_pos ) * r1_Dt_ice / MAX( at_i(ji,jj), epsi10 ) & ! divided by at_i since this is (re)multiplied by a_i in icethd_dh.F90
& - qsb_ice_bot(ji,jj) )
qlead(ji,jj) = 0._wp
ELSE
diff --git a/src/ICE/icestp.F90 b/src/ICE/icestp.F90
index 070052dbbaf5a88d32e277c1df600355deeffadd..5b4074175d55d544f6c3a0586dba864af8552bda 100644
--- a/src/ICE/icestp.F90
+++ b/src/ICE/icestp.F90
@@ -109,7 +109,7 @@ CONTAINS
!! - save the outputs
!! - save the outputs for restart when necessary
!!
- !! ** Action : - time evolution of the LIM sea-ice model
+ !! ** Action : - time evolution of the SI3 sea-ice model
!! - update all sbc variables below sea-ice:
!! utau, vtau, taum, wndm, qns , qsr, emp , sfx
!!---------------------------------------------------------------------
@@ -117,25 +117,27 @@ CONTAINS
INTEGER, INTENT(in) :: Kbb, Kmm ! ocean time level indices
INTEGER, INTENT(in) :: ksbc ! flux formulation (user defined, bulk, or Pure Coupled)
!
- INTEGER :: jl ! dummy loop index
+ INTEGER :: ji, jj, jl ! dummy loop index
!!----------------------------------------------------------------------
!
IF( ln_timing ) CALL timing_start('icestp')
!
- ! !-----------------------!
- IF( MOD( kt-1, nn_fsbc ) == 0 ) THEN ! --- Ice time step --- !
- ! !-----------------------!
+ IF( MOD( kt-1, nn_fsbc ) == 0 ) THEN ! Ice time step
!
- kt_ice = kt ! -- Ice model time step
+ kt_ice = kt ! Ice model time step
!
- u_oce(:,:) = ssu_m(:,:) ! -- mean surface ocean current
- v_oce(:,:) = ssv_m(:,:)
+ DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) ! mean surface ocean current
+ u_oce(ji,jj) = ssu_m(ji,jj)
+ v_oce(ji,jj) = ssv_m(ji,jj)
+ END_2D
!
- CALL eos_fzp( sss_m(:,:) , t_bo(:,:) ) ! -- freezing temperature [Kelvin] (set to rt0 over land)
- t_bo(:,:) = ( t_bo(:,:) + rt0 ) * tmask(:,:,1) + rt0 * ( 1._wp - tmask(:,:,1) )
+ CALL eos_fzp( sss_m(:,:), t_bo(:,:), kbnd=0 ) ! freezing temperature [Kelvin] (set to rt0 over land)
+ t_bo(:,:) = ( t_bo(:,:) + rt0 ) * smask0(:,:) + rt0 * ( 1._wp - smask0(:,:) )
!
- ! !== AGRIF Parent to Child ==!
#if defined key_agrif
+ !-------------------------------!
+ ! --- AGRIF Parent to Child --- !
+ !-------------------------------!
! ! nbstep_ice ranges from 1 to the nb of child ocean steps inside one parent ice step
IF( .NOT. Agrif_Root() ) nbstep_ice = MOD( nbstep_ice, Agrif_irhot() * Agrif_Parent(nn_fsbc) / nn_fsbc ) + 1
! ! these calls must remain here for restartability purposes
@@ -148,54 +150,66 @@ CONTAINS
!------------------------------------------------!
! --- Dynamical coupling with the atmosphere --- !
!------------------------------------------------!
- ! It provides the following fields used in sea ice model:
- ! utau_ice, vtau_ice = surface ice stress [N/m2]
- !------------------------------------------------!
+ ! surface ice stress (utau_ice, vtau_ice) [N/m2]
CALL ice_sbc_tau( kt, ksbc, utau_ice, vtau_ice )
+ !
!-------------------------------------!
- ! --- ice dynamics and advection --- !
+ ! --- Ice dynamics and advection --- !
!-------------------------------------!
CALL diag_set0 ! set diag of mass, heat and salt fluxes to 0
CALL ice_rst_opn( kt ) ! Open Ice restart file (if necessary)
!
IF( ln_icedyn .AND. .NOT.ln_c1d ) &
& CALL ice_dyn( kt, Kmm ) ! -- Ice dynamics
- !
+ ! ==> clem: here, all the global variables are correctly defined in the halos
+ !
CALL diag_trends( 1 ) ! record dyn trends
!
- ! !== lateral boundary conditions ==!
+ !-----------------------------!
+ ! --- Thermodynamics BDY --- !
+ !-----------------------------!
IF( ln_icethd .AND. ln_bdy ) CALL bdy_ice( kt ) ! -- bdy ice thermo
+ ! ==> clem: here, all the global variables are correctly defined in the halos
!
- ! !== previous lead fraction and ice volume for flux calculations
- CALL ice_var_glo2eqv ! h_i and h_s for ice albedo calculation
+ !-------------------------------------------------!
+ ! --- Change from global to equivalent arrays --- !
+ !-------------------------------------------------!
+ CALL ice_var_glo2eqv(2) ! h_i and h_s for ice albedo calculation
CALL ice_var_agg(1) ! at_i for coupling
CALL store_fields ! Store now ice values
!
!------------------------------------------------------!
! --- Thermodynamical coupling with the atmosphere --- !
!------------------------------------------------------!
- ! It provides the following fields used in sea ice model:
- ! emp_oce , emp_ice = E-P over ocean and sea ice [Kg/m2/s]
- ! sprecip = solid precipitation [Kg/m2/s]
- ! evap_ice = sublimation [Kg/m2/s]
- ! qsr_tot , qns_tot = solar & non solar heat flux (total) [W/m2]
- ! qsr_ice , qns_ice = solar & non solar heat flux over ice [W/m2]
- ! dqns_ice = non solar heat sensistivity [W/m2]
- ! qemp_oce, qemp_ice, = sensible heat (associated with evap & precip) [W/m2]
- ! qprec_ice, qevap_ice
- !------------------------------------------------------!
+ ! It provides the following fields used in sea ice model:
+ ! emp_oce , emp_ice = E-P over ocean and sea ice [Kg/m2/s]
+ ! sprecip , tprecip = solid and total precipitation [Kg/m2/s]
+ ! evap_ice, devap_ice = sublimation and sensitivity [Kg/m2/s ; Kg/m2/s/K]
+ ! qsr_tot , qns_tot = solar & non solar heat flux (total) [W/m2]
+ ! qsr_ice , qns_ice = solar & non solar heat flux over ice [W/m2]
+ ! dqns_ice = non solar heat sensistivity [W/m2/K]
+ ! qemp_oce, qemp_ice,
+ ! qprec_ice, qevap_ice = sensible heat associated with mass exchange [W/m2]
+ ! qla_ice, dqla_ice = latent heat and sensitivity [W/m2 ; W/m2/K]
+ ! qtr_ice_top = solar heat transmitted thru the ice/snow ssl [W/m2]
+ !------------------------------------------------------!
CALL ice_sbc_flx( kt, ksbc )
+ !
!----------------------------!
! --- ice thermodynamics --- !
!----------------------------!
IF( ln_icethd ) CALL ice_thd( kt ) ! -- Ice thermodynamics
+ ! ==> clem: here, all the global variables are correctly defined in the halos
!
- CALL diag_trends( 2 ) ! record thermo trends
- CALL ice_var_glo2eqv ! necessary calls (at least for coupling)
- CALL ice_var_agg( 2 ) ! necessary calls (at least for coupling)
+ CALL diag_trends(2) ! record thermo trends
+ CALL ice_var_glo2eqv(2)
+ CALL ice_var_agg(2)
!
CALL ice_update_flx( kt ) ! -- Update ocean surface mass, heat and salt fluxes
!
+ !------------------------!
+ ! --- Diag and write --- !
+ !------------------------!
IF( ln_icediahsb ) CALL ice_dia( kt ) ! -- Diagnostics outputs
!
IF( ln_icediachk ) CALL ice_drift_wri( kt ) ! -- Diagnostics outputs for conservation
@@ -274,7 +288,7 @@ CONTAINS
ELSE
CALL ice_istate( nit000, Kbb, Kmm, Kaa ) ! start from rest or read a file
ENDIF
- CALL ice_var_glo2eqv
+ CALL ice_var_glo2eqv(1)
CALL ice_var_agg(1)
!
CALL ice_dyn_init ! set ice dynamics parameters
@@ -288,7 +302,7 @@ CONTAINS
CALL ice_drift_init ! initialization for diags of conservation
!
fr_i (:,:) = at_i(:,:) ! initialisation of sea-ice fraction
- tn_ice(:,:,:) = t_su(:,:,:) ! initialisation of surface temp for coupled simu
+ tn_ice(:,:,:) = t_su(A2D(0),:) ! initialisation of surface temp for coupled simu
!
IF( ln_rstart ) THEN
CALL iom_close( numrir ) ! close input ice restart file
@@ -369,26 +383,33 @@ CONTAINS
INTEGER :: ji, jj, jl ! dummy loop index
!!----------------------------------------------------------------------
!
- a_i_b (:,:,:) = a_i (:,:,:) ! ice area
- v_i_b (:,:,:) = v_i (:,:,:) ! ice volume
- v_s_b (:,:,:) = v_s (:,:,:) ! snow volume
- v_ip_b(:,:,:) = v_ip(:,:,:) ! pond volume
- v_il_b(:,:,:) = v_il(:,:,:) ! pond lid volume
- sv_i_b(:,:,:) = sv_i(:,:,:) ! salt content
- e_s_b (:,:,:,:) = e_s (:,:,:,:) ! snow thermal energy
- e_i_b (:,:,:,:) = e_i (:,:,:,:) ! ice thermal energy
- WHERE( a_i_b(:,:,:) >= epsi20 )
- h_i_b(:,:,:) = v_i_b(:,:,:) / a_i_b(:,:,:) ! ice thickness
- h_s_b(:,:,:) = v_s_b(:,:,:) / a_i_b(:,:,:) ! snw thickness
- ELSEWHERE
- h_i_b(:,:,:) = 0._wp
- h_s_b(:,:,:) = 0._wp
- END WHERE
- !
- ! ice velocities & total concentration
+ DO jl = 1, jpl
+ DO_2D( 0, 0, 0, 0 )
+ a_i_b (ji,jj,jl) = a_i (ji,jj,jl) ! ice area
+ v_i_b (ji,jj,jl) = v_i (ji,jj,jl) ! ice volume
+ v_s_b (ji,jj,jl) = v_s (ji,jj,jl) ! snow volume
+ v_ip_b(ji,jj,jl) = v_ip(ji,jj,jl) ! pond volume
+ v_il_b(ji,jj,jl) = v_il(ji,jj,jl) ! pond lid volume
+ sv_i_b(ji,jj,jl) = sv_i(ji,jj,jl) ! salt content
+ IF( a_i_b(ji,jj,jl) >= epsi20 ) THEN
+ h_i_b(ji,jj,jl) = v_i_b(ji,jj,jl) / a_i_b(ji,jj,jl) ! ice thickness
+ h_s_b(ji,jj,jl) = v_s_b(ji,jj,jl) / a_i_b(ji,jj,jl) ! snw thickness
+ ELSE
+ h_i_b(ji,jj,jl) = 0._wp
+ h_s_b(ji,jj,jl) = 0._wp
+ ENDIF
+ e_s_b (ji,jj,:,jl) = e_s (ji,jj,:,jl) ! snow thermal energy
+ e_i_b (ji,jj,:,jl) = e_i (ji,jj,:,jl) ! ice thermal energy
+ END_2D
+ ENDDO
+ ! total concentration
at_i_b(:,:) = SUM( a_i_b(:,:,:), dim=3 )
- u_ice_b(:,:) = u_ice(:,:)
- v_ice_b(:,:) = v_ice(:,:)
+
+ ! ice velocity
+ DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ u_ice_b(ji,jj) = u_ice(ji,jj)
+ v_ice_b(ji,jj) = v_ice(ji,jj)
+ END_2D
!
END SUBROUTINE store_fields
@@ -402,20 +423,19 @@ CONTAINS
!!----------------------------------------------------------------------
INTEGER :: ji, jj, jl ! dummy loop index
!!----------------------------------------------------------------------
-
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) ! needed for (at least) diag_adv_mass -> to be removed
+ DO_2D( 0, 0, 0, 0 )
sfx (ji,jj) = 0._wp ;
sfx_bri(ji,jj) = 0._wp ; sfx_lam(ji,jj) = 0._wp
sfx_sni(ji,jj) = 0._wp ; sfx_opw(ji,jj) = 0._wp
sfx_bog(ji,jj) = 0._wp ; sfx_dyn(ji,jj) = 0._wp
sfx_bom(ji,jj) = 0._wp ; sfx_sum(ji,jj) = 0._wp
- sfx_res(ji,jj) = 0._wp ; sfx_sub(ji,jj) = 0._wp
+ sfx_sub(ji,jj) = 0._wp ; sfx_res(ji,jj) = 0._wp
!
wfx_snw(ji,jj) = 0._wp ; wfx_ice(ji,jj) = 0._wp
wfx_sni(ji,jj) = 0._wp ; wfx_opw(ji,jj) = 0._wp
wfx_bog(ji,jj) = 0._wp ; wfx_dyn(ji,jj) = 0._wp
wfx_bom(ji,jj) = 0._wp ; wfx_sum(ji,jj) = 0._wp
- wfx_res(ji,jj) = 0._wp ; wfx_sub(ji,jj) = 0._wp
+ wfx_sub(ji,jj) = 0._wp ; wfx_res(ji,jj) = 0._wp
wfx_spr(ji,jj) = 0._wp ; wfx_lam(ji,jj) = 0._wp
wfx_snw_dyn(ji,jj) = 0._wp ; wfx_snw_sum(ji,jj) = 0._wp
wfx_snw_sub(ji,jj) = 0._wp ; wfx_ice_sub(ji,jj) = 0._wp
@@ -426,7 +446,7 @@ CONTAINS
hfx_snw(ji,jj) = 0._wp ; hfx_opw(ji,jj) = 0._wp
hfx_bog(ji,jj) = 0._wp ; hfx_dyn(ji,jj) = 0._wp
hfx_bom(ji,jj) = 0._wp ; hfx_sum(ji,jj) = 0._wp
- hfx_res(ji,jj) = 0._wp ; hfx_sub(ji,jj) = 0._wp
+ hfx_sub(ji,jj) = 0._wp ; hfx_res(ji,jj) = 0._wp
hfx_spr(ji,jj) = 0._wp ; hfx_dif(ji,jj) = 0._wp
hfx_err_dif(ji,jj) = 0._wp
wfx_err_sub(ji,jj) = 0._wp
@@ -451,7 +471,7 @@ CONTAINS
END_2D
DO jl = 1, jpl
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
! SIMIP diagnostics
t_si (ji,jj,jl) = rt0 ! temp at the ice-snow interface
qcn_ice_bot(ji,jj,jl) = 0._wp
@@ -477,22 +497,25 @@ CONTAINS
!! and outputs
!!----------------------------------------------------------------------
INTEGER, INTENT(in) :: kn ! 1 = after dyn ; 2 = after thermo
- !!----------------------------------------------------------------------
+ INTEGER :: ji, jj, jl ! dummy loop index
+ !!----------------------------------------------------------------------
!
! --- trends of heat, salt, mass (used for conservation controls)
IF( ln_icediachk .OR. iom_use('hfxdhc') ) THEN
!
- diag_heat(:,:) = diag_heat(:,:) &
- & - SUM(SUM( e_i (:,:,1:nlay_i,:) - e_i_b (:,:,1:nlay_i,:), dim=4 ), dim=3 ) * r1_Dt_ice &
- & - SUM(SUM( e_s (:,:,1:nlay_s,:) - e_s_b (:,:,1:nlay_s,:), dim=4 ), dim=3 ) * r1_Dt_ice
- diag_sice(:,:) = diag_sice(:,:) &
- & + SUM( sv_i(:,:,:) - sv_i_b(:,:,:) , dim=3 ) * r1_Dt_ice * rhoi
- diag_vice(:,:) = diag_vice(:,:) &
- & + SUM( v_i (:,:,:) - v_i_b (:,:,:) , dim=3 ) * r1_Dt_ice * rhoi
- diag_vsnw(:,:) = diag_vsnw(:,:) &
- & + SUM( v_s (:,:,:) - v_s_b (:,:,:) , dim=3 ) * r1_Dt_ice * rhos
- diag_vpnd(:,:) = diag_vpnd(:,:) &
- & + SUM( v_ip + v_il - v_ip_b - v_il_b , dim=3 ) * r1_Dt_ice * rhow
+ DO_2D( 0, 0, 0, 0 )
+ diag_heat(ji,jj) = diag_heat(ji,jj) &
+ & - SUM(SUM( e_i (ji,jj,1:nlay_i,:) - e_i_b (ji,jj,1:nlay_i,:), dim=2 ) ) * r1_Dt_ice &
+ & - SUM(SUM( e_s (ji,jj,1:nlay_s,:) - e_s_b (ji,jj,1:nlay_s,:), dim=2 ) ) * r1_Dt_ice
+ diag_sice(ji,jj) = diag_sice(ji,jj) &
+ & + SUM( sv_i(ji,jj,:) - sv_i_b(ji,jj,:) ) * r1_Dt_ice * rhoi
+ diag_vice(ji,jj) = diag_vice(ji,jj) &
+ & + SUM( v_i (ji,jj,:) - v_i_b (ji,jj,:) ) * r1_Dt_ice * rhoi
+ diag_vsnw(ji,jj) = diag_vsnw(ji,jj) &
+ & + SUM( v_s (ji,jj,:) - v_s_b (ji,jj,:) ) * r1_Dt_ice * rhos
+ diag_vpnd(ji,jj) = diag_vpnd(ji,jj) &
+ & + SUM( v_ip(ji,jj,:)+v_il(ji,jj,:) - v_ip_b(ji,jj,:)-v_il_b(ji,jj,:) ) * r1_Dt_ice * rhow
+ END_2D
!
IF( kn == 2 ) CALL iom_put ( 'hfxdhc' , diag_heat ) ! output of heat trend
!
@@ -501,11 +524,13 @@ CONTAINS
! --- trends of concentration (used for simip outputs)
IF( iom_use('afxdyn') .OR. iom_use('afxthd') .OR. iom_use('afxtot') ) THEN
!
- diag_aice(:,:) = diag_aice(:,:) + SUM( a_i(:,:,:) - a_i_b(:,:,:), dim=3 ) * r1_Dt_ice
+ DO_2D( 0, 0, 0, 0 )
+ diag_aice(ji,jj) = diag_aice(ji,jj) + SUM( a_i(ji,jj,:) - a_i_b(ji,jj,:) ) * r1_Dt_ice
+ END_2D
!
- IF( kn == 1 ) CALL iom_put( 'afxdyn' , diag_aice ) ! dyn trend
- IF( kn == 2 ) CALL iom_put( 'afxthd' , SUM( a_i(:,:,:) - a_i_b(:,:,:), dim=3 ) * r1_Dt_ice ) ! thermo trend
- IF( kn == 2 ) CALL iom_put( 'afxtot' , diag_aice ) ! total trend
+ IF( kn == 1 ) CALL iom_put( 'afxdyn' , diag_aice ) ! dyn trend
+ IF( kn == 2 ) CALL iom_put( 'afxthd' , SUM( a_i(A2D(0),:) - a_i_b(:,:,:), dim=3 ) * r1_Dt_ice ) ! thermo trend
+ IF( kn == 2 ) CALL iom_put( 'afxtot' , diag_aice ) ! total trend
!
ENDIF
!
diff --git a/src/ICE/icetab.F90 b/src/ICE/icetab.F90
index 2b1b880f55bc92ee24f8c057ae6655fd4267ef43..db9575fcd28e30cf9868554b98461545fe73a740 100644
--- a/src/ICE/icetab.F90
+++ b/src/ICE/icetab.F90
@@ -20,8 +20,10 @@ MODULE icetab
IMPLICIT NONE
PRIVATE
+ PUBLIC tab_4d_3d
PUBLIC tab_3d_2d
PUBLIC tab_2d_1d
+ PUBLIC tab_3d_4d
PUBLIC tab_2d_3d
PUBLIC tab_1d_2d
@@ -32,21 +34,63 @@ MODULE icetab
!!----------------------------------------------------------------------
CONTAINS
+ SUBROUTINE tab_4d_3d( ndim1d, tab_ind, tab1d, tab2d )
+ !!----------------------------------------------------------------------
+ !! *** ROUTINE tab_2d_1d ***
+ !!----------------------------------------------------------------------
+ INTEGER , INTENT(in ) :: ndim1d ! 1d size
+ INTEGER , DIMENSION(ndim1d) , INTENT(in ) :: tab_ind ! input index
+ REAL(wp), DIMENSION(:,:,:,:), INTENT(in ) :: tab2d ! input 2D field
+ REAL(wp), DIMENSION(:,:,:) , INTENT(inout) :: tab1d ! output 1D field
+ !
+ INTEGER :: ipi, ipj, ipk, ji0, jj0, jk, jl, jn, jid, jjd
+ !!----------------------------------------------------------------------
+ ipi = SIZE(tab2d,1) ! 1st dimension
+ ipj = SIZE(tab2d,2) ! 2nd dimension
+ ipk = SIZE(tab2d,3) ! 3d dimension
+ !
+ IF( ipi == jpi .AND. ipj == jpj ) THEN ! full arrays then no need to change index jid and jjd
+ ji0 = 0 ; jj0 = 0
+ ELSE ! reduced arrays then need to shift index by nn_hls
+ ji0 = nn_hls ; jj0 = nn_hls ! since tab2d is shifted by nn_hls
+ ENDIF ! (i.e. from hls+1:jpi-hls to 1:jpi-2*hls)
+ !
+ DO jl = 1, jpl
+ DO jk = 1, ipk
+ DO jn = 1, ndim1d
+ jid = MOD( tab_ind(jn) - 1 , jpi ) + 1 - ji0
+ jjd = ( tab_ind(jn) - 1 ) / jpi + 1 - jj0
+ tab1d(jn,jk,jl) = tab2d(jid,jjd,jk,jl)
+ END DO
+ END DO
+ END DO
+ !
+ END SUBROUTINE tab_4d_3d
+
SUBROUTINE tab_3d_2d( ndim1d, tab_ind, tab1d, tab2d )
!!----------------------------------------------------------------------
!! *** ROUTINE tab_2d_1d ***
!!----------------------------------------------------------------------
INTEGER , INTENT(in ) :: ndim1d ! 1d size
INTEGER , DIMENSION(ndim1d) , INTENT(in ) :: tab_ind ! input index
- REAL(wp), DIMENSION(jpi,jpj,jpl), INTENT(in ) :: tab2d ! input 2D field
+ REAL(wp), DIMENSION(:,:,:) , INTENT(in ) :: tab2d ! input 2D field
REAL(wp), DIMENSION(ndim1d,jpl) , INTENT(inout) :: tab1d ! output 1D field
!
- INTEGER :: jl, jn, jid, jjd
+ INTEGER :: ipi, ipj, ji0, jj0, jl, jn, jid, jjd
!!----------------------------------------------------------------------
+ ipi = SIZE(tab2d,1) ! 1st dimension
+ ipj = SIZE(tab2d,2) ! 2nd dimension
+ !
+ IF( ipi == jpi .AND. ipj == jpj ) THEN ! full arrays then no need to change index jid and jjd
+ ji0 = 0 ; jj0 = 0
+ ELSE ! reduced arrays then need to shift index by nn_hls
+ ji0 = nn_hls ; jj0 = nn_hls ! since tab2d is shifted by nn_hls
+ ENDIF ! (i.e. from hls+1:jpi-hls to 1:jpi-2*hls)
+ !
DO jl = 1, jpl
DO jn = 1, ndim1d
- jid = MOD( tab_ind(jn) - 1 , jpi ) + 1
- jjd = ( tab_ind(jn) - 1 ) / jpi + 1
+ jid = MOD( tab_ind(jn) - 1 , jpi ) + 1 - ji0
+ jjd = ( tab_ind(jn) - 1 ) / jpi + 1 - jj0
tab1d(jn,jl) = tab2d(jid,jjd,jl)
END DO
END DO
@@ -59,18 +103,59 @@ CONTAINS
!!----------------------------------------------------------------------
INTEGER , INTENT(in ) :: ndim1d ! 1d size
INTEGER , DIMENSION(ndim1d) , INTENT(in ) :: tab_ind ! input index
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: tab2d ! input 2D field
+ REAL(wp), DIMENSION(:,:) , INTENT(in ) :: tab2d ! input 2D field
REAL(wp), DIMENSION(ndim1d) , INTENT(inout) :: tab1d ! output 1D field
!
- INTEGER :: jn , jid, jjd
+ INTEGER :: ipi, ipj, ji0, jj0, jn, jid, jjd
!!----------------------------------------------------------------------
+ ipi = SIZE(tab2d,1) ! 1st dimension
+ ipj = SIZE(tab2d,2) ! 2nd dimension
+ !
+ IF( ipi == jpi .AND. ipj == jpj ) THEN ! full arrays then no need to change index jid and jjd
+ ji0 = 0 ; jj0 = 0
+ ELSE ! reduced arrays then need to shift index by nn_hls
+ ji0 = nn_hls ; jj0 = nn_hls ! since tab2d is shifted by nn_hls
+ ENDIF ! (i.e. from hls+1:jpi-hls to 1:jpi-2*hls)
+ !
DO jn = 1, ndim1d
- jid = MOD( tab_ind(jn) - 1 , jpi ) + 1
- jjd = ( tab_ind(jn) - 1 ) / jpi + 1
+ jid = MOD( tab_ind(jn) - 1 , jpi ) + 1 - ji0
+ jjd = ( tab_ind(jn) - 1 ) / jpi + 1 - jj0
tab1d( jn) = tab2d( jid, jjd)
END DO
END SUBROUTINE tab_2d_1d
+ SUBROUTINE tab_3d_4d( ndim1d, tab_ind, tab1d, tab2d )
+ !!----------------------------------------------------------------------
+ !! *** ROUTINE tab_2d_1d ***
+ !!----------------------------------------------------------------------
+ INTEGER , INTENT(in ) :: ndim1d ! 1D size
+ INTEGER , DIMENSION(ndim1d) , INTENT(in ) :: tab_ind ! input index
+ REAL(wp), DIMENSION(:,:,:) , INTENT(in ) :: tab1d ! input 1D field
+ REAL(wp), DIMENSION(:,:,:,:), INTENT(inout) :: tab2d ! output 2D field
+ !
+ INTEGER :: ipi, ipj, ipk, ji0, jj0, jk, jl, jn, jid, jjd
+ !!----------------------------------------------------------------------
+ ipi = SIZE(tab2d,1) ! 1st dimension
+ ipj = SIZE(tab2d,2) ! 2nd dimension
+ ipk = SIZE(tab2d,3) ! 3d dimension
+ !
+ IF( ipi == jpi .AND. ipj == jpj ) THEN ! full arrays then no need to change index jid and jjd
+ ji0 = 0 ; jj0 = 0
+ ELSE ! reduced arrays then need to shift index by nn_hls
+ ji0 = nn_hls ; jj0 = nn_hls ! since tab2d is shifted by nn_hls
+ ENDIF ! (i.e. from hls+1:jpi-hls to 1:jpi-2*hls)
+ !
+ DO jl = 1, jpl
+ DO jk = 1, ipk
+ DO jn = 1, ndim1d
+ jid = MOD( tab_ind(jn) - 1 , jpi ) + 1 - ji0
+ jjd = ( tab_ind(jn) - 1 ) / jpi + 1 - jj0
+ tab2d(jid,jjd,jk,jl) = tab1d(jn,jk,jl)
+ END DO
+ END DO
+ END DO
+ !
+ END SUBROUTINE tab_3d_4d
SUBROUTINE tab_2d_3d( ndim1d, tab_ind, tab1d, tab2d )
!!----------------------------------------------------------------------
@@ -79,14 +164,23 @@ CONTAINS
INTEGER , INTENT(in ) :: ndim1d ! 1D size
INTEGER , DIMENSION(ndim1d) , INTENT(in ) :: tab_ind ! input index
REAL(wp), DIMENSION(ndim1d,jpl) , INTENT(in ) :: tab1d ! input 1D field
- REAL(wp), DIMENSION(jpi,jpj,jpl), INTENT(inout) :: tab2d ! output 2D field
+ REAL(wp), DIMENSION(:,:,:) , INTENT(inout) :: tab2d ! output 2D field
!
- INTEGER :: jl, jn, jid, jjd
+ INTEGER :: ipi, ipj, ji0, jj0, jl, jn, jid, jjd
!!----------------------------------------------------------------------
+ ipi = SIZE(tab2d,1) ! 1st dimension
+ ipj = SIZE(tab2d,2) ! 2nd dimension
+ !
+ IF( ipi == jpi .AND. ipj == jpj ) THEN ! full arrays then no need to change index jid and jjd
+ ji0 = 0 ; jj0 = 0
+ ELSE ! reduced arrays then need to shift index by nn_hls
+ ji0 = nn_hls ; jj0 = nn_hls ! since tab2d is shifted by nn_hls
+ ENDIF ! (i.e. from hls+1:jpi-hls to 1:jpi-2*hls)
+ !
DO jl = 1, jpl
DO jn = 1, ndim1d
- jid = MOD( tab_ind(jn) - 1 , jpi ) + 1
- jjd = ( tab_ind(jn) - 1 ) / jpi + 1
+ jid = MOD( tab_ind(jn) - 1 , jpi ) + 1 - ji0
+ jjd = ( tab_ind(jn) - 1 ) / jpi + 1 - jj0
tab2d(jid,jjd,jl) = tab1d(jn,jl)
END DO
END DO
@@ -100,13 +194,22 @@ CONTAINS
INTEGER , INTENT(in ) :: ndim1d ! 1D size
INTEGER , DIMENSION(ndim1d) , INTENT(in ) :: tab_ind ! input index
REAL(wp), DIMENSION(ndim1d) , INTENT(in ) :: tab1d ! input 1D field
- REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: tab2d ! output 2D field
+ REAL(wp), DIMENSION(:,:) , INTENT(inout) :: tab2d ! output 2D field
!
- INTEGER :: jn , jid, jjd
+ INTEGER :: ipi, ipj, ji0, jj0, jn, jid, jjd
!!----------------------------------------------------------------------
+ ipi = SIZE(tab2d,1) ! 1st dimension
+ ipj = SIZE(tab2d,2) ! 2nd dimension
+ !
+ IF( ipi == jpi .AND. ipj == jpj ) THEN ! full arrays then no need to change index jid and jjd
+ ji0 = 0 ; jj0 = 0
+ ELSE ! reduced arrays then need to shift index by nn_hls
+ ji0 = nn_hls ; jj0 = nn_hls ! since tab2d is shifted by nn_hls
+ ENDIF ! (i.e. from hls+1:jpi-hls to 1:jpi-2*hls)
+ !
DO jn = 1, ndim1d
- jid = MOD( tab_ind(jn) - 1 , jpi ) + 1
- jjd = ( tab_ind(jn) - 1 ) / jpi + 1
+ jid = MOD( tab_ind(jn) - 1 , jpi ) + 1 - ji0
+ jjd = ( tab_ind(jn) - 1 ) / jpi + 1 - jj0
tab2d(jid, jjd) = tab1d( jn)
END DO
END SUBROUTINE tab_1d_2d
diff --git a/src/ICE/icethd.F90 b/src/ICE/icethd.F90
index 3971c4415240950ed6423023821b958247370d3f..ddc4ddf2b6fdce2307bbf7f398c74e17f34c0b17 100644
--- a/src/ICE/icethd.F90
+++ b/src/ICE/icethd.F90
@@ -25,7 +25,6 @@ MODULE icethd
USE icethd_dh ! sea-ice: ice-snow growth and melt
USE icethd_da ! sea-ice: lateral melting
USE icethd_sal ! sea-ice: salinity
- USE icethd_ent ! sea-ice: enthalpy redistribution
USE icethd_do ! sea-ice: growth in open water
USE icethd_pnd ! sea-ice: melt ponds
USE iceitd ! sea-ice: remapping thickness distribution
@@ -72,7 +71,6 @@ CONTAINS
!! - call ice_thd_zdf for vertical heat diffusion
!! - call ice_thd_dh for vertical ice growth and melt
!! - call ice_thd_pnd for melt ponds
- !! - call ice_thd_ent for enthalpy remapping
!! - call ice_thd_sal for ice desalination
!! - call ice_thd_temp to retrieve temperature from ice enthalpy
!! - call ice_thd_mono for extra lateral ice melt if active virtual thickness distribution
@@ -85,6 +83,7 @@ CONTAINS
!
INTEGER :: ji, jj, jk, jl ! dummy loop indices
!!-------------------------------------------------------------------
+
! controls
IF( ln_timing ) CALL timing_start('icethd') ! timing
IF( ln_icediachk ) CALL ice_cons_hsm(0, 'icethd', rdiag_v, rdiag_s, rdiag_t, rdiag_fv, rdiag_fs, rdiag_ft) ! conservation
@@ -98,7 +97,7 @@ CONTAINS
! convergence tests
IF( ln_zdf_chkcvg ) THEN
- ALLOCATE( ztice_cvgerr(jpi,jpj,jpl) , ztice_cvgstp(jpi,jpj,jpl) )
+ ALLOCATE( ztice_cvgerr(A2D(0),jpl) , ztice_cvgstp(A2D(0),jpl) )
ztice_cvgerr = 0._wp ; ztice_cvgstp = 0._wp
ENDIF
!
@@ -111,7 +110,7 @@ CONTAINS
! select ice covered grid points
npti = 0 ; nptidx(:) = 0
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
IF ( a_i(ji,jj,jl) > epsi10 ) THEN
npti = npti + 1
nptidx(npti) = (jj - 1) * jpi + ji
@@ -131,8 +130,7 @@ CONTAINS
CALL ice_thd_zdf ! --- Ice-Snow temperature --- !
!
IF( ln_icedH ) THEN ! --- Growing/Melting --- !
- CALL ice_thd_dh ! Ice-Snow thickness
- CALL ice_thd_ent( e_i_1d(1:npti,:) ) ! Ice enthalpy remapping
+ CALL ice_thd_dh
ENDIF
CALL ice_thd_sal( ln_icedS ) ! --- Ice salinity --- !
!
@@ -161,8 +159,14 @@ CONTAINS
!
CALL ice_cor( kt , 2 ) ! --- Corrections --- !
!
- oa_i(:,:,:) = oa_i(:,:,:) + a_i(:,:,:) * rDt_ice ! --- Ice natural aging incrementation
+ oa_i(A2D(0),:) = oa_i(A2D(0),:) + a_i(A2D(0),:) * rDt_ice ! --- Ice natural aging incrementation
+ !
+ ! ! --- LBC for the halos --- !
+ CALL lbc_lnk( 'icethd', a_i , 'T', 1._wp, v_i , 'T', 1._wp, v_s , 'T', 1._wp, sv_i, 'T', 1._wp, oa_i, 'T', 1._wp, &
+ & t_su, 'T', 1._wp, a_ip, 'T', 1._wp, v_ip, 'T', 1._wp, v_il, 'T', 1._wp )
+ CALL lbc_lnk( 'icethd', e_i , 'T', 1._wp, e_s , 'T', 1._wp )
!
+ at_i(:,:) = SUM( a_i, dim=3 )
DO_2D( 0, 0, 0, 0 ) ! --- Ice velocity corrections
IF( at_i(ji,jj) == 0._wp ) THEN ! if ice has melted
IF( at_i(ji+1,jj) == 0._wp ) u_ice(ji ,jj) = 0._wp ! right side
@@ -202,15 +206,15 @@ CONTAINS
! Recover ice temperature
DO jk = 1, nlay_i
DO ji = 1, npti
- ztmelts = -rTmlt * sz_i_1d(ji,jk)
- ! Conversion q(S,T) -> T (second order equation)
- zbbb = ( rcp - rcpi ) * ztmelts + e_i_1d(ji,jk) * r1_rhoi - rLfus
- zccc = SQRT( MAX( zbbb * zbbb - 4._wp * rcpi * rLfus * ztmelts, 0._wp ) )
- t_i_1d(ji,jk) = rt0 - ( zbbb + zccc ) * 0.5_wp * r1_rcpi
-
- ! mask temperature
- rswitch = 1._wp - MAX( 0._wp , SIGN( 1._wp , - h_i_1d(ji) ) )
- t_i_1d(ji,jk) = rswitch * t_i_1d(ji,jk) + ( 1._wp - rswitch ) * rt0
+ IF( h_i_1d(ji) > 0._wp ) THEN
+ ztmelts = -rTmlt * sz_i_1d(ji,jk)
+ ! Conversion q(S,T) -> T (second order equation)
+ zbbb = ( rcp - rcpi ) * ztmelts + e_i_1d(ji,jk) * r1_rhoi - rLfus
+ zccc = SQRT( MAX( zbbb * zbbb - 4._wp * rcpi * rLfus * ztmelts, 0._wp ) )
+ t_i_1d(ji,jk) = rt0 - ( zbbb + zccc ) * 0.5_wp * r1_rcpi
+ ELSE
+ t_i_1d(ji,jk) = rt0
+ ENDIF
END DO
END DO
!
@@ -237,8 +241,7 @@ CONTAINS
zvs = a_i_1d(ji) * h_s_1d(ji)
! lateral melting = concentration change
zhi_bef = h_i_1d(ji) - zdh_mel
- rswitch = MAX( 0._wp , SIGN( 1._wp , zhi_bef - epsi20 ) )
- zda_mel = rswitch * a_i_1d(ji) * zdh_mel / ( 2._wp * MAX( zhi_bef, epsi20 ) )
+ zda_mel = MAX( -a_i_1d(ji) , a_i_1d(ji) * zdh_mel / ( 2._wp * MAX( zhi_bef, epsi20 ) ) )
a_i_1d(ji) = MAX( epsi20, a_i_1d(ji) + zda_mel )
! adjust thickness
h_i_1d(ji) = zvi / a_i_1d(ji)
diff --git a/src/ICE/icethd_dh.F90 b/src/ICE/icethd_dh.F90
index 90a5b591053183b7ae3455704f0af67c4a80e61c..5264b7566aef2a99676495afece415a797844e41 100644
--- a/src/ICE/icethd_dh.F90
+++ b/src/ICE/icethd_dh.F90
@@ -68,9 +68,6 @@ CONTAINS
REAL(wp) :: ztmelts ! local scalar
REAL(wp) :: zdum
REAL(wp) :: zfracs ! fractionation coefficient for bottom salt entrapment
- REAL(wp) :: zswi1 ! switch for computation of bottom salinity
- REAL(wp) :: zswi12 ! switch for computation of bottom salinity
- REAL(wp) :: zswi2 ! switch for computation of bottom salinity
REAL(wp) :: zgrr ! bottom growth rate
REAL(wp) :: zt_i_new ! bottom formation temperature
REAL(wp) :: z1_rho ! 1/(rhos+rho0-rhoi)
@@ -85,14 +82,16 @@ CONTAINS
REAL(wp), DIMENSION(jpij) :: zq_bot ! heat for bottom ablation (J.m-2)
REAL(wp), DIMENSION(jpij) :: zq_rema ! remaining heat at the end of the routine (J.m-2)
REAL(wp), DIMENSION(jpij) :: zf_tt ! Heat budget to determine melting or freezing(W.m-2)
- REAL(wp), DIMENSION(jpij) :: zevap_rema ! remaining mass flux from sublimation (kg.m-2)
- REAL(wp), DIMENSION(jpij) :: zdeltah
+ REAL(wp) :: zevap_rema ! remaining mass flux from sublimation (kg.m-2)
+ REAL(wp) :: zdeltah
REAL(wp), DIMENSION(jpij) :: zsnw ! distribution of snow after wind blowing
- INTEGER , DIMENSION(jpij,nlay_i) :: icount ! number of layers vanishing by melting
- REAL(wp), DIMENSION(jpij,0:nlay_i+1) :: zh_i ! ice layer thickness (m)
- REAL(wp), DIMENSION(jpij,0:nlay_s ) :: zh_s ! snw layer thickness (m)
- REAL(wp), DIMENSION(jpij,0:nlay_s ) :: ze_s ! snw layer enthalpy (J.m-3)
+ INTEGER , DIMENSION(nlay_i) :: icount ! number of layers vanishing by melting
+ REAL(wp), DIMENSION(0:nlay_i+1) :: zh_i ! ice layer thickness (m)
+ REAL(wp), DIMENSION(0:nlay_s ) :: zh_s ! snw layer thickness (m)
+ REAL(wp), DIMENSION(0:nlay_s ) :: ze_s ! snw layer enthalpy (J.m-3)
+ REAL(wp), DIMENSION(0:nlay_i+1) :: zh_i_old ! old thickness
+ REAL(wp), DIMENSION(0:nlay_i+1) :: ze_i_old ! old enthalpy
REAL(wp) :: zswitch_sal
@@ -104,155 +103,150 @@ CONTAINS
CASE( 1 , 3 ) ; zswitch_sal = 0._wp ! prescribed salinity profile
CASE( 2 ) ; zswitch_sal = 1._wp ! varying salinity profile
END SELECT
-
- ! initialize ice layer thicknesses and enthalpies
- eh_i_old(1:npti,0:nlay_i+1) = 0._wp
- h_i_old (1:npti,0:nlay_i+1) = 0._wp
- zh_i (1:npti,0:nlay_i+1) = 0._wp
- DO jk = 1, nlay_i
- DO ji = 1, npti
- eh_i_old(ji,jk) = h_i_1d(ji) * r1_nlay_i * e_i_1d(ji,jk)
- h_i_old (ji,jk) = h_i_1d(ji) * r1_nlay_i
- zh_i (ji,jk) = h_i_1d(ji) * r1_nlay_i
- END DO
- END DO
- !
- ! initialize snw layer thicknesses and enthalpies
- zh_s(1:npti,0) = 0._wp
- ze_s(1:npti,0) = 0._wp
- DO jk = 1, nlay_s
- DO ji = 1, npti
- zh_s(ji,jk) = h_s_1d(ji) * r1_nlay_s
- ze_s(ji,jk) = e_s_1d(ji,jk)
- END DO
- END DO
!
! ! ============================================== !
! ! Available heat for surface and bottom ablation !
! ! ============================================== !
- !
IF( ln_cndflx .AND. .NOT.ln_cndemulate ) THEN
- !
DO ji = 1, npti
- zq_top(ji) = MAX( 0._wp, qml_ice_1d(ji) * rDt_ice )
+ zq_top(ji) = MAX( 0._wp, qml_ice_1d(ji) * rDt_ice )
END DO
- !
ELSE
- !
DO ji = 1, npti
- zdum = qns_ice_1d(ji) + qsr_ice_1d(ji) - qtr_ice_top_1d(ji) - qcn_ice_top_1d(ji)
- qml_ice_1d(ji) = zdum * MAX( 0._wp , SIGN( 1._wp, t_su_1d(ji) - rt0 ) )
- zq_top(ji) = MAX( 0._wp, qml_ice_1d(ji) * rDt_ice )
+ IF( t_su_1d(ji) >= rt0 ) THEN
+ qml_ice_1d(ji) = qns_ice_1d(ji) + qsr_ice_1d(ji) - qtr_ice_top_1d(ji) - qcn_ice_top_1d(ji)
+ ELSE
+ qml_ice_1d(ji) = 0._wp
+ ENDIF
+ zq_top(ji) = MAX( 0._wp, qml_ice_1d(ji) * rDt_ice )
END DO
- !
ENDIF
!
DO ji = 1, npti
- zf_tt(ji) = qcn_ice_bot_1d(ji) + qsb_ice_bot_1d(ji) + fhld_1d(ji) + qtr_ice_bot_1d(ji) * frq_m_1d(ji)
- zq_bot(ji) = MAX( 0._wp, zf_tt(ji) * rDt_ice )
- END DO
-
- ! ! ============ !
- ! ! Snow !
- ! ! ============ !
+ zf_tt(ji) = qcn_ice_bot_1d(ji) + qsb_ice_bot_1d(ji) + fhld_1d(ji) + qtr_ice_bot_1d(ji) * frq_m_1d(ji)
+ zq_bot(ji) = MAX( 0._wp, zf_tt(ji) * rDt_ice )
+ END DO
+ ! ! ========== !
+ ! ! Other init !
+ ! ! ========== !
!
- ! Internal melting
- ! ----------------
- ! IF snow temperature is above freezing point, THEN snow melts (should not happen but sometimes it does)
- DO jk = 1, nlay_s
- DO ji = 1, npti
+ ! snow distribution over ice after wind blowing
+ CALL ice_var_snwblow( 1._wp - at_i_1d(1:npti), zsnw(1:npti) )
+ !
+ ! for snw-ice formation
+ z1_rho = 1._wp / ( rhos+rho0-rhoi )
+ !
+ ! number of iterations for new sea ice
+ IF( nn_icesal == 2 ) THEN ; num_iter_max = 5 ! salinity varying in time
+ ELSE ; num_iter_max = 1
+ ENDIF
+ ! ! ==================== !
+ ! ! Start main loop here !
+ ! ! ==================== !
+ DO ji = 1, npti
+
+ ! initialize ice layer thicknesses and enthalpies
+ ze_i_old(0:nlay_i+1) = 0._wp
+ zh_i_old(0:nlay_i+1) = 0._wp
+ zh_i (0:nlay_i+1) = 0._wp
+ DO jk = 1, nlay_i
+ ze_i_old(jk) = h_i_1d(ji) * r1_nlay_i * e_i_1d(ji,jk)
+ zh_i_old(jk) = h_i_1d(ji) * r1_nlay_i
+ zh_i (jk) = h_i_1d(ji) * r1_nlay_i
+ END DO
+ !
+ ! initialize snw layer thicknesses and enthalpies
+ zh_s(0) = 0._wp
+ ze_s(0) = 0._wp
+ DO jk = 1, nlay_s
+ zh_s(jk) = h_s_1d(ji) * r1_nlay_s
+ ze_s(jk) = e_s_1d(ji,jk)
+ END DO
+ !
+ ! ! ============ !
+ ! ! Snow !
+ ! ! ============ !
+ !
+ ! Internal melting
+ ! ----------------
+ ! IF snow temperature is above freezing point, THEN snow melts (should not happen but sometimes it does)
+ DO jk = 1, nlay_s
IF( t_s_1d(ji,jk) > rt0 ) THEN
- hfx_res_1d (ji) = hfx_res_1d (ji) - ze_s(ji,jk) * zh_s(ji,jk) * a_i_1d(ji) * r1_Dt_ice ! heat flux to the ocean [W.m-2], < 0
- wfx_snw_sum_1d(ji) = wfx_snw_sum_1d(ji) + rhos * zh_s(ji,jk) * a_i_1d(ji) * r1_Dt_ice ! mass flux
+ hfx_res_1d (ji) = hfx_res_1d (ji) - ze_s(jk) * zh_s(jk) * a_i_1d(ji) * r1_Dt_ice ! heat flux to the ocean [W.m-2], < 0
+ wfx_snw_sum_1d(ji) = wfx_snw_sum_1d(ji) + rhos * zh_s(jk) * a_i_1d(ji) * r1_Dt_ice ! mass flux
! updates
- dh_s_mlt(ji) = dh_s_mlt(ji) - zh_s(ji,jk)
- h_s_1d (ji) = MAX( 0._wp, h_s_1d (ji) - zh_s(ji,jk) )
- zh_s (ji,jk) = 0._wp
- ze_s (ji,jk) = 0._wp
+ dh_s_mlt(ji) = dh_s_mlt(ji) - zh_s(jk)
+ h_s_1d (ji) = MAX( 0._wp, h_s_1d (ji) - zh_s(jk) )
+ zh_s (jk) = 0._wp
+ ze_s (jk) = 0._wp
END IF
END DO
- END DO
- ! Snow precipitation
- !-------------------
- CALL ice_var_snwblow( 1._wp - at_i_1d(1:npti), zsnw(1:npti) ) ! snow distribution over ice after wind blowing
-
- DO ji = 1, npti
+ ! Snow precipitation
+ !-------------------
IF( sprecip_1d(ji) > 0._wp ) THEN
- zh_s(ji,0) = zsnw(ji) * sprecip_1d(ji) * rDt_ice * r1_rhos / at_i_1d(ji) ! thickness of precip
- ze_s(ji,0) = MAX( 0._wp, - qprec_ice_1d(ji) ) ! enthalpy of the precip (>0, J.m-3)
+ zh_s(0) = zsnw(ji) * sprecip_1d(ji) * rDt_ice * r1_rhos / at_i_1d(ji) ! thickness of precip
+ ze_s(0) = MAX( 0._wp, - qprec_ice_1d(ji) ) ! enthalpy of the precip (>0, J.m-3)
!
- hfx_spr_1d(ji) = hfx_spr_1d(ji) + ze_s(ji,0) * zh_s(ji,0) * a_i_1d(ji) * r1_Dt_ice ! heat flux from snow precip (>0, W.m-2)
- wfx_spr_1d(ji) = wfx_spr_1d(ji) - rhos * zh_s(ji,0) * a_i_1d(ji) * r1_Dt_ice ! mass flux, <0
+ hfx_spr_1d(ji) = hfx_spr_1d(ji) + ze_s(0) * zh_s(0) * a_i_1d(ji) * r1_Dt_ice ! heat flux from snow precip (>0, W.m-2)
+ wfx_spr_1d(ji) = wfx_spr_1d(ji) - rhos * zh_s(0) * a_i_1d(ji) * r1_Dt_ice ! mass flux, <0
!
! update thickness
- h_s_1d(ji) = h_s_1d(ji) + zh_s(ji,0)
+ h_s_1d(ji) = h_s_1d(ji) + zh_s(0)
ENDIF
- END DO
- ! Snow melting
- ! ------------
- ! If heat still available (zq_top > 0)
- ! then all snw precip has been melted and we need to melt more snow
- DO jk = 0, nlay_s
- DO ji = 1, npti
- IF( zh_s(ji,jk) > 0._wp .AND. zq_top(ji) > 0._wp ) THEN
+ ! Snow melting
+ ! ------------
+ ! If heat still available (zq_top > 0)
+ ! then all snw precip has been melted and we need to melt more snow
+ DO jk = 0, nlay_s
+ IF( zh_s(jk) > 0._wp .AND. zq_top(ji) > 0._wp ) THEN
!
- rswitch = MAX( 0._wp , SIGN( 1._wp , ze_s(ji,jk) - epsi20 ) )
- zdum = - rswitch * zq_top(ji) / MAX( ze_s(ji,jk), epsi20 ) ! thickness change
- zdum = MAX( zdum , - zh_s(ji,jk) ) ! bound melting
-
- hfx_snw_1d (ji) = hfx_snw_1d (ji) - ze_s(ji,jk) * zdum * a_i_1d(ji) * r1_Dt_ice ! heat used to melt snow(W.m-2, >0)
- wfx_snw_sum_1d(ji) = wfx_snw_sum_1d(ji) - rhos * zdum * a_i_1d(ji) * r1_Dt_ice ! snow melting only = water into the ocean
-
+ zdum = - zq_top(ji) / MAX( ze_s(jk), epsi20 ) ! thickness change
+ zdum = MAX( zdum , - zh_s(jk) ) ! bound melting
+
+ hfx_snw_1d (ji) = hfx_snw_1d (ji) - ze_s(jk) * zdum * a_i_1d(ji) * r1_Dt_ice ! heat used to melt snow(W.m-2, >0)
+ wfx_snw_sum_1d(ji) = wfx_snw_sum_1d(ji) - rhos * zdum * a_i_1d(ji) * r1_Dt_ice ! snow melting only = water into the ocean
+
! updates available heat + thickness
- dh_s_mlt(ji) = dh_s_mlt(ji) + zdum
- zq_top (ji) = MAX( 0._wp , zq_top (ji) + zdum * ze_s(ji,jk) )
- h_s_1d (ji) = MAX( 0._wp , h_s_1d (ji) + zdum )
- zh_s (ji,jk) = MAX( 0._wp , zh_s (ji,jk) + zdum )
-!!$ IF( zh_s(ji,jk) == 0._wp ) ze_s(ji,jk) = 0._wp
+ dh_s_mlt(ji) = dh_s_mlt(ji) + zdum
+ zq_top (ji) = MAX( 0._wp , zq_top (ji) + zdum * ze_s(jk) )
+ h_s_1d (ji) = MAX( 0._wp , h_s_1d (ji) + zdum )
+ zh_s (jk) = MAX( 0._wp , zh_s (jk) + zdum )
+!!$ IF( zh_s(jk) == 0._wp ) ze_s(jk) = 0._wp
!
ENDIF
END DO
- END DO
- ! Snow sublimation
- !-----------------
- ! qla_ice is always >=0 (upwards), heat goes to the atmosphere, therefore snow sublimates
- ! comment: not counted in mass/heat exchange in iceupdate.F90 since this is an exchange with atm. (not ocean)
- zdeltah (1:npti) = 0._wp ! total snow thickness that sublimates, < 0
- zevap_rema(1:npti) = 0._wp
- DO ji = 1, npti
- zdeltah (ji) = MAX( - evap_ice_1d(ji) * r1_rhos * rDt_ice, - h_s_1d(ji) ) ! amount of snw that sublimates, < 0
- zevap_rema(ji) = evap_ice_1d(ji) * rDt_ice + zdeltah(ji) * rhos ! remaining evap in kg.m-2 (used for ice sublimation later on)
- END DO
-
- DO jk = 0, nlay_s
- DO ji = 1, npti
- zdum = MAX( -zh_s(ji,jk), zdeltah(ji) ) ! snow layer thickness that sublimates, < 0
+ ! Snow sublimation
+ !-----------------
+ ! qla_ice is always >=0 (upwards), heat goes to the atmosphere, therefore snow sublimates
+ ! comment: not counted in mass/heat exchange in iceupdate.F90 since this is an exchange with atm. (not ocean)
+ zdeltah = MAX( - evap_ice_1d(ji) * r1_rhos * rDt_ice, - h_s_1d(ji) ) ! amount of snw that sublimates, < 0
+ zevap_rema = evap_ice_1d(ji) * rDt_ice + zdeltah * rhos ! remaining evap in kg.m-2 (used for ice sublimation later on)
+ DO jk = 0, nlay_s
+ zdum = MAX( -zh_s(jk), zdeltah ) ! snow layer thickness that sublimates, < 0
!
- hfx_sub_1d (ji) = hfx_sub_1d (ji) + ze_s(ji,jk) * zdum * a_i_1d(ji) * r1_Dt_ice ! Heat flux of snw that sublimates [W.m-2], < 0
- wfx_snw_sub_1d(ji) = wfx_snw_sub_1d(ji) - rhos * zdum * a_i_1d(ji) * r1_Dt_ice ! Mass flux by sublimation
+ hfx_sub_1d (ji) = hfx_sub_1d (ji) + ze_s(jk) * zdum * a_i_1d(ji) * r1_Dt_ice ! Heat flux of snw that sublimates [W.m-2], < 0
+ wfx_snw_sub_1d(ji) = wfx_snw_sub_1d(ji) - rhos * zdum * a_i_1d(ji) * r1_Dt_ice ! Mass flux by sublimation
! update thickness
- h_s_1d(ji) = MAX( 0._wp , h_s_1d(ji) + zdum )
- zh_s (ji,jk) = MAX( 0._wp , zh_s (ji,jk) + zdum )
-!!$ IF( zh_s(ji,jk) == 0._wp ) ze_s(ji,jk) = 0._wp
+ h_s_1d(ji) = MAX( 0._wp , h_s_1d(ji) + zdum )
+ zh_s (jk) = MAX( 0._wp , zh_s (jk) + zdum )
+!!$ IF( zh_s(jk) == 0._wp ) ze_s(jk) = 0._wp
! update sublimation left
- zdeltah(ji) = MIN( zdeltah(ji) - zdum, 0._wp )
+ zdeltah = MIN( zdeltah - zdum, 0._wp )
END DO
- END DO
- !
- ! ! ============ !
- ! ! Ice !
- ! ! ============ !
+ !
+ ! ! ============ !
+ ! ! Ice !
+ ! ! ============ !
- ! Surface ice melting
- !--------------------
- DO jk = 1, nlay_i
- DO ji = 1, npti
+ ! Surface ice melting
+ !--------------------
+ DO jk = 1, nlay_i
ztmelts = - rTmlt * sz_i_1d(ji,jk) ! Melting point of layer k [C]
IF( t_i_1d(ji,jk) >= (ztmelts+rt0) ) THEN !-- Internal melting
@@ -260,7 +254,7 @@ CONTAINS
zEi = - e_i_1d(ji,jk) * r1_rhoi ! Specific enthalpy of layer k [J/kg, <0]
zdE = 0._wp ! Specific enthalpy difference (J/kg, <0)
! set up at 0 since no energy is needed to melt water...(it is already melted)
- zdum = MIN( 0._wp , - zh_i(ji,jk) ) ! internal melting occurs when the internal temperature is above freezing
+ zdum = MIN( 0._wp , - zh_i(jk) ) ! internal melting occurs when the internal temperature is above freezing
! this should normally not happen, but sometimes, heat diffusion leads to this
zfmdt = - zdum * rhoi ! Recompute mass flux [kg/m2, >0]
!
@@ -281,7 +275,7 @@ CONTAINS
zdum = - zfmdt * r1_rhoi ! Melt of layer jk [m, <0]
- zdum = MIN( 0._wp , MAX( zdum , - zh_i(ji,jk) ) ) ! Melt of layer jk cannot exceed the layer thickness [m, <0]
+ zdum = MIN( 0._wp , MAX( zdum , - zh_i(jk) ) ) ! Melt of layer jk cannot exceed the layer thickness [m, <0]
zq_top(ji) = MAX( 0._wp , zq_top(ji) - zdum * rhoi * zdE ) ! update available heat
@@ -298,17 +292,17 @@ CONTAINS
! using s_i_1d and not sz_i_1d(jk) is ok)
END IF
! update thickness
- zh_i(ji,jk) = MAX( 0._wp, zh_i(ji,jk) + zdum )
- h_i_1d(ji) = MAX( 0._wp, h_i_1d(ji) + zdum )
+ zh_i (jk) = MAX( 0._wp, zh_i (jk) + zdum )
+ h_i_1d(ji) = MAX( 0._wp, h_i_1d(ji) + zdum )
!
! update heat content (J.m-2) and layer thickness
- eh_i_old(ji,jk) = eh_i_old(ji,jk) + zdum * e_i_1d(ji,jk)
- h_i_old (ji,jk) = h_i_old (ji,jk) + zdum
+ ze_i_old(jk) = ze_i_old(jk) + zdum * e_i_1d(ji,jk)
+ zh_i_old(jk) = zh_i_old(jk) + zdum
!
!
! Ice sublimation
! ---------------
- zdum = MAX( - zh_i(ji,jk) , - zevap_rema(ji) * r1_rhoi )
+ zdum = MAX( - zh_i(jk) , - zevap_rema * r1_rhoi )
!
hfx_sub_1d(ji) = hfx_sub_1d(ji) + e_i_1d(ji,jk) * zdum * a_i_1d(ji) * r1_Dt_ice ! Heat flux [W.m-2], < 0
wfx_ice_sub_1d(ji) = wfx_ice_sub_1d(ji) - rhoi * zdum * a_i_1d(ji) * r1_Dt_ice ! Mass flux > 0
@@ -317,60 +311,50 @@ CONTAINS
! but salt should remain in the ice except
! if all ice is melted. => must be corrected
! update remaining mass flux and thickness
- zevap_rema(ji) = zevap_rema(ji) + zdum * rhoi
- zh_i(ji,jk) = MAX( 0._wp, zh_i(ji,jk) + zdum )
- h_i_1d(ji) = MAX( 0._wp, h_i_1d(ji) + zdum )
- dh_i_sub(ji) = dh_i_sub(ji) + zdum
+ zevap_rema = zevap_rema + zdum * rhoi
+ zh_i (jk) = MAX( 0._wp, zh_i (jk) + zdum )
+ h_i_1d(ji) = MAX( 0._wp, h_i_1d(ji) + zdum )
+ dh_i_sub(ji) = dh_i_sub(ji) + zdum
! update heat content (J.m-2) and layer thickness
- eh_i_old(ji,jk) = eh_i_old(ji,jk) + zdum * e_i_1d(ji,jk)
- h_i_old (ji,jk) = h_i_old (ji,jk) + zdum
+ ze_i_old(jk) = ze_i_old(jk) + zdum * e_i_1d(ji,jk)
+ zh_i_old(jk) = zh_i_old(jk) + zdum
! record which layers have disappeared (for bottom melting)
! => icount=0 : no layer has vanished
! => icount=5 : 5 layers have vanished
- rswitch = MAX( 0._wp , SIGN( 1._wp , - zh_i(ji,jk) ) )
- icount(ji,jk) = NINT( rswitch )
+ IF( zh_i(jk) > 0._wp ) THEN ; icount(jk) = 0
+ ELSE ; icount(jk) = 1 ; ENDIF
END DO
- END DO
- ! remaining "potential" evap is sent to ocean
- DO ji = 1, npti
- wfx_err_sub_1d(ji) = wfx_err_sub_1d(ji) - zevap_rema(ji) * a_i_1d(ji) * r1_Dt_ice ! <=0 (net evap for the ocean in kg.m-2.s-1)
- END DO
+ ! remaining "potential" evap is sent to ocean
+ wfx_err_sub_1d(ji) = wfx_err_sub_1d(ji) - zevap_rema * a_i_1d(ji) * r1_Dt_ice ! <=0 (net evap for the ocean in kg.m-2.s-1)
- ! Ice Basal growth
- !------------------
- ! Basal growth is driven by heat imbalance at the ice-ocean interface,
- ! between the inner conductive flux (qcn_ice_bot), from the open water heat flux
- ! (fhld) and the sensible ice-ocean flux (qsb_ice_bot).
- ! qcn_ice_bot is positive downwards. qsb_ice_bot and fhld are positive to the ice
+ ! Ice Basal growth
+ !------------------
+ ! Basal growth is driven by heat imbalance at the ice-ocean interface,
+ ! between the inner conductive flux (qcn_ice_bot), from the open water heat flux
+ ! (fhld) and the sensible ice-ocean flux (qsb_ice_bot).
+ ! qcn_ice_bot is positive downwards. qsb_ice_bot and fhld are positive to the ice
- ! If salinity varies in time, an iterative procedure is required, because
- ! the involved quantities are inter-dependent.
- ! Basal growth (dh_i_bog) depends upon new ice specific enthalpy (zEi),
- ! which depends on forming ice salinity (s_i_new), which depends on dh/dt (dh_i_bog)
- ! -> need for an iterative procedure, which converges quickly
+ ! If salinity varies in time, an iterative procedure is required, because
+ ! the involved quantities are inter-dependent.
+ ! Basal growth (dh_i_bog) depends upon new ice specific enthalpy (zEi),
+ ! which depends on forming ice salinity (s_i_new), which depends on dh/dt (dh_i_bog)
+ ! -> need for an iterative procedure, which converges quickly
- num_iter_max = 1
- IF( nn_icesal == 2 ) num_iter_max = 5 ! salinity varying in time
-
- DO ji = 1, npti
IF( zf_tt(ji) < 0._wp ) THEN
DO iter = 1, num_iter_max ! iterations
! New bottom ice salinity (Cox & Weeks, JGR88 )
- !--- zswi1 if dh/dt < 2.0e-8
- !--- zswi12 if 2.0e-8 < dh/dt < 3.6e-7
- !--- zswi2 if dh/dt > 3.6e-7
- zgrr = MIN( 1.0e-3, MAX ( dh_i_bog(ji) * r1_Dt_ice , epsi10 ) )
- zswi2 = MAX( 0._wp , SIGN( 1._wp , zgrr - 3.6e-7 ) )
- zswi12 = MAX( 0._wp , SIGN( 1._wp , zgrr - 2.0e-8 ) ) * ( 1.0 - zswi2 )
- zswi1 = 1. - zswi2 * zswi12
- zfracs = MIN( zswi1 * 0.12 + zswi12 * ( 0.8925 + 0.0568 * LOG( 100.0 * zgrr ) ) &
- & + zswi2 * 0.26 / ( 0.26 + 0.74 * EXP ( - 724300.0 * zgrr ) ) , 0.5 )
+ zgrr = MIN( 1.0e-3_wp, MAX ( dh_i_bog(ji) * r1_Dt_ice , epsi10 ) )
+ !
+ IF ( zgrr < 2.0e-8_wp ) THEN ; zfracs = 0.12_wp
+ ELSEIF( zgrr >= 3.6e-7_wp ) THEN ; zfracs = MIN( 0.26_wp / ( 0.26_wp + 0.74_wp * EXP(-724300._wp*zgrr) ) , 0.5_wp )
+ ELSE ; zfracs = MIN( 0.8925_wp + 0.0568_wp * LOG(100._wp*zgrr), 0.5_wp )
+ ENDIF
s_i_new(ji) = zswitch_sal * zfracs * sss_1d(ji) + ( 1. - zswitch_sal ) * s_i_1d(ji) ! New ice salinity
@@ -397,22 +381,19 @@ CONTAINS
sfx_bog_1d(ji) = sfx_bog_1d(ji) - rhoi * dh_i_bog(ji) * s_i_new(ji) * a_i_1d(ji) * r1_Dt_ice ! Salt flux, <0
! update thickness
- zh_i(ji,nlay_i+1) = zh_i(ji,nlay_i+1) + dh_i_bog(ji)
- h_i_1d(ji) = h_i_1d(ji) + dh_i_bog(ji)
+ zh_i(nlay_i+1) = zh_i(nlay_i+1) + dh_i_bog(ji)
+ h_i_1d(ji) = h_i_1d(ji) + dh_i_bog(ji)
! update heat content (J.m-2) and layer thickness
- eh_i_old(ji,nlay_i+1) = eh_i_old(ji,nlay_i+1) + dh_i_bog(ji) * (-zEi * rhoi)
- h_i_old (ji,nlay_i+1) = h_i_old (ji,nlay_i+1) + dh_i_bog(ji)
+ ze_i_old(nlay_i+1) = ze_i_old(nlay_i+1) + dh_i_bog(ji) * (-zEi * rhoi)
+ zh_i_old(nlay_i+1) = zh_i_old(nlay_i+1) + dh_i_bog(ji)
ENDIF
- END DO
-
- ! Ice Basal melt
- !---------------
- DO jk = nlay_i, 1, -1
- DO ji = 1, npti
- IF( zf_tt(ji) > 0._wp .AND. jk > icount(ji,jk) ) THEN ! do not calculate where layer has already disappeared by surface melting
+ ! Ice Basal melt
+ !---------------
+ DO jk = nlay_i, 1, -1
+ IF( zf_tt(ji) > 0._wp .AND. jk > icount(jk) ) THEN ! do not calculate where layer has already disappeared by surface melting
ztmelts = - rTmlt * sz_i_1d(ji,jk) ! Melting point of layer jk (C)
@@ -421,7 +402,7 @@ CONTAINS
zEi = - e_i_1d(ji,jk) * r1_rhoi ! Specific enthalpy of melting ice (J/kg, <0)
zdE = 0._wp ! Specific enthalpy difference (J/kg, <0)
! set up at 0 since no energy is needed to melt water...(it is already melted)
- zdum = MIN( 0._wp , - zh_i(ji,jk) ) ! internal melting occurs when the internal temperature is above freezing
+ zdum = MIN( 0._wp , - zh_i(jk) ) ! internal melting occurs when the internal temperature is above freezing
! this should normally not happen, but sometimes, heat diffusion leads to this
dh_i_itm (ji) = dh_i_itm(ji) + zdum
!
@@ -442,7 +423,7 @@ CONTAINS
zdum = - zfmdt * r1_rhoi ! Gross thickness change
- zdum = MIN( 0._wp , MAX( zdum, - zh_i(ji,jk) ) ) ! bound thickness change
+ zdum = MIN( 0._wp , MAX( zdum, - zh_i(jk) ) ) ! bound thickness change
zq_bot(ji) = MAX( 0._wp , zq_bot(ji) - zdum * rhoi * zdE ) ! update available heat. MAX is necessary for roundup errors
@@ -459,63 +440,55 @@ CONTAINS
! using s_i_1d and not sz_i_1d(jk) is ok
ENDIF
! update thickness
- zh_i(ji,jk) = MAX( 0._wp, zh_i(ji,jk) + zdum )
- h_i_1d(ji) = MAX( 0._wp, h_i_1d(ji) + zdum )
+ zh_i (jk) = MAX( 0._wp, zh_i (jk) + zdum )
+ h_i_1d(ji) = MAX( 0._wp, h_i_1d(ji) + zdum )
!
! update heat content (J.m-2) and layer thickness
- eh_i_old(ji,jk) = eh_i_old(ji,jk) + zdum * e_i_1d(ji,jk)
- h_i_old (ji,jk) = h_i_old (ji,jk) + zdum
+ ze_i_old(jk) = ze_i_old(jk) + zdum * e_i_1d(ji,jk)
+ zh_i_old(jk) = zh_i_old(jk) + zdum
ENDIF
END DO
- END DO
- ! Remove snow if ice has melted entirely
- ! --------------------------------------
- DO jk = 0, nlay_s
- DO ji = 1,npti
- IF( h_i_1d(ji) == 0._wp ) THEN
+ ! Remove snow if ice has melted entirely
+ ! --------------------------------------
+ IF( h_i_1d(ji) == 0._wp ) THEN
+ DO jk = 0, nlay_s
! mass & energy loss to the ocean
- hfx_res_1d(ji) = hfx_res_1d(ji) - ze_s(ji,jk) * zh_s(ji,jk) * a_i_1d(ji) * r1_Dt_ice ! heat flux to the ocean [W.m-2], < 0
- wfx_res_1d(ji) = wfx_res_1d(ji) + rhos * zh_s(ji,jk) * a_i_1d(ji) * r1_Dt_ice ! mass flux
+ hfx_res_1d(ji) = hfx_res_1d(ji) - ze_s(jk) * zh_s(jk) * a_i_1d(ji) * r1_Dt_ice ! heat flux to the ocean [W.m-2], < 0
+ wfx_res_1d(ji) = wfx_res_1d(ji) + rhos * zh_s(jk) * a_i_1d(ji) * r1_Dt_ice ! mass flux
! update thickness and energy
- h_s_1d(ji) = 0._wp
- ze_s (ji,jk) = 0._wp
- zh_s (ji,jk) = 0._wp
- ENDIF
- END DO
- END DO
+ h_s_1d(ji) = 0._wp
+ ze_s (jk) = 0._wp
+ zh_s (jk) = 0._wp
+ END DO
+ ENDIF
- ! Snow load on ice
- ! -----------------
- ! When snow load exceeds Archimede's limit and sst is positive,
- ! snow-ice formation (next bloc) can lead to negative ice enthalpy.
- ! Therefore we consider here that this excess of snow falls into the ocean
- zdeltah(1:npti) = h_s_1d(1:npti) + h_i_1d(1:npti) * (rhoi-rho0) * r1_rhos
- DO jk = 0, nlay_s
- DO ji = 1, npti
- IF( zdeltah(ji) > 0._wp .AND. sst_1d(ji) > 0._wp ) THEN
+ ! Snow load on ice
+ ! -----------------
+ ! When snow load exceeds Archimede's limit and sst is positive,
+ ! snow-ice formation (next bloc) can lead to negative ice enthalpy.
+ ! Therefore we consider here that this excess of snow falls into the ocean
+ zdeltah = h_s_1d(ji) + h_i_1d(ji) * (rhoi-rho0) * r1_rhos
+ DO jk = 0, nlay_s
+ IF( zdeltah > 0._wp .AND. sst_1d(ji) > 0._wp ) THEN
! snow layer thickness that falls into the ocean
- zdum = MIN( zdeltah(ji) , zh_s(ji,jk) )
+ zdum = MIN( zdeltah , zh_s(jk) )
! mass & energy loss to the ocean
- hfx_res_1d(ji) = hfx_res_1d(ji) - ze_s(ji,jk) * zdum * a_i_1d(ji) * r1_Dt_ice ! heat flux to the ocean [W.m-2], < 0
- wfx_res_1d(ji) = wfx_res_1d(ji) + rhos * zdum * a_i_1d(ji) * r1_Dt_ice ! mass flux
+ hfx_res_1d(ji) = hfx_res_1d(ji) - ze_s(jk) * zdum * a_i_1d(ji) * r1_Dt_ice ! heat flux to the ocean [W.m-2], < 0
+ wfx_res_1d(ji) = wfx_res_1d(ji) + rhos * zdum * a_i_1d(ji) * r1_Dt_ice ! mass flux
! update thickness and energy
- h_s_1d(ji) = MAX( 0._wp, h_s_1d(ji) - zdum )
- zh_s (ji,jk) = MAX( 0._wp, zh_s(ji,jk) - zdum )
+ h_s_1d(ji) = MAX( 0._wp, h_s_1d(ji) - zdum )
+ zh_s (jk) = MAX( 0._wp, zh_s (jk) - zdum )
! update snow thickness that still has to fall
- zdeltah(ji) = MAX( 0._wp, zdeltah(ji) - zdum )
+ zdeltah = MAX( 0._wp, zdeltah - zdum )
ENDIF
END DO
- END DO
- ! Snow-Ice formation
- ! ------------------
- ! When snow load exceeds Archimede's limit, snow-ice interface goes down under sea-level,
- ! flooding of seawater transforms snow into ice. Thickness that is transformed is dh_snowice (positive for the ice)
- z1_rho = 1._wp / ( rhos+rho0-rhoi )
- zdeltah(1:npti) = 0._wp
- DO ji = 1, npti
+ ! Snow-Ice formation
+ ! ------------------
+ ! When snow load exceeds Archimede's limit, snow-ice interface goes down under sea-level,
+ ! flooding of seawater transforms snow into ice. Thickness that is transformed is dh_snowice (positive for the ice)
!
dh_snowice(ji) = MAX( 0._wp , ( rhos * h_s_1d(ji) + (rhoi-rho0) * h_i_1d(ji) ) * z1_rho )
@@ -541,50 +514,53 @@ CONTAINS
wfx_snw_sni_1d(ji) = wfx_snw_sni_1d(ji) + dh_snowice(ji) * rhos * a_i_1d(ji) * r1_Dt_ice
! update thickness
- zh_i(ji,0) = zh_i(ji,0) + dh_snowice(ji)
- zdeltah(ji) = dh_snowice(ji)
+ zh_i(0) = zh_i(0) + dh_snowice(ji)
+ zdeltah = dh_snowice(ji)
! update heat content (J.m-2) and layer thickness
- h_i_old (ji,0) = h_i_old (ji,0) + dh_snowice(ji)
- eh_i_old(ji,0) = eh_i_old(ji,0) + zfmdt * zEw ! 1st part (sea water enthalpy)
+ zh_i_old(0) = zh_i_old(0) + dh_snowice(ji)
+ ze_i_old(0) = ze_i_old(0) + zfmdt * zEw ! 1st part (sea water enthalpy)
- END DO
- !
- DO jk = nlay_s, 0, -1 ! flooding of snow starts from the base
- DO ji = 1, npti
- zdum = MIN( zdeltah(ji), zh_s(ji,jk) ) ! amount of snw that floods, > 0
- zh_s(ji,jk) = MAX( 0._wp, zh_s(ji,jk) - zdum ) ! remove some snow thickness
- eh_i_old(ji,0) = eh_i_old(ji,0) + zdum * ze_s(ji,jk) ! 2nd part (snow enthalpy)
+ !
+ DO jk = nlay_s, 0, -1 ! flooding of snow starts from the base
+ zdum = MIN( zdeltah, zh_s(jk) ) ! amount of snw that floods, > 0
+ zh_s(jk) = MAX( 0._wp, zh_s(jk) - zdum ) ! remove some snow thickness
+ ze_i_old(0) = ze_i_old(0) + zdum * ze_s(jk) ! 2nd part (snow enthalpy)
! update dh_snowice
- zdeltah(ji) = MAX( 0._wp, zdeltah(ji) - zdum )
+ zdeltah = MAX( 0._wp, zdeltah - zdum )
END DO
- END DO
- !
- !
+ !
+ !
!!$ ! --- Update snow diags --- !
!!$ !!clem: this is wrong. dh_s_tot is not used anyway
!!$ DO ji = 1, npti
-!!$ dh_s_tot(ji) = dh_s_tot(ji) + dh_s_mlt(ji) + zdeltah(ji) + zdh_s_sub(ji) - dh_snowice(ji)
+!!$ dh_s_tot(ji) = dh_s_tot(ji) + dh_s_mlt(ji) + zdeltah + zdh_s_sub(ji) - dh_snowice(ji)
!!$ END DO
- !
- !
- ! Remapping of snw enthalpy on a regular grid
- !--------------------------------------------
- CALL snw_ent( zh_s, ze_s, e_s_1d )
-
- ! recalculate t_s_1d from e_s_1d
- DO jk = 1, nlay_s
- DO ji = 1,npti
- IF( h_s_1d(ji) > 0._wp ) THEN
+ !
+ ! Remapping of snw enthalpy on a regular grid
+ !--------------------------------------------
+ e_s_1d(ji,:) = snw_ent( zh_s(:), ze_s(:) )
+
+ ! recalculate t_s_1d from e_s_1d
+ IF( h_s_1d(ji) > 0._wp ) THEN
+ DO jk = 1, nlay_s
t_s_1d(ji,jk) = rt0 + ( - e_s_1d(ji,jk) * r1_rhos * r1_rcpi + rLfus * r1_rcpi )
- ELSE
+ END DO
+ ELSE
+ DO jk = 1, nlay_s
t_s_1d(ji,jk) = rt0
- ENDIF
- END DO
- END DO
+ END DO
+ ENDIF
- ! Note: remapping of ice enthalpy is done in icethd.F90
+ ! Remapping of ice enthalpy on a regular grid
+ !--------------------------------------------
+ e_i_1d(ji,:) = ice_ent1( zh_i_old(:), ze_i_old(:) )
+ END DO ! npti
+ ! ! ================== !
+ ! ! End main loop here !
+ ! ! ================== !
+
! --- ensure that a_i = 0 & h_s = 0 where h_i = 0 ---
WHERE( h_i_1d(1:npti) == 0._wp )
a_i_1d (1:npti) = 0._wp
@@ -594,7 +570,7 @@ CONTAINS
END SUBROUTINE ice_thd_dh
- SUBROUTINE snw_ent( ph_old, pe_old, pe_new )
+ FUNCTION snw_ent( ph_old, pe_old )
!!-------------------------------------------------------------------
!! *** ROUTINE snw_ent ***
!!
@@ -619,73 +595,148 @@ CONTAINS
!!
!! References : Bitz & Lipscomb, JGR 99; Vancoppenolle et al., GRL, 2005
!!-------------------------------------------------------------------
- REAL(wp), DIMENSION(jpij,0:nlay_s), INTENT(in ) :: ph_old ! old thicknesses (m)
- REAL(wp), DIMENSION(jpij,0:nlay_s), INTENT(in ) :: pe_old ! old enthlapies (J.m-3)
- REAL(wp), DIMENSION(jpij,1:nlay_s), INTENT(inout) :: pe_new ! new enthlapies (J.m-3, remapped)
+ REAL(wp), DIMENSION(0:nlay_s), INTENT(in) :: ph_old ! old thicknesses (m)
+ REAL(wp), DIMENSION(0:nlay_s), INTENT(in) :: pe_old ! old enthlapies (J.m-3)
+ REAL(wp), DIMENSION(1:nlay_s) :: snw_ent ! new enthlapies (J.m-3, remapped)
!
INTEGER :: ji ! dummy loop indices
INTEGER :: jk0, jk1 ! old/new layer indices
!
- REAL(wp), DIMENSION(jpij,0:nlay_s+1) :: zeh_cum0, zh_cum0 ! old cumulative enthlapies and layers interfaces
- REAL(wp), DIMENSION(jpij,0:nlay_s) :: zeh_cum1, zh_cum1 ! new cumulative enthlapies and layers interfaces
- REAL(wp), DIMENSION(jpij) :: zhnew ! new layers thicknesses
+ REAL(wp), DIMENSION(0:nlay_s+1) :: zeh_cum0, zh_cum0 ! old cumulative enthlapies and layers interfaces
+ REAL(wp), DIMENSION(0:nlay_s) :: zeh_cum1, zh_cum1 ! new cumulative enthlapies and layers interfaces
+ REAL(wp) :: zhnew ! new layers thicknesses
!!-------------------------------------------------------------------
!--------------------------------------------------------------------------
! 1) Cumulative integral of old enthalpy * thickness and layers interfaces
!--------------------------------------------------------------------------
- zeh_cum0(1:npti,0) = 0._wp
- zh_cum0 (1:npti,0) = 0._wp
+ zeh_cum0(0) = 0._wp
+ zh_cum0 (0) = 0._wp
DO jk0 = 1, nlay_s+1
- DO ji = 1, npti
- zeh_cum0(ji,jk0) = zeh_cum0(ji,jk0-1) + pe_old(ji,jk0-1) * ph_old(ji,jk0-1)
- zh_cum0 (ji,jk0) = zh_cum0 (ji,jk0-1) + ph_old(ji,jk0-1)
- END DO
+ zeh_cum0(jk0) = zeh_cum0(jk0-1) + pe_old(jk0-1) * ph_old(jk0-1)
+ zh_cum0 (jk0) = zh_cum0 (jk0-1) + ph_old(jk0-1)
END DO
!------------------------------------
! 2) Interpolation on the new layers
!------------------------------------
! new layer thickesses
- DO ji = 1, npti
- zhnew(ji) = SUM( ph_old(ji,0:nlay_s) ) * r1_nlay_s
- END DO
+ zhnew = SUM( ph_old(0:nlay_s) ) * r1_nlay_s
! new layers interfaces
- zh_cum1(1:npti,0) = 0._wp
+ zh_cum1(0) = 0._wp
DO jk1 = 1, nlay_s
- DO ji = 1, npti
- zh_cum1(ji,jk1) = zh_cum1(ji,jk1-1) + zhnew(ji)
- END DO
+ zh_cum1(jk1) = zh_cum1(jk1-1) + zhnew
END DO
- zeh_cum1(1:npti,0:nlay_s) = 0._wp
+ zeh_cum1(0:nlay_s) = 0._wp
! new cumulative q*h => linear interpolation
DO jk0 = 1, nlay_s+1
DO jk1 = 1, nlay_s-1
- DO ji = 1, npti
- IF( zh_cum1(ji,jk1) <= zh_cum0(ji,jk0) .AND. zh_cum1(ji,jk1) > zh_cum0(ji,jk0-1) ) THEN
- zeh_cum1(ji,jk1) = ( zeh_cum0(ji,jk0-1) * ( zh_cum0(ji,jk0) - zh_cum1(ji,jk1 ) ) + &
- & zeh_cum0(ji,jk0 ) * ( zh_cum1(ji,jk1) - zh_cum0(ji,jk0-1) ) ) &
- & / ( zh_cum0(ji,jk0) - zh_cum0(ji,jk0-1) )
- ENDIF
- END DO
+ IF( zh_cum1(jk1) <= zh_cum0(jk0) .AND. zh_cum1(jk1) > zh_cum0(jk0-1) ) THEN
+ zeh_cum1(jk1) = ( zeh_cum0(jk0-1) * ( zh_cum0(jk0) - zh_cum1(jk1 ) ) + &
+ & zeh_cum0(jk0 ) * ( zh_cum1(jk1) - zh_cum0(jk0-1) ) ) &
+ & / ( zh_cum0(jk0) - zh_cum0(jk0-1) )
+ ENDIF
END DO
END DO
! to ensure that total heat content is strictly conserved, set:
- zeh_cum1(1:npti,nlay_s) = zeh_cum0(1:npti,nlay_s+1)
+ zeh_cum1(nlay_s) = zeh_cum0(nlay_s+1)
! new enthalpies
DO jk1 = 1, nlay_s
- DO ji = 1, npti
- rswitch = MAX( 0._wp , SIGN( 1._wp , zhnew(ji) - epsi20 ) )
- pe_new(ji,jk1) = rswitch * ( zeh_cum1(ji,jk1) - zeh_cum1(ji,jk1-1) ) / MAX( zhnew(ji), epsi20 )
+ snw_ent(jk1) = MAX( 0._wp, zeh_cum1(jk1) - zeh_cum1(jk1-1) ) / MAX( zhnew, epsi20 ) ! max for roundoff error
+ END DO
+
+
+ END FUNCTION snw_ent
+
+ FUNCTION ice_ent1( ph_old, pe_old )
+ !!-------------------------------------------------------------------
+ !! *** ROUTINE ice_ent1 ***
+ !!
+ !! ** Purpose :
+ !! This routine computes new vertical grids in the ice,
+ !! and consistently redistributes temperatures.
+ !! Redistribution is made so as to ensure to energy conservation
+ !!
+ !!
+ !! ** Method : linear conservative remapping
+ !!
+ !! ** Steps : 1) cumulative integrals of old enthalpies/thicknesses
+ !! 2) linear remapping on the new layers
+ !!
+ !! ------------ cum0(0) ------------- cum1(0)
+ !! NEW -------------
+ !! ------------ cum0(1) ==> -------------
+ !! ... -------------
+ !! ------------ -------------
+ !! ------------ cum0(nlay_i+2) ------------- cum1(nlay_i)
+ !!
+ !!
+ !! References : Bitz & Lipscomb, JGR 99; Vancoppenolle et al., GRL, 2005
+ !!-------------------------------------------------------------------
+ REAL(wp), DIMENSION(0:nlay_i+1), INTENT(in) :: ph_old, pe_old ! old tickness and enthlapy
+ REAL(wp), DIMENSION(1:nlay_i) :: ice_ent1 ! new enthlapies (J.m-3, remapped)
+ !
+ INTEGER :: ji ! dummy loop indices
+ INTEGER :: jk0, jk1 ! old/new layer indices
+ !
+ REAL(wp), DIMENSION(0:nlay_i+2) :: zeh_cum0, zh_cum0 ! old cumulative enthlapies and layers interfaces
+ REAL(wp), DIMENSION(0:nlay_i) :: zeh_cum1, zh_cum1 ! new cumulative enthlapies and layers interfaces
+ REAL(wp) :: zhnew ! new layers thicknesses
+ !!-------------------------------------------------------------------
+
+ !--------------------------------------------------------------------------
+ ! 1) Cumulative integral of old enthalpy * thickness and layers interfaces
+ !--------------------------------------------------------------------------
+ zeh_cum0(0) = 0._wp
+ zh_cum0 (0) = 0._wp
+ DO jk0 = 1, nlay_i+2
+ zeh_cum0(jk0) = zeh_cum0(jk0-1) + pe_old(jk0-1)
+ zh_cum0 (jk0) = zh_cum0 (jk0-1) + ph_old(jk0-1)
+ END DO
+
+ !------------------------------------
+ ! 2) Interpolation on the new layers
+ !------------------------------------
+ ! new layer thickesses
+ zhnew = SUM( ph_old(0:nlay_i+1) ) * r1_nlay_i
+
+ ! new layers interfaces
+ zh_cum1(0) = 0._wp
+ DO jk1 = 1, nlay_i
+ zh_cum1(jk1) = zh_cum1(jk1-1) + zhnew
+ END DO
+
+ zeh_cum1(0:nlay_i) = 0._wp
+ ! new cumulative q*h => linear interpolation
+ DO jk0 = 1, nlay_i+2
+ DO jk1 = 1, nlay_i-1
+ IF( zh_cum1(jk1) <= zh_cum0(jk0) .AND. zh_cum1(jk1) > zh_cum0(jk0-1) ) THEN
+ zeh_cum1(jk1) = ( zeh_cum0(jk0-1) * ( zh_cum0(jk0) - zh_cum1(jk1 ) ) + &
+ & zeh_cum0(jk0 ) * ( zh_cum1(jk1) - zh_cum0(jk0-1) ) ) &
+ & / ( zh_cum0(jk0) - zh_cum0(jk0-1) )
+ ENDIF
END DO
END DO
+ ! to ensure that total heat content is strictly conserved, set:
+ zeh_cum1(nlay_i) = zeh_cum0(nlay_i+2)
- END SUBROUTINE snw_ent
+ ! new enthalpies
+ DO jk1 = 1, nlay_i
+ ice_ent1(jk1) = MAX( 0._wp, zeh_cum1(jk1) - zeh_cum1(jk1-1) ) / MAX( zhnew, epsi20 ) ! max for roundoff error
+ END DO
+ ! --- diag error on heat remapping --- !
+ ! comment: if input h_old and eh_old are already multiplied by a_i (as in icethd_do),
+ ! then we should not (* a_i) again but not important since this is just to check that remap error is ~0
+ ! hfx_err_rem_1d(ji) = hfx_err_rem_1d(ji) + a_i_1d(ji) * r1_Dt_ice * &
+ ! & ( SUM( pe_new(ji,1:nlay_i) ) * zhnew(ji) - SUM( eh_old(ji,0:nlay_i+1) ) )
+
+ END FUNCTION ice_ent1
+
#else
!!----------------------------------------------------------------------
!! Default option NO SI3 sea-ice model
diff --git a/src/ICE/icethd_do.F90 b/src/ICE/icethd_do.F90
index 3cd1bcd7ba3875bf6704a267ac63b4fd84f15981..90e0cee2bfb606cab3ddbe26d7184071ccee394c 100644
--- a/src/ICE/icethd_do.F90
+++ b/src/ICE/icethd_do.F90
@@ -21,14 +21,12 @@ MODULE icethd_do
USE ice ! sea-ice: variables
USE icetab ! sea-ice: 2D <==> 1D
USE icectl ! sea-ice: conservation
- USE icethd_ent ! sea-ice: thermodynamics, enthalpy
USE icevar ! sea-ice: operations
USE icethd_sal ! sea-ice: salinity profiles
!
USE in_out_manager ! I/O manager
USE lib_mpp ! MPP library
USE lib_fortran ! fortran utilities (glob_sum + no signed zero)
- USE lbclnk ! lateral boundary conditions (or mpp links)
IMPLICIT NONE
PRIVATE
@@ -79,41 +77,39 @@ CONTAINS
REAL(wp) :: zEw ! seawater specific enthalpy (J/kg)
REAL(wp) :: zfmdt ! mass flux x time step (kg/m2, >0 towards ocean)
!
+ INTEGER :: jcat ! indexes of categories where new ice grows
+ !
REAL(wp) :: zv_newfra
+ REAL(wp) :: zv_newice ! volume of accreted ice
+ REAL(wp) :: za_newice ! fractional area of accreted ice
+ REAL(wp) :: ze_newice ! heat content of accreted ice
+ REAL(wp) :: zo_newice ! age of accreted ice
+ REAL(wp) :: zdv_res ! residual volume in case of excessive heat budget
+ REAL(wp) :: zda_res ! residual area in case of excessive heat budget
+ REAL(wp) :: zv_frazb ! accretion of frazil ice at the ice bottom
!
- INTEGER , DIMENSION(jpij) :: jcat ! indexes of categories where new ice grows
- REAL(wp), DIMENSION(jpij) :: zswinew ! switch for new ice or not
+ REAL(wp), DIMENSION(jpl) :: zv_b ! old volume of ice in category jl
+ REAL(wp), DIMENSION(jpl) :: za_b ! old area of ice in category jl
!
- REAL(wp), DIMENSION(jpij) :: zv_newice ! volume of accreted ice
- REAL(wp), DIMENSION(jpij) :: za_newice ! fractional area of accreted ice
- REAL(wp), DIMENSION(jpij) :: zh_newice ! thickness of accreted ice
- REAL(wp), DIMENSION(jpij) :: ze_newice ! heat content of accreted ice
- REAL(wp), DIMENSION(jpij) :: zs_newice ! salinity of accreted ice
- REAL(wp), DIMENSION(jpij) :: zo_newice ! age of accreted ice
- REAL(wp), DIMENSION(jpij) :: zdv_res ! residual volume in case of excessive heat budget
- REAL(wp), DIMENSION(jpij) :: zda_res ! residual area in case of excessive heat budget
- REAL(wp), DIMENSION(jpij) :: zv_frazb ! accretion of frazil ice at the ice bottom
+ REAL(wp), DIMENSION(jpij) :: zs_newice ! salinity of accreted ice
+ REAL(wp), DIMENSION(jpij) :: zh_newice ! thickness of accreted ice
REAL(wp), DIMENSION(jpij) :: zfraz_frac_1d ! relative ice / frazil velocity (1D vector)
!
- REAL(wp), DIMENSION(jpij,jpl) :: zv_b ! old volume of ice in category jl
- REAL(wp), DIMENSION(jpij,jpl) :: za_b ! old area of ice in category jl
- !
- REAL(wp), DIMENSION(jpij,nlay_i,jpl) :: ze_i_2d !: 1-D version of e_i
- !
+ REAL(wp), DIMENSION(0:nlay_i+1) :: zh_i_old, ze_i_old
!!-----------------------------------------------------------------------!
IF( ln_icediachk ) CALL ice_cons_hsm( 0, 'icethd_do', rdiag_v, rdiag_s, rdiag_t, rdiag_fv, rdiag_fs, rdiag_ft )
IF( ln_icediachk ) CALL ice_cons2D ( 0, 'icethd_do', diag_v, diag_s, diag_t, diag_fv, diag_fs, diag_ft )
- at_i(:,:) = SUM( a_i, dim=3 )
!------------------------------------------------------------------------------!
! 1) Compute thickness, salinity, enthalpy, age, area and volume of new ice
!------------------------------------------------------------------------------!
! it occurs if cooling
+ at_i(A2D(0)) = SUM( a_i(A2D(0),:), dim=3 )
! Identify grid points where new ice forms
npti = 0 ; nptidx(:) = 0
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
IF ( qlead(ji,jj) < 0._wp ) THEN
npti = npti + 1
nptidx( npti ) = (jj - 1) * jpi + ji
@@ -123,42 +119,34 @@ CONTAINS
! Move from 2-D to 1-D vectors
IF ( npti > 0 ) THEN
- CALL tab_2d_1d( npti, nptidx(1:npti), at_i_1d(1:npti) , at_i )
- CALL tab_3d_2d( npti, nptidx(1:npti), a_i_2d (1:npti,1:jpl), a_i (:,:,:) )
- CALL tab_3d_2d( npti, nptidx(1:npti), v_i_2d (1:npti,1:jpl), v_i (:,:,:) )
- CALL tab_3d_2d( npti, nptidx(1:npti), sv_i_2d(1:npti,1:jpl), sv_i(:,:,:) )
- DO jl = 1, jpl
- DO jk = 1, nlay_i
- CALL tab_2d_1d( npti, nptidx(1:npti), ze_i_2d(1:npti,jk,jl), e_i(:,:,jk,jl) )
- END DO
- END DO
- CALL tab_2d_1d( npti, nptidx(1:npti), qlead_1d (1:npti) , qlead )
- CALL tab_2d_1d( npti, nptidx(1:npti), t_bo_1d (1:npti) , t_bo )
- CALL tab_2d_1d( npti, nptidx(1:npti), sfx_opw_1d (1:npti) , sfx_opw )
- CALL tab_2d_1d( npti, nptidx(1:npti), wfx_opw_1d (1:npti) , wfx_opw )
- CALL tab_2d_1d( npti, nptidx(1:npti), zh_newice (1:npti) , ht_i_new )
- CALL tab_2d_1d( npti, nptidx(1:npti), zfraz_frac_1d(1:npti) , fraz_frac )
-
- CALL tab_2d_1d( npti, nptidx(1:npti), hfx_thd_1d(1:npti) , hfx_thd )
- CALL tab_2d_1d( npti, nptidx(1:npti), hfx_opw_1d(1:npti) , hfx_opw )
- CALL tab_2d_1d( npti, nptidx(1:npti), rn_amax_1d(1:npti) , rn_amax_2d )
- CALL tab_2d_1d( npti, nptidx(1:npti), sss_1d (1:npti) , sss_m )
+ CALL tab_2d_1d( npti, nptidx(1:npti), at_i_1d(1:npti) , at_i )
+ CALL tab_3d_2d( npti, nptidx(1:npti), a_i_2d (1:npti,:), a_i (:,:,:) )
+ CALL tab_3d_2d( npti, nptidx(1:npti), v_i_2d (1:npti,:), v_i (:,:,:) )
+ CALL tab_3d_2d( npti, nptidx(1:npti), sv_i_2d(1:npti,:), sv_i(:,:,:) )
+ CALL tab_4d_3d( npti, nptidx(1:npti), e_i_2d (1:npti,:,:), e_i )
+ CALL tab_2d_1d( npti, nptidx(1:npti), qlead_1d (1:npti), qlead )
+ CALL tab_2d_1d( npti, nptidx(1:npti), t_bo_1d (1:npti), t_bo )
+ CALL tab_2d_1d( npti, nptidx(1:npti), sfx_opw_1d (1:npti), sfx_opw )
+ CALL tab_2d_1d( npti, nptidx(1:npti), wfx_opw_1d (1:npti), wfx_opw )
+ CALL tab_2d_1d( npti, nptidx(1:npti), zh_newice (1:npti), ht_i_new )
+ CALL tab_2d_1d( npti, nptidx(1:npti), zfraz_frac_1d(1:npti), fraz_frac )
+
+ CALL tab_2d_1d( npti, nptidx(1:npti), hfx_thd_1d(1:npti), hfx_thd )
+ CALL tab_2d_1d( npti, nptidx(1:npti), hfx_opw_1d(1:npti), hfx_opw )
+ CALL tab_2d_1d( npti, nptidx(1:npti), rn_amax_1d(1:npti), rn_amax_2d )
+ CALL tab_2d_1d( npti, nptidx(1:npti), sss_1d (1:npti), sss_m )
! Convert units for ice internal energy
DO jl = 1, jpl
DO jk = 1, nlay_i
WHERE( v_i_2d(1:npti,jl) > 0._wp )
- ze_i_2d(1:npti,jk,jl) = ze_i_2d(1:npti,jk,jl) / v_i_2d(1:npti,jl) * REAL( nlay_i )
+ e_i_2d(1:npti,jk,jl) = e_i_2d(1:npti,jk,jl) / v_i_2d(1:npti,jl) * REAL( nlay_i )
ELSEWHERE
- ze_i_2d(1:npti,jk,jl) = 0._wp
+ e_i_2d(1:npti,jk,jl) = 0._wp
END WHERE
END DO
END DO
- ! Keep old ice areas and volume in memory
- zv_b(1:npti,:) = v_i_2d(1:npti,:)
- za_b(1:npti,:) = a_i_2d(1:npti,:)
-
! --- Salinity of new ice --- !
SELECT CASE ( nn_icesal )
CASE ( 1 ) ! Sice = constant
@@ -170,23 +158,30 @@ CONTAINS
CASE ( 3 ) ! Sice = F(z) [multiyear ice]
zs_newice(1:npti) = 2.3
END SELECT
-
- ! --- Heat content of new ice --- !
- ! We assume that new ice is formed at the seawater freezing point
- DO ji = 1, npti
- ztmelts = - rTmlt * zs_newice(ji) ! Melting point (C)
- ze_newice(ji) = rhoi * ( rcpi * ( ztmelts - ( t_bo_1d(ji) - rt0 ) ) &
- & + rLfus * ( 1.0 - ztmelts / MIN( t_bo_1d(ji) - rt0, -epsi10 ) ) &
- & - rcp * ztmelts )
- END DO
-
- ! --- Age of new ice --- !
- zo_newice(1:npti) = 0._wp
-
- ! --- Volume of new ice --- !
+ !
+ ! ! ==================== !
+ ! ! Start main loop here !
+ ! ! ==================== !
DO ji = 1, npti
-
- zEi = - ze_newice(ji) * r1_rhoi ! specific enthalpy of forming ice [J/kg]
+
+ ! Keep old ice areas and volume in memory
+ DO jl = 1, jpl
+ zv_b(jl) = v_i_2d(ji,jl)
+ za_b(jl) = a_i_2d(ji,jl)
+ ENDDO
+
+ ! --- Heat content of new ice --- !
+ ! We assume that new ice is formed at the seawater freezing point
+ ztmelts = - rTmlt * zs_newice(ji) ! Melting point (C)
+ ze_newice = rhoi * ( rcpi * ( ztmelts - ( t_bo_1d(ji) - rt0 ) ) &
+ & + rLfus * ( 1.0 - ztmelts / MIN( t_bo_1d(ji) - rt0, -epsi10 ) ) &
+ & - rcp * ztmelts )
+
+ ! --- Age of new ice --- !
+ zo_newice = 0._wp
+
+ ! --- Volume of new ice --- !
+ zEi = - ze_newice * r1_rhoi ! specific enthalpy of forming ice [J/kg]
zEw = rcp * ( t_bo_1d(ji) - rt0 ) ! specific enthalpy of seawater at t_bo_1d [J/kg]
! clem: we suppose we are already at the freezing point (condition qlead<0 is satisfyied)
@@ -195,7 +190,7 @@ CONTAINS
zfmdt = - qlead_1d(ji) / zdE ! Fm.dt [kg/m2] (<0)
! clem: we use qlead instead of zqld (icethd) because we suppose we are at the freezing point
- zv_newice(ji) = - zfmdt * r1_rhoi
+ zv_newice = - zfmdt * r1_rhoi
zQm = zfmdt * zEw ! heat to the ocean >0 associated with mass flux
@@ -204,120 +199,102 @@ CONTAINS
! Total heat flux used in this process [W.m-2]
hfx_opw_1d(ji) = hfx_opw_1d(ji) - zfmdt * zdE * r1_Dt_ice
! mass flux
- wfx_opw_1d(ji) = wfx_opw_1d(ji) - zv_newice(ji) * rhoi * r1_Dt_ice
+ wfx_opw_1d(ji) = wfx_opw_1d(ji) - zv_newice * rhoi * r1_Dt_ice
! salt flux
- sfx_opw_1d(ji) = sfx_opw_1d(ji) - zv_newice(ji) * rhoi * zs_newice(ji) * r1_Dt_ice
- END DO
+ sfx_opw_1d(ji) = sfx_opw_1d(ji) - zv_newice * rhoi * zs_newice(ji) * r1_Dt_ice
- ! A fraction fraz_frac of frazil ice is accreted at the ice bottom
- DO ji = 1, npti
- rswitch = 1._wp - MAX( 0._wp, SIGN( 1._wp , - at_i_1d(ji) ) )
- zv_frazb(ji) = zfraz_frac_1d(ji) * rswitch * zv_newice(ji)
- zv_newice(ji) = ( 1._wp - zfraz_frac_1d(ji) * rswitch ) * zv_newice(ji)
- END DO
-
- ! --- Area of new ice --- !
- DO ji = 1, npti
- za_newice(ji) = zv_newice(ji) / zh_newice(ji)
- END DO
+ ! A fraction fraz_frac of frazil ice is accreted at the ice bottom
+ IF( at_i_1d(ji) > 0._wp ) THEN
+ zv_frazb = zfraz_frac_1d(ji) * zv_newice
+ zv_newice = ( 1._wp - zfraz_frac_1d(ji) ) * zv_newice
+ ELSE
+ zv_frazb = 0._wp
+ ENDIF
+ ! --- Area of new ice --- !
+ za_newice = zv_newice / zh_newice(ji)
- !------------------------------------------------------------------------------!
- ! 2) Redistribute new ice area and volume into ice categories !
- !------------------------------------------------------------------------------!
- ! --- lateral ice growth --- !
- ! If lateral ice growth gives an ice concentration > amax, then
- ! we keep the excessive volume in memory and attribute it later to bottom accretion
- DO ji = 1, npti
- IF ( za_newice(ji) > MAX( 0._wp, rn_amax_1d(ji) - at_i_1d(ji) ) ) THEN ! max is for roundoff error
- zda_res(ji) = za_newice(ji) - MAX( 0._wp, rn_amax_1d(ji) - at_i_1d(ji) )
- zdv_res(ji) = zda_res (ji) * zh_newice(ji)
- za_newice(ji) = MAX( 0._wp, za_newice(ji) - zda_res (ji) )
- zv_newice(ji) = MAX( 0._wp, zv_newice(ji) - zdv_res (ji) )
+ ! --- Redistribute new ice area and volume into ice categories --- !
+
+ ! --- lateral ice growth --- !
+ ! If lateral ice growth gives an ice concentration > amax, then
+ ! we keep the excessive volume in memory and attribute it later to bottom accretion
+ IF ( za_newice > MAX( 0._wp, rn_amax_1d(ji) - at_i_1d(ji) ) ) THEN ! max is for roundoff error
+ zda_res = za_newice - MAX( 0._wp, rn_amax_1d(ji) - at_i_1d(ji) )
+ zdv_res = zda_res * zh_newice(ji)
+ za_newice = MAX( 0._wp, za_newice - zda_res )
+ zv_newice = MAX( 0._wp, zv_newice - zdv_res )
ELSE
- zda_res(ji) = 0._wp
- zdv_res(ji) = 0._wp
+ zda_res = 0._wp
+ zdv_res = 0._wp
ENDIF
- END DO
- ! find which category to fill
- DO jl = 1, jpl
- DO ji = 1, npti
+ ! find which category to fill
+ at_i_1d(ji) = 0._wp
+ DO jl = 1, jpl
IF( zh_newice(ji) > hi_max(jl-1) .AND. zh_newice(ji) <= hi_max(jl) ) THEN
- a_i_2d(ji,jl) = a_i_2d(ji,jl) + za_newice(ji)
- v_i_2d(ji,jl) = v_i_2d(ji,jl) + zv_newice(ji)
- jcat(ji) = jl
+ a_i_2d(ji,jl) = a_i_2d(ji,jl) + za_newice
+ v_i_2d(ji,jl) = v_i_2d(ji,jl) + zv_newice
+ jcat = jl
ENDIF
+ at_i_1d(ji) = at_i_1d(ji) + a_i_2d(ji,jl)
END DO
- END DO
- at_i_1d(1:npti) = SUM( a_i_2d(1:npti,:), dim=2 )
-
- ! Heat content
- DO ji = 1, npti
- jl = jcat(ji) ! categroy in which new ice is put
- zswinew (ji) = MAX( 0._wp , SIGN( 1._wp , - za_b(ji,jl) ) ) ! 0 if old ice
- END DO
-
- DO jk = 1, nlay_i
- DO ji = 1, npti
- jl = jcat(ji)
- rswitch = MAX( 0._wp, SIGN( 1._wp , v_i_2d(ji,jl) - epsi20 ) )
- ze_i_2d(ji,jk,jl) = zswinew(ji) * ze_newice(ji) + &
- & ( 1.0 - zswinew(ji) ) * ( ze_newice(ji) * zv_newice(ji) + ze_i_2d(ji,jk,jl) * zv_b(ji,jl) ) &
- & * rswitch / MAX( v_i_2d(ji,jl), epsi20 )
- END DO
- END DO
- ! --- bottom ice growth + ice enthalpy remapping --- !
- DO jl = 1, jpl
-
- ! for remapping
- h_i_old (1:npti,0:nlay_i+1) = 0._wp
- eh_i_old(1:npti,0:nlay_i+1) = 0._wp
- DO jk = 1, nlay_i
- DO ji = 1, npti
- h_i_old (ji,jk) = v_i_2d(ji,jl) * r1_nlay_i
- eh_i_old(ji,jk) = ze_i_2d(ji,jk,jl) * h_i_old(ji,jk)
+ ! Heat content
+ jl = jcat ! categroy in which new ice is put
+ IF( za_b(jl) > 0._wp ) THEN
+ e_i_2d(ji,:,jl) = ( ze_newice * zv_newice + e_i_2d(ji,:,jl) * zv_b(jl) ) / MAX( v_i_2d(ji,jl), epsi20 )
+ ELSE
+ e_i_2d(ji,:,jl) = ze_newice
+ ENDIF
+
+ ! --- bottom ice growth + ice enthalpy remapping --- !
+ DO jl = 1, jpl
+
+ ! for remapping
+ zh_i_old(0:nlay_i+1) = 0._wp
+ ze_i_old(0:nlay_i+1) = 0._wp
+ DO jk = 1, nlay_i
+ zh_i_old(jk) = v_i_2d(ji,jl) * r1_nlay_i
+ ze_i_old(jk) = e_i_2d(ji,jk,jl) * v_i_2d(ji,jl) * r1_nlay_i
END DO
- END DO
- ! new volumes including lateral/bottom accretion + residual
- DO ji = 1, npti
- rswitch = MAX( 0._wp, SIGN( 1._wp , at_i_1d(ji) - epsi20 ) )
- zv_newfra = rswitch * ( zdv_res(ji) + zv_frazb(ji) ) * a_i_2d(ji,jl) / MAX( at_i_1d(ji) , epsi20 )
- a_i_2d(ji,jl) = rswitch * a_i_2d(ji,jl)
+ ! new volumes including lateral/bottom accretion + residual
+ IF( at_i_1d(ji) >= epsi20 ) THEN
+ zv_newfra = ( zdv_res + zv_frazb ) * a_i_2d(ji,jl) / MAX( at_i_1d(ji) , epsi20 )
+ ELSE
+ zv_newfra = 0._wp
+ a_i_2d(ji,jl) = 0._wp
+ ENDIF
v_i_2d(ji,jl) = v_i_2d(ji,jl) + zv_newfra
! for remapping
- h_i_old (ji,nlay_i+1) = zv_newfra
- eh_i_old(ji,nlay_i+1) = ze_newice(ji) * zv_newfra
- END DO
- ! --- Ice enthalpy remapping --- !
- CALL ice_thd_ent( ze_i_2d(1:npti,:,jl) )
- END DO
-
- ! --- Update salinity --- !
- DO jl = 1, jpl
- DO ji = 1, npti
- sv_i_2d(ji,jl) = sv_i_2d(ji,jl) + zs_newice(ji) * ( v_i_2d(ji,jl) - zv_b(ji,jl) )
+ zh_i_old(nlay_i+1) = zv_newfra
+ ze_i_old(nlay_i+1) = ze_newice * zv_newfra
+
+ ! --- Update salinity --- !
+ sv_i_2d(ji,jl) = sv_i_2d(ji,jl) + zs_newice(ji) * ( v_i_2d(ji,jl) - zv_b(jl) )
+
+ ! --- Ice enthalpy remapping --- !
+ e_i_2d(ji,:,jl) = ice_ent2( zh_i_old(:), ze_i_old(:) )
END DO
- END DO
-
+
+ END DO ! npti
+ ! ! ================== !
+ ! ! End main loop here !
+ ! ! ================== !
+ !
! Change units for e_i
DO jl = 1, jpl
DO jk = 1, nlay_i
- ze_i_2d(1:npti,jk,jl) = ze_i_2d(1:npti,jk,jl) * v_i_2d(1:npti,jl) * r1_nlay_i
+ e_i_2d(1:npti,jk,jl) = e_i_2d(1:npti,jk,jl) * v_i_2d(1:npti,jl) * r1_nlay_i
END DO
END DO
! Move 2D vectors to 1D vectors
- CALL tab_2d_3d( npti, nptidx(1:npti), a_i_2d (1:npti,1:jpl), a_i (:,:,:) )
- CALL tab_2d_3d( npti, nptidx(1:npti), v_i_2d (1:npti,1:jpl), v_i (:,:,:) )
- CALL tab_2d_3d( npti, nptidx(1:npti), sv_i_2d(1:npti,1:jpl), sv_i(:,:,:) )
- DO jl = 1, jpl
- DO jk = 1, nlay_i
- CALL tab_1d_2d( npti, nptidx(1:npti), ze_i_2d(1:npti,jk,jl), e_i(:,:,jk,jl) )
- END DO
- END DO
+ CALL tab_2d_3d( npti, nptidx(1:npti), a_i_2d (1:npti,:), a_i (:,:,:) )
+ CALL tab_2d_3d( npti, nptidx(1:npti), v_i_2d (1:npti,:), v_i (:,:,:) )
+ CALL tab_2d_3d( npti, nptidx(1:npti), sv_i_2d(1:npti,:), sv_i(:,:,:) )
+ CALL tab_3d_4d( npti, nptidx(1:npti), e_i_2d (1:npti,:,:), e_i )
CALL tab_1d_2d( npti, nptidx(1:npti), sfx_opw_1d(1:npti), sfx_opw )
CALL tab_1d_2d( npti, nptidx(1:npti), wfx_opw_1d(1:npti), wfx_opw )
CALL tab_1d_2d( npti, nptidx(1:npti), hfx_thd_1d(1:npti), hfx_thd )
@@ -325,6 +302,8 @@ CONTAINS
!
ENDIF ! npti > 0
!
+ ! the following fields need to be updated on the halos (done in icethd): a_i, v_i, sv_i, e_i
+ !
IF( ln_icediachk ) CALL ice_cons_hsm(1, 'icethd_do', rdiag_v, rdiag_s, rdiag_t, rdiag_fv, rdiag_fs, rdiag_ft)
IF( ln_icediachk ) CALL ice_cons2D (1, 'icethd_do', diag_v, diag_s, diag_t, diag_fv, diag_fs, diag_ft)
!
@@ -372,26 +351,31 @@ CONTAINS
DO_2D( 0, 0, 0, 0 )
IF ( qlead(ji,jj) < 0._wp ) THEN ! cooling
! -- Wind stress -- !
- ztaux = ( utau_ice(ji-1,jj ) * umask(ji-1,jj ,1) + utau_ice(ji,jj) * umask(ji,jj,1) ) * 0.5_wp
- ztauy = ( vtau_ice(ji ,jj-1) * vmask(ji ,jj-1,1) + vtau_ice(ji,jj) * vmask(ji,jj,1) ) * 0.5_wp
+ ztaux = utau_ice(ji,jj) * smask0(ji,jj)
+ ztauy = vtau_ice(ji,jj) * smask0(ji,jj)
! Square root of wind stress
ztenagm = SQRT( SQRT( ztaux * ztaux + ztauy * ztauy ) )
! -- Frazil ice velocity -- !
- rswitch = MAX( 0._wp, SIGN( 1._wp , ztenagm - epsi10 ) )
- zvfrx = rswitch * zgamafr * zsqcd * ztaux / MAX( ztenagm, epsi10 )
- zvfry = rswitch * zgamafr * zsqcd * ztauy / MAX( ztenagm, epsi10 )
-
+ IF( ztenagm >= epsi10 ) THEN
+ zvfrx = zgamafr * zsqcd * ztaux / MAX( ztenagm, epsi10 )
+ zvfry = zgamafr * zsqcd * ztauy / MAX( ztenagm, epsi10 )
+ ELSE
+ zvfrx = 0._wp
+ zvfry = 0._wp
+ ENDIF
! -- Pack ice velocity -- !
- zvgx = ( u_ice(ji-1,jj ) * umask(ji-1,jj ,1) + u_ice(ji,jj) * umask(ji,jj,1) ) * 0.5_wp
- zvgy = ( v_ice(ji ,jj-1) * vmask(ji ,jj-1,1) + v_ice(ji,jj) * vmask(ji,jj,1) ) * 0.5_wp
-
- ! -- Relative frazil/pack ice velocity -- !
- rswitch = MAX( 0._wp, SIGN( 1._wp , at_i(ji,jj) - epsi10 ) )
- zvrel2 = MAX( (zvfrx - zvgx)*(zvfrx - zvgx) + (zvfry - zvgy)*(zvfry - zvgy), 0.15_wp*0.15_wp ) * rswitch
-
- ! -- fraction of frazil ice -- !
- fraz_frac(ji,jj) = rswitch * ( TANH( rn_Cfraz * ( SQRT(zvrel2) - rn_vfraz ) ) + 1._wp ) * 0.5_wp * rn_maxfraz
+ zvgx = ( u_ice(ji-1,jj ) * umask(ji-1,jj ,1) + u_ice(ji,jj) * umask(ji,jj,1) ) * 0.5_wp
+ zvgy = ( v_ice(ji ,jj-1) * vmask(ji ,jj-1,1) + v_ice(ji,jj) * vmask(ji,jj,1) ) * 0.5_wp
+
+ ! -- Relative frazil/pack ice velocity & fraction of frazil ice-- !
+ IF( at_i(ji,jj) >= epsi10 ) THEN
+ zvrel2 = MAX( (zvfrx - zvgx)*(zvfrx - zvgx) + (zvfry - zvgy)*(zvfry - zvgy), 0.15_wp*0.15_wp )
+ fraz_frac(ji,jj) = ( TANH( rn_Cfraz * ( SQRT(zvrel2) - rn_vfraz ) ) + 1._wp ) * 0.5_wp * rn_maxfraz
+ ELSE
+ zvrel2 = 0._wp
+ fraz_frac(ji,jj) = 0._wp
+ ENDIF
! -- new ice thickness (iterative loop) -- !
ht_i_new(ji,jj) = zhicrit + ( zhicrit + 0.1_wp ) &
@@ -415,11 +399,95 @@ CONTAINS
!
END_2D
!
- CALL lbc_lnk( 'icethd_frazil', fraz_frac, 'T', 1.0_wp, ht_i_new, 'T', 1.0_wp )
-
ENDIF
END SUBROUTINE ice_thd_frazil
+ FUNCTION ice_ent2( ph_old, pe_old )
+ !!-------------------------------------------------------------------
+ !! *** ROUTINE ice_ent2 ***
+ !!
+ !! ** Purpose :
+ !! This routine computes new vertical grids in the ice,
+ !! and consistently redistributes temperatures.
+ !! Redistribution is made so as to ensure to energy conservation
+ !!
+ !!
+ !! ** Method : linear conservative remapping
+ !!
+ !! ** Steps : 1) cumulative integrals of old enthalpies/thicknesses
+ !! 2) linear remapping on the new layers
+ !!
+ !! ------------ cum0(0) ------------- cum1(0)
+ !! NEW -------------
+ !! ------------ cum0(1) ==> -------------
+ !! ... -------------
+ !! ------------ -------------
+ !! ------------ cum0(nlay_i+2) ------------- cum1(nlay_i)
+ !!
+ !!
+ !! References : Bitz & Lipscomb, JGR 99; Vancoppenolle et al., GRL, 2005
+ !!-------------------------------------------------------------------
+ REAL(wp), DIMENSION(0:nlay_i+1), INTENT(in) :: ph_old, pe_old ! old tickness and enthlapy
+ REAL(wp), DIMENSION(1:nlay_i) :: ice_ent2 ! new enthlapies (J.m-3, remapped)
+ !
+ INTEGER :: ji ! dummy loop indices
+ INTEGER :: jk0, jk1 ! old/new layer indices
+ !
+ REAL(wp), DIMENSION(0:nlay_i+2) :: zeh_cum0, zh_cum0 ! old cumulative enthlapies and layers interfaces
+ REAL(wp), DIMENSION(0:nlay_i) :: zeh_cum1, zh_cum1 ! new cumulative enthlapies and layers interfaces
+ REAL(wp) :: zhnew ! new layers thicknesses
+ !!-------------------------------------------------------------------
+
+ !--------------------------------------------------------------------------
+ ! 1) Cumulative integral of old enthalpy * thickness and layers interfaces
+ !--------------------------------------------------------------------------
+ zeh_cum0(0) = 0._wp
+ zh_cum0 (0) = 0._wp
+ DO jk0 = 1, nlay_i+2
+ zeh_cum0(jk0) = zeh_cum0(jk0-1) + pe_old(jk0-1)
+ zh_cum0 (jk0) = zh_cum0 (jk0-1) + ph_old(jk0-1)
+ END DO
+
+ !------------------------------------
+ ! 2) Interpolation on the new layers
+ !------------------------------------
+ ! new layer thickesses
+ zhnew = SUM( ph_old(0:nlay_i+1) ) * r1_nlay_i
+
+ ! new layers interfaces
+ zh_cum1(0) = 0._wp
+ DO jk1 = 1, nlay_i
+ zh_cum1(jk1) = zh_cum1(jk1-1) + zhnew
+ END DO
+
+ zeh_cum1(0:nlay_i) = 0._wp
+ ! new cumulative q*h => linear interpolation
+ DO jk0 = 1, nlay_i+2
+ DO jk1 = 1, nlay_i-1
+ IF( zh_cum1(jk1) <= zh_cum0(jk0) .AND. zh_cum1(jk1) > zh_cum0(jk0-1) ) THEN
+ zeh_cum1(jk1) = ( zeh_cum0(jk0-1) * ( zh_cum0(jk0) - zh_cum1(jk1 ) ) + &
+ & zeh_cum0(jk0 ) * ( zh_cum1(jk1) - zh_cum0(jk0-1) ) ) &
+ & / ( zh_cum0(jk0) - zh_cum0(jk0-1) )
+ ENDIF
+ END DO
+ END DO
+ ! to ensure that total heat content is strictly conserved, set:
+ zeh_cum1(nlay_i) = zeh_cum0(nlay_i+2)
+
+ ! new enthalpies
+ DO jk1 = 1, nlay_i
+ ice_ent2(jk1) = MAX( 0._wp, zeh_cum1(jk1) - zeh_cum1(jk1-1) ) / MAX( zhnew, epsi20 ) ! max for roundoff error
+ END DO
+
+ ! --- diag error on heat remapping --- !
+ ! comment: if input h_old and eh_old are already multiplied by a_i (as in icethd_do),
+ ! then we should not (* a_i) again but not important since this is just to check that remap error is ~0
+ ! hfx_err_rem_1d(ji) = hfx_err_rem_1d(ji) + a_i_1d(ji) * r1_Dt_ice * &
+ ! & ( SUM( pe_new(ji,1:nlay_i) ) * zhnew(ji) - SUM( eh_old(ji,0:nlay_i+1) ) )
+
+
+ END FUNCTION ice_ent2
+
SUBROUTINE ice_thd_do_init
!!-----------------------------------------------------------------------
diff --git a/src/ICE/icethd_ent.F90 b/src/ICE/icethd_ent.F90
deleted file mode 100644
index 286e570ea133dcc4a697fe4323f2095a00ba942e..0000000000000000000000000000000000000000
--- a/src/ICE/icethd_ent.F90
+++ /dev/null
@@ -1,144 +0,0 @@
-MODULE icethd_ent
- !!======================================================================
- !! *** MODULE icethd_ent ***
- !! sea-ice: redistribution of enthalpy in the ice on the new vertical grid
- !! after vertical growth/melt
- !!======================================================================
- !! History : ! 2003-05 (M. Vancoppenolle) Original code in 1D
- !! ! 2005-07 (M. Vancoppenolle) 3D version
- !! 3.6 ! 2014-05 (C. Rousset) New version
- !! 4.0 ! 2018 (many people) SI3 [aka Sea Ice cube]
- !!----------------------------------------------------------------------
-#if defined key_si3
- !!----------------------------------------------------------------------
- !! 'key_si3' SI3 sea-ice model
- !!----------------------------------------------------------------------
- !! ice_thd_ent : ice redistribution of enthalpy
- !!----------------------------------------------------------------------
- USE dom_oce ! domain variables
- USE domain !
- USE phycst ! physical constants
- USE ice ! sea-ice: variables
- USE ice1D ! sea-ice: thermodynamics variables
- !
- USE in_out_manager ! I/O manager
- USE lib_mpp ! MPP library
- USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined)
-
- IMPLICIT NONE
- PRIVATE
-
- PUBLIC ice_thd_ent ! called by icethd and icethd_do
-
- !!----------------------------------------------------------------------
- !! NEMO/ICE 4.0 , NEMO Consortium (2018)
- !! $Id: icethd_ent.F90 14778 2021-05-03 08:58:22Z clem $
- !! Software governed by the CeCILL license (see ./LICENSE)
- !!----------------------------------------------------------------------
-CONTAINS
-
- SUBROUTINE ice_thd_ent( qnew )
- !!-------------------------------------------------------------------
- !! *** ROUTINE ice_thd_ent ***
- !!
- !! ** Purpose :
- !! This routine computes new vertical grids in the ice,
- !! and consistently redistributes temperatures.
- !! Redistribution is made so as to ensure to energy conservation
- !!
- !!
- !! ** Method : linear conservative remapping
- !!
- !! ** Steps : 1) cumulative integrals of old enthalpies/thicknesses
- !! 2) linear remapping on the new layers
- !!
- !! ------------ cum0(0) ------------- cum1(0)
- !! NEW -------------
- !! ------------ cum0(1) ==> -------------
- !! ... -------------
- !! ------------ -------------
- !! ------------ cum0(nlay_i+2) ------------- cum1(nlay_i)
- !!
- !!
- !! References : Bitz & Lipscomb, JGR 99; Vancoppenolle et al., GRL, 2005
- !!-------------------------------------------------------------------
- REAL(wp), DIMENSION(:,:), INTENT(inout) :: qnew ! new enthlapies (J.m-3, remapped)
- !
- INTEGER :: ji ! dummy loop indices
- INTEGER :: jk0, jk1 ! old/new layer indices
- !
- REAL(wp), DIMENSION(jpij,0:nlay_i+2) :: zeh_cum0, zh_cum0 ! old cumulative enthlapies and layers interfaces
- REAL(wp), DIMENSION(jpij,0:nlay_i) :: zeh_cum1, zh_cum1 ! new cumulative enthlapies and layers interfaces
- REAL(wp), DIMENSION(jpij) :: zhnew ! new layers thicknesses
- !!-------------------------------------------------------------------
-
- !--------------------------------------------------------------------------
- ! 1) Cumulative integral of old enthalpy * thickness and layers interfaces
- !--------------------------------------------------------------------------
- zeh_cum0(1:npti,0) = 0._wp
- zh_cum0 (1:npti,0) = 0._wp
- DO jk0 = 1, nlay_i+2
- DO ji = 1, npti
- zeh_cum0(ji,jk0) = zeh_cum0(ji,jk0-1) + eh_i_old(ji,jk0-1)
- zh_cum0 (ji,jk0) = zh_cum0 (ji,jk0-1) + h_i_old (ji,jk0-1)
- END DO
- END DO
-
- !------------------------------------
- ! 2) Interpolation on the new layers
- !------------------------------------
- ! new layer thickesses
- DO ji = 1, npti
- zhnew(ji) = SUM( h_i_old(ji,0:nlay_i+1) ) * r1_nlay_i
- END DO
-
- ! new layers interfaces
- zh_cum1(1:npti,0) = 0._wp
- DO jk1 = 1, nlay_i
- DO ji = 1, npti
- zh_cum1(ji,jk1) = zh_cum1(ji,jk1-1) + zhnew(ji)
- END DO
- END DO
-
- zeh_cum1(1:npti,0:nlay_i) = 0._wp
- ! new cumulative q*h => linear interpolation
- DO jk0 = 1, nlay_i+2
- DO jk1 = 1, nlay_i-1
- DO ji = 1, npti
- IF( zh_cum1(ji,jk1) <= zh_cum0(ji,jk0) .AND. zh_cum1(ji,jk1) > zh_cum0(ji,jk0-1) ) THEN
- zeh_cum1(ji,jk1) = ( zeh_cum0(ji,jk0-1) * ( zh_cum0(ji,jk0) - zh_cum1(ji,jk1 ) ) + &
- & zeh_cum0(ji,jk0 ) * ( zh_cum1(ji,jk1) - zh_cum0(ji,jk0-1) ) ) &
- & / ( zh_cum0(ji,jk0) - zh_cum0(ji,jk0-1) )
- ENDIF
- END DO
- END DO
- END DO
- ! to ensure that total heat content is strictly conserved, set:
- zeh_cum1(1:npti,nlay_i) = zeh_cum0(1:npti,nlay_i+2)
-
- ! new enthalpies
- DO jk1 = 1, nlay_i
- DO ji = 1, npti
- rswitch = MAX( 0._wp , SIGN( 1._wp , zhnew(ji) - epsi20 ) )
- qnew(ji,jk1) = rswitch * MAX( 0._wp, zeh_cum1(ji,jk1) - zeh_cum1(ji,jk1-1) ) / MAX( zhnew(ji), epsi20 ) ! max for roundoff error
- END DO
- END DO
-
- ! --- diag error on heat remapping --- !
- ! comment: if input h_i_old and eh_i_old are already multiplied by a_i (as in icethd_do),
- ! then we should not (* a_i) again but not important since this is just to check that remap error is ~0
- !DO ji = 1, npti
- ! hfx_err_rem_1d(ji) = hfx_err_rem_1d(ji) + a_i_1d(ji) * r1_Dt_ice * &
- ! & ( SUM( qnew(ji,1:nlay_i) ) * zhnew(ji) - SUM( eh_i_old(ji,0:nlay_i+1) ) )
- !END DO
-
- END SUBROUTINE ice_thd_ent
-
-#else
- !!----------------------------------------------------------------------
- !! Default option NO SI3 sea-ice model
- !!----------------------------------------------------------------------
-#endif
-
- !!======================================================================
-END MODULE icethd_ent
diff --git a/src/ICE/icethd_pnd.F90 b/src/ICE/icethd_pnd.F90
index f0949d8f0a60d34ca08079f06367b099b10f079b..8f5b63df6fafe2d57bee60219d80aa32321082f9 100644
--- a/src/ICE/icethd_pnd.F90
+++ b/src/ICE/icethd_pnd.F90
@@ -84,7 +84,7 @@ CONTAINS
INTEGER :: ji, jj, jl ! loop indices
!!-------------------------------------------------------------------
- ALLOCATE( diag_dvpn_mlt(jpi,jpj), diag_dvpn_lid(jpi,jpj), diag_dvpn_drn(jpi,jpj), diag_dvpn_rnf(jpi,jpj) )
+ ALLOCATE( diag_dvpn_mlt(A2D(0)) , diag_dvpn_lid(A2D(0)) , diag_dvpn_drn(A2D(0)) , diag_dvpn_rnf(A2D(0)) )
ALLOCATE( diag_dvpn_mlt_1d(jpij), diag_dvpn_lid_1d(jpij), diag_dvpn_drn_1d(jpij), diag_dvpn_rnf_1d(jpij) )
!
diag_dvpn_mlt (:,:) = 0._wp ; diag_dvpn_drn (:,:) = 0._wp
@@ -98,7 +98,7 @@ CONTAINS
at_i(:,:) = SUM( a_i, dim=3 )
!
DO jl = 1, jpl
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
IF( v_i(ji,jj,jl) < epsi10 .OR. at_i(ji,jj) < epsi10 ) THEN
wfx_pnd (ji,jj) = wfx_pnd(ji,jj) + ( v_ip(ji,jj,jl) + v_il(ji,jj,jl) ) * rhow * r1_Dt_ice
a_ip (ji,jj,jl) = 0._wp
@@ -115,7 +115,7 @@ CONTAINS
! Identify grid cells with ice
!------------------------------
npti = 0 ; nptidx(:) = 0
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
IF( at_i(ji,jj) >= epsi10 ) THEN
npti = npti + 1
nptidx( npti ) = (jj - 1) * jpi + ji
@@ -137,6 +137,8 @@ CONTAINS
END SELECT
ENDIF
+ ! the following fields need to be updated in the halos (done in icethd): a_ip, v_ip, v_il, h_ip, h_il
+
!------------------------------------
! Diagnostics
!------------------------------------
@@ -529,7 +531,7 @@ CONTAINS
zv_pnd , & ! volume of meltwater contributing to ponds
zv_mlt ! total amount of meltwater produced
- REAL(wp), DIMENSION(jpi,jpj) :: zvolp_ini , & !! total melt pond water available before redistribution and drainage
+ REAL(wp), DIMENSION(A2D(0)) :: zvolp_ini , & !! total melt pond water available before redistribution and drainage
zvolp , & !! total melt pond water volume
zvolp_res !! remaining melt pond water available after drainage
@@ -589,7 +591,7 @@ CONTAINS
zvolp(:,:) = 0._wp
DO jl = 1, jpl
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
IF ( a_i(ji,jj,jl) > epsi10 ) THEN
@@ -637,7 +639,7 @@ CONTAINS
IF( ln_pnd_lids ) THEN
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
IF ( at_i(ji,jj) > 0.01 .AND. hm_i(ji,jj) > rn_himin .AND. zvolp_ini(ji,jj) > zvp_min * at_i(ji,jj) ) THEN
@@ -764,7 +766,7 @@ CONTAINS
DO jl = 1, jpl
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
! ! zap lids on small ponds
! IF ( a_i(ji,jj,jl) > epsi10 .AND. v_ip(ji,jj,jl) < epsi10 &
@@ -826,7 +828,7 @@ CONTAINS
!!
!!------------------------------------------------------------------
- REAL (wp), DIMENSION(jpi,jpj), INTENT(INOUT) :: &
+ REAL (wp), DIMENSION(A2D(0)), INTENT(INOUT) :: &
zvolp, & ! total available pond water
zdvolp ! remaining meltwater after redistribution
@@ -865,10 +867,10 @@ CONTAINS
INTEGER :: ji, jj, jk, jl ! loop indices
- a_ip(:,:,:) = 0._wp
- h_ip(:,:,:) = 0._wp
+ a_ip(A2D(0),:) = 0._wp
+ h_ip(A2D(0),:) = 0._wp
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
IF ( at_i(ji,jj) > 0.01 .AND. hm_i(ji,jj) > rn_himin .AND. zvolp(ji,jj) > zvp_min * at_i(ji,jj) ) THEN
diff --git a/src/ICE/icethd_zdf_bl99.F90 b/src/ICE/icethd_zdf_bl99.F90
index 493435f3fa75d2c68657ee0978bc7111e9290f76..c68662595d3c33c172e725245536cde4038a598c 100644
--- a/src/ICE/icethd_zdf_bl99.F90
+++ b/src/ICE/icethd_zdf_bl99.F90
@@ -76,12 +76,9 @@ CONTAINS
!
INTEGER :: ji, jk ! spatial loop index
INTEGER :: jm ! current reference number of equation
- INTEGER :: jm_mint, jm_maxt
INTEGER :: iconv ! number of iterations in iterative procedure
INTEGER :: iconv_max = 50 ! max number of iterations in iterative procedure
!
- INTEGER, DIMENSION(jpij) :: jm_min ! reference number of top equation
- INTEGER, DIMENSION(jpij) :: jm_max ! reference number of bottom equation
LOGICAL, DIMENSION(jpij) :: l_T_converged ! true when T converges (per grid point)
!
@@ -105,22 +102,17 @@ CONTAINS
REAL(wp), DIMENSION(jpij) :: zh_i, z1_h_i ! ice layer thickness
REAL(wp), DIMENSION(jpij) :: zh_s, z1_h_s ! snow layer thickness
REAL(wp), DIMENSION(jpij) :: zqns_ice_b ! solar radiation absorbed at the surface
- REAL(wp), DIMENSION(jpij) :: zfnet ! surface flux function
REAL(wp), DIMENSION(jpij) :: zdqns_ice_b ! derivative of the surface flux function
- !
- REAL(wp), DIMENSION(jpij ) :: ztsuold ! Old surface temperature in the ice
- REAL(wp), DIMENSION(jpij,nlay_i) :: ztiold ! Old temperature in the ice
- REAL(wp), DIMENSION(jpij,nlay_s) :: ztsold ! Old temperature in the snow
- REAL(wp), DIMENSION(jpij,nlay_i) :: ztib ! Temporary temperature in the ice to check the convergence
- REAL(wp), DIMENSION(jpij,nlay_s) :: ztsb ! Temporary temperature in the snow to check the convergence
- REAL(wp), DIMENSION(jpij,0:nlay_i) :: ztcond_i ! Ice thermal conductivity
- REAL(wp), DIMENSION(jpij,0:nlay_i) :: ztcond_i_cp ! copy
+ REAL(wp), DIMENSION(jpij,0:nlay_s) :: zradtr_s ! Radiation transmited through the snow
+ REAL(wp), DIMENSION(jpij,0:nlay_s) :: zradab_s ! Radiation absorbed in the snow
REAL(wp), DIMENSION(jpij,0:nlay_i) :: zradtr_i ! Radiation transmitted through the ice
REAL(wp), DIMENSION(jpij,0:nlay_i) :: zradab_i ! Radiation absorbed in the ice
+ REAL(wp), DIMENSION(jpij,0:nlay_i) :: ztcond_i ! Ice thermal conductivity
+ REAL(wp), DIMENSION(jpij,0:nlay_i) :: ztcond_i_cp ! copy
+ REAL(wp), DIMENSION(jpij,nlay_i) :: ztiold ! Old temperature in the ice
+ REAL(wp), DIMENSION(jpij,nlay_s) :: ztsold ! Old temperature in the snow
REAL(wp), DIMENSION(jpij,0:nlay_i) :: zkappa_i ! Kappa factor in the ice
REAL(wp), DIMENSION(jpij,0:nlay_i) :: zeta_i ! Eta factor in the ice
- REAL(wp), DIMENSION(jpij,0:nlay_s) :: zradtr_s ! Radiation transmited through the snow
- REAL(wp), DIMENSION(jpij,0:nlay_s) :: zradab_s ! Radiation absorbed in the snow
REAL(wp), DIMENSION(jpij,0:nlay_s) :: zkappa_s ! Kappa factor in the snow
REAL(wp), DIMENSION(jpij,0:nlay_s) :: zeta_s ! Eta factor in the snow
REAL(wp), DIMENSION(jpij) :: zkappa_comb ! Combined snow and ice surface conductivity
@@ -129,10 +121,16 @@ CONTAINS
REAL(wp), DIMENSION(jpij) :: za_s_fra ! ice fraction covered by snow
REAL(wp), DIMENSION(jpij) :: isnow ! snow presence (1) or not (0)
REAL(wp), DIMENSION(jpij) :: isnow_comb ! snow presence for met-office
- REAL(wp), DIMENSION(jpij,nlay_i+nlay_s+1) :: zindterm ! 'Ind'ependent term
- REAL(wp), DIMENSION(jpij,nlay_i+nlay_s+1) :: zindtbis ! Temporary 'ind'ependent term
- REAL(wp), DIMENSION(jpij,nlay_i+nlay_s+1) :: zdiagbis ! Temporary 'dia'gonal term
- REAL(wp), DIMENSION(jpij,nlay_i+nlay_s+1,3) :: ztrid ! Tridiagonal system terms
+ !
+ INTEGER :: jm_min ! reference number of top equation
+ INTEGER :: jm_max ! reference number of bottom equation
+ REAL(wp) :: zfnet ! surface flux function
+ REAL(wp), DIMENSION(nlay_i) :: ztib ! Temporary temperature in the ice to check the convergence
+ REAL(wp), DIMENSION(nlay_s) :: ztsb ! Temporary temperature in the snow to check the convergence
+ REAL(wp), DIMENSION(nlay_i+nlay_s+1) :: zindterm ! 'Ind'ependent term
+ REAL(wp), DIMENSION(nlay_i+nlay_s+1) :: zindtbis ! Temporary 'ind'ependent term
+ REAL(wp), DIMENSION(nlay_i+nlay_s+1) :: zdiagbis ! Temporary 'dia'gonal term
+ REAL(wp), DIMENSION(nlay_i+nlay_s+1,3) :: ztrid ! Tridiagonal system terms
!
! Mono-category
REAL(wp) :: zepsilon ! determines thres. above which computation of G(h) is done
@@ -195,7 +193,6 @@ CONTAINS
! Store initial temperatures and non solar heat fluxes
IF( k_cnd == np_cnd_OFF .OR. k_cnd == np_cnd_EMU ) THEN
ztsub (1:npti) = t_su_1d(1:npti) ! surface temperature at iteration n-1
- ztsuold (1:npti) = t_su_1d(1:npti) ! surface temperature initial value
t_su_1d (1:npti) = MIN( t_su_1d(1:npti), rt0 - ztsu_err ) ! required to leave the choice between melting or not
zdqns_ice_b(1:npti) = dqns_ice_1d(1:npti) ! derivative of incoming nonsolar flux
zqns_ice_b (1:npti) = qns_ice_1d(1:npti) ! store previous qns_ice_1d value
@@ -230,9 +227,12 @@ CONTAINS
! ! radiation absorbed by the layer-th ice layer
zradab_i(ji,jk) = zradtr_i(ji,jk-1) - zradtr_i(ji,jk)
END DO
+ END DO
+ !
+ DO ji = 1, npti
+ qtr_ice_bot_1d(ji) = zradtr_i(ji,nlay_i) ! record radiation transmitted below the ice
END DO
!
- qtr_ice_bot_1d(1:npti) = zradtr_i(1:npti,nlay_i) ! record radiation transmitted below the ice
!
iconv = 0 ! number of iterations
!
@@ -246,9 +246,6 @@ CONTAINS
! !============================!
iconv = iconv + 1
!
- ztib(1:npti,:) = t_i_1d(1:npti,:)
- ztsb(1:npti,:) = t_s_1d(1:npti,:)
- !
!--------------------------------
! 3) Sea ice thermal conductivity
!--------------------------------
@@ -311,306 +308,278 @@ CONTAINS
!-----------------
! 4) kappa factors
!-----------------
- !--- Snow
- ! Variable used after iterations
- ! Value must be frozen after convergence for MPP independance reason
- DO jk = 0, nlay_s-1
- DO ji = 1, npti
- IF ( .NOT. l_T_converged(ji) ) &
+ DO ji = 1, npti
+ !
+ IF ( .NOT. l_T_converged(ji) ) THEN
+ !
+ !--- Snow
+ ! Variable used after iterations
+ ! Value must be frozen after convergence for MPP independance reason
+ DO jk = 0, nlay_s-1
zkappa_s(ji,jk) = zghe(ji) * rn_cnd_s * z1_h_s(ji)
- END DO
- END DO
- DO ji = 1, npti ! Snow-ice interface
- IF ( .NOT. l_T_converged(ji) ) &
- zkappa_s(ji,nlay_s) = isnow(ji) * zghe(ji) * rn_cnd_s * ztcond_i(ji,0) &
+ END DO
+ zkappa_s(ji,nlay_s) = isnow(ji) * zghe(ji) * rn_cnd_s * ztcond_i(ji,0) & ! Snow-ice interface
& / ( 0.5_wp * ( ztcond_i(ji,0) * zh_s(ji) + rn_cnd_s * zh_i(ji) ) )
- END DO
-
- !--- Ice
- ! Variable used after iterations
- ! Value must be frozen after convergence for MPP independance reason
- DO jk = 0, nlay_i
- DO ji = 1, npti
- IF ( .NOT. l_T_converged(ji) ) &
+ !
+ !--- Ice
+ ! Variable used after iterations
+ ! Value must be frozen after convergence for MPP independance reason
+ DO jk = 0, nlay_i
zkappa_i(ji,jk) = zghe(ji) * ztcond_i(ji,jk) * z1_h_i(ji)
- END DO
- END DO
- DO ji = 1, npti ! Snow-ice interface
- IF ( .NOT. l_T_converged(ji) ) THEN
+ END DO
! Calculate combined surface snow and ice conductivity to pass through the coupler (met-office)
zkappa_comb(ji) = isnow_comb(ji) * zkappa_s(ji,0) + ( 1._wp - isnow_comb(ji) ) * zkappa_i(ji,0)
! If there is snow then use the same snow-ice interface conductivity for the top layer of ice
- IF( h_s_1d(ji) > 0._wp ) zkappa_i(ji,0) = zkappa_s(ji,nlay_s)
- ENDIF
+ IF( h_s_1d(ji) > 0._wp ) zkappa_i(ji,0) = zkappa_s(ji,nlay_s) ! Snow-ice interface
+ !
+ ENDIF
+ !
END DO
- !
+
!--------------------------------------
! 5) Sea ice specific heat, eta factors
!--------------------------------------
DO jk = 1, nlay_i
DO ji = 1, npti
- zcpi = rcpi + zgamma * sz_i_1d(ji,jk) / MAX( ( t_i_1d(ji,jk) - rt0 ) * ( ztiold(ji,jk) - rt0 ), epsi10 )
- zeta_i(ji,jk) = rDt_ice * r1_rhoi * z1_h_i(ji) / zcpi
+ IF ( .NOT. l_T_converged(ji) ) THEN
+ zcpi = rcpi + zgamma * sz_i_1d(ji,jk) / MAX( ( t_i_1d(ji,jk) - rt0 ) * ( ztiold(ji,jk) - rt0 ), epsi10 )
+ zeta_i(ji,jk) = rDt_ice * r1_rhoi * z1_h_i(ji) / zcpi
+ ENDIF
END DO
END DO
-
+ !
DO jk = 1, nlay_s
DO ji = 1, npti
- zeta_s(ji,jk) = rDt_ice * r1_rhos * r1_rcpi * z1_h_s(ji)
+ IF ( .NOT. l_T_converged(ji) ) &
+ & zeta_s(ji,jk) = rDt_ice * r1_rhos * r1_rcpi * z1_h_s(ji)
END DO
END DO
!
- !----------------------------------------!
- ! !
- ! Conduction flux is off or emulated !
- ! !
- !----------------------------------------!
!
IF( k_cnd == np_cnd_OFF .OR. k_cnd == np_cnd_EMU ) THEN
+ !----------------------------------------!
+ ! !
+ ! Conduction flux is off or emulated !
+ ! !
+ !----------------------------------------!
!
! ==> The original BL99 temperature computation is used
! (with qsr_ice, qns_ice and dqns_ice as inputs)
!
- !----------------------------
- ! 6) surface flux computation
- !----------------------------
- ! update of the non solar flux according to the update in T_su
DO ji = 1, npti
+ !
+ !----------------------------
+ ! 6) surface flux computation
+ !----------------------------
+ ! update of the non solar flux according to the update in T_su
! Variable used after iterations
! Value must be frozen after convergence for MPP independance reason
- IF ( .NOT. l_T_converged(ji) ) &
+ IF ( .NOT. l_T_converged(ji) ) THEN
+ !
qns_ice_1d(ji) = qns_ice_1d(ji) + dqns_ice_1d(ji) * ( t_su_1d(ji) - ztsub(ji) )
- END DO
-
- DO ji = 1, npti
- zfnet(ji) = qsr_ice_1d(ji) - qtr_ice_top_1d(ji) + qns_ice_1d(ji) ! net heat flux = net - transmitted solar + non solar
- END DO
- !
- !----------------------------
- ! 7) tridiagonal system terms
- !----------------------------
- ! layer denotes the number of the layer in the snow or in the ice
- ! jm denotes the reference number of the equation in the tridiagonal
- ! system, terms of tridiagonal system are indexed as following :
- ! 1 is subdiagonal term, 2 is diagonal and 3 is superdiagonal one
-
- ! ice interior terms (top equation has the same form as the others)
- ztrid (1:npti,:,:) = 0._wp
- zindterm(1:npti,:) = 0._wp
- zindtbis(1:npti,:) = 0._wp
- zdiagbis(1:npti,:) = 0._wp
-
- DO jm = nlay_s + 2, nlay_s + nlay_i
- DO ji = 1, npti
- jk = jm - nlay_s - 1
- ztrid (ji,jm,1) = - zeta_i(ji,jk) * zkappa_i(ji,jk-1)
- ztrid (ji,jm,2) = 1._wp + zeta_i(ji,jk) * ( zkappa_i(ji,jk-1) + zkappa_i(ji,jk) )
- ztrid (ji,jm,3) = - zeta_i(ji,jk) * zkappa_i(ji,jk)
- zindterm(ji,jm) = ztiold(ji,jk) + zeta_i(ji,jk) * zradab_i(ji,jk)
- END DO
- END DO
-
- jm = nlay_s + nlay_i + 1
- DO ji = 1, npti
- ! ice bottom term
- ztrid (ji,jm,1) = - zeta_i(ji,nlay_i) * zkappa_i(ji,nlay_i-1)
- ztrid (ji,jm,2) = 1._wp + zeta_i(ji,nlay_i) * ( zkappa_i(ji,nlay_i-1) + zkappa_i(ji,nlay_i) * zg1 )
- ztrid (ji,jm,3) = 0._wp
- zindterm(ji,jm) = ztiold(ji,nlay_i) + zeta_i(ji,nlay_i) * &
- & ( zradab_i(ji,nlay_i) + zkappa_i(ji,nlay_i) * zg1 * t_bo_1d(ji) )
- END DO
-
- DO ji = 1, npti
- ! !---------------------!
- IF( h_s_1d(ji) > 0._wp ) THEN ! snow-covered cells !
- ! !---------------------!
- ! snow interior terms (bottom equation has the same form as the others)
- DO jm = 3, nlay_s + 1
- jk = jm - 1
- ztrid (ji,jm,1) = - zeta_s(ji,jk) * zkappa_s(ji,jk-1)
- ztrid (ji,jm,2) = 1._wp + zeta_s(ji,jk) * ( zkappa_s(ji,jk-1) + zkappa_s(ji,jk) )
- ztrid (ji,jm,3) = - zeta_s(ji,jk) * zkappa_s(ji,jk)
- zindterm(ji,jm) = ztsold(ji,jk) + zeta_s(ji,jk) * zradab_s(ji,jk)
- END DO
-
- ! case of only one layer in the ice (ice equation is altered)
- IF( nlay_i == 1 ) THEN
- ztrid (ji,nlay_s+2,3) = 0._wp
- zindterm(ji,nlay_s+2) = zindterm(ji,nlay_s+2) + zeta_i(ji,1) * zkappa_i(ji,1) * t_bo_1d(ji)
- ENDIF
-
- IF( t_su_1d(ji) < rt0 ) THEN !-- case 1 : no surface melting
-
- jm_min(ji) = 1
- jm_max(ji) = nlay_i + nlay_s + 1
-
- ! surface equation
- ztrid (ji,1,1) = 0._wp
- ztrid (ji,1,2) = zdqns_ice_b(ji) - zg1s * zkappa_s(ji,0)
- ztrid (ji,1,3) = zg1s * zkappa_s(ji,0)
- zindterm(ji,1) = zdqns_ice_b(ji) * t_su_1d(ji) - zfnet(ji)
-
- ! first layer of snow equation
- ztrid (ji,2,1) = - zeta_s(ji,1) * zkappa_s(ji,0) * zg1s
- ztrid (ji,2,2) = 1._wp + zeta_s(ji,1) * ( zkappa_s(ji,1) + zkappa_s(ji,0) * zg1s )
- ztrid (ji,2,3) = - zeta_s(ji,1) * zkappa_s(ji,1)
- zindterm(ji,2) = ztsold(ji,1) + zeta_s(ji,1) * zradab_s(ji,1)
-
- ELSE !-- case 2 : surface is melting
- !
- jm_min(ji) = 2
- jm_max(ji) = nlay_i + nlay_s + 1
-
- ! first layer of snow equation
- ztrid (ji,2,1) = 0._wp
- ztrid (ji,2,2) = 1._wp + zeta_s(ji,1) * ( zkappa_s(ji,1) + zkappa_s(ji,0) * zg1s )
- ztrid (ji,2,3) = - zeta_s(ji,1) * zkappa_s(ji,1)
- zindterm(ji,2) = ztsold(ji,1) + zeta_s(ji,1) * ( zradab_s(ji,1) + zkappa_s(ji,0) * zg1s * t_su_1d(ji) )
- ENDIF
- ! !---------------------!
- ELSE ! cells without snow !
- ! !---------------------!
!
- IF( t_su_1d(ji) < rt0 ) THEN !-- case 1 : no surface melting
- !
- jm_min(ji) = nlay_s + 1
- jm_max(ji) = nlay_i + nlay_s + 1
-
- ! surface equation
- ztrid (ji,jm_min(ji),1) = 0._wp
- ztrid (ji,jm_min(ji),2) = zdqns_ice_b(ji) - zkappa_i(ji,0) * zg1
- ztrid (ji,jm_min(ji),3) = zkappa_i(ji,0) * zg1
- zindterm(ji,jm_min(ji)) = zdqns_ice_b(ji) * t_su_1d(ji) - zfnet(ji)
+ zfnet = qsr_ice_1d(ji) - qtr_ice_top_1d(ji) + qns_ice_1d(ji) ! net heat flux = net - transmitted solar + non solar
+ !
+ ! before temperatures
+ ztib(:) = t_i_1d(ji,:)
+ ztsb(:) = t_s_1d(ji,:)
+ !
+ !----------------------------
+ ! 7) tridiagonal system terms
+ !----------------------------
+ ! layer denotes the number of the layer in the snow or in the ice
+ ! jm denotes the reference number of the equation in the tridiagonal
+ ! system, terms of tridiagonal system are indexed as following :
+ ! 1 is subdiagonal term, 2 is diagonal and 3 is superdiagonal one
+
+ ! ice interior terms (top equation has the same form as the others)
+ ztrid (:,:) = 0._wp
+ zindterm(:) = 0._wp
+ zindtbis(:) = 0._wp
+ zdiagbis(:) = 0._wp
+
+ DO jm = nlay_s + 2, nlay_s + nlay_i
+ jk = jm - nlay_s - 1
+ ztrid (jm,1) = - zeta_i(ji,jk) * zkappa_i(ji,jk-1)
+ ztrid (jm,2) = 1._wp + zeta_i(ji,jk) * ( zkappa_i(ji,jk-1) + zkappa_i(ji,jk) )
+ ztrid (jm,3) = - zeta_i(ji,jk) * zkappa_i(ji,jk)
+ zindterm(jm) = ztiold(ji,jk) + zeta_i(ji,jk) * zradab_i(ji,jk)
+ END DO
- ! first layer of ice equation
- ztrid (ji,jm_min(ji)+1,1) = - zeta_i(ji,1) * zkappa_i(ji,0) * zg1
- ztrid (ji,jm_min(ji)+1,2) = 1._wp + zeta_i(ji,1) * ( zkappa_i(ji,1) + zkappa_i(ji,0) * zg1 )
- ztrid (ji,jm_min(ji)+1,3) = - zeta_i(ji,1) * zkappa_i(ji,1)
- zindterm(ji,jm_min(ji)+1) = ztiold(ji,1) + zeta_i(ji,1) * zradab_i(ji,1)
+ jm = nlay_s + nlay_i + 1
+ ! ice bottom term
+ ztrid (jm,1) = - zeta_i(ji,nlay_i) * zkappa_i(ji,nlay_i-1)
+ ztrid (jm,2) = 1._wp + zeta_i(ji,nlay_i) * ( zkappa_i(ji,nlay_i-1) + zkappa_i(ji,nlay_i) * zg1 )
+ ztrid (jm,3) = 0._wp
+ zindterm(jm) = ztiold(ji,nlay_i) + zeta_i(ji,nlay_i) * &
+ & ( zradab_i(ji,nlay_i) + zkappa_i(ji,nlay_i) * zg1 * t_bo_1d(ji) )
+
+ ! !---------------------!
+ IF( h_s_1d(ji) > 0._wp ) THEN ! snow-covered cells !
+ ! !---------------------!
+ ! snow interior terms (bottom equation has the same form as the others)
+ DO jm = 3, nlay_s + 1
+ jk = jm - 1
+ ztrid (jm,1) = - zeta_s(ji,jk) * zkappa_s(ji,jk-1)
+ ztrid (jm,2) = 1._wp + zeta_s(ji,jk) * ( zkappa_s(ji,jk-1) + zkappa_s(ji,jk) )
+ ztrid (jm,3) = - zeta_s(ji,jk) * zkappa_s(ji,jk)
+ zindterm(jm) = ztsold(ji,jk) + zeta_s(ji,jk) * zradab_s(ji,jk)
+ END DO
- ! case of only one layer in the ice (surface & ice equations are altered)
+ ! case of only one layer in the ice (ice equation is altered)
IF( nlay_i == 1 ) THEN
- ztrid (ji,jm_min(ji),1) = 0._wp
- ztrid (ji,jm_min(ji),2) = zdqns_ice_b(ji) - zkappa_i(ji,0) * 2._wp
- ztrid (ji,jm_min(ji),3) = zkappa_i(ji,0) * 2._wp
- ztrid (ji,jm_min(ji)+1,1) = - zeta_i(ji,1) * zkappa_i(ji,0) * 2._wp
- ztrid (ji,jm_min(ji)+1,2) = 1._wp + zeta_i(ji,1) * ( zkappa_i(ji,0) * 2._wp + zkappa_i(ji,1) )
- ztrid (ji,jm_min(ji)+1,3) = 0._wp
- zindterm(ji,jm_min(ji)+1) = ztiold(ji,1) + zeta_i(ji,1) * (zradab_i(ji,1) + zkappa_i(ji,1) * t_bo_1d(ji))
+ ztrid (nlay_s+2,3) = 0._wp
+ zindterm(nlay_s+2) = zindterm(nlay_s+2) + zeta_i(ji,1) * zkappa_i(ji,1) * t_bo_1d(ji)
ENDIF
- ELSE !-- case 2 : surface is melting
-
- jm_min(ji) = nlay_s + 2
- jm_max(ji) = nlay_i + nlay_s + 1
-
- ! first layer of ice equation
- ztrid (ji,jm_min(ji),1) = 0._wp
- ztrid (ji,jm_min(ji),2) = 1._wp + zeta_i(ji,1) * ( zkappa_i(ji,1) + zkappa_i(ji,0) * zg1 )
- ztrid (ji,jm_min(ji),3) = - zeta_i(ji,1) * zkappa_i(ji,1)
- zindterm(ji,jm_min(ji)) = ztiold(ji,1) + zeta_i(ji,1) * (zradab_i(ji,1) + zkappa_i(ji,0) * zg1 * t_su_1d(ji))
-
- ! case of only one layer in the ice (surface & ice equations are altered)
- IF( nlay_i == 1 ) THEN
- ztrid (ji,jm_min(ji),1) = 0._wp
- ztrid (ji,jm_min(ji),2) = 1._wp + zeta_i(ji,1) * ( zkappa_i(ji,0) * 2._wp + zkappa_i(ji,1) )
- ztrid (ji,jm_min(ji),3) = 0._wp
- zindterm(ji,jm_min(ji)) = ztiold(ji,1) + zeta_i(ji,1) * ( zradab_i(ji,1) + zkappa_i(ji,1) * t_bo_1d(ji) ) &
- & + t_su_1d(ji) * zeta_i(ji,1) * zkappa_i(ji,0) * 2._wp
+ IF( t_su_1d(ji) < rt0 ) THEN !-- case 1 : no surface melting
+
+ jm_min = 1
+ jm_max = nlay_i + nlay_s + 1
+
+ ! surface equation
+ ztrid (1,1) = 0._wp
+ ztrid (1,2) = zdqns_ice_b(ji) - zg1s * zkappa_s(ji,0)
+ ztrid (1,3) = zg1s * zkappa_s(ji,0)
+ zindterm(1) = zdqns_ice_b(ji) * t_su_1d(ji) - zfnet
+
+ ! first layer of snow equation
+ ztrid (2,1) = - zeta_s(ji,1) * zkappa_s(ji,0) * zg1s
+ ztrid (2,2) = 1._wp + zeta_s(ji,1) * ( zkappa_s(ji,1) + zkappa_s(ji,0) * zg1s )
+ ztrid (2,3) = - zeta_s(ji,1) * zkappa_s(ji,1)
+ zindterm(2) = ztsold(ji,1) + zeta_s(ji,1) * zradab_s(ji,1)
+
+ ELSE !-- case 2 : surface is melting
+ !
+ jm_min = 2
+ jm_max = nlay_i + nlay_s + 1
+
+ ! first layer of snow equation
+ ztrid (2,1) = 0._wp
+ ztrid (2,2) = 1._wp + zeta_s(ji,1) * ( zkappa_s(ji,1) + zkappa_s(ji,0) * zg1s )
+ ztrid (2,3) = - zeta_s(ji,1) * zkappa_s(ji,1)
+ zindterm(2) = ztsold(ji,1) + zeta_s(ji,1) * ( zradab_s(ji,1) + zkappa_s(ji,0) * zg1s * t_su_1d(ji) )
ENDIF
+ ! !---------------------!
+ ELSE ! cells without snow !
+ ! !---------------------!
+ !
+ IF( t_su_1d(ji) < rt0 ) THEN !-- case 1 : no surface melting
+ !
+ jm_min = nlay_s + 1
+ jm_max = nlay_i + nlay_s + 1
+
+ ! surface equation
+ ztrid (jm_min,1) = 0._wp
+ ztrid (jm_min,2) = zdqns_ice_b(ji) - zkappa_i(ji,0) * zg1
+ ztrid (jm_min,3) = zkappa_i(ji,0) * zg1
+ zindterm(jm_min) = zdqns_ice_b(ji) * t_su_1d(ji) - zfnet
+
+ ! first layer of ice equation
+ ztrid (jm_min+1,1) = - zeta_i(ji,1) * zkappa_i(ji,0) * zg1
+ ztrid (jm_min+1,2) = 1._wp + zeta_i(ji,1) * ( zkappa_i(ji,1) + zkappa_i(ji,0) * zg1 )
+ ztrid (jm_min+1,3) = - zeta_i(ji,1) * zkappa_i(ji,1)
+ zindterm(jm_min+1) = ztiold(ji,1) + zeta_i(ji,1) * zradab_i(ji,1)
+
+ ! case of only one layer in the ice (surface & ice equations are altered)
+ IF( nlay_i == 1 ) THEN
+ ztrid (jm_min,1) = 0._wp
+ ztrid (jm_min,2) = zdqns_ice_b(ji) - zkappa_i(ji,0) * 2._wp
+ ztrid (jm_min,3) = zkappa_i(ji,0) * 2._wp
+ ztrid (jm_min+1,1) = - zeta_i(ji,1) * zkappa_i(ji,0) * 2._wp
+ ztrid (jm_min+1,2) = 1._wp + zeta_i(ji,1) * ( zkappa_i(ji,0) * 2._wp + zkappa_i(ji,1) )
+ ztrid (jm_min+1,3) = 0._wp
+ zindterm(jm_min+1) = ztiold(ji,1) + zeta_i(ji,1) * (zradab_i(ji,1) + zkappa_i(ji,1) * t_bo_1d(ji))
+ ENDIF
+
+ ELSE !-- case 2 : surface is melting
+
+ jm_min = nlay_s + 2
+ jm_max = nlay_i + nlay_s + 1
+
+ ! first layer of ice equation
+ ztrid (jm_min,1) = 0._wp
+ ztrid (jm_min,2) = 1._wp + zeta_i(ji,1) * ( zkappa_i(ji,1) + zkappa_i(ji,0) * zg1 )
+ ztrid (jm_min,3) = - zeta_i(ji,1) * zkappa_i(ji,1)
+ zindterm(jm_min) = ztiold(ji,1) + zeta_i(ji,1) * (zradab_i(ji,1) + zkappa_i(ji,0) * zg1 * t_su_1d(ji))
+
+ ! case of only one layer in the ice (surface & ice equations are altered)
+ IF( nlay_i == 1 ) THEN
+ ztrid (jm_min,1) = 0._wp
+ ztrid (jm_min,2) = 1._wp + zeta_i(ji,1) * ( zkappa_i(ji,0) * 2._wp + zkappa_i(ji,1) )
+ ztrid (jm_min,3) = 0._wp
+ zindterm(jm_min) = ztiold(ji,1) + zeta_i(ji,1) * ( zradab_i(ji,1) + zkappa_i(ji,1) * t_bo_1d(ji) ) &
+ & + t_su_1d(ji) * zeta_i(ji,1) * zkappa_i(ji,0) * 2._wp
+ ENDIF
+ ENDIF
ENDIF
- ENDIF
- !
- zindtbis(ji,jm_min(ji)) = zindterm(ji,jm_min(ji))
- zdiagbis(ji,jm_min(ji)) = ztrid (ji,jm_min(ji),2)
- !
- END DO
- !
- !------------------------------
- ! 8) tridiagonal system solving
- !------------------------------
- ! Solve the tridiagonal system with Gauss elimination method.
- ! Thomas algorithm, from Computational fluid Dynamics, J.D. ANDERSON, McGraw-Hill 1984
+ !
+ zindtbis(jm_min) = zindterm(jm_min)
+ zdiagbis(jm_min) = ztrid (jm_min,2)
+ !
+ !
+ !------------------------------
+ ! 8) tridiagonal system solving
+ !------------------------------
+ ! Solve the tridiagonal system with Gauss elimination method.
+ ! Thomas algorithm, from Computational fluid Dynamics, J.D. ANDERSON, McGraw-Hill 1984
!!$ jm_maxt = 0
!!$ jm_mint = nlay_i+5
!!$ DO ji = 1, npti
-!!$ jm_mint = MIN(jm_min(ji),jm_mint)
-!!$ jm_maxt = MAX(jm_max(ji),jm_maxt)
+!!$ jm_mint = MIN(jm_min,jm_mint)
+!!$ jm_maxt = MAX(jm_max,jm_maxt)
!!$ END DO
!!$ !!clem SNWLAY => check why LIM1D does not get this loop. Is nlay_i+5 correct?
!!$
!!$ DO jk = jm_mint+1, jm_maxt
!!$ DO ji = 1, npti
-!!$ jm = MIN(MAX(jm_min(ji)+1,jk),jm_max(ji))
+!!$ jm = MIN(MAX(jm_min+1,jk),jm_max)
!!$ zdiagbis(ji,jm) = ztrid (ji,jm,2) - ztrid(ji,jm,1) * ztrid (ji,jm-1,3) / zdiagbis(ji,jm-1)
!!$ zindtbis(ji,jm) = zindterm(ji,jm ) - ztrid(ji,jm,1) * zindtbis(ji,jm-1 ) / zdiagbis(ji,jm-1)
!!$ END DO
!!$ END DO
- ! clem: maybe one should find a way to reverse this loop for mpi performance
- DO ji = 1, npti
- jm_mint = jm_min(ji)
- jm_maxt = jm_max(ji)
- DO jm = jm_mint+1, jm_maxt
- zdiagbis(ji,jm) = ztrid (ji,jm,2) - ztrid(ji,jm,1) * ztrid (ji,jm-1,3) / zdiagbis(ji,jm-1)
- zindtbis(ji,jm) = zindterm(ji,jm ) - ztrid(ji,jm,1) * zindtbis(ji,jm-1 ) / zdiagbis(ji,jm-1)
- END DO
- END DO
- ! ice temperatures
- DO ji = 1, npti
- ! Variable used after iterations
- ! Value must be frozen after convergence for MPP independance reason
- IF ( .NOT. l_T_converged(ji) ) &
- t_i_1d(ji,nlay_i) = zindtbis(ji,jm_max(ji)) / zdiagbis(ji,jm_max(ji))
- END DO
-
- DO jm = nlay_i + nlay_s, nlay_s + 2, -1
- DO ji = 1, npti
- jk = jm - nlay_s - 1
- IF ( .NOT. l_T_converged(ji) ) &
- t_i_1d(ji,jk) = ( zindtbis(ji,jm) - ztrid(ji,jm,3) * t_i_1d(ji,jk+1) ) / zdiagbis(ji,jm)
- END DO
- END DO
+ DO jm = jm_min+1, jm_max
+ zdiagbis(jm) = ztrid (jm,2) - ztrid(jm,1) * ztrid (jm-1,3) / zdiagbis(jm-1)
+ zindtbis(jm) = zindterm(jm ) - ztrid(jm,1) * zindtbis(jm-1 ) / zdiagbis(jm-1)
+ END DO
- ! snow temperatures
- DO ji = 1, npti
- ! Variables used after iterations
- ! Value must be frozen after convergence for MPP independance reason
- IF ( .NOT. l_T_converged(ji) .AND. h_s_1d(ji) > 0._wp ) &
- & t_s_1d(ji,nlay_s) = ( zindtbis(ji,nlay_s+1) - ztrid(ji,nlay_s+1,3) * t_i_1d(ji,1) ) / zdiagbis(ji,nlay_s+1)
- END DO
- !!clem SNWLAY
- DO jm = nlay_s, 2, -1
- DO ji = 1, npti
- jk = jm - 1
- IF ( .NOT. l_T_converged(ji) .AND. h_s_1d(ji) > 0._wp ) &
- & t_s_1d(ji,jk) = ( zindtbis(ji,jm) - ztrid(ji,jm,3) * t_s_1d(ji,jk+1) ) / zdiagbis(ji,jm)
- END DO
- END DO
+ ! ice temperatures
+ ! Variable used after iterations
+ ! Value must be frozen after convergence for MPP independance reason
+ t_i_1d(ji,nlay_i) = zindtbis(jm_max) / zdiagbis(jm_max)
+
+ DO jm = nlay_i + nlay_s, nlay_s + 2, -1
+ jk = jm - nlay_s - 1
+ t_i_1d(ji,jk) = ( zindtbis(jm) - ztrid(jm,3) * t_i_1d(ji,jk+1) ) / zdiagbis(jm)
+ END DO
- ! surface temperature
- DO ji = 1, npti
- IF( .NOT. l_T_converged(ji) ) THEN
+ ! snow temperatures
+ ! Variables used after iterations
+ ! Value must be frozen after convergence for MPP independance reason
+ IF ( h_s_1d(ji) > 0._wp ) &
+ & t_s_1d(ji,nlay_s) = ( zindtbis(nlay_s+1) - ztrid(nlay_s+1,3) * t_i_1d(ji,1) ) / zdiagbis(nlay_s+1)
+ !!clem SNWLAY
+ DO jm = nlay_s, 2, -1
+ jk = jm - 1
+ IF ( h_s_1d(ji) > 0._wp ) &
+ & t_s_1d(ji,jk) = ( zindtbis(jm) - ztrid(jm,3) * t_s_1d(ji,jk+1) ) / zdiagbis(jm)
+ END DO
+
+ ! surface temperature
ztsub(ji) = t_su_1d(ji)
IF( t_su_1d(ji) < rt0 ) THEN
- t_su_1d(ji) = ( zindtbis(ji,jm_min(ji)) - ztrid(ji,jm_min(ji),3) * &
- & ( isnow(ji) * t_s_1d(ji,1) + ( 1._wp - isnow(ji) ) * t_i_1d(ji,1) ) ) / zdiagbis(ji,jm_min(ji))
+ t_su_1d(ji) = ( zindtbis(jm_min) - ztrid(jm_min,3) * &
+ & ( isnow(ji) * t_s_1d(ji,1) + ( 1._wp - isnow(ji) ) * t_i_1d(ji,1) ) ) / zdiagbis(jm_min)
ENDIF
- ENDIF
- END DO
- !
- !--------------------------------------------------------------
- ! 9) Has the scheme converged?, end of the iterative procedure
- !--------------------------------------------------------------
- ! check that nowhere it has started to melt
- ! zdti_max is a measure of error, it has to be under zdti_bnd
-
- DO ji = 1, npti
-
- zdti_max = 0._wp
-
- IF ( .NOT. l_T_converged(ji) ) THEN
+ !
+ !--------------------------------------------------------------
+ ! 9) Has the scheme converged?, end of the iterative procedure
+ !--------------------------------------------------------------
+ ! check that nowhere it has started to melt
+ ! zdti_max is a measure of error, it has to be under zdti_bnd
+ zdti_max = 0._wp
t_su_1d(ji) = MAX( MIN( t_su_1d(ji) , rt0 ) , rt0 - 100._wp )
zdti_max = MAX( zdti_max, ABS( t_su_1d(ji) - ztsub(ji) ) )
@@ -618,14 +587,14 @@ CONTAINS
IF( h_s_1d(ji) > 0._wp ) THEN
DO jk = 1, nlay_s
t_s_1d(ji,jk) = MAX( MIN( t_s_1d(ji,jk), rt0 ), rt0 - 100._wp )
- zdti_max = MAX ( zdti_max , ABS( t_s_1d(ji,jk) - ztsb(ji,jk) ) )
+ zdti_max = MAX ( zdti_max , ABS( t_s_1d(ji,jk) - ztsb(jk) ) )
END DO
ENDIF
DO jk = 1, nlay_i
ztmelts = -rTmlt * sz_i_1d(ji,jk) + rt0
t_i_1d(ji,jk) = MAX( MIN( t_i_1d(ji,jk), ztmelts ), rt0 - 100._wp )
- zdti_max = MAX( zdti_max, ABS( t_i_1d(ji,jk) - ztib(ji,jk) ) )
+ zdti_max = MAX( zdti_max, ABS( t_i_1d(ji,jk) - ztib(jk) ) )
END DO
! convergence test
@@ -637,194 +606,174 @@ CONTAINS
IF( zdti_max < zdti_bnd ) l_T_converged(ji) = .TRUE.
ENDIF
-
- END DO
-
- !----------------------------------------!
- ! !
- ! Conduction flux is on !
- ! !
- !----------------------------------------!
- !
+
+ END DO
+ !
ELSEIF( k_cnd == np_cnd_ON ) THEN
+ !----------------------------------------!
+ ! !
+ ! Conduction flux is on !
+ ! !
+ !----------------------------------------!
!
! ==> we use a modified BL99 solver with conduction flux (qcn_ice) as forcing term
!
- !----------------------------
- ! 7) tridiagonal system terms
- !----------------------------
- ! layer denotes the number of the layer in the snow or in the ice
- ! jm denotes the reference number of the equation in the tridiagonal
- ! system, terms of tridiagonal system are indexed as following :
- ! 1 is subdiagonal term, 2 is diagonal and 3 is superdiagonal one
-
- ! ice interior terms (top equation has the same form as the others)
- ztrid (1:npti,:,:) = 0._wp
- zindterm(1:npti,:) = 0._wp
- zindtbis(1:npti,:) = 0._wp
- zdiagbis(1:npti,:) = 0._wp
-
- DO jm = nlay_s + 2, nlay_s + nlay_i
- DO ji = 1, npti
- jk = jm - nlay_s - 1
- ztrid (ji,jm,1) = - zeta_i(ji,jk) * zkappa_i(ji,jk-1)
- ztrid (ji,jm,2) = 1._wp + zeta_i(ji,jk) * ( zkappa_i(ji,jk-1) + zkappa_i(ji,jk) )
- ztrid (ji,jm,3) = - zeta_i(ji,jk) * zkappa_i(ji,jk)
- zindterm(ji,jm) = ztiold(ji,jk) + zeta_i(ji,jk) * zradab_i(ji,jk)
- END DO
- ENDDO
-
- jm = nlay_s + nlay_i + 1
DO ji = 1, npti
- ! ice bottom term
- ztrid (ji,jm,1) = - zeta_i(ji,nlay_i) * zkappa_i(ji,nlay_i-1)
- ztrid (ji,jm,2) = 1._wp + zeta_i(ji,nlay_i) * ( zkappa_i(ji,nlay_i-1) + zkappa_i(ji,nlay_i) * zg1 )
- ztrid (ji,jm,3) = 0._wp
- zindterm(ji,jm) = ztiold(ji,nlay_i) + zeta_i(ji,nlay_i) * &
- & ( zradab_i(ji,nlay_i) + zkappa_i(ji,nlay_i) * zg1 * t_bo_1d(ji) )
- ENDDO
-
- DO ji = 1, npti
- ! !---------------------!
- IF( h_s_1d(ji) > 0._wp ) THEN ! snow-covered cells !
- ! !---------------------!
- ! snow interior terms (bottom equation has the same form as the others)
- DO jm = 3, nlay_s + 1
- jk = jm - 1
- ztrid (ji,jm,1) = - zeta_s(ji,jk) * zkappa_s(ji,jk-1)
- ztrid (ji,jm,2) = 1._wp + zeta_s(ji,jk) * ( zkappa_s(ji,jk-1) + zkappa_s(ji,jk) )
- ztrid (ji,jm,3) = - zeta_s(ji,jk) * zkappa_s(ji,jk)
- zindterm(ji,jm) = ztsold(ji,jk) + zeta_s(ji,jk) * zradab_s(ji,jk)
+ !
+ IF ( .NOT. l_T_converged(ji) ) THEN
+ ! before temperatures
+ ztib(:) = t_i_1d(ji,:)
+ ztsb(:) = t_s_1d(ji,:)
+ !
+ !----------------------------
+ ! 7) tridiagonal system terms
+ !----------------------------
+ ! layer denotes the number of the layer in the snow or in the ice
+ ! jm denotes the reference number of the equation in the tridiagonal
+ ! system, terms of tridiagonal system are indexed as following :
+ ! 1 is subdiagonal term, 2 is diagonal and 3 is superdiagonal one
+
+ ! ice interior terms (top equation has the same form as the others)
+ ztrid (:,:) = 0._wp
+ zindterm(:) = 0._wp
+ zindtbis(:) = 0._wp
+ zdiagbis(:) = 0._wp
+
+ DO jm = nlay_s + 2, nlay_s + nlay_i
+ jk = jm - nlay_s - 1
+ ztrid (jm,1) = - zeta_i(ji,jk) * zkappa_i(ji,jk-1)
+ ztrid (jm,2) = 1._wp + zeta_i(ji,jk) * ( zkappa_i(ji,jk-1) + zkappa_i(ji,jk) )
+ ztrid (jm,3) = - zeta_i(ji,jk) * zkappa_i(ji,jk)
+ zindterm(jm) = ztiold(ji,jk) + zeta_i(ji,jk) * zradab_i(ji,jk)
END DO
- ! case of only one layer in the ice (ice equation is altered)
- IF ( nlay_i == 1 ) THEN
- ztrid (ji,nlay_s+2,3) = 0._wp
- zindterm(ji,nlay_s+2) = zindterm(ji,nlay_s+2) + zeta_i(ji,1) * zkappa_i(ji,1) * t_bo_1d(ji)
- ENDIF
+ ! ice bottom term
+ jm = nlay_s + nlay_i + 1
+ ztrid (jm,1) = - zeta_i(ji,nlay_i) * zkappa_i(ji,nlay_i-1)
+ ztrid (jm,2) = 1._wp + zeta_i(ji,nlay_i) * ( zkappa_i(ji,nlay_i-1) + zkappa_i(ji,nlay_i) * zg1 )
+ ztrid (jm,3) = 0._wp
+ zindterm(jm) = ztiold(ji,nlay_i) + zeta_i(ji,nlay_i) * &
+ & ( zradab_i(ji,nlay_i) + zkappa_i(ji,nlay_i) * zg1 * t_bo_1d(ji) )
+
+ ! !---------------------!
+ IF( h_s_1d(ji) > 0._wp ) THEN ! snow-covered cells !
+ ! !---------------------!
+ ! snow interior terms (bottom equation has the same form as the others)
+ DO jm = 3, nlay_s + 1
+ jk = jm - 1
+ ztrid (jm,1) = - zeta_s(ji,jk) * zkappa_s(ji,jk-1)
+ ztrid (jm,2) = 1._wp + zeta_s(ji,jk) * ( zkappa_s(ji,jk-1) + zkappa_s(ji,jk) )
+ ztrid (jm,3) = - zeta_s(ji,jk) * zkappa_s(ji,jk)
+ zindterm(jm) = ztsold(ji,jk) + zeta_s(ji,jk) * zradab_s(ji,jk)
+ END DO
- jm_min(ji) = 2
- jm_max(ji) = nlay_i + nlay_s + 1
-
- ! first layer of snow equation
- ztrid (ji,2,1) = 0._wp
- ztrid (ji,2,2) = 1._wp + zeta_s(ji,1) * zkappa_s(ji,1)
- ztrid (ji,2,3) = - zeta_s(ji,1) * zkappa_s(ji,1)
- zindterm(ji,2) = ztsold(ji,1) + zeta_s(ji,1) * ( zradab_s(ji,1) + qcn_ice_1d(ji) )
-
- ! !---------------------!
- ELSE ! cells without snow !
- ! !---------------------!
- jm_min(ji) = nlay_s + 2
- jm_max(ji) = nlay_i + nlay_s + 1
-
- ! first layer of ice equation
- ztrid (ji,jm_min(ji),1) = 0._wp
- ztrid (ji,jm_min(ji),2) = 1._wp + zeta_i(ji,1) * zkappa_i(ji,1)
- ztrid (ji,jm_min(ji),3) = - zeta_i(ji,1) * zkappa_i(ji,1)
- zindterm(ji,jm_min(ji)) = ztiold(ji,1) + zeta_i(ji,1) * ( zradab_i(ji,1) + qcn_ice_1d(ji) )
-
- ! case of only one layer in the ice (surface & ice equations are altered)
- IF( nlay_i == 1 ) THEN
- ztrid (ji,jm_min(ji),1) = 0._wp
- ztrid (ji,jm_min(ji),2) = 1._wp + zeta_i(ji,1) * zkappa_i(ji,1)
- ztrid (ji,jm_min(ji),3) = 0._wp
- zindterm(ji,jm_min(ji)) = ztiold(ji,1) + zeta_i(ji,1) * &
- & ( zradab_i(ji,1) + zkappa_i(ji,1) * t_bo_1d(ji) + qcn_ice_1d(ji) )
- ENDIF
+ ! case of only one layer in the ice (ice equation is altered)
+ IF ( nlay_i == 1 ) THEN
+ ztrid (nlay_s+2,3) = 0._wp
+ zindterm(nlay_s+2) = zindterm(nlay_s+2) + zeta_i(ji,1) * zkappa_i(ji,1) * t_bo_1d(ji)
+ ENDIF
- ENDIF
- !
- zindtbis(ji,jm_min(ji)) = zindterm(ji,jm_min(ji))
- zdiagbis(ji,jm_min(ji)) = ztrid (ji,jm_min(ji),2)
- !
- END DO
- !
- !------------------------------
- ! 8) tridiagonal system solving
- !------------------------------
- ! Solve the tridiagonal system with Gauss elimination method.
- ! Thomas algorithm, from Computational fluid Dynamics, J.D. ANDERSON, McGraw-Hill 1984
+ jm_min = 2
+ jm_max = nlay_i + nlay_s + 1
+
+ ! first layer of snow equation
+ ztrid (2,1) = 0._wp
+ ztrid (2,2) = 1._wp + zeta_s(ji,1) * zkappa_s(ji,1)
+ ztrid (2,3) = - zeta_s(ji,1) * zkappa_s(ji,1)
+ zindterm(2) = ztsold(ji,1) + zeta_s(ji,1) * ( zradab_s(ji,1) + qcn_ice_1d(ji) )
+
+ ! !---------------------!
+ ELSE ! cells without snow !
+ ! !---------------------!
+ jm_min = nlay_s + 2
+ jm_max = nlay_i + nlay_s + 1
+
+ ! first layer of ice equation
+ ztrid (jm_min,1) = 0._wp
+ ztrid (jm_min,2) = 1._wp + zeta_i(ji,1) * zkappa_i(ji,1)
+ ztrid (jm_min,3) = - zeta_i(ji,1) * zkappa_i(ji,1)
+ zindterm(jm_min) = ztiold(ji,1) + zeta_i(ji,1) * ( zradab_i(ji,1) + qcn_ice_1d(ji) )
+
+ ! case of only one layer in the ice (surface & ice equations are altered)
+ IF( nlay_i == 1 ) THEN
+ ztrid (jm_min,1) = 0._wp
+ ztrid (jm_min,2) = 1._wp + zeta_i(ji,1) * zkappa_i(ji,1)
+ ztrid (jm_min,3) = 0._wp
+ zindterm(jm_min) = ztiold(ji,1) + zeta_i(ji,1) * &
+ & ( zradab_i(ji,1) + zkappa_i(ji,1) * t_bo_1d(ji) + qcn_ice_1d(ji) )
+ ENDIF
+
+ ENDIF
+ !
+ zindtbis(jm_min) = zindterm(jm_min)
+ zdiagbis(jm_min) = ztrid (jm_min,2)
+ !
+ !
+ !------------------------------
+ ! 8) tridiagonal system solving
+ !------------------------------
+ ! Solve the tridiagonal system with Gauss elimination method.
+ ! Thomas algorithm, from Computational fluid Dynamics, J.D. ANDERSON, McGraw-Hill 1984
!!$ jm_maxt = 0
!!$ jm_mint = nlay_i+5
!!$ DO ji = 1, npti
-!!$ jm_mint = MIN(jm_min(ji),jm_mint)
-!!$ jm_maxt = MAX(jm_max(ji),jm_maxt)
+!!$ jm_mint = MIN(jm_min,jm_mint)
+!!$ jm_maxt = MAX(jm_max,jm_maxt)
!!$ END DO
!!$
!!$ DO jk = jm_mint+1, jm_maxt
!!$ DO ji = 1, npti
-!!$ jm = MIN(MAX(jm_min(ji)+1,jk),jm_max(ji))
+!!$ jm = MIN(MAX(jm_min+1,jk),jm_max)
!!$ zdiagbis(ji,jm) = ztrid (ji,jm,2) - ztrid(ji,jm,1) * ztrid (ji,jm-1,3) / zdiagbis(ji,jm-1)
!!$ zindtbis(ji,jm) = zindterm(ji,jm) - ztrid(ji,jm,1) * zindtbis(ji,jm-1) / zdiagbis(ji,jm-1)
!!$ END DO
!!$ END DO
- ! clem: maybe one should find a way to reverse this loop for mpi performance
- DO ji = 1, npti
- jm_mint = jm_min(ji)
- jm_maxt = jm_max(ji)
- DO jm = jm_mint+1, jm_maxt
- zdiagbis(ji,jm) = ztrid (ji,jm,2) - ztrid(ji,jm,1) * ztrid (ji,jm-1,3) / zdiagbis(ji,jm-1)
- zindtbis(ji,jm) = zindterm(ji,jm ) - ztrid(ji,jm,1) * zindtbis(ji,jm-1 ) / zdiagbis(ji,jm-1)
- END DO
- END DO
- ! ice temperatures
- DO ji = 1, npti
- ! Variable used after iterations
- ! Value must be frozen after convergence for MPP independance reason
- IF ( .NOT. l_T_converged(ji) ) &
- t_i_1d(ji,nlay_i) = zindtbis(ji,jm_max(ji)) / zdiagbis(ji,jm_max(ji))
- END DO
-
- DO jm = nlay_i + nlay_s, nlay_s + 2, -1
- DO ji = 1, npti
- IF ( .NOT. l_T_converged(ji) ) THEN
- jk = jm - nlay_s - 1
- t_i_1d(ji,jk) = ( zindtbis(ji,jm) - ztrid(ji,jm,3) * t_i_1d(ji,jk+1) ) / zdiagbis(ji,jm)
- ENDIF
- END DO
- END DO
-
- ! snow temperatures
- DO ji = 1, npti
- ! Variables used after iterations
- ! Value must be frozen after convergence for MPP independance reason
- IF ( .NOT. l_T_converged(ji) .AND. h_s_1d(ji) > 0._wp ) &
- & t_s_1d(ji,nlay_s) = ( zindtbis(ji,nlay_s+1) - ztrid(ji,nlay_s+1,3) * t_i_1d(ji,1) ) / zdiagbis(ji,nlay_s+1)
- END DO
- !!clem SNWLAY
- DO jm = nlay_s, 2, -1
- DO ji = 1, npti
- jk = jm - 1
- IF ( .NOT. l_T_converged(ji) .AND. h_s_1d(ji) > 0._wp ) &
- & t_s_1d(ji,jk) = ( zindtbis(ji,jm) - ztrid(ji,jm,3) * t_s_1d(ji,jk+1) ) / zdiagbis(ji,jm)
- END DO
- END DO
- !
- !--------------------------------------------------------------
- ! 9) Has the scheme converged?, end of the iterative procedure
- !--------------------------------------------------------------
- ! check that nowhere it has started to melt
- ! zdti_max is a measure of error, it has to be under zdti_bnd
+ DO jm = jm_min+1, jm_max
+ zdiagbis(jm) = ztrid (jm,2) - ztrid(jm,1) * ztrid (jm-1,3) / zdiagbis(jm-1)
+ zindtbis(jm) = zindterm(jm ) - ztrid(jm,1) * zindtbis(jm-1 ) / zdiagbis(jm-1)
+ END DO
- DO ji = 1, npti
+ ! ice temperatures
+ ! Variable used after iterations
+ ! Value must be frozen after convergence for MPP independance reason
+ t_i_1d(ji,nlay_i) = zindtbis(jm_max) / zdiagbis(jm_max)
- zdti_max = 0._wp
+ DO jm = nlay_i + nlay_s, nlay_s + 2, -1
+ jk = jm - nlay_s - 1
+ t_i_1d(ji,jk) = ( zindtbis(jm) - ztrid(jm,3) * t_i_1d(ji,jk+1) ) / zdiagbis(jm)
+ END DO
- IF ( .NOT. l_T_converged(ji) ) THEN
+ ! snow temperatures
+ ! Variables used after iterations
+ ! Value must be frozen after convergence for MPP independance reason
+ IF ( h_s_1d(ji) > 0._wp ) &
+ & t_s_1d(ji,nlay_s) = ( zindtbis(nlay_s+1) - ztrid(nlay_s+1,3) * t_i_1d(ji,1) ) / zdiagbis(nlay_s+1)
+ !!clem SNWLAY
+ DO jm = nlay_s, 2, -1
+ jk = jm - 1
+ IF ( h_s_1d(ji) > 0._wp ) &
+ & t_s_1d(ji,jk) = ( zindtbis(jm) - ztrid(jm,3) * t_s_1d(ji,jk+1) ) / zdiagbis(jm)
+ END DO
+ !
+ !--------------------------------------------------------------
+ ! 9) Has the scheme converged?, end of the iterative procedure
+ !--------------------------------------------------------------
+ ! check that nowhere it has started to melt
+ ! zdti_max is a measure of error, it has to be under zdti_bnd
+ zdti_max = 0._wp
IF( h_s_1d(ji) > 0._wp ) THEN
DO jk = 1, nlay_s
t_s_1d(ji,jk) = MAX( MIN( t_s_1d(ji,jk), rt0 ), rt0 - 100._wp )
- zdti_max = MAX ( zdti_max , ABS( t_s_1d(ji,jk) - ztsb(ji,jk) ) )
+ zdti_max = MAX ( zdti_max , ABS( t_s_1d(ji,jk) - ztsb(jk) ) )
END DO
ENDIF
DO jk = 1, nlay_i
ztmelts = -rTmlt * sz_i_1d(ji,jk) + rt0
t_i_1d(ji,jk) = MAX( MIN( t_i_1d(ji,jk), ztmelts ), rt0 - 100._wp )
- zdti_max = MAX ( zdti_max, ABS( t_i_1d(ji,jk) - ztib(ji,jk) ) )
+ zdti_max = MAX ( zdti_max, ABS( t_i_1d(ji,jk) - ztib(jk) ) )
END DO
! convergence test
@@ -847,49 +796,38 @@ CONTAINS
! 10) Fluxes at the interfaces
!-----------------------------
!
- ! --- calculate conduction fluxes (positive downward)
- ! bottom ice conduction flux
- DO ji = 1, npti
- qcn_ice_bot_1d(ji) = - zkappa_i(ji,nlay_i) * zg1 * ( t_bo_1d(ji ) - t_i_1d (ji,nlay_i) )
- END DO
- ! surface ice conduction flux
IF( k_cnd == np_cnd_OFF .OR. k_cnd == np_cnd_EMU ) THEN
!
DO ji = 1, npti
- qcn_ice_top_1d(ji) = - isnow(ji) * zkappa_s(ji,0) * zg1s * ( t_s_1d(ji,1) - t_su_1d(ji) ) &
+ ! --- ice conduction fluxes (positive downward)
+ qcn_ice_bot_1d(ji) = - zkappa_i(ji,nlay_i) * zg1 * ( t_bo_1d(ji ) - t_i_1d (ji,nlay_i) ) ! bottom
+ qcn_ice_top_1d(ji) = - isnow(ji) * zkappa_s(ji,0) * zg1s * ( t_s_1d(ji,1) - t_su_1d(ji) ) & ! surface
& - ( 1._wp - isnow(ji) ) * zkappa_i(ji,0) * zg1 * ( t_i_1d(ji,1) - t_su_1d(ji) )
+ ! --- Diagnose the heat loss due to changing non-solar / conduction flux
+ hfx_err_dif_1d(ji) = hfx_err_dif_1d(ji) - ( qns_ice_1d(ji) - zqns_ice_b(ji) ) * a_i_1d(ji)
END DO
!
ELSEIF( k_cnd == np_cnd_ON ) THEN
!
DO ji = 1, npti
- qcn_ice_top_1d(ji) = qcn_ice_1d(ji)
- END DO
- !
- ENDIF
- ! surface ice temperature
- IF( k_cnd == np_cnd_ON .AND. ln_cndemulate ) THEN
- !
- DO ji = 1, npti
- t_su_1d(ji) = ( qcn_ice_top_1d(ji) + isnow(ji) * zkappa_s(ji,0) * zg1s * t_s_1d(ji,1) + &
- & ( 1._wp - isnow(ji) ) * zkappa_i(ji,0) * zg1 * t_i_1d(ji,1) ) &
- & / MAX( epsi10, isnow(ji) * zkappa_s(ji,0) * zg1s + ( 1._wp - isnow(ji) ) * zkappa_i(ji,0) * zg1 )
- t_su_1d(ji) = MAX( MIN( t_su_1d(ji), rt0 ), rt0 - 100._wp ) ! cap t_su
+ ! --- ice conduction fluxes (positive downward)
+ qcn_ice_bot_1d(ji) = - zkappa_i(ji,nlay_i) * zg1 * ( t_bo_1d(ji ) - t_i_1d (ji,nlay_i) ) ! bottom
+ qcn_ice_top_1d(ji) = qcn_ice_1d(ji) ! surface
END DO
!
- ENDIF
- !
- ! --- Diagnose the heat loss due to changing non-solar / conduction flux --- !
- !
- IF( k_cnd == np_cnd_OFF .OR. k_cnd == np_cnd_EMU ) THEN
- !
- DO ji = 1, npti
- hfx_err_dif_1d(ji) = hfx_err_dif_1d(ji) - ( qns_ice_1d(ji) - zqns_ice_b(ji) ) * a_i_1d(ji)
- END DO
+ ! --- surface ice temperature
+ IF( ln_cndemulate ) THEN
+ DO ji = 1, npti
+ t_su_1d(ji) = ( qcn_ice_top_1d(ji) + isnow(ji) * zkappa_s(ji,0) * zg1s * t_s_1d(ji,1) + &
+ & ( 1._wp - isnow(ji) ) * zkappa_i(ji,0) * zg1 * t_i_1d(ji,1) ) &
+ & / MAX( epsi10, isnow(ji) * zkappa_s(ji,0) * zg1s + ( 1._wp - isnow(ji) ) * zkappa_i(ji,0) * zg1 )
+ t_su_1d(ji) = MAX( MIN( t_su_1d(ji), rt0 ), rt0 - 100._wp ) ! cap t_su
+ END DO
+ ENDIF
!
ENDIF
!
- ! --- Diagnose the heat loss due to non-fully converged temperature solution (should not be above 10-4 W-m2) --- !
+ ! --- Diagnose the heat loss due to non-fully converged temperature solution (should not be larger than 10-4 W-m2)
!
IF( k_cnd == np_cnd_OFF .OR. k_cnd == np_cnd_ON ) THEN
@@ -949,10 +887,8 @@ CONTAINS
qcn_ice_1d(1:npti) = qcn_ice_top_1d(1:npti)
ENDIF
!
- ! --- SIMIP diagnostics
- !
+ ! --- SIMIP diagnostics (Snow-ice interfacial temperature)
DO ji = 1, npti
- !--- Snow-ice interfacial temperature (diagnostic SIMIP)
IF( h_s_1d(ji) >= zhs_ssl ) THEN
t_si_1d(ji) = ( rn_cnd_s * h_i_1d(ji) * r1_nlay_i * t_s_1d(ji,nlay_s) &
& + ztcond_i(ji,1) * h_s_1d(ji) * r1_nlay_s * t_i_1d(ji,1) ) &
diff --git a/src/ICE/iceupdate.F90 b/src/ICE/iceupdate.F90
index 6c8221ca1e91590ca2e03a47a22c99f8c5a1e707..3e6a29c042560bf92cb6efeb89ee02bd319d06f8 100644
--- a/src/ICE/iceupdate.F90
+++ b/src/ICE/iceupdate.F90
@@ -55,7 +55,7 @@ CONTAINS
!!-------------------------------------------------------------------
!! *** ROUTINE ice_update_alloc ***
!!-------------------------------------------------------------------
- ALLOCATE( utau_oce(jpi,jpj), vtau_oce(jpi,jpj), tmod_io(jpi,jpj), STAT=ice_update_alloc )
+ ALLOCATE( utau_oce(A2D(0)), vtau_oce(A2D(0)), tmod_io(jpi,jpj), STAT=ice_update_alloc )
!
CALL mpp_sum( 'iceupdate', ice_update_alloc )
IF( ice_update_alloc /= 0 ) CALL ctl_stop( 'STOP', 'ice_update_alloc: failed to allocate arrays' )
@@ -100,26 +100,33 @@ CONTAINS
WRITE(numout,*)'ice_update_flx: update fluxes (mass, salt and heat) at the ice-ocean interface'
WRITE(numout,*)'~~~~~~~~~~~~~~'
ENDIF
-
+
! Net heat flux on top of the ice-ocean (W.m-2)
!----------------------------------------------
IF( ln_cndflx ) THEN ! ice-atm interface = conduction (and melting) fluxes
- qt_atm_oi(:,:) = ( 1._wp - at_i_b(:,:) ) * ( qns_oce(:,:) + qsr_oce(:,:) ) + qemp_oce(:,:) + &
- & SUM( a_i_b * ( qcn_ice + qml_ice + qtr_ice_top ), dim=3 ) + qemp_ice(:,:)
+ DO_2D( 0, 0, 0, 0 )
+ qt_atm_oi(ji,jj) = ( 1._wp - at_i_b(ji,jj) ) * ( qns_oce(ji,jj) + qsr_oce(ji,jj) ) + qemp_oce(ji,jj) &
+ & + SUM( a_i_b(ji,jj,:) * ( qcn_ice(ji,jj,:) + qml_ice(ji,jj,:) + qtr_ice_top(ji,jj,:) ) ) &
+ & + qemp_ice(ji,jj)
+ END_2D
ELSE ! ice-atm interface = solar and non-solar fluxes
- qt_atm_oi(:,:) = qns_tot(:,:) + qsr_tot(:,:)
+ DO_2D( 0, 0, 0, 0 )
+ qt_atm_oi(ji,jj) = qns_tot(ji,jj) + qsr_tot(ji,jj)
+ END_2D
ENDIF
! --- case we bypass ice thermodynamics --- !
IF( .NOT. ln_icethd ) THEN ! we suppose ice is impermeable => ocean is isolated from atmosphere
- qt_atm_oi (:,:) = ( 1._wp - at_i_b(:,:) ) * ( qns_oce(:,:) + qsr_oce(:,:) ) + qemp_oce(:,:)
- qt_oce_ai (:,:) = ( 1._wp - at_i_b(:,:) ) * qns_oce(:,:) + qemp_oce(:,:)
- emp_ice (:,:) = 0._wp
- qemp_ice (:,:) = 0._wp
- qevap_ice (:,:,:) = 0._wp
+ DO_2D( 0, 0, 0, 0 )
+ qt_atm_oi (ji,jj) = ( 1._wp - at_i_b(ji,jj) ) * ( qns_oce(ji,jj) + qsr_oce(ji,jj) ) + qemp_oce(ji,jj)
+ qt_oce_ai (ji,jj) = ( 1._wp - at_i_b(ji,jj) ) * qns_oce(ji,jj) + qemp_oce(ji,jj)
+ emp_ice (ji,jj) = 0._wp
+ qemp_ice (ji,jj) = 0._wp
+ qevap_ice (ji,jj,:) = 0._wp
+ END_2D
ENDIF
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
! Solar heat flux reaching the ocean (max) = zqsr (W.m-2)
!---------------------------------------------------
@@ -170,7 +177,7 @@ CONTAINS
wfx_snw(ji,jj) = wfx_snw_sni(ji,jj) + wfx_snw_dyn(ji,jj) + wfx_snw_sum(ji,jj)
! total mass flux at the ocean/ice interface
- fmmflx(ji,jj) = - wfx_ice(ji,jj) - wfx_snw(ji,jj) - wfx_pnd(ji,jj) - wfx_err_sub(ji,jj) ! ice-ocean mass flux saved at least for biogeochemical model
+ fwfice(ji,jj) = wfx_ice(ji,jj) + wfx_snw(ji,jj) + wfx_pnd(ji,jj) + wfx_err_sub(ji,jj) ! ice-ocean mass flux saved at least for biogeochemical model
emp (ji,jj) = emp_oce(ji,jj) - wfx_ice(ji,jj) - wfx_snw(ji,jj) - wfx_pnd(ji,jj) - wfx_err_sub(ji,jj) ! atm-ocean + ice-ocean mass flux
! Salt flux at the ocean surface
@@ -178,24 +185,31 @@ CONTAINS
sfx(ji,jj) = sfx_bog(ji,jj) + sfx_bom(ji,jj) + sfx_sum(ji,jj) + sfx_sni(ji,jj) + sfx_opw(ji,jj) &
& + sfx_res(ji,jj) + sfx_dyn(ji,jj) + sfx_bri(ji,jj) + sfx_sub(ji,jj) + sfx_lam(ji,jj)
- ! Mass of snow and ice per unit area
- !----------------------------------------
- snwice_mass_b(ji,jj) = snwice_mass(ji,jj) ! save mass from the previous ice time step
- ! ! new mass per unit area
- snwice_mass (ji,jj) = tmask(ji,jj,1) * ( rhos * vt_s(ji,jj) + rhoi * vt_i(ji,jj) + rhow * (vt_ip(ji,jj) + vt_il(ji,jj)) )
- ! ! time evolution of snow+ice mass
- snwice_fmass (ji,jj) = ( snwice_mass(ji,jj) - snwice_mass_b(ji,jj) ) * r1_Dt_ice
+ END_2D
+ ! Mass of snow and ice per unit area
+ !----------------------------------------
+ DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ snwice_mass_b(ji,jj) = snwice_mass(ji,jj) ! save mass from the previous ice time step
+ snwice_mass (ji,jj) = tmask(ji,jj,1) * & ! new mass per unit area
+ & ( rhos * vt_s(ji,jj) + rhoi * vt_i(ji,jj) + rhow * (vt_ip(ji,jj) + vt_il(ji,jj)) )
+ snwice_fmass (ji,jj) = ( snwice_mass(ji,jj) - snwice_mass_b(ji,jj) ) * r1_Dt_ice ! time evolution of snow+ice mass
END_2D
! Storing the transmitted variables
!----------------------------------
- fr_i (:,:) = at_i(:,:) ! Sea-ice fraction
- tn_ice(:,:,:) = t_su(:,:,:) ! Ice surface temperature
+ DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ fr_i(ji,jj) = at_i(ji,jj) ! Sea-ice fraction
+ END_2D
+ DO jl = 1, jpl
+ DO_2D( 0, 0, 0, 0 )
+ tn_ice(ji,jj,jl) = t_su(ji,jj,jl) ! Ice surface temperature
+ END_2D
+ ENDDO
! Snow/ice albedo (only if sent to coupler, useless in forced mode)
!------------------------------------------------------------------
- CALL ice_alb( t_su, h_i, h_s, ln_pnd_alb, a_ip_eff, h_ip, cloud_fra, alb_ice ) ! ice albedo
-
+ CALL ice_alb( ln_pnd_alb, t_su(A2D(0),:), h_i(A2D(0),:), h_s(A2D(0),:), a_ip_eff(:,:,:), h_ip(A2D(0),:), cloud_fra(:,:), & ! <<== in
+ & alb_ice(:,:,:) ) ! ==>> out
!
IF( lrst_ice ) THEN !* write snwice_mass fields in the restart file
CALL update_rst( 'WRITE', kt )
@@ -215,8 +229,8 @@ CONTAINS
IF( iom_use('sfxopw' ) ) CALL iom_put( 'sfxopw', sfx_opw * 1.e-03 ) ! salt flux from open water formation
IF( iom_use('sfxdyn' ) ) CALL iom_put( 'sfxdyn', sfx_dyn * 1.e-03 ) ! salt flux from ridging rafting
IF( iom_use('sfxbri' ) ) CALL iom_put( 'sfxbri', sfx_bri * 1.e-03 ) ! salt flux from brines
- IF( iom_use('sfxres' ) ) CALL iom_put( 'sfxres', sfx_res * 1.e-03 ) ! salt flux from undiagnosed processes
IF( iom_use('sfxsub' ) ) CALL iom_put( 'sfxsub', sfx_sub * 1.e-03 ) ! salt flux from sublimation
+ IF( iom_use('sfxres' ) ) CALL iom_put( 'sfxres', sfx_res * 1.e-03 ) ! salt flux from undiagnosed processes
! --- mass fluxes [kg/m2/s] --- !
CALL iom_put( 'emp_oce', emp_oce ) ! emp over ocean (taking into account the snow blown away from the ice)
@@ -231,13 +245,13 @@ CONTAINS
CALL iom_put( 'vfxsni' , wfx_sni ) ! mass flux from snow-ice formation
CALL iom_put( 'vfxopw' , wfx_opw ) ! mass flux from growth in open water
CALL iom_put( 'vfxdyn' , wfx_dyn ) ! mass flux from dynamics (ridging)
- CALL iom_put( 'vfxres' , wfx_res ) ! mass flux from undiagnosed processes
CALL iom_put( 'vfxpnd' , wfx_pnd ) ! mass flux from melt ponds
CALL iom_put( 'vfxsub' , wfx_ice_sub ) ! mass flux from ice sublimation (ice-atm.)
CALL iom_put( 'vfxsub_err', wfx_err_sub ) ! "excess" of sublimation sent to ocean
+ CALL iom_put( 'vfxres' , wfx_res ) ! mass flux from undiagnosed processes
IF ( iom_use( 'vfxthin' ) ) THEN ! mass flux from ice growth in open water + thin ice (<20cm) => comparable to observations
- ALLOCATE( z2d(jpi,jpj) )
+ ALLOCATE( z2d(A2D(0)) )
WHERE( hm_i(:,:) < 0.2 .AND. hm_i(:,:) > 0. ) ; z2d = wfx_bog
ELSEWHERE ; z2d = 0._wp
END WHERE
@@ -263,8 +277,8 @@ CONTAINS
IF( iom_use('qtr_ice_top') ) CALL iom_put( 'qtr_ice_top', SUM( qtr_ice_top * a_i_b, dim=3 ) ) ! solar flux transmitted thru ice surface
IF( iom_use('qt_oce' ) ) CALL iom_put( 'qt_oce' , ( qsr_oce + qns_oce ) * ( 1._wp - at_i_b ) + qemp_oce )
IF( iom_use('qt_ice' ) ) CALL iom_put( 'qt_ice' , SUM( ( qns_ice + qsr_ice ) * a_i_b, dim=3 ) + qemp_ice )
- IF( iom_use('qt_oce_ai' ) ) CALL iom_put( 'qt_oce_ai' , qt_oce_ai * tmask(:,:,1) ) ! total heat flux at the ocean surface: interface oce-(ice+atm)
- IF( iom_use('qt_atm_oi' ) ) CALL iom_put( 'qt_atm_oi' , qt_atm_oi * tmask(:,:,1) ) ! total heat flux at the oce-ice surface: interface atm-(ice+oce)
+ IF( iom_use('qt_oce_ai' ) ) CALL iom_put( 'qt_oce_ai' , qt_oce_ai * smask0 ) ! total heat flux at the ocean surface: interface oce-(ice+atm)
+ IF( iom_use('qt_atm_oi' ) ) CALL iom_put( 'qt_atm_oi' , qt_atm_oi * smask0 ) ! total heat flux at the oce-ice surface: interface atm-(ice+oce)
IF( iom_use('qemp_oce' ) ) CALL iom_put( 'qemp_oce' , qemp_oce ) ! Downward Heat Flux from E-P over ocean
IF( iom_use('qemp_ice' ) ) CALL iom_put( 'qemp_ice' , qemp_ice ) ! Downward Heat Flux from E-P over ice
@@ -281,9 +295,9 @@ CONTAINS
! heat fluxes associated with mass exchange (freeze/melt/precip...)
CALL iom_put ('hfxthd' , hfx_thd ) !
CALL iom_put ('hfxdyn' , hfx_dyn ) !
- CALL iom_put ('hfxres' , hfx_res ) !
CALL iom_put ('hfxsub' , hfx_sub ) !
CALL iom_put ('hfxspr' , hfx_spr ) ! Heat flux from snow precip heat content
+ CALL iom_put ('hfxres' , hfx_res ) !
! other heat fluxes
IF( iom_use('hfxsensib' ) ) CALL iom_put( 'hfxsensib' , qsb_ice_bot * at_i_b ) ! Sensible oceanic heat flux
@@ -313,7 +327,7 @@ CONTAINS
!!
!! ** Action : * at each ice time step (every nn_fsbc time step):
!! - compute the modulus of ice-ocean relative velocity
- !! (*rho*Cd) at T-point (C-grid) or I-point (B-grid)
+ !! (*rho*Cd) at T-point (C-grid)
!! tmod_io = rhoco * | U_ice-U_oce |
!! - update the modulus of stress at ocean surface
!! taum = (1-a) * taum + a * tmod_io * | U_ice-U_oce |
@@ -324,19 +338,19 @@ CONTAINS
!!
!! NB: - ice-ocean rotation angle no more allowed
!! - here we make an approximation: taum is only computed every ice time step
- !! This avoids mutiple average to pass from T -> U,V grids and next from U,V grids
- !! to T grid. taum is used in TKE and GLS, which should not be too sensitive to this approximaton...
+ !! This avoids mutiple average to pass from U,V grids to T grids
+ !! taum is used in TKE and GLS, which should not be too sensitive to this approximaton...
!!
- !! ** Outputs : - utau, vtau : surface ocean i- and j-stress (u- & v-pts) updated with ice-ocean fluxes
+ !! ** Outputs : - utau, vtau : surface ocean i- and j-stress (T-pts) updated with ice-ocean fluxes
!! - taum : modulus of the surface ocean stress (T-point) updated with ice-ocean fluxes
!!---------------------------------------------------------------------
INTEGER , INTENT(in) :: kt ! ocean time-step index
REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pu_oce, pv_oce ! surface ocean currents
!
INTEGER :: ji, jj ! dummy loop indices
- REAL(wp) :: zat_u, zutau_ice, zu_t, zmodt ! local scalar
- REAL(wp) :: zat_v, zvtau_ice, zv_t, zrhoco ! - -
- REAL(wp) :: zflagi ! - -
+ REAL(wp) :: zutau_ice, zu_t, zmodt ! local scalar
+ REAL(wp) :: zvtau_ice, zv_t, zrhoco ! - -
+ REAL(wp) :: zflagi ! - -
!!---------------------------------------------------------------------
IF( ln_timing ) CALL timing_start('iceupdate')
@@ -349,46 +363,53 @@ CONTAINS
zrhoco = rho0 * rn_cio
!
IF( MOD( kt-1, nn_fsbc ) == 0 ) THEN !== Ice time-step only ==! (i.e. surface module time-step)
- DO_2D( 0, 0, 0, 0 ) !* update the modulus of stress at ocean surface (T-point)
+ DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) !* rhoco * |U_ice-U_oce| at T-point
+ ! ! 2*(U_ice-U_oce) at T-point
+ zu_t = ( u_ice(ji,jj) + u_ice(ji-1,jj) ) - ( u_oce(ji,jj) + u_oce(ji-1,jj) ) ! u_oce = ssu_m add () for
+ zv_t = ( v_ice(ji,jj) + v_ice(ji,jj-1) ) - ( v_oce(ji,jj) + v_oce(ji,jj-1) ) ! v_oce = ssv_m NP repro
+ ! ! |U_ice-U_oce|^2
+ zmodt = 0.25_wp * ( zu_t * zu_t + zv_t * zv_t )
+ !
+ tmod_io(ji,jj) = zrhoco * SQRT( zmodt )
+ END_2D
+ IF( nn_hls == 1 ) CALL lbc_lnk( 'iceupdate', tmod_io, 'T', 1._wp )
+ !
+ DO_2D( 0, 0, 0, 0 ) !* save the air-ocean stresses at ice time-step
! ! 2*(U_ice-U_oce) at T-point
- zu_t = u_ice(ji,jj) + u_ice(ji-1,jj) - u_oce(ji,jj) - u_oce(ji-1,jj)
- zv_t = v_ice(ji,jj) + v_ice(ji,jj-1) - v_oce(ji,jj) - v_oce(ji,jj-1)
- ! ! |U_ice-U_oce|^2
+ zu_t = ( u_ice(ji,jj) + u_ice(ji-1,jj) ) - ( u_oce(ji,jj) + u_oce(ji-1,jj) ) ! u_oce = ssu_m add () for
+ zv_t = ( v_ice(ji,jj) + v_ice(ji,jj-1) ) - ( v_oce(ji,jj) + v_oce(ji,jj-1) ) ! v_oce = ssv_m NP repro
+ ! ! |U_ice-U_oce|^2
zmodt = 0.25_wp * ( zu_t * zu_t + zv_t * zv_t )
! ! update the ocean stress modulus
taum(ji,jj) = ( 1._wp - at_i(ji,jj) ) * taum(ji,jj) + at_i(ji,jj) * zrhoco * zmodt
- tmod_io(ji,jj) = zrhoco * SQRT( zmodt ) ! rhoco * |U_ice-U_oce| at T-point
+ !
+ utau_oce(ji,jj) = utau(ji,jj)
+ vtau_oce(ji,jj) = vtau(ji,jj)
END_2D
- CALL lbc_lnk( 'iceupdate', taum, 'T', 1.0_wp, tmod_io, 'T', 1.0_wp )
- !
- utau_oce(:,:) = utau(:,:) !* save the air-ocean stresses at ice time-step
- vtau_oce(:,:) = vtau(:,:)
!
ENDIF
!
! !== every ocean time-step ==!
IF ( ln_drgice_imp ) THEN
! Save drag with right sign to update top drag in the ocean implicit friction
- rCdU_ice(:,:) = -r1_rho0 * tmod_io(:,:) * at_i(:,:) * tmask(:,:,1)
+ DO_2D( 1, 1, 1, 1 )
+ rCdU_ice(ji,jj) = -r1_rho0 * tmod_io(ji,jj) * at_i(ji,jj) * tmask(ji,jj,1)
+ END_2D
zflagi = 0._wp
ELSE
zflagi = 1._wp
ENDIF
!
DO_2D( 0, 0, 0, 0 ) !* update the stress WITHOUT an ice-ocean rotation angle
- ! ice area at u and v-points
- zat_u = ( at_i(ji,jj) * tmask(ji,jj,1) + at_i (ji+1,jj ) * tmask(ji+1,jj ,1) ) &
- & / MAX( 1.0_wp , tmask(ji,jj,1) + tmask(ji+1,jj ,1) )
- zat_v = ( at_i(ji,jj) * tmask(ji,jj,1) + at_i (ji ,jj+1 ) * tmask(ji ,jj+1,1) ) &
- & / MAX( 1.0_wp , tmask(ji,jj,1) + tmask(ji ,jj+1,1) )
! ! linearized quadratic drag formulation
- zutau_ice = 0.5_wp * ( tmod_io(ji,jj) + tmod_io(ji+1,jj) ) * ( u_ice(ji,jj) - pu_oce(ji,jj) )
- zvtau_ice = 0.5_wp * ( tmod_io(ji,jj) + tmod_io(ji,jj+1) ) * ( v_ice(ji,jj) - pv_oce(ji,jj) )
+ zutau_ice = 0.5_wp * tmod_io(ji,jj) &
+ & * ( ( u_ice(ji,jj) + u_ice(ji-1,jj) ) - ( pu_oce(ji,jj) + pu_oce(ji-1,jj) ) ) ! add () for
+ zvtau_ice = 0.5_wp * tmod_io(ji,jj) &
+ & * ( ( v_ice(ji,jj) + v_ice(ji,jj-1) ) - ( pv_oce(ji,jj) + pv_oce(ji,jj-1) ) ) ! NP repro
! ! stresses at the ocean surface
- utau(ji,jj) = ( 1._wp - zat_u ) * utau_oce(ji,jj) + zat_u * zutau_ice
- vtau(ji,jj) = ( 1._wp - zat_v ) * vtau_oce(ji,jj) + zat_v * zvtau_ice
+ utau(ji,jj) = ( 1._wp - at_i(ji,jj) ) * utau_oce(ji,jj) + at_i(ji,jj) * zutau_ice
+ vtau(ji,jj) = ( 1._wp - at_i(ji,jj) ) * vtau_oce(ji,jj) + at_i(ji,jj) * zvtau_ice
END_2D
- CALL lbc_lnk( 'iceupdate', utau, 'U', -1.0_wp, vtau, 'V', -1.0_wp ) ! lateral boundary condition
!
IF( ln_timing ) CALL timing_stop('iceupdate')
!
@@ -445,15 +466,13 @@ CONTAINS
CALL iom_get( numrir, jpdom_auto, 'snwice_mass_b', snwice_mass_b )
ELSE ! start from rest
IF(lwp) WRITE(numout,*) ' ==>> previous run without snow-ice mass output then set it'
- snwice_mass (:,:) = tmask(:,:,1) * ( rhos * vt_s(:,:) + rhoi * vt_i(:,:) &
- & + rhow * (vt_ip(:,:) + vt_il(:,:)) )
+ snwice_mass (:,:) = tmask(:,:,1) * ( rhos * vt_s(:,:) + rhoi * vt_i(:,:) + rhow * (vt_ip(:,:) + vt_il(:,:)) )
snwice_mass_b(:,:) = snwice_mass(:,:)
ENDIF
ELSE !* Start from rest
!JC: I think this is useless with what is now done in ice_istate
IF(lwp) WRITE(numout,*) ' ==>> start from rest: set the snow-ice mass'
- snwice_mass (:,:) = tmask(:,:,1) * ( rhos * vt_s(:,:) + rhoi * vt_i(:,:) &
- & + rhow * (vt_ip(:,:) + vt_il(:,:)) )
+ snwice_mass (:,:) = tmask(:,:,1) * ( rhos * vt_s(:,:) + rhoi * vt_i(:,:) + rhow * (vt_ip(:,:) + vt_il(:,:)) )
snwice_mass_b(:,:) = snwice_mass(:,:)
ENDIF
!
diff --git a/src/ICE/icevar.F90 b/src/ICE/icevar.F90
index 535c5eb62a320b1c987727d2aacd4882abba6591..03d1fd6d28e5c7f8f1c1a2047f03237a0f56ee1f 100644
--- a/src/ICE/icevar.F90
+++ b/src/ICE/icevar.F90
@@ -55,7 +55,7 @@ MODULE icevar
!!----------------------------------------------------------------------
USE dom_oce ! ocean space and time domain
USE phycst ! physical constants (ocean directory)
- USE sbc_oce , ONLY : sss_m, ln_ice_embd, nn_fsbc
+ USE sbc_oce , ONLY : sss_m, sst_m, ln_ice_embd, nn_fsbc
USE ice ! sea-ice: variables
USE ice1D ! sea-ice: thermodynamics variables
!
@@ -113,100 +113,153 @@ CONTAINS
INTEGER, INTENT( in ) :: kn ! =1 state variables only
! ! >1 state variables + others
!
- INTEGER :: ji, jj, jk, jl ! dummy loop indices
- REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: z1_at_i, z1_vt_i, z1_vt_s
+ INTEGER :: ji, jj, jk, jl ! dummy loop indices
+ REAL(wp) :: z1_vt_i, z1_vt_s, z1_at_i
!!-------------------------------------------------------------------
!
- ! ! integrated values
- vt_i(:,:) = SUM( v_i (:,:,:) , dim=3 )
- vt_s(:,:) = SUM( v_s (:,:,:) , dim=3 )
- st_i(:,:) = SUM( sv_i(:,:,:) , dim=3 )
- at_i(:,:) = SUM( a_i (:,:,:) , dim=3 )
- et_s(:,:) = SUM( SUM( e_s (:,:,:,:), dim=4 ), dim=3 )
- et_i(:,:) = SUM( SUM( e_i (:,:,:,:), dim=4 ), dim=3 )
- !
- at_ip(:,:) = SUM( a_ip(:,:,:), dim=3 ) ! melt ponds
- vt_ip(:,:) = SUM( v_ip(:,:,:), dim=3 )
- vt_il(:,:) = SUM( v_il(:,:,:), dim=3 )
+ ! full arrays: vt_i, vt_s, at_i, vt_ip, vt_il, at_ip
+ ! reduced arrays: the rest
!
- ato_i(:,:) = 1._wp - at_i(:,:) ! open water fraction
+ ! --- integrated values
+ DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ vt_i(ji,jj) = SUM( v_i (ji,jj,:) )
+ vt_s(ji,jj) = SUM( v_s (ji,jj,:) )
+ at_i(ji,jj) = SUM( a_i (ji,jj,:) )
+ !
+ at_ip(ji,jj) = SUM( a_ip(ji,jj,:) ) ! melt ponds
+ vt_ip(ji,jj) = SUM( v_ip(ji,jj,:) )
+ vt_il(ji,jj) = SUM( v_il(ji,jj,:) )
+ !
+ ato_i(ji,jj) = 1._wp - at_i(ji,jj) ! open water fraction
+ END_2D
!
- !!GS: tm_su always needed by ABL over sea-ice
- ALLOCATE( z1_at_i(jpi,jpj) )
- WHERE( at_i(:,:) > epsi20 ) ; z1_at_i(:,:) = 1._wp / at_i(:,:)
- ELSEWHERE ; z1_at_i(:,:) = 0._wp
- END WHERE
- tm_su(:,:) = SUM( t_su(:,:,:) * a_i(:,:,:) , dim=3 ) * z1_at_i(:,:)
- WHERE( at_i(:,:)<=epsi20 ) tm_su(:,:) = rt0
+ DO_2D( 0, 0, 0, 0 )
+ st_i(ji,jj) = SUM( sv_i(ji,jj,:) )
+ et_s(ji,jj) = SUM( SUM( e_s (ji,jj,:,:), dim=2 ) )
+ et_i(ji,jj) = SUM( SUM( e_i (ji,jj,:,:), dim=2 ) )
+ !
+ !!GS: tm_su always needed by ABL over sea-ice
+ IF( at_i(ji,jj) <= epsi20 ) THEN
+ tm_su (ji,jj) = rt0
+ ELSE
+ tm_su (ji,jj) = SUM( t_su(ji,jj,:) * a_i(ji,jj,:) ) / at_i(ji,jj)
+ ENDIF
+ END_2D
!
! The following fields are calculated for diagnostics and outputs only
! ==> Do not use them for other purposes
IF( kn > 1 ) THEN
!
- ALLOCATE( z1_vt_i(jpi,jpj) , z1_vt_s(jpi,jpj) )
- WHERE( vt_i(:,:) > epsi20 ) ; z1_vt_i(:,:) = 1._wp / vt_i(:,:)
- ELSEWHERE ; z1_vt_i(:,:) = 0._wp
- END WHERE
- WHERE( vt_s(:,:) > epsi20 ) ; z1_vt_s(:,:) = 1._wp / vt_s(:,:)
- ELSEWHERE ; z1_vt_s(:,:) = 0._wp
- END WHERE
- !
- ! ! mean ice/snow thickness
- hm_i(:,:) = vt_i(:,:) * z1_at_i(:,:)
- hm_s(:,:) = vt_s(:,:) * z1_at_i(:,:)
- !
- ! ! mean temperature (K), salinity and age
- tm_si(:,:) = SUM( t_si(:,:,:) * a_i(:,:,:) , dim=3 ) * z1_at_i(:,:)
- om_i (:,:) = SUM( oa_i(:,:,:) , dim=3 ) * z1_at_i(:,:)
- sm_i (:,:) = st_i(:,:) * z1_vt_i(:,:)
- !
+ DO_2D( 0, 0, 0, 0 )
+ IF( at_i(ji,jj) > epsi20 ) THEN ; z1_at_i = 1._wp / at_i(ji,jj)
+ ELSE ; z1_at_i = 0._wp
+ ENDIF
+ IF( vt_i(ji,jj) > epsi20 ) THEN ; z1_vt_i = 1._wp / vt_i(ji,jj)
+ ELSE ; z1_vt_i = 0._wp
+ ENDIF
+
+ ! mean ice/snow thickness
+ hm_i(ji,jj) = vt_i(ji,jj) * z1_at_i
+ hm_s(ji,jj) = vt_s(ji,jj) * z1_at_i
+ !
+ ! mean temperature (K), salinity and age
+ tm_si(ji,jj) = SUM( t_si(ji,jj,:) * a_i(ji,jj,:) ) * z1_at_i
+ om_i (ji,jj) = SUM( oa_i(ji,jj,:) ) * z1_at_i
+ sm_i (ji,jj) = st_i(ji,jj) * z1_vt_i
+ END_2D
+ !
tm_i(:,:) = 0._wp
tm_s(:,:) = 0._wp
DO jl = 1, jpl
- DO jk = 1, nlay_i
- tm_i(:,:) = tm_i(:,:) + r1_nlay_i * t_i (:,:,jk,jl) * v_i(:,:,jl) * z1_vt_i(:,:)
- END DO
- DO jk = 1, nlay_s
- tm_s(:,:) = tm_s(:,:) + r1_nlay_s * t_s (:,:,jk,jl) * v_s(:,:,jl) * z1_vt_s(:,:)
- END DO
+ DO_3D( 0, 0, 0, 0, 1, nlay_i )
+ IF( vt_i(ji,jj) > epsi20 ) THEN
+ tm_i(ji,jj) = tm_i(ji,jj) + r1_nlay_i * t_i (ji,jj,jk,jl) * v_i(ji,jj,jl) / vt_i(ji,jj)
+ ELSE
+ tm_i(ji,jj) = rt0
+ ENDIF
+ END_3D
END DO
- !
- ! ! put rt0 where there is no ice
- WHERE( at_i(:,:)<=epsi20 )
+ DO jl = 1, jpl
+ DO_3D( 0, 0, 0, 0, 1, nlay_s )
+ IF( vt_s(ji,jj) > epsi20 ) THEN
+ tm_s(ji,jj) = tm_s(ji,jj) + r1_nlay_s * t_s (ji,jj,jk,jl) * v_s(ji,jj,jl) / vt_s(ji,jj)
+ ELSE
+ tm_s(ji,jj) = rt0
+ ENDIF
+ END_3D
+ END DO
+ !
+!!$ DO_2D( 0, 0, 0, 0 )
+!!$ IF( at_i(ji,jj) > epsi20 ) THEN ; z1_at_i = 1._wp / at_i(ji,jj)
+!!$ ELSE ; z1_at_i = 0._wp
+!!$ ENDIF
+!!$ IF( vt_i(ji,jj) > epsi20 ) THEN ; z1_vt_i = 1._wp / vt_i(ji,jj)
+!!$ ELSE ; z1_vt_i = 0._wp
+!!$ ENDIF
+!!$ IF( vt_s(ji,jj) > epsi20 ) THEN ; z1_vt_s = 1._wp / vt_s(ji,jj)
+!!$ ELSE ; z1_vt_s = 0._wp
+!!$ ENDIF
+!!$
+!!$ ! mean ice/snow thickness
+!!$ hm_i(ji,jj) = vt_i(ji,jj) * z1_at_i
+!!$ hm_s(ji,jj) = vt_s(ji,jj) * z1_at_i
+!!$ !
+!!$ ! mean temperature (K), salinity and age
+!!$ tm_si(ji,jj) = SUM( t_si(ji,jj,:) * a_i(ji,jj,:) ) * z1_at_i
+!!$ om_i (ji,jj) = SUM( oa_i(ji,jj,:) ) * z1_at_i
+!!$ sm_i (ji,jj) = st_i(ji,jj) * z1_vt_i
+!!$ !
+!!$ tm_i(ji,jj) = 0._wp
+!!$ tm_s(ji,jj) = 0._wp
+!!$ DO jl = 1, jpl
+!!$ DO jk = 1, nlay_i
+!!$ tm_i(ji,jj) = tm_i(ji,jj) + r1_nlay_i * t_i (ji,jj,jk,jl) * v_i(ji,jj,jl) * z1_vt_i
+!!$ END DO
+!!$ DO jk = 1, nlay_s
+!!$ tm_s(ji,jj) = tm_s(ji,jj) + r1_nlay_s * t_s (ji,jj,jk,jl) * v_s(ji,jj,jl) * z1_vt_s
+!!$ END DO
+!!$ END DO
+!!$ !
+!!$ END_2D
+ ! put rt0 where there is no ice
+ WHERE( at_i(A2D(0)) <= epsi20 )
tm_si(:,:) = rt0
tm_i (:,:) = rt0
tm_s (:,:) = rt0
END WHERE
!
- ! ! mean melt pond depth
- WHERE( at_ip(:,:) > epsi20 ) ; hm_ip(:,:) = vt_ip(:,:) / at_ip(:,:) ; hm_il(:,:) = vt_il(:,:) / at_ip(:,:)
- ELSEWHERE ; hm_ip(:,:) = 0._wp ; hm_il(:,:) = 0._wp
+ ! mean melt pond depth
+ WHERE( at_ip(A2D(0)) > epsi20 )
+ hm_ip(:,:) = vt_ip(A2D(0)) / at_ip(A2D(0))
+ hm_il(:,:) = vt_il(A2D(0)) / at_ip(A2D(0))
+ ELSEWHERE
+ hm_ip(:,:) = 0._wp
+ hm_il(:,:) = 0._wp
END WHERE
!
- DEALLOCATE( z1_vt_i , z1_vt_s )
- !
ENDIF
!
- DEALLOCATE( z1_at_i )
- !
END SUBROUTINE ice_var_agg
- SUBROUTINE ice_var_glo2eqv
+ SUBROUTINE ice_var_glo2eqv( kn )
!!-------------------------------------------------------------------
!! *** ROUTINE ice_var_glo2eqv ***
!!
!! ** Purpose : computes equivalent variables as function of
!! global variables, i.e. it turns VGLO into VEQV
!!-------------------------------------------------------------------
+ INTEGER, INTENT( in ) :: kn ! =1 everything including ponds (necessary for init)
+ ! ! =2 excluding ponds if ln_pnd=F
INTEGER :: ji, jj, jk, jl ! dummy loop indices
REAL(wp) :: ze_i ! local scalars
REAL(wp) :: ze_s, ztmelts, zbbb, zccc ! - -
- REAL(wp) :: zhmax, z1_zhmax ! - -
+ REAL(wp) :: zhmax, z1_hmax ! - -
REAL(wp) :: zlay_i, zlay_s ! - -
REAL(wp), PARAMETER :: zhl_max = 0.015_wp ! pond lid thickness above which the ponds disappear from the albedo calculation
REAL(wp), PARAMETER :: zhl_min = 0.005_wp ! pond lid thickness below which the full pond area is used in the albedo calculation
- REAL(wp), DIMENSION(jpi,jpj,jpl) :: z1_a_i, z1_v_i, z1_a_ip, za_s_fra
+ REAL(wp) :: z1_hl, z1_a_i, z1_a_ip
+ REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: za_s_fra
!!-------------------------------------------------------------------
!!gm Question 2: It is possible to define existence of sea-ice in a common way between
@@ -217,92 +270,115 @@ CONTAINS
!---------------------------------------------------------------
! Ice thickness, snow thickness, ice salinity, ice age and ponds
!---------------------------------------------------------------
- ! !--- inverse of the ice area
- WHERE( a_i(:,:,:) > epsi20 ) ; z1_a_i(:,:,:) = 1._wp / a_i(:,:,:)
- ELSEWHERE ; z1_a_i(:,:,:) = 0._wp
- END WHERE
- !
- WHERE( v_i(:,:,:) > epsi20 ) ; z1_v_i(:,:,:) = 1._wp / v_i(:,:,:)
- ELSEWHERE ; z1_v_i(:,:,:) = 0._wp
- END WHERE
- !
- WHERE( a_ip(:,:,:) > epsi20 ) ; z1_a_ip(:,:,:) = 1._wp / a_ip(:,:,:)
- ELSEWHERE ; z1_a_ip(:,:,:) = 0._wp
- END WHERE
- ! !--- ice thickness
- h_i(:,:,:) = v_i (:,:,:) * z1_a_i(:,:,:)
-
- zhmax = hi_max(jpl)
- z1_zhmax = 1._wp / hi_max(jpl)
- WHERE( h_i(:,:,jpl) > zhmax ) ! bound h_i by hi_max (i.e. 99 m) with associated update of ice area
- h_i (:,:,jpl) = zhmax
- a_i (:,:,jpl) = v_i(:,:,jpl) * z1_zhmax
- z1_a_i(:,:,jpl) = zhmax * z1_v_i(:,:,jpl)
- END WHERE
- ! !--- snow thickness
- h_s(:,:,:) = v_s (:,:,:) * z1_a_i(:,:,:)
- ! !--- ice age
- o_i(:,:,:) = oa_i(:,:,:) * z1_a_i(:,:,:)
- ! !--- pond and lid thickness
- h_ip(:,:,:) = v_ip(:,:,:) * z1_a_ip(:,:,:)
- h_il(:,:,:) = v_il(:,:,:) * z1_a_ip(:,:,:)
- ! !--- melt pond effective area (used for albedo)
- a_ip_frac(:,:,:) = a_ip(:,:,:) * z1_a_i(:,:,:)
- WHERE ( h_il(:,:,:) <= zhl_min ) ; a_ip_eff(:,:,:) = a_ip_frac(:,:,:) ! lid is very thin. Expose all the pond
- ELSEWHERE( h_il(:,:,:) >= zhl_max ) ; a_ip_eff(:,:,:) = 0._wp ! lid is very thick. Cover all the pond up with ice and snow
- ELSEWHERE ; a_ip_eff(:,:,:) = a_ip_frac(:,:,:) * & ! lid is in between. Expose part of the pond
- & ( zhl_max - h_il(:,:,:) ) / ( zhl_max - zhl_min )
- END WHERE
- !
- CALL ice_var_snwfra( h_s, za_s_fra ) ! calculate ice fraction covered by snow
- a_ip_eff = MIN( a_ip_eff, 1._wp - za_s_fra ) ! make sure (a_ip_eff + a_s_fra) <= 1
!
- ! !--- salinity (with a minimum value imposed everywhere)
+ ! bound h_i by hi_max (i.e. 99 m) with associated update of ice area
+ ! clem: if a>1 then do something
+ zhmax = hi_max(jpl)
+ z1_hmax = 1._wp / hi_max(jpl)
+ DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ IF( v_i(ji,jj,jpl) > ( zhmax*a_i(ji,jj,jpl) ) ) a_i(ji,jj,jpl) = MIN( 1._wp, v_i(ji,jj,jpl) * z1_hmax )
+ END_2D
+
+ DO jl = 1, jpl
+ DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ ! !--- inverse of the ice area
+ IF( a_i(ji,jj,jl) > epsi20 ) THEN ; z1_a_i = 1._wp / a_i(ji,jj,jl)
+ ELSE ; z1_a_i = 0._wp
+ ENDIF
+ ! !--- ice thickness
+ h_i(ji,jj,jl) = v_i (ji,jj,jl) * z1_a_i
+ ! !--- snow thickness
+ h_s(ji,jj,jl) = v_s (ji,jj,jl) * z1_a_i
+ ! !--- ice age
+ o_i(ji,jj,jl) = oa_i(ji,jj,jl) * z1_a_i
+ !
+ END_2D
+ ENDDO
+ ! !--- salinity (with a minimum value imposed everywhere)
IF( nn_icesal == 2 ) THEN
- WHERE( v_i(:,:,:) > epsi20 ) ; s_i(:,:,:) = MAX( rn_simin , MIN( rn_simax, sv_i(:,:,:) * z1_v_i(:,:,:) ) )
+ WHERE( v_i(:,:,:) > epsi20 ) ; s_i(:,:,:) = MAX( rn_simin , MIN( rn_simax, sv_i(:,:,:) / v_i(:,:,:) ) )
ELSEWHERE ; s_i(:,:,:) = rn_simin
END WHERE
ENDIF
CALL ice_var_salprof ! salinity profile
+ IF( kn == 1 .OR. ln_pnd ) THEN
+ ALLOCATE( za_s_fra(A2D(0),jpl) )
+ !
+ z1_hl = 1._wp / ( zhl_max - zhl_min )
+ DO jl = 1, jpl
+ DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ IF( a_ip(ji,jj,jl) > epsi20 ) THEN ; z1_a_ip = 1._wp / a_ip(ji,jj,jl)
+ ELSE ; z1_a_ip = 0._wp
+ ENDIF
+ ! !--- pond and lid thickness
+ h_ip(ji,jj,jl) = v_ip(ji,jj,jl) * z1_a_ip
+ h_il(ji,jj,jl) = v_il(ji,jj,jl) * z1_a_ip
+ END_2D
+ ! !--- melt pond effective area (used for albedo)
+ DO_2D( 0, 0, 0, 0 )
+ IF( a_i(ji,jj,jl) > epsi20 ) THEN ; a_ip_frac(ji,jj,jl) = a_ip(ji,jj,jl) / a_i(ji,jj,jl)
+ ELSE ; a_ip_frac(ji,jj,jl) = 0._wp
+ ENDIF
+ IF ( h_il(ji,jj,jl) <= zhl_min ) THEN ; a_ip_eff(ji,jj,jl) = a_ip_frac(ji,jj,jl) ! lid is very thin. Expose all the pond
+ ELSEIF( h_il(ji,jj,jl) >= zhl_max ) THEN ; a_ip_eff(ji,jj,jl) = 0._wp ! lid is very thick. Cover all the pond up with ice and snow
+ ELSE ; a_ip_eff(ji,jj,jl) = a_ip_frac(ji,jj,jl) * & ! lid is in between. Expose part of the pond
+ & ( zhl_max - h_il(ji,jj,jl) ) * z1_hl
+ ENDIF
+ !
+ END_2D
+ ENDDO
+ !
+ CALL ice_var_snwfra( h_s(A2D(0),:), za_s_fra(:,:,:) ) ! calculate ice fraction covered by snow
+ a_ip_eff(:,:,:) = MIN( a_ip_eff(:,:,:), 1._wp - za_s_fra(:,:,:) ) ! make sure (a_ip_eff + a_s_fra) <= 1
+ !
+ DEALLOCATE( za_s_fra )
+ ENDIF
+
!-------------------
! Ice temperature [K] (with a minimum value (rt0 - 100.))
!-------------------
- zlay_i = REAL( nlay_i , wp ) ! number of layers
+ zlay_i = REAL( nlay_i , wp ) ! number of layers
DO jl = 1, jpl
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, nlay_i )
- IF ( v_i(ji,jj,jl) > epsi20 ) THEN !--- icy area
- !
- ze_i = e_i (ji,jj,jk,jl) * z1_v_i(ji,jj,jl) * zlay_i ! Energy of melting e(S,T) [J.m-3]
- ztmelts = - sz_i(ji,jj,jk,jl) * rTmlt ! Ice layer melt temperature [C]
- ! Conversion q(S,T) -> T (second order equation)
- zbbb = ( rcp - rcpi ) * ztmelts + ze_i * r1_rhoi - rLfus
- zccc = SQRT( MAX( zbbb * zbbb - 4._wp * rcpi * rLfus * ztmelts , 0._wp) )
- t_i(ji,jj,jk,jl) = MAX( -100._wp , MIN( -( zbbb + zccc ) * 0.5_wp * r1_rcpi , ztmelts ) ) + rt0 ! [K] with bounds: -100 < t_i < ztmelts
- !
- ELSE !--- no ice
- t_i(ji,jj,jk,jl) = rt0
- ENDIF
- END_3D
+ DO jk = 1, nlay_i
+ DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ IF ( v_i(ji,jj,jl) > epsi20 ) THEN !--- icy area
+ !
+ ze_i = e_i (ji,jj,jk,jl) / v_i(ji,jj,jl) * zlay_i ! Energy of melting e(S,T) [J.m-3]
+ ztmelts = - sz_i(ji,jj,jk,jl) * rTmlt ! Ice layer melt temperature [C]
+ ! Conversion q(S,T) -> T (second order equation)
+ zbbb = ( rcp - rcpi ) * ztmelts + ze_i * r1_rhoi - rLfus
+ zccc = SQRT( MAX( zbbb * zbbb - 4._wp * rcpi * rLfus * ztmelts , 0._wp) )
+ t_i(ji,jj,jk,jl) = MAX( -100._wp , MIN( -( zbbb + zccc ) * 0.5_wp * r1_rcpi , ztmelts ) ) + rt0 ! [K] with bounds: -100 < t_i < ztmelts
+ !
+ ELSE !--- no ice
+ t_i(ji,jj,jk,jl) = rt0
+ ENDIF
+ END_2D
+ END DO
END DO
!--------------------
! Snow temperature [K] (with a minimum value (rt0 - 100.))
!--------------------
zlay_s = REAL( nlay_s , wp )
- DO jk = 1, nlay_s
- WHERE( v_s(:,:,:) > epsi20 ) !--- icy area
- t_s(:,:,jk,:) = rt0 + MAX( -100._wp , &
- & MIN( r1_rcpi * ( -r1_rhos * ( e_s(:,:,jk,:) / v_s(:,:,:) * zlay_s ) + rLfus ) , 0._wp ) )
- ELSEWHERE !--- no ice
- t_s(:,:,jk,:) = rt0
- END WHERE
+ DO jl = 1, jpl
+ DO jk = 1, nlay_s
+ DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ IF ( v_s(ji,jj,jl) > epsi20 ) THEN !--- icy area
+ t_s(ji,jj,jk,jl) = rt0 + MAX( -100._wp , &
+ & MIN( r1_rcpi*( -r1_rhos*( e_s(ji,jj,jk,jl) / v_s(ji,jj,jl) * zlay_s ) + rLfus ) , 0._wp ) )
+ ELSE !--- no ice
+ t_s(ji,jj,jk,jl) = rt0
+ ENDIF
+ END_2D
+ END DO
END DO
!
! integrated values
- vt_i (:,:) = SUM( v_i , dim=3 )
- vt_s (:,:) = SUM( v_s , dim=3 )
- at_i (:,:) = SUM( a_i , dim=3 )
+ vt_i (:,:) = SUM( v_i, dim=3 )
+ vt_s (:,:) = SUM( v_s, dim=3 )
+ at_i (:,:) = SUM( a_i, dim=3 )
!
END SUBROUTINE ice_var_glo2eqv
@@ -314,12 +390,18 @@ CONTAINS
!! ** Purpose : computes global variables as function of
!! equivalent variables, i.e. it turns VEQV into VGLO
!!-------------------------------------------------------------------
+ INTEGER :: ji, jj, jl ! dummy loop indices
+ !!-------------------------------------------------------------------
!
- v_i (:,:,:) = h_i (:,:,:) * a_i (:,:,:)
- v_s (:,:,:) = h_s (:,:,:) * a_i (:,:,:)
- sv_i(:,:,:) = s_i (:,:,:) * v_i (:,:,:)
- v_ip(:,:,:) = h_ip(:,:,:) * a_ip(:,:,:)
- v_il(:,:,:) = h_il(:,:,:) * a_ip(:,:,:)
+ DO jl = 1, jpl
+ DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ v_i (ji,jj,jl) = h_i (ji,jj,jl) * a_i (ji,jj,jl)
+ v_s (ji,jj,jl) = h_s (ji,jj,jl) * a_i (ji,jj,jl)
+ sv_i(ji,jj,jl) = s_i (ji,jj,jl) * v_i (ji,jj,jl)
+ v_ip(ji,jj,jl) = h_ip(ji,jj,jl) * a_ip(ji,jj,jl)
+ v_il(ji,jj,jl) = h_il(ji,jj,jl) * a_ip(ji,jj,jl)
+ END_2D
+ ENDDO
!
END SUBROUTINE ice_var_eqv2glo
@@ -342,7 +424,7 @@ CONTAINS
INTEGER :: ji, jj, jk, jl ! dummy loop index
REAL(wp) :: z1_dS
REAL(wp) :: ztmp1, ztmp2, zs0, zs
- REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: z_slope_s, zalpha ! case 2 only
+ REAL(wp) :: z_slope_s, zalpha ! case 2 only
REAL(wp), PARAMETER :: zsi0 = 3.5_wp
REAL(wp), PARAMETER :: zsi1 = 4.5_wp
!!-------------------------------------------------------------------
@@ -362,33 +444,26 @@ CONTAINS
! !---------------------------------------------!
z1_dS = 1._wp / ( zsi1 - zsi0 )
!
- ALLOCATE( z_slope_s(jpi,jpj) , zalpha(jpi,jpj) )
- !
DO jl = 1, jpl
-
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
- ! ! Slope of the linear profile
- IF( h_i(ji,jj,jl) > epsi20 ) THEN
- z_slope_s(ji,jj) = 2._wp * s_i(ji,jj,jl) / h_i(ji,jj,jl)
- ELSE
- z_slope_s(ji,jj) = 0._wp
- ENDIF
- !
- zalpha(ji,jj) = MAX( 0._wp , MIN( ( zsi1 - s_i(ji,jj,jl) ) * z1_dS , 1._wp ) )
- ! ! force a constant profile when SSS too low (Baltic Sea)
- IF( 2._wp * s_i(ji,jj,jl) >= sss_m(ji,jj) ) zalpha(ji,jj) = 0._wp
- END_2D
- !
- ! Computation of the profile
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, nlay_i )
- ! ! linear profile with 0 surface value
- zs0 = z_slope_s(ji,jj) * ( REAL(jk,wp) - 0.5_wp ) * h_i(ji,jj,jl) * r1_nlay_i
- zs = zalpha(ji,jj) * zs0 + ( 1._wp - zalpha(ji,jj) ) * s_i(ji,jj,jl) ! weighting the profile
- sz_i(ji,jj,jk,jl) = MIN( rn_simax, MAX( zs, rn_simin ) )
- END_3D
- END DO
- !
- DEALLOCATE( z_slope_s , zalpha )
+ DO jk = 1, nlay_i
+ DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ ! ! Slope of the linear profile
+ IF( h_i(ji,jj,jl) > epsi20 ) THEN ; z_slope_s = 2._wp * s_i(ji,jj,jl) / h_i(ji,jj,jl)
+ ELSE ; z_slope_s = 0._wp
+ ENDIF
+ !
+ zalpha = MAX( 0._wp , MIN( ( zsi1 - s_i(ji,jj,jl) ) * z1_dS , 1._wp ) )
+ ! ! force a constant profile when SSS too low (Baltic Sea)
+ IF( 2._wp * s_i(ji,jj,jl) >= sss_m(ji,jj) ) zalpha = 0._wp
+ !
+ ! Computation of the profile
+ ! ! linear profile with 0 surface value
+ zs0 = z_slope_s * ( REAL(jk,wp) - 0.5_wp ) * h_i(ji,jj,jl) * r1_nlay_i
+ zs = zalpha * zs0 + ( 1._wp - zalpha ) * s_i(ji,jj,jl) ! weighting the profile
+ sz_i(ji,jj,jk,jl) = MIN( rn_simax, MAX( zs, rn_simin ) )
+ END_2D
+ ENDDO
+ ENDDO
!
! !-------------------------------------------!
CASE( 3 ) ! constant salinity with a fix profile ! (Schwarzacher (1959) multiyear salinity profile
@@ -401,7 +476,6 @@ CONTAINS
! sz_i(:,:,jk,:) = S_prof(jk)
! END DO
!!gm end
- !
DO jl = 1, jpl
DO jk = 1, nlay_i
ztmp1 = ( REAL(jk,wp) - 0.5_wp ) * r1_nlay_i
@@ -411,7 +485,7 @@ CONTAINS
END_2D
END DO
END DO
- !
+ !
END SELECT
!
END SUBROUTINE ice_var_salprof
@@ -428,7 +502,7 @@ CONTAINS
REAL(wp) :: ztmp1, ztmp2, z1_dS ! local scalars
REAL(wp) :: zs, zs0 ! - -
!
- REAL(wp), ALLOCATABLE, DIMENSION(:) :: z_slope_s, zalpha !
+ REAL(wp) :: z_slope_s, zalpha !
REAL(wp), PARAMETER :: zsi0 = 3.5_wp
REAL(wp), PARAMETER :: zsi1 = 4.5_wp
!!-------------------------------------------------------------------
@@ -445,34 +519,26 @@ CONTAINS
! !---------------------------------------------!
z1_dS = 1._wp / ( zsi1 - zsi0 )
!
- ALLOCATE( z_slope_s(jpij), zalpha(jpij) )
- !
- DO ji = 1, npti
- ! ! Slope of the linear profile
- IF( h_i_1d(ji) > epsi20 ) THEN
- z_slope_s(ji) = 2._wp * s_i_1d(ji) / h_i_1d(ji)
- ELSE
- z_slope_s(ji) = 0._wp
- ENDIF
- !
- zalpha(ji) = MAX( 0._wp , MIN( ( zsi1 - s_i_1d(ji) ) * z1_dS , 1._wp ) )
- ! ! force a constant profile when SSS too low (Baltic Sea)
- IF( 2._wp * s_i_1d(ji) >= sss_1d(ji) ) zalpha(ji) = 0._wp
- !
- END DO
- !
- ! Computation of the profile
DO jk = 1, nlay_i
DO ji = 1, npti
+ ! ! Slope of the linear profile
+ IF( h_i_1d(ji) > epsi20 ) THEN ; z_slope_s = 2._wp * s_i_1d(ji) / h_i_1d(ji)
+ ELSE ; z_slope_s = 0._wp
+ ENDIF
+ !
+ zalpha = MAX( 0._wp , MIN( ( zsi1 - s_i_1d(ji) ) * z1_dS , 1._wp ) )
+ ! ! force a constant profile when SSS too low (Baltic Sea)
+ IF( 2._wp * s_i_1d(ji) >= sss_1d(ji) ) zalpha = 0._wp
+ !
+ !
+ ! Computation of the profile
! ! linear profile with 0 surface value
- zs0 = z_slope_s(ji) * ( REAL(jk,wp) - 0.5_wp ) * h_i_1d(ji) * r1_nlay_i
- zs = zalpha(ji) * zs0 + ( 1._wp - zalpha(ji) ) * s_i_1d(ji)
+ zs0 = z_slope_s * ( REAL(jk,wp) - 0.5_wp ) * h_i_1d(ji) * r1_nlay_i
+ zs = zalpha * zs0 + ( 1._wp - zalpha ) * s_i_1d(ji)
sz_i_1d(ji,jk) = MIN( rn_simax , MAX( zs , rn_simin ) )
END DO
END DO
!
- DEALLOCATE( z_slope_s, zalpha )
-
! !-------------------------------------------!
CASE( 3 ) ! constant salinity with a fix profile ! (Schwarzacher (1959) multiyear salinity profile
! !-------------------------------------------! (mean = 2.30)
@@ -500,69 +566,81 @@ CONTAINS
!! ** Purpose : Remove too small sea ice areas and correct fluxes
!!-------------------------------------------------------------------
INTEGER :: ji, jj, jl, jk ! dummy loop indices
- REAL(wp), DIMENSION(jpi,jpj) :: zswitch
+ REAL(wp) :: zsmall
!!-------------------------------------------------------------------
!
- DO jl = 1, jpl !== loop over the categories ==!
- !
- WHERE( a_i(:,:,jl) > epsi10 ) ; h_i(:,:,jl) = v_i(:,:,jl) / a_i(:,:,jl)
- ELSEWHERE ; h_i(:,:,jl) = 0._wp
- END WHERE
- !
- WHERE( a_i(:,:,jl) < epsi10 .OR. v_i(:,:,jl) < epsi10 .OR. h_i(:,:,jl) < epsi10 ) ; zswitch(:,:) = 0._wp
- ELSEWHERE ; zswitch(:,:) = 1._wp
- END WHERE
- !
- !-----------------------------------------------------------------
- ! Zap ice energy and use ocean heat to melt ice
- !-----------------------------------------------------------------
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, nlay_i )
- ! update exchanges with ocean
- hfx_res(ji,jj) = hfx_res(ji,jj) - (1._wp - zswitch(ji,jj) ) * e_i(ji,jj,jk,jl) * r1_Dt_ice ! W.m-2 <0
- e_i(ji,jj,jk,jl) = e_i(ji,jj,jk,jl) * zswitch(ji,jj)
- t_i(ji,jj,jk,jl) = t_i(ji,jj,jk,jl) * zswitch(ji,jj) + rt0 * ( 1._wp - zswitch(ji,jj) )
- END_3D
- !
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, nlay_s )
- ! update exchanges with ocean
- hfx_res(ji,jj) = hfx_res(ji,jj) - (1._wp - zswitch(ji,jj) ) * e_s(ji,jj,jk,jl) * r1_Dt_ice ! W.m-2 <0
- e_s(ji,jj,jk,jl) = e_s(ji,jj,jk,jl) * zswitch(ji,jj)
- t_s(ji,jj,jk,jl) = t_s(ji,jj,jk,jl) * zswitch(ji,jj) + rt0 * ( 1._wp - zswitch(ji,jj) )
+ WHERE( a_i(A2D(0),:) > epsi10 ) ; h_i(A2D(0),:) = v_i(A2D(0),:) / a_i(A2D(0),:)
+ ELSEWHERE ; h_i(A2D(0),:) = 0._wp
+ END WHERE
+ !
+ !-----------------------------------------------------------------
+ ! Zap ice energy and use ocean heat to melt ice
+ !-----------------------------------------------------------------
+ DO jl = 1, jpl
+ DO_3D( 0, 0, 0, 0, 1, nlay_i )
+ !
+ zsmall = MIN( a_i(ji,jj,jl), v_i(ji,jj,jl), h_i(ji,jj,jl) )
+ !
+ IF( zsmall < epsi10 ) THEN
+ ! update exchanges with ocean
+ hfx_res(ji,jj) = hfx_res(ji,jj) - e_i(ji,jj,jk,jl) * r1_Dt_ice ! W.m-2 <0
+ e_i(ji,jj,jk,jl) = 0._wp
+ t_i(ji,jj,jk,jl) = rt0
+ ENDIF
END_3D
- !
- !-----------------------------------------------------------------
- ! zap ice and snow volume, add water and salt to ocean
- !-----------------------------------------------------------------
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
- ! update exchanges with ocean
- sfx_res(ji,jj) = sfx_res(ji,jj) + ( 1._wp - zswitch(ji,jj) ) * sv_i(ji,jj,jl) * rhoi * r1_Dt_ice
- wfx_res(ji,jj) = wfx_res(ji,jj) + ( 1._wp - zswitch(ji,jj) ) * v_i (ji,jj,jl) * rhoi * r1_Dt_ice
- wfx_res(ji,jj) = wfx_res(ji,jj) + ( 1._wp - zswitch(ji,jj) ) * v_s (ji,jj,jl) * rhos * r1_Dt_ice
- wfx_pnd(ji,jj) = wfx_pnd(ji,jj) + ( 1._wp - zswitch(ji,jj) ) * ( v_ip(ji,jj,jl)+v_il(ji,jj,jl) ) * rhow * r1_Dt_ice
+ ENDDO
+
+ DO jl = 1, jpl
+ DO_3D( 0, 0, 0, 0, 1, nlay_s )
!
- a_i (ji,jj,jl) = a_i (ji,jj,jl) * zswitch(ji,jj)
- v_i (ji,jj,jl) = v_i (ji,jj,jl) * zswitch(ji,jj)
- v_s (ji,jj,jl) = v_s (ji,jj,jl) * zswitch(ji,jj)
- t_su (ji,jj,jl) = t_su(ji,jj,jl) * zswitch(ji,jj) + t_bo(ji,jj) * ( 1._wp - zswitch(ji,jj) )
- oa_i (ji,jj,jl) = oa_i(ji,jj,jl) * zswitch(ji,jj)
- sv_i (ji,jj,jl) = sv_i(ji,jj,jl) * zswitch(ji,jj)
+ zsmall = MIN( a_i(ji,jj,jl), v_i(ji,jj,jl), h_i(ji,jj,jl) )
!
- h_i (ji,jj,jl) = h_i (ji,jj,jl) * zswitch(ji,jj)
- h_s (ji,jj,jl) = h_s (ji,jj,jl) * zswitch(ji,jj)
+ IF( zsmall < epsi10 ) THEN
+ ! update exchanges with ocean
+ hfx_res(ji,jj) = hfx_res(ji,jj) - e_s(ji,jj,jk,jl) * r1_Dt_ice ! W.m-2 <0
+ e_s(ji,jj,jk,jl) = 0._wp
+ t_s(ji,jj,jk,jl) = rt0
+ ENDIF
+ END_3D
+ ENDDO
+ !
+ !-----------------------------------------------------------------
+ ! zap ice and snow volume, add water and salt to ocean
+ !-----------------------------------------------------------------
+ DO jl = 1, jpl
+ DO_2D( 0, 0, 0, 0 )
!
- a_ip (ji,jj,jl) = a_ip (ji,jj,jl) * zswitch(ji,jj)
- v_ip (ji,jj,jl) = v_ip (ji,jj,jl) * zswitch(ji,jj)
- v_il (ji,jj,jl) = v_il (ji,jj,jl) * zswitch(ji,jj)
- h_ip (ji,jj,jl) = h_ip (ji,jj,jl) * zswitch(ji,jj)
- h_il (ji,jj,jl) = h_il (ji,jj,jl) * zswitch(ji,jj)
+ zsmall = MIN( a_i(ji,jj,jl), v_i(ji,jj,jl), h_i(ji,jj,jl) )
!
+ IF( zsmall < epsi10 ) THEN
+ ! update exchanges with ocean
+ sfx_res(ji,jj) = sfx_res(ji,jj) + sv_i(ji,jj,jl) * rhoi * r1_Dt_ice
+ wfx_res(ji,jj) = wfx_res(ji,jj) + v_i (ji,jj,jl) * rhoi * r1_Dt_ice
+ wfx_res(ji,jj) = wfx_res(ji,jj) + v_s (ji,jj,jl) * rhos * r1_Dt_ice
+ wfx_res(ji,jj) = wfx_res(ji,jj) + ( v_ip(ji,jj,jl)+v_il(ji,jj,jl) ) * rhow * r1_Dt_ice
+ !
+ a_i (ji,jj,jl) = 0._wp
+ v_i (ji,jj,jl) = 0._wp
+ v_s (ji,jj,jl) = 0._wp
+ t_su (ji,jj,jl) = sst_m(ji,jj) + rt0
+ oa_i (ji,jj,jl) = 0._wp
+ sv_i (ji,jj,jl) = 0._wp
+ !
+ h_i (ji,jj,jl) = 0._wp
+ h_s (ji,jj,jl) = 0._wp
+ !
+ a_ip (ji,jj,jl) = 0._wp
+ v_ip (ji,jj,jl) = 0._wp
+ v_il (ji,jj,jl) = 0._wp
+ h_ip (ji,jj,jl) = 0._wp
+ h_il (ji,jj,jl) = 0._wp
+ ENDIF
END_2D
- !
END DO
-
+
! to be sure that at_i is the sum of a_i(jl)
- at_i (:,:) = SUM( a_i (:,:,:), dim=3 )
- vt_i (:,:) = SUM( v_i (:,:,:), dim=3 )
+ at_i (A2D(0)) = SUM( a_i (A2D(0),:), dim=3 )
+ vt_i (A2D(0)) = SUM( v_i (A2D(0),:), dim=3 )
!!clem add?
! vt_s (:,:) = SUM( v_s (:,:,:), dim=3 )
! st_i (:,:) = SUM( sv_i(:,:,:), dim=3 )
@@ -571,17 +649,18 @@ CONTAINS
!!clem
! open water = 1 if at_i=0
- WHERE( at_i(:,:) == 0._wp ) ato_i(:,:) = 1._wp
+ WHERE( at_i(A2D(0)) == 0._wp ) ato_i(A2D(0)) = 1._wp
!
END SUBROUTINE ice_var_zapsmall
- SUBROUTINE ice_var_zapneg( pdt, pato_i, pv_i, pv_s, psv_i, poa_i, pa_i, pa_ip, pv_ip, pv_il, pe_s, pe_i )
+ SUBROUTINE ice_var_zapneg( ihls, pdt, pato_i, pv_i, pv_s, psv_i, poa_i, pa_i, pa_ip, pv_ip, pv_il, pe_s, pe_i )
!!-------------------------------------------------------------------
!! *** ROUTINE ice_var_zapneg ***
!!
!! ** Purpose : Remove negative sea ice fields and correct fluxes
!!-------------------------------------------------------------------
+ INTEGER , INTENT(in ) :: ihls ! loop index
REAL(wp) , INTENT(in ) :: pdt ! tracer time-step
REAL(wp), DIMENSION(:,:) , INTENT(inout) :: pato_i ! open water area
REAL(wp), DIMENSION(:,:,:) , INTENT(inout) :: pv_i ! ice volume
@@ -597,60 +676,76 @@ CONTAINS
!
INTEGER :: ji, jj, jl, jk ! dummy loop indices
REAL(wp) :: z1_dt
+ REAL(wp), DIMENSION(jpi,jpj) :: zwfx_res, zhfx_res, zsfx_res ! needed since loop is not (0,0,0,0)
!!-------------------------------------------------------------------
!
+ DO_2D( ihls, ihls, ihls, ihls )
+ zwfx_res(ji,jj) = 0._wp
+ zhfx_res(ji,jj) = 0._wp
+ zsfx_res(ji,jj) = 0._wp
+ END_2D
+
z1_dt = 1._wp / pdt
!
- DO jl = 1, jpl !== loop over the categories ==!
- !
- ! make sure a_i=0 where v_i<=0
- WHERE( pv_i(:,:,:) <= 0._wp ) pa_i(:,:,:) = 0._wp
-
- !----------------------------------------
- ! zap ice energy and send it to the ocean
- !----------------------------------------
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, nlay_i )
+ ! make sure a_i=0 where v_i<=0
+ WHERE( pv_i(:,:,:) <= 0._wp ) pa_i(:,:,:) = 0._wp
+
+ !----------------------------------------
+ ! zap ice energy and send it to the ocean
+ !----------------------------------------
+ DO jl = 1, jpl
+ DO_3D( ihls, ihls, ihls, ihls, 1, nlay_i )
IF( pe_i(ji,jj,jk,jl) < 0._wp .OR. pa_i(ji,jj,jl) <= 0._wp ) THEN
- hfx_res(ji,jj) = hfx_res(ji,jj) - pe_i(ji,jj,jk,jl) * z1_dt ! W.m-2 >0
+ zhfx_res(ji,jj) = zhfx_res(ji,jj) - pe_i(ji,jj,jk,jl) * z1_dt ! W.m-2 >0
pe_i(ji,jj,jk,jl) = 0._wp
ENDIF
END_3D
- !
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, nlay_s )
+ ENDDO
+ !
+ DO jl = 1, jpl
+ DO_3D( ihls, ihls, ihls, ihls, 1, nlay_s )
IF( pe_s(ji,jj,jk,jl) < 0._wp .OR. pa_i(ji,jj,jl) <= 0._wp ) THEN
- hfx_res(ji,jj) = hfx_res(ji,jj) - pe_s(ji,jj,jk,jl) * z1_dt ! W.m-2 <0
+ zhfx_res(ji,jj) = zhfx_res(ji,jj) - pe_s(ji,jj,jk,jl) * z1_dt ! W.m-2 <0
pe_s(ji,jj,jk,jl) = 0._wp
ENDIF
END_3D
- !
- !-----------------------------------------------------
- ! zap ice and snow volume, add water and salt to ocean
- !-----------------------------------------------------
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ ENDDO
+ !
+ !-----------------------------------------------------
+ ! zap ice and snow volume, add water and salt to ocean
+ !-----------------------------------------------------
+ DO jl = 1, jpl
+ DO_2D( ihls, ihls, ihls, ihls )
IF( pv_i(ji,jj,jl) < 0._wp .OR. pa_i(ji,jj,jl) <= 0._wp ) THEN
- wfx_res(ji,jj) = wfx_res(ji,jj) + pv_i (ji,jj,jl) * rhoi * z1_dt
- pv_i (ji,jj,jl) = 0._wp
+ zwfx_res(ji,jj) = zwfx_res(ji,jj) + pv_i (ji,jj,jl) * rhoi * z1_dt
+ pv_i (ji,jj,jl) = 0._wp
ENDIF
IF( pv_s(ji,jj,jl) < 0._wp .OR. pa_i(ji,jj,jl) <= 0._wp ) THEN
- wfx_res(ji,jj) = wfx_res(ji,jj) + pv_s (ji,jj,jl) * rhos * z1_dt
- pv_s (ji,jj,jl) = 0._wp
+ zwfx_res(ji,jj) = zwfx_res(ji,jj) + pv_s (ji,jj,jl) * rhos * z1_dt
+ pv_s (ji,jj,jl) = 0._wp
ENDIF
IF( psv_i(ji,jj,jl) < 0._wp .OR. pa_i(ji,jj,jl) <= 0._wp .OR. pv_i(ji,jj,jl) <= 0._wp ) THEN
- sfx_res(ji,jj) = sfx_res(ji,jj) + psv_i(ji,jj,jl) * rhoi * z1_dt
- psv_i (ji,jj,jl) = 0._wp
+ zsfx_res(ji,jj) = zsfx_res(ji,jj) + psv_i(ji,jj,jl) * rhoi * z1_dt
+ psv_i (ji,jj,jl) = 0._wp
ENDIF
IF( pv_ip(ji,jj,jl) < 0._wp .OR. pv_il(ji,jj,jl) < 0._wp .OR. pa_ip(ji,jj,jl) <= 0._wp ) THEN
- wfx_pnd(ji,jj) = wfx_pnd(ji,jj) + pv_il(ji,jj,jl) * rhow * z1_dt
- pv_il (ji,jj,jl) = 0._wp
+ zwfx_res(ji,jj) = zwfx_res(ji,jj) + pv_il(ji,jj,jl) * rhow * z1_dt
+ pv_il (ji,jj,jl) = 0._wp
ENDIF
IF( pv_ip(ji,jj,jl) < 0._wp .OR. pa_ip(ji,jj,jl) <= 0._wp ) THEN
- wfx_pnd(ji,jj) = wfx_pnd(ji,jj) + pv_ip(ji,jj,jl) * rhow * z1_dt
- pv_ip (ji,jj,jl) = 0._wp
+ zwfx_res(ji,jj) = zwfx_res(ji,jj) + pv_ip(ji,jj,jl) * rhow * z1_dt
+ pv_ip (ji,jj,jl) = 0._wp
ENDIF
END_2D
- !
END DO
!
+ ! record residual fluxes
+ DO_2D( 0, 0, 0, 0 )
+ wfx_res(ji,jj) = wfx_res(ji,jj) + zwfx_res(ji,jj)
+ hfx_res(ji,jj) = hfx_res(ji,jj) + zhfx_res(ji,jj)
+ sfx_res(ji,jj) = sfx_res(ji,jj) + zsfx_res(ji,jj)
+ END_2D
+ !
WHERE( pato_i(:,:) < 0._wp ) pato_i(:,:) = 0._wp
WHERE( poa_i (:,:,:) < 0._wp ) poa_i (:,:,:) = 0._wp
WHERE( pa_i (:,:,:) < 0._wp ) pa_i (:,:,:) = 0._wp
@@ -676,7 +771,6 @@ CONTAINS
REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: pe_s ! snw heat content
REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: pe_i ! ice heat content
!!-------------------------------------------------------------------
- !
WHERE( pa_i (1:npti,:) < 0._wp ) pa_i (1:npti,:) = 0._wp ! a_i must be >= 0
WHERE( pv_i (1:npti,:) < 0._wp ) pv_i (1:npti,:) = 0._wp ! v_i must be >= 0
@@ -709,19 +803,22 @@ CONTAINS
INTEGER :: ji, jj, jk, jl ! dummy loop indices
!!-------------------------------------------------------------------
!
-!!gm I prefere to use WHERE / ELSEWHERE to set it to zero only where needed <<<=== to be done
-!! instead of setting everything to zero as just below
bv_i (:,:,:) = 0._wp
DO jl = 1, jpl
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, nlay_i )
+ DO_3D( 0, 0, 0, 0, 1, nlay_i )
IF( t_i(ji,jj,jk,jl) < rt0 - epsi10 ) THEN
bv_i(ji,jj,jl) = bv_i(ji,jj,jl) - rTmlt * sz_i(ji,jj,jk,jl) * r1_nlay_i / ( t_i(ji,jj,jk,jl) - rt0 )
ENDIF
END_3D
- END DO
- WHERE( vt_i(:,:) > epsi20 ) ; bvm_i(:,:) = SUM( bv_i(:,:,:) * v_i(:,:,:) , dim=3 ) / vt_i(:,:)
- ELSEWHERE ; bvm_i(:,:) = 0._wp
- END WHERE
+ ENDDO
+ !
+ DO_2D( 0, 0, 0, 0 )
+ IF( vt_i(ji,jj) > epsi20 ) THEN
+ bvm_i(ji,jj) = SUM( bv_i(ji,jj,:) * v_i(ji,jj,:) ) / vt_i(ji,jj)
+ ELSE
+ bvm_i(ji,jj) = 0._wp
+ ENDIF
+ END_2D
!
END SUBROUTINE ice_var_bv
@@ -740,7 +837,7 @@ CONTAINS
!
DO jk = 1, nlay_i ! Sea ice energy of melting
DO ji = 1, npti
- ztmelts = - rTmlt * sz_i_1d(ji,jk)
+ ztmelts = - rTmlt * sz_i_1d(ji,jk)
t_i_1d(ji,jk) = MIN( t_i_1d(ji,jk), ztmelts + rt0 ) ! Force t_i_1d to be lower than melting point => likely conservation issue
! (sometimes zdf scheme produces abnormally high temperatures)
e_i_1d(ji,jk) = rhoi * ( rcpi * ( ztmelts - ( t_i_1d(ji,jk) - rt0 ) ) &
@@ -748,6 +845,7 @@ CONTAINS
& - rcp * ztmelts )
END DO
END DO
+ !
DO jk = 1, nlay_s ! Snow energy of melting
DO ji = 1, npti
e_s_1d(ji,jk) = rhos * ( rcpi * ( rt0 - t_s_1d(ji,jk) ) + rLfus )
@@ -1286,8 +1384,8 @@ CONTAINS
!!
!!-------------------------------------------------------------------
SUBROUTINE ice_var_snwfra_3d( ph_s, pa_s_fra )
- REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: ph_s ! snow thickness
- REAL(wp), DIMENSION(:,:,:), INTENT( out) :: pa_s_fra ! ice fraction covered by snow
+ REAL(wp), DIMENSION(A2D(0),jpl), INTENT(in ) :: ph_s ! snow thickness
+ REAL(wp), DIMENSION(A2D(0),jpl), INTENT( out) :: pa_s_fra ! ice fraction covered by snow
IF ( nn_snwfra == 0 ) THEN ! basic 0 or 1 snow cover
WHERE( ph_s > 0._wp ) ; pa_s_fra = 1._wp
ELSEWHERE ; pa_s_fra = 0._wp
@@ -1344,8 +1442,8 @@ CONTAINS
!!--------------------------------------------------------------------------
!!gm I think it can be usefull to set this as a FUNCTION, not a SUBROUTINE....
SUBROUTINE ice_var_snwblow_2d( pin, pout )
- REAL(wp), DIMENSION(:,:), INTENT(in ) :: pin ! previous fraction lead ( 1. - a_i_b )
- REAL(wp), DIMENSION(:,:), INTENT(inout) :: pout
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in ) :: pin ! previous fraction lead ( 1. - a_i_b )
+ REAL(wp), DIMENSION(A2D(0)), INTENT(inout) :: pout
pout = ( 1._wp - ( pin )**rn_snwblow )
END SUBROUTINE ice_var_snwblow_2d
diff --git a/src/ICE/icewri.F90 b/src/ICE/icewri.F90
index 078e3b007baf4ff4ea136f0426dccfed9adbf189..d72fd7d807fd1174fd3b6c5a8506889531769dfd 100644
--- a/src/ICE/icewri.F90
+++ b/src/ICE/icewri.F90
@@ -26,7 +26,6 @@ MODULE icewri
USE iom ! I/O manager library
USE lib_mpp ! MPP library
USE lib_fortran ! fortran utilities (glob_sum + no signed zero)
- USE lbclnk ! lateral boundary conditions (or mpp links)
USE timing ! Timing
IMPLICIT NONE
@@ -53,10 +52,10 @@ CONTAINS
INTEGER :: ji, jj, jk, jl ! dummy loop indices
REAL(wp) :: z2da, z2db, zrho1, zrho2
REAL(wp) :: zmiss_val ! missing value retrieved from xios
- REAL(wp), DIMENSION(jpi,jpj) :: z2d ! 2D workspace
- REAL(wp), DIMENSION(jpi,jpj) :: zmsk00, zmsk05, zmsk15, zmsksn ! O%, 5% and 15% concentration mask and snow mask
- REAL(wp), DIMENSION(jpi,jpj,jpl) :: zmsk00l, zmsksnl ! cat masks
- REAL(wp), DIMENSION(:,:), ALLOCATABLE :: zfast, zalb, zmskalb ! 2D workspace
+ REAL(wp), DIMENSION(A2D(0)) :: z2d ! 2D workspace
+ REAL(wp), DIMENSION(A2D(0)) :: zmsk00, zmsk05, zmsk15, zmsksn ! O%, 5% and 15% concentration mask and snow mask
+ REAL(wp), DIMENSION(A2D(0),jpl) :: zmsk00l, zmsksnl ! cat masks
+ REAL(wp), DIMENSION(:,:), ALLOCATABLE :: zfast, zalb, zmskalb ! 2D workspace
!
! Global ice diagnostics (SIMIP)
REAL(wp) :: zdiag_area_nh, zdiag_extt_nh, zdiag_volu_nh ! area, extent, volume
@@ -69,21 +68,33 @@ CONTAINS
CALL iom_miss_val( 'icetemp', zmiss_val )
! brine volume
- CALL ice_var_bv
+ IF( iom_use('icebrv') .OR. iom_use('icebrv_cat') ) CALL ice_var_bv
! tresholds for outputs
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
- zmsk00(ji,jj) = MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) - epsi06 ) ) ! 1 if ice , 0 if no ice
- zmsk05(ji,jj) = MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) - 0.05_wp ) ) ! 1 if 5% ice , 0 if less
- zmsk15(ji,jj) = MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) - 0.15_wp ) ) ! 1 if 15% ice, 0 if less
- zmsksn(ji,jj) = MAX( 0._wp , SIGN( 1._wp , vt_s(ji,jj) - epsi06 ) ) ! 1 if snow , 0 if no snow
+ DO_2D( 0, 0, 0, 0 )
+ IF( at_i(ji,jj) >= epsi06 ) THEN ; zmsk00(ji,jj) = 1._wp ! 1 if ice , 0 if no ice
+ ELSE ; zmsk00(ji,jj) = 0._wp
+ ENDIF
+ IF( at_i(ji,jj) >= 0.05_wp ) THEN ; zmsk05(ji,jj) = 1._wp ! 1 if 5% ice , 0 if less
+ ELSE ; zmsk05(ji,jj) = 0._wp
+ ENDIF
+ IF( at_i(ji,jj) >= 0.15_wp ) THEN ; zmsk15(ji,jj) = 1._wp ! 1 if 15% ice, 0 if less
+ ELSE ; zmsk15(ji,jj) = 0._wp
+ ENDIF
+ IF( vt_s(ji,jj) >= epsi06 ) THEN ; zmsksn(ji,jj) = 1._wp ! 1 if snow , 0 if no snow
+ ELSE ; zmsksn(ji,jj) = 0._wp
+ ENDIF
END_2D
DO jl = 1, jpl
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
- zmsk00l(ji,jj,jl) = MAX( 0._wp , SIGN( 1._wp , a_i(ji,jj,jl) - epsi06 ) )
- zmsksnl(ji,jj,jl) = MAX( 0._wp , SIGN( 1._wp , v_s(ji,jj,jl) - epsi06 ) )
+ DO_2D( 0, 0, 0, 0 )
+ IF( a_i(ji,jj,jl) >= epsi06 ) THEN ; zmsk00l(ji,jj,jl) = 1._wp ! 1 if ice , 0 if no ice
+ ELSE ; zmsk00l(ji,jj,jl) = 0._wp
+ ENDIF
+ IF( v_s(ji,jj,jl) >= epsi06 ) THEN ; zmsksnl(ji,jj,jl) = 1._wp ! 1 if snow , 0 if no snow
+ ELSE ; zmsksnl(ji,jj,jl) = 0._wp
+ ENDIF
END_2D
- END DO
+ ENDDO
!-----------------
! Standard outputs
@@ -96,102 +107,111 @@ CONTAINS
CALL iom_put( 'icepres' , zmsk00 ) ! Ice presence (1 or 0)
!
! general fields
- IF( iom_use('icemass' ) ) CALL iom_put( 'icemass', vt_i * rhoi * zmsk00 ) ! Ice mass per cell area
- IF( iom_use('snwmass' ) ) CALL iom_put( 'snwmass', vt_s * rhos * zmsksn ) ! Snow mass per cell area
- IF( iom_use('iceconc' ) ) CALL iom_put( 'iceconc', at_i * zmsk00 ) ! ice concentration
- IF( iom_use('icevolu' ) ) CALL iom_put( 'icevolu', vt_i * zmsk00 ) ! ice volume = mean ice thickness over the cell
- IF( iom_use('icethic' ) ) CALL iom_put( 'icethic', hm_i * zmsk00 ) ! ice thickness
- IF( iom_use('snwthic' ) ) CALL iom_put( 'snwthic', hm_s * zmsk00 ) ! snw thickness
- IF( iom_use('icebrv' ) ) CALL iom_put( 'icebrv' , bvm_i* 100. * zmsk00 ) ! brine volume
- IF( iom_use('iceage' ) ) CALL iom_put( 'iceage' , om_i / rday * zmsk15 + zmiss_val * ( 1._wp - zmsk15 ) ) ! ice age
- IF( iom_use('icehnew' ) ) CALL iom_put( 'icehnew', ht_i_new ) ! new ice thickness formed in the leads
- IF( iom_use('snwvolu' ) ) CALL iom_put( 'snwvolu', vt_s * zmsksn ) ! snow volume
- IF( iom_use('icefrb' ) ) THEN ! Ice freeboard
- z2d(:,:) = ( zrho1 * hm_i(:,:) - zrho2 * hm_s(:,:) )
+ IF( iom_use('icemass' ) ) CALL iom_put( 'icemass', vt_i(A2D(0)) * rhoi * zmsk00 ) ! Ice mass per cell area
+ IF( iom_use('snwmass' ) ) CALL iom_put( 'snwmass', vt_s(A2D(0)) * rhos * zmsksn ) ! Snow mass per cell area
+ IF( iom_use('iceconc' ) ) CALL iom_put( 'iceconc', at_i(A2D(0)) * zmsk00 ) ! ice concentration
+ IF( iom_use('icevolu' ) ) CALL iom_put( 'icevolu', vt_i(A2D(0)) * zmsk00 ) ! ice volume = mean ice thickness over the cell
+ IF( iom_use('icethic' ) ) CALL iom_put( 'icethic', hm_i(:,:) * zmsk00 ) ! ice thickness
+ IF( iom_use('snwthic' ) ) CALL iom_put( 'snwthic', hm_s(:,:) * zmsk00 ) ! snw thickness
+ IF( iom_use('icebrv' ) ) CALL iom_put( 'icebrv' , bvm_i(:,:)* 100. * zmsk00 ) ! brine volume
+ IF( iom_use('iceage' ) ) CALL iom_put( 'iceage' , om_i(:,:) / rday * zmsk15 + zmiss_val * ( 1._wp - zmsk15 ) ) ! ice age
+ IF( iom_use('icehnew' ) ) CALL iom_put( 'icehnew', ht_i_new(:,:) ) ! new ice thickness formed in the leads
+ IF( iom_use('snwvolu' ) ) CALL iom_put( 'snwvolu', vt_s(A2D(0)) * zmsksn ) ! snow volume
+ IF( iom_use('icefrb' ) ) THEN ! Ice freeboard
+ z2d(:,:) = zrho1 * hm_i(:,:) - zrho2 * hm_s(:,:)
WHERE( z2d < 0._wp ) z2d = 0._wp
- CALL iom_put( 'icefrb' , z2d * zmsk00 )
+ CALL iom_put( 'icefrb' , z2d * zmsk00 )
ENDIF
! melt ponds
- IF( iom_use('iceapnd' ) ) CALL iom_put( 'iceapnd', at_ip * zmsk00 ) ! melt pond total fraction
- IF( iom_use('icehpnd' ) ) CALL iom_put( 'icehpnd', hm_ip * zmsk00 ) ! melt pond depth
- IF( iom_use('icevpnd' ) ) CALL iom_put( 'icevpnd', vt_ip * zmsk00 ) ! melt pond total volume per unit area
- IF( iom_use('icehlid' ) ) CALL iom_put( 'icehlid', hm_il * zmsk00 ) ! melt pond lid depth
- IF( iom_use('icevlid' ) ) CALL iom_put( 'icevlid', vt_il * zmsk00 ) ! melt pond lid total volume per unit area
+ IF( iom_use('iceapnd' ) ) CALL iom_put( 'iceapnd', at_ip(A2D(0)) * zmsk00 ) ! melt pond total fraction
+ IF( iom_use('icehpnd' ) ) CALL iom_put( 'icehpnd', hm_ip(:,:) * zmsk00 ) ! melt pond depth
+ IF( iom_use('icevpnd' ) ) CALL iom_put( 'icevpnd', vt_ip(A2D(0)) * zmsk00 ) ! melt pond total volume per unit area
+ IF( iom_use('icehlid' ) ) CALL iom_put( 'icehlid', hm_il(:,:) * zmsk00 ) ! melt pond lid depth
+ IF( iom_use('icevlid' ) ) CALL iom_put( 'icevlid', vt_il(A2D(0)) * zmsk00 ) ! melt pond lid total volume per unit area
! salt
- IF( iom_use('icesalt' ) ) CALL iom_put( 'icesalt', sm_i * zmsk00 + zmiss_val * ( 1._wp - zmsk00 ) ) ! mean ice salinity
- IF( iom_use('icesalm' ) ) CALL iom_put( 'icesalm', st_i * rhoi * 1.0e-3 * zmsk00 ) ! Mass of salt in sea ice per cell area
+ IF( iom_use('icesalt' ) ) CALL iom_put( 'icesalt', sm_i(:,:) * zmsk00 + zmiss_val * ( 1._wp - zmsk00 ) ) ! mean ice salinity
+ IF( iom_use('icesalm' ) ) CALL iom_put( 'icesalm', st_i(:,:) * rhoi * 1.0e-3 * zmsk00 ) ! Mass of salt in sea ice per cell area
! heat
- IF( iom_use('icetemp' ) ) CALL iom_put( 'icetemp', ( tm_i - rt0 ) * zmsk00 + zmiss_val * ( 1._wp - zmsk00 ) ) ! ice mean temperature
- IF( iom_use('snwtemp' ) ) CALL iom_put( 'snwtemp', ( tm_s - rt0 ) * zmsksn + zmiss_val * ( 1._wp - zmsksn ) ) ! snw mean temperature
- IF( iom_use('icettop' ) ) CALL iom_put( 'icettop', ( tm_su - rt0 ) * zmsk00 + zmiss_val * ( 1._wp - zmsk00 ) ) ! temperature at the ice surface
- IF( iom_use('icetbot' ) ) CALL iom_put( 'icetbot', ( t_bo - rt0 ) * zmsk00 + zmiss_val * ( 1._wp - zmsk00 ) ) ! temperature at the ice bottom
- IF( iom_use('icetsni' ) ) CALL iom_put( 'icetsni', ( tm_si - rt0 ) * zmsk00 + zmiss_val * ( 1._wp - zmsk00 ) ) ! temperature at the snow-ice interface
- IF( iom_use('icehc' ) ) CALL iom_put( 'icehc' , -et_i * zmsk00 ) ! ice heat content
- IF( iom_use('snwhc' ) ) CALL iom_put( 'snwhc' , -et_s * zmsksn ) ! snow heat content
+ IF( iom_use('icetemp' ) ) CALL iom_put( 'icetemp', ( tm_i (:,:) - rt0 ) * zmsk00 + zmiss_val * ( 1._wp - zmsk00 ) ) ! ice mean temperature
+ IF( iom_use('snwtemp' ) ) CALL iom_put( 'snwtemp', ( tm_s (:,:) - rt0 ) * zmsksn + zmiss_val * ( 1._wp - zmsksn ) ) ! snw mean temperature
+ IF( iom_use('icettop' ) ) CALL iom_put( 'icettop', ( tm_su(:,:) - rt0 ) * zmsk00 + zmiss_val * ( 1._wp - zmsk00 ) ) ! temperature at the ice surface
+ IF( iom_use('icetbot' ) ) CALL iom_put( 'icetbot', ( t_bo (:,:) - rt0 ) * zmsk00 + zmiss_val * ( 1._wp - zmsk00 ) ) ! temperature at the ice bottom
+ IF( iom_use('icetsni' ) ) CALL iom_put( 'icetsni', ( tm_si(:,:) - rt0 ) * zmsk00 + zmiss_val * ( 1._wp - zmsk00 ) ) ! temperature at the snow-ice interface
+ IF( iom_use('icehc' ) ) CALL iom_put( 'icehc' , -et_i (:,:) * zmsk00 ) ! ice heat content
+ IF( iom_use('snwhc' ) ) CALL iom_put( 'snwhc' , -et_s (:,:) * zmsksn ) ! snow heat content
! momentum
- IF( iom_use('uice' ) ) CALL iom_put( 'uice' , u_ice ) ! ice velocity u
- IF( iom_use('vice' ) ) CALL iom_put( 'vice' , v_ice ) ! ice velocity v
+ IF( iom_use('uice' ) ) CALL iom_put( 'uice' , u_ice(:,:) ) ! ice velocity u
+ IF( iom_use('vice' ) ) CALL iom_put( 'vice' , v_ice(:,:) ) ! ice velocity v
!
- IF( iom_use('icevel') .OR. iom_use('fasticepres') ) THEN ! module of ice velocity & fast ice
- ALLOCATE( zfast(jpi,jpj) )
+ IF( iom_use('icevel') .OR. iom_use('fasticepres') ) THEN ! module of ice velocity & fast ice
+ ALLOCATE( zfast(A2D(0)) )
DO_2D( 0, 0, 0, 0 )
z2da = u_ice(ji,jj) + u_ice(ji-1,jj)
z2db = v_ice(ji,jj) + v_ice(ji,jj-1)
z2d(ji,jj) = 0.5_wp * SQRT( z2da * z2da + z2db * z2db )
END_2D
- CALL lbc_lnk( 'icewri', z2d, 'T', 1.0_wp )
CALL iom_put( 'icevel', z2d )
- WHERE( z2d(:,:) < 5.e-04_wp .AND. zmsk15(:,:) == 1._wp ) ; zfast(:,:) = 1._wp ! record presence of fast ice
+ WHERE( z2d(:,:) < 5.e-04_wp .AND. zmsk15(:,:) == 1._wp ) ; zfast(:,:) = 1._wp ! record presence of fast ice
ELSEWHERE ; zfast(:,:) = 0._wp
END WHERE
CALL iom_put( 'fasticepres', zfast )
DEALLOCATE( zfast )
ENDIF
!
- IF( iom_use('icealb') .OR. iom_use('albedo') ) THEN ! ice albedo and surface albedo
- ALLOCATE( zalb(jpi,jpj), zmskalb(jpi,jpj) )
+ IF( iom_use('icealb') .OR. iom_use('albedo') ) THEN ! ice albedo and surface albedo
+ ALLOCATE( zalb(A2D(0)), zmskalb(A2D(0)) )
! ice albedo
- WHERE( at_i_b < 1.e-03 )
+ WHERE( at_i_b(:,:) < 1.e-03 )
zmskalb(:,:) = 0._wp
zalb (:,:) = rn_alb_oce
ELSEWHERE
zmskalb(:,:) = 1._wp
- zalb (:,:) = SUM( alb_ice * a_i_b, dim=3 ) / at_i_b
+ zalb (:,:) = SUM( alb_ice(:,:,:) * a_i_b(:,:,:), dim=3 ) / at_i_b(:,:)
END WHERE
CALL iom_put( 'icealb' , zalb * zmskalb + zmiss_val * ( 1._wp - zmskalb ) )
! ice+ocean albedo
- zalb(:,:) = SUM( alb_ice * a_i_b, dim=3 ) + rn_alb_oce * ( 1._wp - at_i_b )
+ zalb(:,:) = SUM( alb_ice(:,:,:) * a_i_b(:,:,:), dim=3 ) + rn_alb_oce * ( 1._wp - at_i_b(:,:) )
CALL iom_put( 'albedo' , zalb )
DEALLOCATE( zalb, zmskalb )
ENDIF
!
! --- category-dependent fields --- !
- IF( iom_use('icemask_cat' ) ) CALL iom_put( 'icemask_cat' , zmsk00l ) ! ice mask 0%
- IF( iom_use('iceconc_cat' ) ) CALL iom_put( 'iceconc_cat' , a_i * zmsk00l ) ! area for categories
- IF( iom_use('icethic_cat' ) ) CALL iom_put( 'icethic_cat' , h_i * zmsk00l + zmiss_val * ( 1._wp - zmsk00l ) ) ! thickness for categories
- IF( iom_use('snwthic_cat' ) ) CALL iom_put( 'snwthic_cat' , h_s * zmsksnl + zmiss_val * ( 1._wp - zmsksnl ) ) ! snow depth for categories
- IF( iom_use('icesalt_cat' ) ) CALL iom_put( 'icesalt_cat' , s_i * zmsk00l + zmiss_val * ( 1._wp - zmsk00l ) ) ! salinity for categories
- IF( iom_use('iceage_cat' ) ) CALL iom_put( 'iceage_cat' , o_i / rday * zmsk00l + zmiss_val * ( 1._wp - zmsk00l ) ) ! ice age
- IF( iom_use('icetemp_cat' ) ) CALL iom_put( 'icetemp_cat' , ( SUM( t_i, dim=3 ) * r1_nlay_i - rt0 ) &
- & * zmsk00l + zmiss_val * ( 1._wp - zmsk00l ) ) ! ice temperature
- IF( iom_use('snwtemp_cat' ) ) CALL iom_put( 'snwtemp_cat' , ( SUM( t_s, dim=3 ) * r1_nlay_s - rt0 ) &
- & * zmsksnl + zmiss_val * ( 1._wp - zmsksnl ) ) ! snow temperature
- IF( iom_use('icettop_cat' ) ) CALL iom_put( 'icettop_cat' , ( t_su - rt0 ) * zmsk00l + zmiss_val * ( 1._wp - zmsk00l ) ) ! surface temperature
- IF( iom_use('icebrv_cat' ) ) CALL iom_put( 'icebrv_cat' , bv_i * 100. * zmsk00l + zmiss_val * ( 1._wp - zmsk00l ) ) ! brine volume
- IF( iom_use('iceapnd_cat' ) ) CALL iom_put( 'iceapnd_cat' , a_ip * zmsk00l ) ! melt pond frac for categories
- IF( iom_use('icevpnd_cat' ) ) CALL iom_put( 'icevpnd_cat' , v_ip * zmsk00l ) ! melt pond volume for categories
- IF( iom_use('icehpnd_cat' ) ) CALL iom_put( 'icehpnd_cat' , h_ip * zmsk00l + zmiss_val * ( 1._wp - zmsk00l ) ) ! melt pond thickness for categories
- IF( iom_use('icehlid_cat' ) ) CALL iom_put( 'icehlid_cat' , h_il * zmsk00l + zmiss_val * ( 1._wp - zmsk00l ) ) ! melt pond lid thickness for categories
- IF( iom_use('iceafpnd_cat') ) CALL iom_put( 'iceafpnd_cat', a_ip_frac * zmsk00l ) ! melt pond frac per ice area for categories
- IF( iom_use('iceaepnd_cat') ) CALL iom_put( 'iceaepnd_cat', a_ip_eff * zmsk00l ) ! melt pond effective frac for categories
- IF( iom_use('icealb_cat' ) ) CALL iom_put( 'icealb_cat' , alb_ice * zmsk00l + zmiss_val * ( 1._wp - zmsk00l ) ) ! ice albedo for categories
+ IF( iom_use('icemask_cat' ) ) CALL iom_put( 'icemask_cat' , zmsk00l ) ! ice mask 0%
+ IF( iom_use('iceconc_cat' ) ) CALL iom_put( 'iceconc_cat' , a_i(A2D(0),:) * zmsk00l ) ! area for categories
+ IF( iom_use('icethic_cat' ) ) CALL iom_put( 'icethic_cat' , h_i(A2D(0),:) * zmsk00l + zmiss_val &
+ & * ( 1._wp - zmsk00l ) ) ! thickness for categories
+ IF( iom_use('snwthic_cat' ) ) CALL iom_put( 'snwthic_cat' , h_s(A2D(0),:) * zmsksnl + zmiss_val &
+ & * ( 1._wp - zmsksnl ) ) ! snow depth for categories
+ IF( iom_use('icesalt_cat' ) ) CALL iom_put( 'icesalt_cat' , s_i(A2D(0),:) * zmsk00l + zmiss_val &
+ & * ( 1._wp - zmsk00l ) ) ! salinity for categories
+ IF( iom_use('iceage_cat' ) ) CALL iom_put( 'iceage_cat' , o_i(A2D(0),:) / rday * zmsk00l + zmiss_val &
+ & * ( 1._wp - zmsk00l ) ) ! ice age
+ IF( iom_use('icetemp_cat' ) ) CALL iom_put( 'icetemp_cat' , ( SUM( t_i(A2D(0),:,:), dim=3 ) * r1_nlay_i - rt0 ) &
+ & * zmsk00l + zmiss_val * ( 1._wp - zmsk00l ) ) ! ice temperature
+ IF( iom_use('snwtemp_cat' ) ) CALL iom_put( 'snwtemp_cat' , ( SUM( t_s(A2D(0),:,:), dim=3 ) * r1_nlay_s - rt0 ) &
+ & * zmsksnl + zmiss_val * ( 1._wp - zmsksnl ) ) ! snow temperature
+ IF( iom_use('icettop_cat' ) ) CALL iom_put( 'icettop_cat' , ( t_su(A2D(0),:) - rt0 ) * zmsk00l + zmiss_val &
+ & * ( 1._wp - zmsk00l ) ) ! surface temperature
+ IF( iom_use('icebrv_cat' ) ) CALL iom_put( 'icebrv_cat' , bv_i(:,:,:) * 100. * zmsk00l + zmiss_val &
+ & * ( 1._wp - zmsk00l ) ) ! brine volume
+ IF( iom_use('iceapnd_cat' ) ) CALL iom_put( 'iceapnd_cat' , a_ip(A2D(0),:) * zmsk00l ) ! melt pond frac for categories
+ IF( iom_use('icevpnd_cat' ) ) CALL iom_put( 'icevpnd_cat' , v_ip(A2D(0),:) * zmsk00l ) ! melt pond volume for categories
+ IF( iom_use('icehpnd_cat' ) ) CALL iom_put( 'icehpnd_cat' , h_ip(A2D(0),:) * zmsk00l + zmiss_val &
+ & * ( 1._wp - zmsk00l ) ) ! melt pond thickness for categories
+ IF( iom_use('icehlid_cat' ) ) CALL iom_put( 'icehlid_cat' , h_il(A2D(0),:) * zmsk00l + zmiss_val &
+ & * ( 1._wp - zmsk00l ) ) ! melt pond lid thickness for categories
+ IF( iom_use('iceafpnd_cat') ) CALL iom_put( 'iceafpnd_cat', a_ip_frac(:,:,:) * zmsk00l ) ! melt pond frac per ice area for categories
+ IF( iom_use('iceaepnd_cat') ) CALL iom_put( 'iceaepnd_cat', a_ip_eff(:,:,:) * zmsk00l ) ! melt pond effective frac for categories
+ IF( iom_use('icealb_cat' ) ) CALL iom_put( 'icealb_cat' , alb_ice(:,:,:) * zmsk00l + zmiss_val &
+ & * ( 1._wp - zmsk00l ) ) ! ice albedo for categories
!------------------
! Add-ons for SIMIP
!------------------
! trends
- IF( iom_use('dmithd') ) CALL iom_put( 'dmithd', - wfx_bog - wfx_bom - wfx_sum - wfx_sni - wfx_opw - wfx_lam - wfx_res ) ! Sea-ice mass change from thermodynamics
+ IF( iom_use('dmithd') ) CALL iom_put( 'dmithd', - wfx_bog(:,:) - wfx_bom(:,:) - wfx_sum(:,:) - wfx_sni(:,:) &
+ & - wfx_opw(:,:) - wfx_lam(:,:) - wfx_res(:,:) ) ! Sea-ice mass change from thermodynamics
IF( iom_use('dmidyn') ) CALL iom_put( 'dmidyn', - wfx_dyn + rhoi * diag_trp_vi ) ! Sea-ice mass change from dynamics(kg/m2/s)
IF( iom_use('dmiopw') ) CALL iom_put( 'dmiopw', - wfx_opw ) ! Sea-ice mass change through growth in open water
IF( iom_use('dmibog') ) CALL iom_put( 'dmibog', - wfx_bog ) ! Sea-ice mass change through basal growth
@@ -211,17 +231,23 @@ CONTAINS
IF( iom_use('NH_icearea') .OR. iom_use('NH_icevolu') .OR. iom_use('NH_iceextt') .OR. &
& iom_use('SH_icearea') .OR. iom_use('SH_icevolu') .OR. iom_use('SH_iceextt') ) THEN
!
- WHERE( ff_t(:,:) > 0._wp ) ; z2d(:,:) = 1._wp
- ELSEWHERE ; z2d(:,:) = 0.
+ WHERE( ff_t(A2D(0)) > 0._wp ) ; z2d(:,:) = 1._wp
+ ELSEWHERE ; z2d(:,:) = 0.
END WHERE
!
- IF( iom_use('NH_icearea') ) zdiag_area_nh = glob_sum( 'icewri', at_i * z2d * e1e2t * 1.e-12 )
- IF( iom_use('NH_icevolu') ) zdiag_volu_nh = glob_sum( 'icewri', vt_i * z2d * e1e2t * 1.e-12 )
- IF( iom_use('NH_iceextt') ) zdiag_extt_nh = glob_sum( 'icewri', z2d * e1e2t * 1.e-12 * zmsk15 )
+ IF( iom_use('NH_icearea') ) zdiag_area_nh = glob_sum( 'icewri', at_i(A2D(0)) * z2d * e1e2t(A2D(0)) &
+ & * 1.e-12 )
+ IF( iom_use('NH_icevolu') ) zdiag_volu_nh = glob_sum( 'icewri', vt_i(A2D(0)) * z2d * e1e2t(A2D(0)) &
+ & * 1.e-12 )
+ IF( iom_use('NH_iceextt') ) zdiag_extt_nh = glob_sum( 'icewri', z2d * e1e2t(A2D(0)) &
+ & * 1.e-12 * zmsk15 )
!
- IF( iom_use('SH_icearea') ) zdiag_area_sh = glob_sum( 'icewri', at_i * ( 1._wp - z2d ) * e1e2t * 1.e-12 )
- IF( iom_use('SH_icevolu') ) zdiag_volu_sh = glob_sum( 'icewri', vt_i * ( 1._wp - z2d ) * e1e2t * 1.e-12 )
- IF( iom_use('SH_iceextt') ) zdiag_extt_sh = glob_sum( 'icewri', ( 1._wp - z2d ) * e1e2t * 1.e-12 * zmsk15 )
+ IF( iom_use('SH_icearea') ) zdiag_area_sh = glob_sum( 'icewri', at_i(A2D(0)) * ( 1._wp - z2d ) * e1e2t(A2D(0)) &
+ & * 1.e-12 )
+ IF( iom_use('SH_icevolu') ) zdiag_volu_sh = glob_sum( 'icewri', vt_i(A2D(0)) * ( 1._wp - z2d ) * e1e2t(A2D(0)) &
+ & * 1.e-12 )
+ IF( iom_use('SH_iceextt') ) zdiag_extt_sh = glob_sum( 'icewri', ( 1._wp - z2d ) * e1e2t(A2D(0)) &
+ & * 1.e-12 * zmsk15 )
!
CALL iom_put( 'NH_icearea' , zdiag_area_nh )
CALL iom_put( 'NH_icevolu' , zdiag_volu_nh )
@@ -258,25 +284,28 @@ CONTAINS
!
!! The file is open in dia_wri_state (ocean routine)
- CALL iom_rstput( 0, 0, kid, 'sithic', hm_i ) ! Ice thickness
- CALL iom_rstput( 0, 0, kid, 'siconc', at_i ) ! Ice concentration
- CALL iom_rstput( 0, 0, kid, 'sitemp', tm_i - rt0 ) ! Ice temperature
- CALL iom_rstput( 0, 0, kid, 'sivelu', u_ice ) ! i-Ice speed
- CALL iom_rstput( 0, 0, kid, 'sivelv', v_ice ) ! j-Ice speed
- CALL iom_rstput( 0, 0, kid, 'sistru', utau_ice ) ! i-Wind stress over ice
- CALL iom_rstput( 0, 0, kid, 'sistrv', vtau_ice ) ! i-Wind stress over ice
- CALL iom_rstput( 0, 0, kid, 'sisflx', qsr ) ! Solar flx over ocean
- CALL iom_rstput( 0, 0, kid, 'sinflx', qns ) ! NonSolar flx over ocean
- CALL iom_rstput( 0, 0, kid, 'snwpre', sprecip ) ! Snow precipitation
- CALL iom_rstput( 0, 0, kid, 'sisali', sm_i ) ! Ice salinity
- CALL iom_rstput( 0, 0, kid, 'sivolu', vt_i ) ! Ice volume
- CALL iom_rstput( 0, 0, kid, 'sidive', divu_i*1.0e8 ) ! Ice divergence
- CALL iom_rstput( 0, 0, kid, 'si_amp', at_ip ) ! Melt pond fraction
- CALL iom_rstput( 0, 0, kid, 'si_vmp', vt_ip ) ! Melt pond volume
- CALL iom_rstput( 0, 0, kid, 'sithicat', h_i ) ! Ice thickness
- CALL iom_rstput( 0, 0, kid, 'siconcat', a_i ) ! Ice concentration
- CALL iom_rstput( 0, 0, kid, 'sisalcat', s_i ) ! Ice salinity
- CALL iom_rstput( 0, 0, kid, 'snthicat', h_s ) ! Snw thickness
+ CALL iom_rstput( 0, 0, kid, 'sithic' , hm_i ) ! Ice thickness
+ CALL iom_rstput( 0, 0, kid, 'siconc' , at_i ) ! Ice concentration
+ CALL iom_rstput( 0, 0, kid, 'sitemp' , tm_i ) ! Ice temperature
+ CALL iom_rstput( 0, 0, kid, 'sittop' , t_su ) ! Surface Ice temperature
+ CALL iom_rstput( 0, 0, kid, 'sitbot' , t_bo ) ! Bottom Ice temperature
+ CALL iom_rstput( 0, 0, kid, 'sivelu' , u_ice ) ! i-Ice speed
+ CALL iom_rstput( 0, 0, kid, 'sivelv' , v_ice ) ! j-Ice speed
+ CALL iom_rstput( 0, 0, kid, 'utau_ice', utau_ice ) ! i-Wind stress over ice
+ CALL iom_rstput( 0, 0, kid, 'vtau_ice', vtau_ice ) ! i-Wind stress over ice
+ CALL iom_rstput( 0, 0, kid, 'snowpre' , sprecip ) ! Snow precipitation
+ CALL iom_rstput( 0, 0, kid, 'sisali' , sm_i ) ! Ice salinity
+ CALL iom_rstput( 0, 0, kid, 'sivolu' , vt_i ) ! Ice volume
+ CALL iom_rstput( 0, 0, kid, 'siapnd' , at_ip ) ! Melt pond fraction
+ CALL iom_rstput( 0, 0, kid, 'sivpnd' , vt_ip ) ! Melt pond volume
+ CALL iom_rstput( 0, 0, kid, 'sithicat', h_i ) ! Ice thickness
+ CALL iom_rstput( 0, 0, kid, 'siconcat', a_i ) ! Ice concentration
+ CALL iom_rstput( 0, 0, kid, 'sisalcat', s_i ) ! Ice salinity
+ CALL iom_rstput( 0, 0, kid, 'snthicat', h_s ) ! Snw thickness
+ CALL iom_rstput( 0, 0, kid, 'qsr' , qsr ) ! Solar flx over ocean
+ CALL iom_rstput( 0, 0, kid, 'qns' , qns ) ! NonSolar flx over ocean
+ CALL iom_rstput( 0, 0, kid, 'sst' , sst_m ) ! sst
+ CALL iom_rstput( 0, 0, kid, 'sss' , sss_m ) ! sss
END SUBROUTINE ice_wri_state
diff --git a/src/NST/agrif_all_update.F90 b/src/NST/agrif_all_update.F90
index 5389c0c2cd240cef1d33241ba0488bfccc93f2b2..b8573fd98908162982b179f9891e8cce1eb15c84 100644
--- a/src/NST/agrif_all_update.F90
+++ b/src/NST/agrif_all_update.F90
@@ -117,12 +117,10 @@ CONTAINS
CALL dom_qco_zgr( Kbb_a, Kmm_a )
#endif
#if defined key_si3
- CALL lbc_lnk( 'finalize_lbc_for_agrif', a_i, 'T',1._wp, v_i,'T',1._wp, &
- & v_s, 'T',1._wp, sv_i,'T',1._wp, oa_i,'T',1._wp, &
- & a_ip,'T',1._wp, v_ip,'T',1._wp, v_il,'T',1._wp )
- CALL lbc_lnk( 'finalize_lbc_for_agrif', t_su,'T',1._wp )
- CALL lbc_lnk( 'finalize_lbc_for_agrif', e_s,'T',1._wp )
- CALL lbc_lnk( 'finalize_lbc_for_agrif', e_i,'T',1._wp )
+ CALL lbc_lnk( 'finalize_lbc_for_agrif', a_i, 'T',1._wp, v_i,'T',1._wp, &
+ & v_s, 'T',1._wp, sv_i,'T',1._wp, oa_i,'T',1._wp, &
+ & a_ip,'T',1._wp, v_ip,'T',1._wp, v_il,'T',1._wp, t_su,'T',1._wp )
+ CALL lbc_lnk( 'finalize_lbc_for_agrif', e_i,'T',1._wp, e_s,'T',1._wp )
CALL lbc_lnk( 'finalize_lbc_for_agrif', u_ice, 'U', -1._wp, v_ice, 'V', -1._wp )
#endif
#if defined key_top
diff --git a/src/NST/agrif_ice_interp.F90 b/src/NST/agrif_ice_interp.F90
index eea3d9477c3de17c4f11bb900afa685c3a0e0fe3..9bc3d8aa8bd08f892b10b2d29b346d868b9f7d3b 100644
--- a/src/NST/agrif_ice_interp.F90
+++ b/src/NST/agrif_ice_interp.F90
@@ -64,12 +64,10 @@ CONTAINS
CALL Agrif_Set_MaskMaxSearch(10)
CALL Agrif_init_variable(tra_iceini_id,procname=interp_tra_ice)
!
- CALL lbc_lnk( 'agrif_istate_ice', a_i,'T',1._wp, v_i,'T',1._wp, &
- & v_s,'T',1._wp, sv_i,'T',1._wp, oa_i,'T',1._wp, &
- & a_ip,'T',1._wp, v_ip,'T',1._wp, v_il,'T',1._wp )
- CALL lbc_lnk( 'agrif_istate_ice', t_su,'T',1._wp )
- CALL lbc_lnk( 'agrif_istate_ice', e_s,'T',1._wp )
- CALL lbc_lnk( 'agrif_istate_ice', e_i,'T',1._wp )
+ CALL lbc_lnk( 'agrif_istate_ice', a_i,'T',1._wp, v_i,'T',1._wp, &
+ & v_s,'T',1._wp, sv_i,'T',1._wp, oa_i,'T',1._wp, &
+ & a_ip,'T',1._wp, v_ip,'T',1._wp, v_il,'T',1._wp, t_su,'T',1._wp )
+ CALL lbc_lnk( 'agrif_istate_ice', e_i,'T',1._wp, e_s,'T',1._wp )
!
! Set u_ice, v_ice:
use_sign_north = .TRUE.
@@ -87,7 +85,7 @@ CONTAINS
!
CALL lbc_lnk( 'agrif_istate_ice', u_ice, 'U', -1._wp, v_ice, 'V', -1._wp )
!
- CALL ice_var_glo2eqv
+ CALL ice_var_glo2eqv(1)
!
END SUBROUTINE agrif_istate_ice
diff --git a/src/NST/agrif_oce_interp.F90 b/src/NST/agrif_oce_interp.F90
index 221450eb7d8474a06bd3e0e75d7061a05b747d9c..19b62117bdade68832dcd509f8c4aa3811a9a347 100644
--- a/src/NST/agrif_oce_interp.F90
+++ b/src/NST/agrif_oce_interp.F90
@@ -273,7 +273,7 @@ CONTAINS
ibdy2 = nn_hls + nbghostcells + nn_shift_bar*Agrif_Rhox() ! halo + land + nbghostcells
!
IF( .NOT.ln_dynspg_ts ) THEN ! Store transport
- DO ji = mi0(ibdy1), mi1(ibdy2)
+ DO ji = mi0(ibdy1,nn_hls), mi1(ibdy2,nn_hls)
DO jj = 1, jpj
uu_b(ji,jj,Krhs_a) = ubdy(ji,jj) * r1_hu(ji,jj,Krhs_a)
vv_b(ji,jj,Krhs_a) = vbdy(ji,jj) * r1_hv(ji,jj,Krhs_a)
@@ -281,7 +281,7 @@ CONTAINS
END DO
ENDIF
!
- DO ji = mi0(ibdy1), mi1(ibdy2)
+ DO ji = mi0(ibdy1,nn_hls), mi1(ibdy2,nn_hls)
zub(ji,:) = 0._wp
zhub(ji,:) = 0._wp
DO jk = 1, jpkm1
@@ -303,7 +303,7 @@ CONTAINS
END DO
END DO
!
- DO ji = mi0(ibdy1), mi1(ibdy2)
+ DO ji = mi0(ibdy1,nn_hls), mi1(ibdy2,nn_hls)
zvb(ji,:) = 0._wp
zhvb(ji,:) = 0._wp
DO jk = 1, jpkm1
@@ -333,14 +333,14 @@ CONTAINS
ibdy2 = jpiglo - ( nn_hls + 2 )
!
IF( .NOT.ln_dynspg_ts ) THEN
- DO ji = mi0(ibdy1), mi1(ibdy2)
+ DO ji = mi0(ibdy1,nn_hls), mi1(ibdy2,nn_hls)
DO jj = 1, jpj
uu_b(ji,jj,Krhs_a) = ubdy(ji,jj) * r1_hu(ji,jj,Krhs_a)
END DO
END DO
ENDIF
!
- DO ji = mi0(ibdy1), mi1(ibdy2)
+ DO ji = mi0(ibdy1,nn_hls), mi1(ibdy2,nn_hls)
zub(ji,:) = 0._wp
zhub(ji,:) = 0._wp
DO jk = 1, jpkm1
@@ -366,14 +366,14 @@ CONTAINS
ibdy2 = jpiglo - ( nn_hls + 1 )
!
IF( .NOT.ln_dynspg_ts ) THEN
- DO ji = mi0(ibdy1), mi1(ibdy2)
+ DO ji = mi0(ibdy1,nn_hls), mi1(ibdy2,nn_hls)
DO jj = 1, jpj
vv_b(ji,jj,Krhs_a) = vbdy(ji,jj) * r1_hv(ji,jj,Krhs_a)
END DO
END DO
ENDIF
!
- DO ji = mi0(ibdy1), mi1(ibdy2)
+ DO ji = mi0(ibdy1,nn_hls), mi1(ibdy2,nn_hls)
zvb(ji,:) = 0._wp
zhvb(ji,:) = 0._wp
DO jk = 1, jpkm1
@@ -403,7 +403,7 @@ CONTAINS
jbdy2 = nn_hls + nbghostcells + nn_shift_bar*Agrif_Rhoy()
!
IF( .NOT.ln_dynspg_ts ) THEN
- DO jj = mj0(jbdy1), mj1(jbdy2)
+ DO jj = mj0(jbdy1,nn_hls), mj1(jbdy2,nn_hls)
DO ji = 1, jpi
uu_b(ji,jj,Krhs_a) = ubdy(ji,jj) * r1_hu(ji,jj,Krhs_a)
vv_b(ji,jj,Krhs_a) = vbdy(ji,jj) * r1_hv(ji,jj,Krhs_a)
@@ -411,7 +411,7 @@ CONTAINS
END DO
ENDIF
!
- DO jj = mj0(jbdy1), mj1(jbdy2)
+ DO jj = mj0(jbdy1,nn_hls), mj1(jbdy2,nn_hls)
zvb(:,jj) = 0._wp
zhvb(:,jj) = 0._wp
DO jk=1,jpkm1
@@ -433,7 +433,7 @@ CONTAINS
END DO
END DO
!
- DO jj = mj0(jbdy1), mj1(jbdy2)
+ DO jj = mj0(jbdy1,nn_hls), mj1(jbdy2,nn_hls)
zub(:,jj) = 0._wp
zhub(:,jj) = 0._wp
DO jk = 1, jpkm1
@@ -463,14 +463,14 @@ CONTAINS
jbdy2 = jpjglo - ( nn_hls + 2 )
!
IF( .NOT.ln_dynspg_ts ) THEN
- DO jj = mj0(jbdy1), mj1(jbdy2)
+ DO jj = mj0(jbdy1,nn_hls), mj1(jbdy2,nn_hls)
DO ji = 1, jpi
vv_b(ji,jj,Krhs_a) = vbdy(ji,jj) * r1_hv(ji,jj,Krhs_a)
END DO
END DO
ENDIF
!
- DO jj = mj0(jbdy1), mj1(jbdy2)
+ DO jj = mj0(jbdy1,nn_hls), mj1(jbdy2,nn_hls)
zvb(:,jj) = 0._wp
zhvb(:,jj) = 0._wp
DO jk=1,jpkm1
@@ -496,14 +496,14 @@ CONTAINS
jbdy2 = jpjglo - ( nn_hls + 1 )
!
IF( .NOT.ln_dynspg_ts ) THEN
- DO jj = mj0(jbdy1), mj1(jbdy2)
+ DO jj = mj0(jbdy1,nn_hls), mj1(jbdy2,nn_hls)
DO ji = 1, jpi
uu_b(ji,jj,Krhs_a) = ubdy(ji,jj) * r1_hu(ji,jj,Krhs_a)
END DO
END DO
ENDIF
!
- DO jj = mj0(jbdy1), mj1(jbdy2)
+ DO jj = mj0(jbdy1,nn_hls), mj1(jbdy2,nn_hls)
zub(:,jj) = 0._wp
zhub(:,jj) = 0._wp
DO jk = 1, jpkm1
@@ -556,7 +556,7 @@ CONTAINS
IF( lk_west ) THEN
istart = nn_hls + 2 ! halo + land + 1
iend = nn_hls + nbghostcells + nn_shift_bar*Agrif_Rhox() ! halo + land + nbghostcells
- DO ji = mi0(istart), mi1(iend)
+ DO ji = mi0(istart,nn_hls), mi1(iend,nn_hls)
DO jj=1,jpj
va_e(ji,jj) = vbdy(ji,jj) * hvr_e(ji,jj)
ua_e(ji,jj) = ubdy(ji,jj) * hur_e(ji,jj)
@@ -568,7 +568,7 @@ CONTAINS
IF( lk_east ) THEN
istart = jpiglo - ( nn_hls + nbghostcells -1 ) - nn_shift_bar*Agrif_Rhox()
iend = jpiglo - ( nn_hls + 1 )
- DO ji = mi0(istart), mi1(iend)
+ DO ji = mi0(istart,nn_hls), mi1(iend,nn_hls)
DO jj=1,jpj
va_e(ji,jj) = vbdy(ji,jj) * hvr_e(ji,jj)
@@ -576,7 +576,7 @@ CONTAINS
END DO
istart = jpiglo - ( nn_hls + nbghostcells ) - nn_shift_bar*Agrif_Rhox()
iend = jpiglo - ( nn_hls + 2 )
- DO ji = mi0(istart), mi1(iend)
+ DO ji = mi0(istart,nn_hls), mi1(iend,nn_hls)
DO jj=1,jpj
ua_e(ji,jj) = ubdy(ji,jj) * hur_e(ji,jj)
END DO
@@ -587,7 +587,7 @@ CONTAINS
IF( lk_south ) THEN
jstart = nn_hls + 2
jend = nn_hls + nbghostcells + nn_shift_bar*Agrif_Rhoy()
- DO jj = mj0(jstart), mj1(jend)
+ DO jj = mj0(jstart,nn_hls), mj1(jend,nn_hls)
DO ji=1,jpi
ua_e(ji,jj) = ubdy(ji,jj) * hur_e(ji,jj)
@@ -600,14 +600,14 @@ CONTAINS
IF( lk_north ) THEN
jstart = jpjglo - ( nn_hls + nbghostcells -1 ) - nn_shift_bar*Agrif_Rhoy()
jend = jpjglo - ( nn_hls + 1 )
- DO jj = mj0(jstart), mj1(jend)
+ DO jj = mj0(jstart,nn_hls), mj1(jend,nn_hls)
DO ji=1,jpi
ua_e(ji,jj) = ubdy(ji,jj) * hur_e(ji,jj)
END DO
END DO
jstart = jpjglo - ( nn_hls + nbghostcells ) - nn_shift_bar*Agrif_Rhoy()
jend = jpjglo - ( nn_hls + 2 )
- DO jj = mj0(jstart), mj1(jend)
+ DO jj = mj0(jstart,nn_hls), mj1(jend,nn_hls)
DO ji=1,jpi
va_e(ji,jj) = vbdy(ji,jj) * hvr_e(ji,jj)
END DO
@@ -645,7 +645,7 @@ CONTAINS
IF( lk_west ) THEN
istart = nn_hls + 2
iend = nn_hls + nbghostcells + nn_shift_bar*Agrif_Rhox()
- DO ji = mi0(istart), mi1(iend)
+ DO ji = mi0(istart,nn_hls), mi1(iend,nn_hls)
DO jj=1,jpj
zv(ji,jj) = vbdy(ji,jj) * e1v(ji,jj)
zu(ji,jj) = ubdy(ji,jj) * e2u(ji,jj)
@@ -657,14 +657,14 @@ CONTAINS
IF( lk_east ) THEN
istart = jpiglo - ( nn_hls + nbghostcells -1 ) - nn_shift_bar*Agrif_Rhox()
iend = jpiglo - ( nn_hls + 1 )
- DO ji = mi0(istart), mi1(iend)
+ DO ji = mi0(istart,nn_hls), mi1(iend,nn_hls)
DO jj=1,jpj
zv(ji,jj) = vbdy(ji,jj) * e1v(ji,jj)
END DO
END DO
istart = jpiglo - ( nn_hls + nbghostcells ) - nn_shift_bar*Agrif_Rhox()
iend = jpiglo - ( nn_hls + 2 )
- DO ji = mi0(istart), mi1(iend)
+ DO ji = mi0(istart,nn_hls), mi1(iend,nn_hls)
DO jj=1,jpj
zu(ji,jj) = ubdy(ji,jj) * e2u(ji,jj)
END DO
@@ -675,7 +675,7 @@ CONTAINS
IF( lk_south ) THEN
jstart = nn_hls + 2
jend = nn_hls + nbghostcells + nn_shift_bar*Agrif_Rhoy()
- DO jj = mj0(jstart), mj1(jend)
+ DO jj = mj0(jstart,nn_hls), mj1(jend,nn_hls)
DO ji=1,jpi
zu(ji,jj) = ubdy(ji,jj) * e2u(ji,jj)
zv(ji,jj) = vbdy(ji,jj) * e1v(ji,jj)
@@ -687,14 +687,14 @@ CONTAINS
IF( lk_north ) THEN
jstart = jpjglo - ( nn_hls + nbghostcells -1 ) - nn_shift_bar*Agrif_Rhoy()
jend = jpjglo - ( nn_hls + 1 )
- DO jj = mj0(jstart), mj1(jend)
+ DO jj = mj0(jstart,nn_hls), mj1(jend,nn_hls)
DO ji=1,jpi
zu(ji,jj) = ubdy(ji,jj) * e2u(ji,jj)
END DO
END DO
jstart = jpjglo - ( nn_hls + nbghostcells ) - nn_shift_bar*Agrif_Rhoy()
jend = jpjglo - ( nn_hls + 2 )
- DO jj = mj0(jstart), mj1(jend)
+ DO jj = mj0(jstart,nn_hls), mj1(jend,nn_hls)
DO ji=1,jpi
zv(ji,jj) = vbdy(ji,jj) * e1v(ji,jj)
END DO
@@ -804,7 +804,7 @@ CONTAINS
istart = nn_hls + 2 ! halo + land + 1
iend = nn_hls + nbghostcells + nn_shift_bar*Agrif_Rhox() ! halo + land + nbghostcells
IF (lk_div_cons) iend = istart
- DO ji = mi0(istart), mi1(iend)
+ DO ji = mi0(istart,nn_hls), mi1(iend,nn_hls)
DO jj = 1, jpj
ssh(ji,jj,Krhs_a) = hbdy(ji,jj)
END DO
@@ -816,7 +816,7 @@ CONTAINS
istart = jpiglo - ( nn_hls + nbghostcells -1 ) - nn_shift_bar*Agrif_Rhox() ! halo + land + nbghostcells - 1
iend = jpiglo - ( nn_hls + 1 ) ! halo + land + 1 - 1
IF (lk_div_cons) istart = iend
- DO ji = mi0(istart), mi1(iend)
+ DO ji = mi0(istart,nn_hls), mi1(iend,nn_hls)
DO jj = 1, jpj
ssh(ji,jj,Krhs_a) = hbdy(ji,jj)
END DO
@@ -828,7 +828,7 @@ CONTAINS
jstart = nn_hls + 2 ! halo + land + 1
jend = nn_hls + nbghostcells + nn_shift_bar*Agrif_Rhoy() ! halo + land + nbghostcells
IF (lk_div_cons) jend = jstart
- DO jj = mj0(jstart), mj1(jend)
+ DO jj = mj0(jstart,nn_hls), mj1(jend,nn_hls)
DO ji = 1, jpi
ssh(ji,jj,Krhs_a) = hbdy(ji,jj)
END DO
@@ -840,7 +840,7 @@ CONTAINS
jstart = jpjglo - ( nn_hls + nbghostcells -1 ) - nn_shift_bar*Agrif_Rhoy() ! halo + land + nbghostcells - 1
jend = jpjglo - ( nn_hls + 1 ) ! halo + land + 1 - 1
IF (lk_div_cons) jstart = jend
- DO jj = mj0(jstart), mj1(jend)
+ DO jj = mj0(jstart,nn_hls), mj1(jend,nn_hls)
DO ji = 1, jpi
ssh(ji,jj,Krhs_a) = hbdy(ji,jj)
END DO
@@ -873,7 +873,7 @@ CONTAINS
istart = nn_hls + 2 ! halo + land + 1
iend = nn_hls + nbghostcells + nn_shift_bar*Agrif_Rhox() ! halo + land + nbghostcells
IF (lk_div_cons) iend = istart
- DO ji = mi0(istart), mi1(iend)
+ DO ji = mi0(istart,nn_hls), mi1(iend,nn_hls)
DO jj = 1, jpj
ssha_e(ji,jj) = hbdy(ji,jj)
END DO
@@ -885,7 +885,7 @@ CONTAINS
istart = jpiglo - ( nn_hls + nbghostcells -1 ) - nn_shift_bar*Agrif_Rhox() ! halo + land + nbghostcells - 1
iend = jpiglo - ( nn_hls + 1 ) ! halo + land + 1 - 1
IF (lk_div_cons) istart = iend
- DO ji = mi0(istart), mi1(iend)
+ DO ji = mi0(istart,nn_hls), mi1(iend,nn_hls)
DO jj = 1, jpj
ssha_e(ji,jj) = hbdy(ji,jj)
END DO
@@ -897,7 +897,7 @@ CONTAINS
jstart = nn_hls + 2 ! halo + land + 1
jend = nn_hls + nbghostcells + nn_shift_bar*Agrif_Rhoy() ! halo + land + nbghostcells
IF (lk_div_cons) jend = jstart
- DO jj = mj0(jstart), mj1(jend)
+ DO jj = mj0(jstart,nn_hls), mj1(jend,nn_hls)
DO ji = 1, jpi
ssha_e(ji,jj) = hbdy(ji,jj)
END DO
@@ -909,7 +909,7 @@ CONTAINS
jstart = jpjglo - ( nn_hls + nbghostcells -1 ) - nn_shift_bar*Agrif_Rhoy() ! halo + land + nbghostcells - 1
jend = jpjglo - ( nn_hls + 1 ) ! halo + land + 1 - 1
IF (lk_div_cons) jstart = jend
- DO jj = mj0(jstart), mj1(jend)
+ DO jj = mj0(jstart,nn_hls), mj1(jend,nn_hls)
DO ji = 1, jpi
ssha_e(ji,jj) = hbdy(ji,jj)
END DO
@@ -975,7 +975,7 @@ CONTAINS
END DO
END DO
- IF( l_vremap .OR. l_ini_child .OR. ln_zps ) THEN
+ IF( l_vremap .OR. l_ini_child .OR. l_zps ) THEN
! Fill cell depths (i.e. gdept) to be interpolated
! Warning: these are masked, hence extrapolated prior interpolation.
@@ -1069,7 +1069,7 @@ CONTAINS
ELSE
- IF ( Agrif_Parent(ln_zps) ) THEN ! Account for partial cells
+ IF ( Agrif_Parent(l_zps) ) THEN ! Account for partial cells
! linear vertical interpolation
DO jj=j1,j2
DO ji=i1,i2
@@ -1574,7 +1574,7 @@ CONTAINS
DO ji=i1,i2
DO jj=j1,j2
IF (utint_stage(ji,jj)==0) THEN
- zx = 2._wp*MOD(ABS(mig0(ji)-nbghostcells_x_w), INT(Agrif_Rhox()))/zrhox - 1._wp
+ zx = 2._wp*MOD(ABS(mig(ji,0)-nbghostcells_x_w), INT(Agrif_Rhox()))/zrhox - 1._wp
ubdy(ji,jj) = ubdy(ji,jj) + 0.25_wp*(1._wp-zx*zx) * ptab(ji,jj) &
& / zrhoy *r1_e2u(ji,jj) * umask(ji,jj,1)
utint_stage(ji,jj) = 1
@@ -1694,7 +1694,7 @@ CONTAINS
DO ji=i1,i2
DO jj=j1,j2
IF (vtint_stage(ji,jj)==0) THEN
- zy = 2._wp*MOD(ABS(mjg0(jj)-nbghostcells_y_s), INT(Agrif_Rhoy()))/zrhoy - 1._wp
+ zy = 2._wp*MOD(ABS(mjg(jj,0)-nbghostcells_y_s), INT(Agrif_Rhoy()))/zrhoy - 1._wp
vbdy(ji,jj) = vbdy(ji,jj) + 0.25_wp*(1._wp-zy*zy) * ptab(ji,jj) &
& / zrhox * r1_e1v(ji,jj) * vmask(ji,jj,1)
vtint_stage(ji,jj) = 1
@@ -1720,7 +1720,7 @@ CONTAINS
!!----------------------------------------------------------------------
!
IF( before ) THEN
- IF ( ln_zps ) THEN
+ IF ( lk_vco_1d3d ) THEN
DO jk = k1, k2
DO jj = j1, j2
DO ji = i1, i2
@@ -1729,7 +1729,13 @@ CONTAINS
END DO
END DO
ELSE
- ptab(i1:i2,j1:j2,k1:k2) = e3t_0(i1:i2,j1:j2,k1:k2)
+ DO jk = k1, k2
+ DO jj = j1, j2
+ DO ji = i1, i2
+ ptab(ji, jj, jk) = e3t_0(ji,jj,jk)
+ END DO
+ END DO
+ END DO
ENDIF
ELSE
!
@@ -1778,7 +1784,7 @@ CONTAINS
DO jj = j1, j2
DO ji = i1, i2
IF( ABS( ptab(ji,jj) - glamt(ji,jj) ) > ztst ) THEN
- WRITE(numout,*) ' Agrif error for glamt: parent, child, i, j ', ptab(ji,jj), glamt(ji,jj), mig0(ji), mig0(jj)
+ WRITE(numout,*) ' Agrif error for glamt: parent, child, i, j ', ptab(ji,jj), glamt(ji,jj), mig(ji,0), mjg(jj,0)
! kindic_agr = kindic_agr + 1
ENDIF
END DO
@@ -1807,7 +1813,7 @@ CONTAINS
DO jj = j1, j2
DO ji = i1, i2
IF( ABS( ptab(ji,jj) - gphit(ji,jj) ) > ztst ) THEN
- WRITE(numout,*) ' Agrif error for gphit: parent, child, i, j ', ptab(ji,jj), gphit(ji,jj), mig0(ji), mig0(jj)
+ WRITE(numout,*) ' Agrif error for gphit: parent, child, i, j ', ptab(ji,jj), gphit(ji,jj), mig(ji,0), mjg(jj,0)
! kindic_agr = kindic_agr + 1
ENDIF
END DO
@@ -1826,15 +1832,21 @@ CONTAINS
LOGICAL , INTENT(in ) :: before
!
INTEGER :: ji, jj, jk
+ INTEGER :: ii1, ii2, ij1, ij2
INTEGER :: N_in, N_out
REAL(wp), DIMENSION(k1:k2) :: tabin, z_in
REAL(wp), DIMENSION(1:jpk) :: z_out
- !!----------------------------------------------------------------------
- !
+ !!----------------------------------------------------------------------
+ ! TEMP: [summer 2022 halo] Quick fix for out of bounds indexing after avm_k declared with A2D(1)
+ ii1 = MAX(i1, LBOUND(avm_k, 1))
+ ii2 = MIN(i2, UBOUND(avm_k, 1))
+ ij1 = MAX(j1, LBOUND(avm_k, 2))
+ ij2 = MIN(j2, UBOUND(avm_k, 2))
+ !
IF (before) THEN
DO jk=k1,k2
- DO jj=j1,j2
- DO ji=i1,i2
+ DO jj=ij1,ij2
+ DO ji=ii1,ii2
ptab(ji,jj,jk,1) = avm_k(ji,jj,jk)
END DO
END DO
@@ -1844,8 +1856,8 @@ CONTAINS
! Interpolate interfaces
! Warning: these are masked, hence extrapolated prior interpolation.
DO jk=k1,k2
- DO jj=j1,j2
- DO ji=i1,i2
+ DO jj=ij1,ij2
+ DO ji=ii1,ii2
ptab(ji,jj,jk,2) = tmask(ji,jj,jk) * gdepw(ji,jj,jk,Kmm_a)
END DO
END DO
@@ -1853,20 +1865,20 @@ CONTAINS
! Save ssh at last level:
IF (.NOT.ln_linssh) THEN
- ptab(i1:i2,j1:j2,k2,2) = ssh(i1:i2,j1:j2,Kmm_a)*tmask(i1:i2,j1:j2,1)
+ ptab(ii1:ii2,ij1:ij2,k2,2) = ssh(ii1:ii2,ij1:ij2,Kmm_a)*tmask(ii1:ii2,ij1:ij2,1)
ELSE
- ptab(i1:i2,j1:j2,k2,2) = 0._wp
+ ptab(ii1:ii2,ij1:ij2,k2,2) = 0._wp
END IF
ENDIF
ELSE
IF( l_vremap ) THEN
- IF (ln_linssh) ptab(i1:i2,j1:j2,k2,2) = 0._wp
- avm_k(i1:i2,j1:j2,1:jpkm1) = 0._wp
+ IF (ln_linssh) ptab(ii1:ii2,ij1:ij2,k2,2) = 0._wp
+ avm_k(ii1:ii2,ij1:ij2,1:jpkm1) = 0._wp
- DO jj = j1, j2
- DO ji =i1, i2
+ DO jj = ij1, ij2
+ DO ji =ii1, ii2
N_in = mbkt_parent(ji,jj)
N_out = mbkt(ji,jj)
IF (N_in*N_out > 0) THEN
@@ -1884,7 +1896,7 @@ CONTAINS
END DO
END DO
ELSE
- avm_k(i1:i2,j1:j2,1:jpkm1) = ptab (i1:i2,j1:j2,1:jpkm1,1)
+ avm_k(ii1:ii2,ij1:ij2,1:jpkm1) = ptab (ii1:ii2,ij1:ij2,1:jpkm1,1)
ENDIF
ENDIF
!
@@ -2022,8 +2034,8 @@ CONTAINS
iend = nn_hls + nbghostcells + ispon ! halo + land + nbghostcells + sponge
jstart = nn_hls + 2
jend = jpjglo - nn_hls - 1
- DO ji = mi0(istart), mi1(iend)
- DO jj = mj0(jstart), mj1(jend)
+ DO ji = mi0(istart,nn_hls), mi1(iend,nn_hls)
+ DO jj = mj0(jstart,nn_hls), mj1(jend,nn_hls)
IF ( ABS(ht0_parent(ji,jj)-ht_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1
IF ( .NOT.ln_vert_remap) THEN
DO jk = 1, jpkm1
@@ -2031,7 +2043,7 @@ CONTAINS
END DO
ENDIF
END DO
- DO jj = mj0(jstart), mj1(jend-1)
+ DO jj = mj0(jstart,nn_hls), mj1(jend-1,nn_hls)
IF ( ABS(hv0_parent(ji,jj)-hv_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1
IF ( .NOT.ln_vert_remap) THEN
DO jk = 1, jpkm1
@@ -2040,8 +2052,8 @@ CONTAINS
ENDIF
END DO
END DO
- DO ji = mi0(istart), mi1(iend-1)
- DO jj = mj0(jstart), mj1(jend)
+ DO ji = mi0(istart,nn_hls), mi1(iend-1,nn_hls)
+ DO jj = mj0(jstart,nn_hls), mj1(jend,nn_hls)
IF ( ABS(hu0_parent(ji,jj)-hu_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1
IF ( .NOT.ln_vert_remap) THEN
DO jk = 1, jpkm1
@@ -2059,8 +2071,8 @@ CONTAINS
iend = jpiglo - nn_hls - 1 ! halo + land + 1 - 1
jstart = nn_hls + 2
jend = jpjglo - nn_hls - 1
- DO ji = mi0(istart), mi1(iend)
- DO jj = mj0(jstart), mj1(jend)
+ DO ji = mi0(istart,nn_hls), mi1(iend,nn_hls)
+ DO jj = mj0(jstart,nn_hls), mj1(jend,nn_hls)
IF ( ABS(ht0_parent(ji,jj)-ht_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1
IF ( .NOT.ln_vert_remap) THEN
DO jk = 1, jpkm1
@@ -2068,7 +2080,7 @@ CONTAINS
END DO
ENDIF
END DO
- DO jj = mj0(jstart), mj1(jend-1)
+ DO jj = mj0(jstart,nn_hls), mj1(jend-1,nn_hls)
IF ( ABS(hv0_parent(ji,jj)-hv_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1
IF ( .NOT.ln_vert_remap) THEN
DO jk = 1, jpkm1
@@ -2077,8 +2089,8 @@ CONTAINS
ENDIF
END DO
END DO
- DO ji = mi0(istart), mi1(iend-1)
- DO jj = mj0(jstart), mj1(jend)
+ DO ji = mi0(istart,nn_hls), mi1(iend-1,nn_hls)
+ DO jj = mj0(jstart,nn_hls), mj1(jend,nn_hls)
IF ( ABS(hu0_parent(ji,jj)-hu_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1
IF ( .NOT.ln_vert_remap) THEN
DO jk = 1, jpkm1
@@ -2096,8 +2108,8 @@ CONTAINS
jend = nn_hls + nbghostcells + ispon ! halo + land + nbghostcells + sponge
istart = nn_hls + 2
iend = jpiglo - nn_hls - 1
- DO jj = mj0(jstart), mj1(jend)
- DO ji = mi0(istart), mi1(iend)
+ DO jj = mj0(jstart,nn_hls), mj1(jend,nn_hls)
+ DO ji = mi0(istart,nn_hls), mi1(iend,nn_hls)
IF ( ABS(ht0_parent(ji,jj)-ht_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1
IF ( .NOT.ln_vert_remap) THEN
DO jk = 1, jpkm1
@@ -2105,7 +2117,7 @@ CONTAINS
END DO
ENDIF
END DO
- DO ji = mi0(istart), mi1(iend-1)
+ DO ji = mi0(istart,nn_hls), mi1(iend-1,nn_hls)
IF ( ABS(hu0_parent(ji,jj)-hu_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1
IF ( .NOT.ln_vert_remap) THEN
DO jk = 1, jpkm1
@@ -2114,8 +2126,8 @@ CONTAINS
ENDIF
END DO
END DO
- DO jj = mj0(jstart), mj1(jend-1)
- DO ji = mi0(istart), mi1(iend)
+ DO jj = mj0(jstart,nn_hls), mj1(jend-1,nn_hls)
+ DO ji = mi0(istart,nn_hls), mi1(iend,nn_hls)
IF ( ABS(hv0_parent(ji,jj)-hv_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1
IF ( .NOT.ln_vert_remap) THEN
DO jk = 1, jpkm1
@@ -2133,8 +2145,8 @@ CONTAINS
jend = jpjglo - nn_hls - 1 ! halo + land + 1 - 1
istart = nn_hls + 2
iend = jpiglo - nn_hls - 1
- DO jj = mj0(jstart), mj1(jend)
- DO ji = mi0(istart), mi1(iend)
+ DO jj = mj0(jstart,nn_hls), mj1(jend,nn_hls)
+ DO ji = mi0(istart,nn_hls), mi1(iend,nn_hls)
IF ( ABS(ht0_parent(ji,jj)-ht_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1
IF ( .NOT.ln_vert_remap) THEN
DO jk = 1, jpkm1
@@ -2142,7 +2154,7 @@ CONTAINS
END DO
ENDIF
END DO
- DO ji = mi0(istart), mi1(iend-1)
+ DO ji = mi0(istart,nn_hls), mi1(iend-1,nn_hls)
IF ( ABS(hu0_parent(ji,jj)-hu_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1
IF ( .NOT.ln_vert_remap) THEN
DO jk = 1, jpkm1
@@ -2151,8 +2163,8 @@ CONTAINS
ENDIF
END DO
END DO
- DO jj = mj0(jstart), mj1(jend-1)
- DO ji = mi0(istart), mi1(iend)
+ DO jj = mj0(jstart,nn_hls), mj1(jend-1,nn_hls)
+ DO ji = mi0(istart,nn_hls), mi1(iend,nn_hls)
IF ( ABS(hv0_parent(ji,jj)-hv_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1
IF ( .NOT.ln_vert_remap) THEN
DO jk = 1, jpkm1
diff --git a/src/NST/agrif_oce_sponge.F90 b/src/NST/agrif_oce_sponge.F90
index d077f7b8846bc7bb5abb81fdf10b3790781c5814..fe2997c0b95928072112a18c86c0e90c8fa15290 100644
--- a/src/NST/agrif_oce_sponge.F90
+++ b/src/NST/agrif_oce_sponge.F90
@@ -161,15 +161,15 @@ CONTAINS
IF( lk_west ) THEN ! --- West --- !
ind1 = nn_hls + nbghostcells ! halo + nbghostcells
ind2 = nn_hls + nbghostcells + ispongearea
- DO ji = mi0(ind1), mi1(ind2)
+ DO ji = mi0(ind1,nn_hls), mi1(ind2,nn_hls)
DO jj = 1, jpj
- ztabramp(ji,jj) = REAL(ind2 - mig(ji), wp) * z1_ispongearea
+ ztabramp(ji,jj) = REAL(ind2 - mig(ji,nn_hls), wp) * z1_ispongearea
END DO
END DO
! ghost cells:
ind1 = 1
ind2 = nn_hls + nbghostcells ! halo + nbghostcells
- DO ji = mi0(ind1), mi1(ind2)
+ DO ji = mi0(ind1,nn_hls), mi1(ind2,nn_hls)
DO jj = 1, jpj
ztabramp(ji,jj) = 1._wp
END DO
@@ -178,15 +178,15 @@ CONTAINS
IF( lk_east ) THEN ! --- East --- !
ind1 = jpiglo - ( nn_hls + nbghostcells -1 ) - ispongearea - 1
ind2 = jpiglo - ( nn_hls + nbghostcells -1 ) - 1 ! halo + land + nbghostcells - 1
- DO ji = mi0(ind1), mi1(ind2)
+ DO ji = mi0(ind1,nn_hls), mi1(ind2,nn_hls)
DO jj = 1, jpj
- ztabramp(ji,jj) = MAX( ztabramp(ji,jj), REAL(mig(ji) - ind1, wp) * z1_ispongearea )
+ ztabramp(ji,jj) = MAX( ztabramp(ji,jj), REAL(mig(ji,nn_hls) - ind1, wp) * z1_ispongearea )
END DO
END DO
! ghost cells:
ind1 = jpiglo - ( nn_hls + nbghostcells -1 ) - 1 ! halo + land + nbghostcells - 1
ind2 = jpiglo - 1
- DO ji = mi0(ind1), mi1(ind2)
+ DO ji = mi0(ind1,nn_hls), mi1(ind2,nn_hls)
DO jj = 1, jpj
ztabramp(ji,jj) = 1._wp
END DO
@@ -195,15 +195,15 @@ CONTAINS
IF( lk_south ) THEN ! --- South --- !
ind1 = nn_hls + nbghostcells ! halo + nbghostcells
ind2 = nn_hls + nbghostcells + jspongearea
- DO jj = mj0(ind1), mj1(ind2)
+ DO jj = mj0(ind1,nn_hls), mj1(ind2,nn_hls)
DO ji = 1, jpi
- ztabramp(ji,jj) = MAX( ztabramp(ji,jj), REAL(ind2 - mjg(jj), wp) * z1_jspongearea )
+ ztabramp(ji,jj) = MAX( ztabramp(ji,jj), REAL(ind2 - mjg(jj,nn_hls), wp) * z1_jspongearea )
END DO
END DO
! ghost cells:
ind1 = 1
ind2 = nn_hls + nbghostcells ! halo + nbghostcells
- DO jj = mj0(ind1), mj1(ind2)
+ DO jj = mj0(ind1,nn_hls), mj1(ind2,nn_hls)
DO ji = 1, jpi
ztabramp(ji,jj) = 1._wp
END DO
@@ -212,15 +212,15 @@ CONTAINS
IF( lk_north ) THEN ! --- North --- !
ind1 = jpjglo - ( nn_hls + nbghostcells -1 ) - jspongearea - 1
ind2 = jpjglo - ( nn_hls + nbghostcells -1 ) - 1 ! halo + nbghostcells - 1
- DO jj = mj0(ind1), mj1(ind2)
+ DO jj = mj0(ind1,nn_hls), mj1(ind2,nn_hls)
DO ji = 1, jpi
- ztabramp(ji,jj) = MAX( ztabramp(ji,jj), REAL(mjg(jj) - ind1, wp) * z1_jspongearea )
+ ztabramp(ji,jj) = MAX( ztabramp(ji,jj), REAL(mjg(jj,nn_hls) - ind1, wp) * z1_jspongearea )
END DO
END DO
! ghost cells:
ind1 = jpjglo - ( nn_hls + nbghostcells -1 ) ! halo + land + nbghostcells - 1
ind2 = jpjglo
- DO jj = mj0(ind1), mj1(ind2)
+ DO jj = mj0(ind1,nn_hls), mj1(ind2,nn_hls)
DO ji = 1, jpi
ztabramp(ji,jj) = 1._wp
END DO
@@ -239,8 +239,8 @@ CONTAINS
fspt(:,:) = 0._wp
fspf(:,:) = 0._wp
DO_2D( 0, 0, 0, 0 )
- fspt(ji,jj) = 0.25_wp * ( ztabramp(ji ,jj ) + ztabramp(ji-1,jj ) &
- & +ztabramp(ji ,jj-1) + ztabramp(ji-1,jj-1) ) * ssmask(ji,jj)
+ fspt(ji,jj) = 0.25_wp * ( ( ztabramp(ji ,jj ) + ztabramp(ji-1,jj ) ) & ! add () for NP repro
+ & + ( ztabramp(ji ,jj-1) + ztabramp(ji-1,jj-1) ) ) * ssmask(ji,jj)
fspf(ji,jj) = ztabramp(ji,jj) * ssvmask(ji,jj) * ssvmask(ji,jj+1)
END_2D
@@ -294,15 +294,15 @@ CONTAINS
IF( lk_west ) THEN ! --- West --- !
ind1 = nn_hls + nbghostcells + ishift
ind2 = nn_hls + nbghostcells + ishift + ispongearea
- DO ji = mi0(ind1), mi1(ind2)
+ DO ji = mi0(ind1,nn_hls), mi1(ind2,nn_hls)
DO jj = 1, jpj
- ztabramp(ji,jj) = REAL(ind2 - mig(ji), wp) * z1_ispongearea
+ ztabramp(ji,jj) = REAL(ind2 - mig(ji,nn_hls), wp) * z1_ispongearea
END DO
END DO
! ghost cells:
ind1 = 1
ind2 = nn_hls + nbghostcells + ishift ! halo + nbghostcells
- DO ji = mi0(ind1), mi1(ind2)
+ DO ji = mi0(ind1,nn_hls), mi1(ind2,nn_hls)
DO jj = 1, jpj
ztabramp(ji,jj) = 1._wp
END DO
@@ -311,15 +311,15 @@ CONTAINS
IF( lk_east ) THEN ! --- East --- !
ind1 = jpiglo - ( nn_hls + nbghostcells -1 + ishift) - ispongearea - 1
ind2 = jpiglo - ( nn_hls + nbghostcells -1 + ishift) - 1 ! halo + nbghostcells - 1
- DO ji = mi0(ind1), mi1(ind2)
+ DO ji = mi0(ind1,nn_hls), mi1(ind2,nn_hls)
DO jj = 1, jpj
- ztabramp(ji,jj) = MAX( ztabramp(ji,jj), REAL(mig(ji) - ind1, wp) * z1_ispongearea )
+ ztabramp(ji,jj) = MAX( ztabramp(ji,jj), REAL(mig(ji,nn_hls) - ind1, wp) * z1_ispongearea )
END DO
END DO
! ghost cells:
ind1 = jpiglo - ( nn_hls + nbghostcells -1 + ishift) - 1 ! halo + nbghostcells - 1
ind2 = jpiglo - 1
- DO ji = mi0(ind1), mi1(ind2)
+ DO ji = mi0(ind1,nn_hls), mi1(ind2,nn_hls)
DO jj = 1, jpj
ztabramp(ji,jj) = 1._wp
END DO
@@ -328,15 +328,15 @@ CONTAINS
IF( lk_south ) THEN ! --- South --- !
ind1 = nn_hls + nbghostcells + jshift ! halo + nbghostcells
ind2 = nn_hls + nbghostcells + jshift + jspongearea
- DO jj = mj0(ind1), mj1(ind2)
+ DO jj = mj0(ind1,nn_hls), mj1(ind2,nn_hls)
DO ji = 1, jpi
- ztabramp(ji,jj) = MAX( ztabramp(ji,jj), REAL(ind2 - mjg(jj), wp) * z1_jspongearea )
+ ztabramp(ji,jj) = MAX( ztabramp(ji,jj), REAL(ind2 - mjg(jj,nn_hls), wp) * z1_jspongearea )
END DO
END DO
! ghost cells:
ind1 = 1
ind2 = nn_hls + nbghostcells + jshift ! halo + land + nbghostcells
- DO jj = mj0(ind1), mj1(ind2)
+ DO jj = mj0(ind1,nn_hls), mj1(ind2,nn_hls)
DO ji = 1, jpi
ztabramp(ji,jj) = 1._wp
END DO
@@ -345,15 +345,15 @@ CONTAINS
IF( lk_north ) THEN ! --- North --- !
ind1 = jpjglo - ( nn_hls + nbghostcells -1 + jshift) - jspongearea - 1
ind2 = jpjglo - ( nn_hls + nbghostcells -1 + jshift) - 1 ! halo + land + nbghostcells - 1
- DO jj = mj0(ind1), mj1(ind2)
+ DO jj = mj0(ind1,nn_hls), mj1(ind2,nn_hls)
DO ji = 1, jpi
- ztabramp(ji,jj) = MAX( ztabramp(ji,jj), REAL(mjg(jj) - ind1, wp) * z1_jspongearea )
+ ztabramp(ji,jj) = MAX( ztabramp(ji,jj), REAL(mjg(jj,nn_hls) - ind1, wp) * z1_jspongearea )
END DO
END DO
! ghost cells:
ind1 = jpjglo - ( nn_hls + nbghostcells -1 + jshift) ! halo + land + nbghostcells - 1
ind2 = jpjglo
- DO jj = mj0(ind1), mj1(ind2)
+ DO jj = mj0(ind1,nn_hls), mj1(ind2,nn_hls)
DO ji = 1, jpi
ztabramp(ji,jj) = 1._wp
END DO
@@ -372,8 +372,8 @@ CONTAINS
fspt_2d(:,:) = 0._wp
fspf_2d(:,:) = 0._wp
DO_2D( 0, 0, 0, 0 )
- fspt_2d(ji,jj) = 0.25_wp * ( ztabramp(ji ,jj ) + ztabramp(ji-1,jj ) &
- & +ztabramp(ji ,jj-1) + ztabramp(ji-1,jj-1) ) * ssmask(ji,jj)
+ fspt_2d(ji,jj) = 0.25_wp * ( ( ztabramp(ji ,jj ) + ztabramp(ji-1,jj ) ) & ! add () for NP repro
+ & + ( ztabramp(ji ,jj-1) + ztabramp(ji-1,jj-1) ) ) * ssmask(ji,jj)
fspf_2d(ji,jj) = ztabramp(ji,jj) * ssvmask(ji,jj) * ssvmask(ji,jj+1)
END_2D
CALL lbc_lnk( 'agrif_Sponge_2d', fspu_2d, 'U', 1._wp, fspv_2d, 'V', 1._wp, fspt_2d, 'T', 1._wp, fspf_2d, 'F', 1._wp )
@@ -418,7 +418,7 @@ CONTAINS
END DO
END DO
- IF ( l_vremap.OR.ln_zps ) THEN
+ IF ( l_vremap.OR.l_zps ) THEN
! Fill cell depths (i.e. gdept) to be interpolated
! Warning: these are masked, hence extrapolated prior interpolation.
@@ -512,7 +512,7 @@ CONTAINS
ELSE
- IF ( Agrif_Parent(ln_zps) ) THEN ! Account for partial cells
+ IF ( Agrif_Parent(l_zps) ) THEN ! Account for partial cells
DO jj=j1,j2
DO ji=i1,i2
@@ -573,7 +573,7 @@ CONTAINS
END DO
END DO
!
- IF( ln_zps ) THEN ! set gradient at partial step level
+ IF( l_zps ) THEN ! set gradient at partial step level
DO jj = j1,j2
DO ji = i1,i2
! last level
@@ -593,8 +593,8 @@ CONTAINS
IF (.NOT. tabspongedone_tsn(ji,jj)) THEN
zbtr = r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm_a)
! horizontal diffusive trends
- ztsa = zbtr * ( ztu(ji,jj,jk) - ztu(ji-1,jj,jk) &
- & + ztv(ji,jj,jk) - ztv(ji,jj-1,jk) ) &
+ ztsa = zbtr * ( ( ztu(ji,jj,jk) - ztu(ji-1,jj,jk) ) & ! add () for NP repro
+ & + ( ztv(ji,jj,jk) - ztv(ji,jj-1,jk) ) ) &
& - rn_trelax_tra * r1_Dt * fspt(ji,jj) * tsbdiff(ji,jj,jk,jn)
! add it to the general tracer trends
ts(ji,jj,jk,jn,Krhs_a) = ts(ji,jj,jk,jn,Krhs_a) + ztsa
@@ -730,7 +730,7 @@ CONTAINS
jmax = j2-1
ind1 = jpjglo - ( nn_hls + nbghostcells + 1 ) ! North
- DO jj = mj0(ind1), mj1(ind1)
+ DO jj = mj0(ind1,nn_hls), mj1(ind1,nn_hls)
jmax = MIN(jmax,jj)
END DO
@@ -858,7 +858,7 @@ CONTAINS
imax = i2 - 1
ind1 = jpiglo - ( nn_hls + nbghostcells + 1 ) ! East
- DO ji = mi0(ind1), mi1(ind1)
+ DO ji = mi0(ind1,nn_hls), mi1(ind1,nn_hls)
imax = MIN(imax,ji)
END DO
@@ -958,7 +958,7 @@ CONTAINS
jmax = j2-1
ind1 = jpjglo - ( nn_hls + nbghostcells + 1 ) ! North
- DO jj = mj0(ind1), mj1(ind1)
+ DO jj = mj0(ind1,nn_hls), mj1(ind1,nn_hls)
jmax = MIN(jmax,jj)
END DO
@@ -1025,7 +1025,7 @@ CONTAINS
imax = i2 - 1
ind1 = jpiglo - ( nn_hls + nbghostcells + 1 ) ! East
- DO ji = mi0(ind1), mi1(ind1)
+ DO ji = mi0(ind1,nn_hls), mi1(ind1,nn_hls)
imax = MIN(imax,ji)
END DO
diff --git a/src/NST/agrif_oce_update.F90 b/src/NST/agrif_oce_update.F90
index 3de6bdc211095f2462a5e31e932b89708d06e732..e48bd2dfaf079416266109c44ba7643139ce87da 100644
--- a/src/NST/agrif_oce_update.F90
+++ b/src/NST/agrif_oce_update.F90
@@ -25,7 +25,6 @@ MODULE agrif_oce_update
!
USE in_out_manager ! I/O manager
USE lib_mpp ! MPP library
- USE domvvl ! Need interpolation routines
USE vremap ! Vertical remapping
USE lbclnk
#if defined key_qco
@@ -201,17 +200,17 @@ CONTAINS
#if defined key_qco
!
Agrif_UseSpecialValueInUpdate = .FALSE.
-#if ! defined DECAL_FEEDBACK_2D
+# if ! defined DECAL_FEEDBACK_2D
CALL Agrif_Update_Variable(r3t_id, locupdate=(/ nn_shift_bar,-2/), procname=update_r3t)
CALL Agrif_Update_Variable(r3f_id, locupdate=(/ nn_shift_bar,-2/), procname=update_r3f)
CALL Agrif_Update_Variable(r3u_id, locupdate1=(/ nn_shift_bar,-2/), locupdate2=(/ nn_shift_bar,-2/), procname=update_r3u)
CALL Agrif_Update_Variable(r3v_id, locupdate1=(/ nn_shift_bar,-2/), locupdate2=(/ nn_shift_bar,-2/), procname=update_r3v)
-#else
+# else
CALL Agrif_Update_Variable(r3t_id, locupdate=(/1+nn_shift_bar,-2/), procname=update_r3t)
CALL Agrif_Update_Variable(r3f_id, locupdate=(/1+nn_shift_bar,-2/), procname=update_r3f)
CALL Agrif_Update_Variable(r3u_id, locupdate1=(/ nn_shift_bar,-2/), locupdate2=(/1+nn_shift_bar,-2/), procname=update_r3u)
CALL Agrif_Update_Variable(r3v_id, locupdate1=(/1+nn_shift_bar,-2/), locupdate2=(/ nn_shift_bar,-2/), procname=update_r3v)
-#endif
+# endif
!
! Old way (update e3 at UVF-points everywhere on parent domain):
! CALL Agrif_ChildGrid_To_ParentGrid()
@@ -220,26 +219,6 @@ CONTAINS
#elif defined key_linssh
!
! DO NOTHING HERE
-#else
- Agrif_UseSpecialValueInUpdate = .FALSE.
- l_vremap = ln_vert_remap
-#if ! defined DECAL_FEEDBACK_2D
- CALL Agrif_Update_Variable(e3t_id, locupdate=(/ nn_shift_bar,-2/), procname=update_e3t)
- CALL Agrif_Update_Variable(e3f_id, locupdate=(/ nn_shift_bar,-2/), procname=update_e3f)
- CALL Agrif_Update_Variable(e3u_id, locupdate1=(/ nn_shift_bar,-2/), locupdate2=(/ nn_shift_bar,-2/), procname=update_e3u)
- CALL Agrif_Update_Variable(e3v_id, locupdate1=(/ nn_shift_bar,-2/), locupdate2=(/ nn_shift_bar,-2/), procname=update_e3v)
-#else
- CALL Agrif_Update_Variable(e3t_id, locupdate=(/1+nn_shift_bar,-2/), procname=update_e3t)
- CALL Agrif_Update_Variable(e3f_id, locupdate=(/1+nn_shift_bar,-2/), procname=update_e3f)
- CALL Agrif_Update_Variable(e3u_id, locupdate1=(/ nn_shift_bar,-2/), locupdate2=(/1+nn_shift_bar,-2/), procname=update_e3u)
- CALL Agrif_Update_Variable(e3v_id, locupdate1=(/1+nn_shift_bar,-2/), locupdate2=(/ nn_shift_bar,-2/), procname=update_e3v)
-#endif
- l_vremap = .FALSE.
- !
-! Old way (update e3 at UVF-points everywhere on parent domain):
-! CALL Agrif_ChildGrid_To_ParentGrid()
-! CALL dom_vvl_update_UVF
-! CALL Agrif_ParentGrid_To_ChildGrid()
#endif
!
END SUBROUTINE Agrif_Update_vvl
@@ -261,80 +240,6 @@ CONTAINS
END SUBROUTINE Agrif_Update_qco
#endif
-#if ! defined key_qco && ! defined key_linssh
- SUBROUTINE dom_vvl_update_UVF
- !!---------------------------------------------
- !! *** ROUTINE dom_vvl_update_UVF ***
- !!---------------------------------------------
- !!
- INTEGER :: jk
- REAL(wp):: zcoef
- !!---------------------------------------------
- IF (lwp.AND.lk_agrif_debug) Write(*,*) 'Finalize e3 on grid Number', &
- & Agrif_Fixed(), 'Step', Agrif_Nb_Step()
-
- ! Save "old" scale factor (prior update) for subsequent asselin correction
- ! of prognostic variables
- ! -----------------------
- !
- e3u(:,:,:,Krhs_a) = e3u(:,:,:,Kmm_a)
- e3v(:,:,:,Krhs_a) = e3v(:,:,:,Kmm_a)
- hu(:,:,Krhs_a) = hu(:,:,Kmm_a)
- hv(:,:,Krhs_a) = hv(:,:,Kmm_a)
-
- ! 1) NOW fields
- !--------------
-
- ! Vertical scale factor interpolations
- ! ------------------------------------
- CALL dom_vvl_interpol( e3t(:,:,:,Kmm_a), e3u(:,:,:,Kmm_a) , 'U' )
- CALL dom_vvl_interpol( e3t(:,:,:,Kmm_a), e3v(:,:,:,Kmm_a) , 'V' )
- CALL dom_vvl_interpol( e3u(:,:,:,Kmm_a), e3f(:,:,:) , 'F' )
-
- CALL dom_vvl_interpol( e3u(:,:,:,Kmm_a), e3uw(:,:,:,Kmm_a), 'UW' )
- CALL dom_vvl_interpol( e3v(:,:,:,Kmm_a), e3vw(:,:,:,Kmm_a), 'VW' )
-
- ! Update total depths:
- ! --------------------
- hu(:,:,Kmm_a) = 0._wp ! Ocean depth at U-points
- hv(:,:,Kmm_a) = 0._wp ! Ocean depth at V-points
- DO jk = 1, jpkm1
- hu(:,:,Kmm_a) = hu(:,:,Kmm_a) + e3u(:,:,jk,Kmm_a) * umask(:,:,jk)
- hv(:,:,Kmm_a) = hv(:,:,Kmm_a) + e3v(:,:,jk,Kmm_a) * vmask(:,:,jk)
- END DO
- ! ! Inverse of the local depth
- r1_hu(:,:,Kmm_a) = ssumask(:,:) / ( hu(:,:,Kmm_a) + 1._wp - ssumask(:,:) )
- r1_hv(:,:,Kmm_a) = ssvmask(:,:) / ( hv(:,:,Kmm_a) + 1._wp - ssvmask(:,:) )
-
-
- ! 2) BEFORE fields:
- !------------------
- IF (.NOT.(lk_agrif_fstep.AND.(l_1st_euler) )) THEN
- !
- ! Vertical scale factor interpolations
- ! ------------------------------------
- CALL dom_vvl_interpol( e3t(:,:,:,Kbb_a), e3u(:,:,:,Kbb_a), 'U' )
- CALL dom_vvl_interpol( e3t(:,:,:,Kbb_a), e3v(:,:,:,Kbb_a), 'V' )
-
- CALL dom_vvl_interpol( e3u(:,:,:,Kbb_a), e3uw(:,:,:,Kbb_a), 'UW' )
- CALL dom_vvl_interpol( e3v(:,:,:,Kbb_a), e3vw(:,:,:,Kbb_a), 'VW' )
-
- ! Update total depths:
- ! --------------------
- hu(:,:,Kbb_a) = 0._wp ! Ocean depth at U-points
- hv(:,:,Kbb_a) = 0._wp ! Ocean depth at V-points
- DO jk = 1, jpkm1
- hu(:,:,Kbb_a) = hu(:,:,Kbb_a) + e3u(:,:,jk,Kbb_a) * umask(:,:,jk)
- hv(:,:,Kbb_a) = hv(:,:,Kbb_a) + e3v(:,:,jk,Kbb_a) * vmask(:,:,jk)
- END DO
- ! ! Inverse of the local depth
- r1_hu(:,:,Kbb_a) = ssumask(:,:) / ( hu(:,:,Kbb_a) + 1._wp - ssumask(:,:) )
- r1_hv(:,:,Kbb_a) = ssvmask(:,:) / ( hv(:,:,Kbb_a) + 1._wp - ssvmask(:,:) )
- ENDIF
- !
- END SUBROUTINE dom_vvl_update_UVF
-#endif
-
SUBROUTINE updateTS( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before )
!!----------------------------------------------------------------------
@@ -1321,7 +1226,6 @@ CONTAINS
e3w (i1:i2,j1:j2,1,Kmm_a) = e3w_0(i1:i2,j1:j2,1) + e3t(i1:i2,j1:j2,1,Kmm_a) - e3t_0(i1:i2,j1:j2,1)
gdept(i1:i2,j1:j2,1,Kmm_a) = 0.5_wp * e3w(i1:i2,j1:j2,1,Kmm_a)
gdepw(i1:i2,j1:j2,1,Kmm_a) = 0.0_wp
- gde3w(i1:i2,j1:j2,1) = gdept(i1:i2,j1:j2,1,Kmm_a) - (ht(i1:i2,j1:j2)-ht_0(i1:i2,j1:j2)) ! Last term in the rhs is ssh
!
DO jk = 2, jpkm1
DO jj = j1,j2
@@ -1332,7 +1236,6 @@ CONTAINS
gdepw(ji,jj,jk,Kmm_a) = gdepw(ji,jj,jk-1,Kmm_a) + e3t(ji,jj,jk-1,Kmm_a)
gdept(ji,jj,jk,Kmm_a) = zcoef * ( gdepw(ji,jj,jk ,Kmm_a) + 0.5_wp * e3w(ji,jj,jk,Kmm_a)) &
& + (1-zcoef) * ( gdept(ji,jj,jk-1,Kmm_a) + e3w(ji,jj,jk,Kmm_a))
- gde3w(ji,jj,jk) = gdept(ji,jj,jk,Kmm_a) - (ht(ji,jj)-ht_0(ji,jj)) ! Last term in the rhs is ssh
END DO
END DO
END DO
@@ -1894,7 +1797,7 @@ CONTAINS
DO jk=k1,k2-1
IF (ABS((ptab(ji,jj,jk)-e3u_0(ji,jj,jk))*umask(ji,jj,jk)).GE.1.e-6) THEN
kindic_agr = kindic_agr + 1
- print *, 'erro u-pt', mig0(ji), mjg0(jj), jk, mbku(ji,jj), ikbot, ptab(ji,jj,jk), e3u_0(ji,jj,jk)
+ PRINT *, 'erro u-pt', mig(ji,0), mjg(jj,0), jk, mbku(ji,jj), ikbot, ptab(ji,jj,jk), e3u_0(ji,jj,jk)
ENDIF
END DO
ENDIF
@@ -1934,7 +1837,7 @@ CONTAINS
DO jk=k1,k2-1
IF (ABS((ptab(ji,jj,jk)-e3v_0(ji,jj,jk))*vmask(ji,jj,jk)).GE.1.e-6) THEN
kindic_agr = kindic_agr + 1
- print *, 'erro v-pt', mig0(ji), mjg0(jj), mbkv(ji,jj), ptab(ji,jj,jk), e3v_0(ji,jj,jk)
+ PRINT *, 'erro v-pt', mig(ji,0), mjg(jj,0), mbkv(ji,jj), ptab(ji,jj,jk), e3v_0(ji,jj,jk)
ENDIF
END DO
ENDIF
diff --git a/src/NST/agrif_top_interp.F90 b/src/NST/agrif_top_interp.F90
index 23ad775defe6e241e9344e484a4142b6120aeddc..cbd489e7057abc0e531442b52a6c445e6bed6c71 100644
--- a/src/NST/agrif_top_interp.F90
+++ b/src/NST/agrif_top_interp.F90
@@ -105,7 +105,7 @@ CONTAINS
END DO
END DO
- IF( l_vremap .OR. l_ini_child .OR. ln_zps ) THEN
+ IF( l_vremap .OR. l_ini_child .OR. l_zps ) THEN
! Fill cell depths (i.e. gdept) to be interpolated
! Warning: these are masked, hence extrapolated prior interpolation.
DO jj=j1,j2
@@ -198,7 +198,7 @@ CONTAINS
ELSE
- IF ( Agrif_Parent(ln_zps) ) THEN ! Account for partial cells
+ IF ( Agrif_Parent(l_zps) ) THEN ! Account for partial cells
! linear vertical interpolation
DO jj=j1,j2
DO ji=i1,i2
diff --git a/src/NST/agrif_top_sponge.F90 b/src/NST/agrif_top_sponge.F90
index 641b9de74e96a4e352885b4c0cadddabd210ab70..a3706693f70e7e90f41bbdf2c93b927c0bb88c47 100644
--- a/src/NST/agrif_top_sponge.F90
+++ b/src/NST/agrif_top_sponge.F90
@@ -98,7 +98,7 @@ CONTAINS
END DO
END DO
- IF ( l_vremap.OR.ln_zps ) THEN
+ IF ( l_vremap.OR.l_zps ) THEN
! Fill cell depths (i.e. gdept) to be interpolated
! Warning: these are masked, hence extrapolated prior interpolation.
@@ -191,7 +191,7 @@ CONTAINS
ELSE
- IF ( Agrif_Parent(ln_zps) ) THEN ! Account for partial cells
+ IF ( Agrif_Parent(l_zps) ) THEN ! Account for partial cells
DO jj=j1,j2
DO ji=i1,i2
@@ -245,7 +245,7 @@ CONTAINS
END DO
END DO
!
- IF( ln_zps ) THEN ! set gradient at partial step level
+ IF( l_zps ) THEN ! set gradient at partial step level
DO jj = j1,j2
DO ji = i1,i2
! last level
@@ -265,8 +265,8 @@ CONTAINS
IF (.NOT. tabspongedone_trn(ji,jj)) THEN
zbtr = r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm_a)
! horizontal diffusive trends
- ztra = zbtr * ( ztu(ji,jj,jk) - ztu(ji-1,jj,jk) &
- & + ztv(ji,jj,jk) - ztv(ji,jj-1,jk) ) &
+ ztra = zbtr * ( ( ztu(ji,jj,jk) - ztu(ji-1,jj,jk) ) & ! add () for NP repro
+ & + ( ztv(ji,jj,jk) - ztv(ji,jj-1,jk) ) ) &
& - rn_trelax_tra * r1_Dt * fspt(ji,jj) * trbdiff(ji,jj,jk,jn)
! add it to the general tracer trends
tr(ji,jj,jk,jn,Krhs_a) = tr(ji,jj,jk,jn,Krhs_a) + ztra
diff --git a/src/NST/agrif_user.F90 b/src/NST/agrif_user.F90
index cdace1b36ed8b1fe1373f7850a7f111cb7120d02..bfe0ec9e14abd195c7ac2e1aeb249ce5f2e49c04 100644
--- a/src/NST/agrif_user.F90
+++ b/src/NST/agrif_user.F90
@@ -270,7 +270,7 @@
mbku_parent(ji,jj) = MIN( mbkt_parent(ji+1,jj ), mbkt_parent(ji,jj) )
mbkv_parent(ji,jj) = MIN( mbkt_parent(ji ,jj+1), mbkt_parent(ji,jj) )
END_2D
- IF ( ln_sco.AND.Agrif_Parent(ln_sco) ) THEN
+ IF ( l_sco.AND.Agrif_Parent(l_sco) ) THEN
DO_2D( 1, 0, 1, 0 )
hu0_parent(ji,jj) = 0.5_wp * ( ht0_parent(ji,jj)+ht0_parent(ji+1,jj) ) * ssumask(ji,jj)
hv0_parent(ji,jj) = 0.5_wp * ( ht0_parent(ji,jj)+ht0_parent(ji,jj+1) ) * ssvmask(ji,jj)
@@ -313,7 +313,7 @@
END_3D
! Assume a step at the bottom except if (pure) s-coordinates
- IF ( .NOT.Agrif_Parent(ln_sco) ) THEN
+ IF ( .NOT.Agrif_Parent(l_sco) ) THEN
DO_2D( 1, 0, 1, 0 )
jk = mbku_parent(ji,jj)
e3u0_parent(ji,jj,jk) = MIN(e3t0_parent(ji,jj,jk), e3t0_parent(ji+1,jj ,jk))
@@ -1104,8 +1104,8 @@
!!----------------------------------------------------------------------
!
SELECT CASE( i )
- CASE(1) ; indglob = mig(indloc)
- CASE(2) ; indglob = mjg(indloc)
+ CASE(1) ; indglob = mig(indloc,nn_hls)
+ CASE(2) ; indglob = mjg(indloc,nn_hls)
CASE DEFAULT ; indglob = indloc
END SELECT
!
@@ -1124,10 +1124,10 @@
INTEGER, INTENT(out) :: jmin, jmax
!!----------------------------------------------------------------------
!
- imin = mig( 1 )
- jmin = mjg( 1 )
- imax = mig(jpi)
- jmax = mjg(jpj)
+ imin = mig( 1 ,nn_hls)
+ jmin = mjg( 1 ,nn_hls)
+ imax = mig(jpi,nn_hls)
+ jmax = mjg(jpj,nn_hls)
!
END SUBROUTINE Agrif_get_proc_info
diff --git a/src/OCE/ASM/asminc.F90 b/src/OCE/ASM/asminc.F90
index 54371a62c3b73a6d626d97937dbbf52d20a565b8..9d5c6701cb1c5e1709a4e5f8d102582cb556cb47 100644
--- a/src/OCE/ASM/asminc.F90
+++ b/src/OCE/ASM/asminc.F90
@@ -25,10 +25,8 @@ MODULE asminc
USE oce ! Dynamics and active tracers defined in memory
USE par_oce ! Ocean space and time domain variables
USE dom_oce ! Ocean space and time domain
- USE domvvl ! domain: variable volume level
USE ldfdyn ! lateral diffusion: eddy viscosity coefficients
USE eosbn2 ! Equation of state - in situ and potential density
- USE zpshde ! Partial step : Horizontal Derivative
USE asmpar ! Parameters for the assmilation interface
USE asmbkg !
USE c1d ! 1D initialization
@@ -519,17 +517,8 @@ CONTAINS
INTEGER :: ji, jj, jk
INTEGER :: it
REAL(wp) :: zincwgt ! IAU weight for current time step
- REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: fzptnz ! 3d freezing point values
+ REAL(wp), DIMENSION(:,:), ALLOCATABLE :: fzptnz, zdep2d ! freezing point values
!!----------------------------------------------------------------------
- !
- ! freezing point calculation taken from oc_fz_pt (but calculated for all depths)
- ! used to prevent the applied increments taking the temperature below the local freezing point
- IF( ln_temnofreeze ) THEN
- DO jk = 1, jpkm1
- CALL eos_fzp( pts(:,:,jk,jp_sal,Kmm), fzptnz(:,:,jk), gdept(:,:,jk,Kmm) )
- END DO
- ENDIF
- !
! !--------------------------------------
IF ( ln_asmiau ) THEN ! Incremental Analysis Updating
! !--------------------------------------
@@ -547,13 +536,21 @@ CONTAINS
ENDIF
ENDIF
!
+ IF( ln_temnofreeze ) ALLOCATE( fzptnz(T2D(0)), zdep2d(T2D(0)) )
+ !
! Update the tracer tendencies
DO jk = 1, jpkm1
IF (ln_temnofreeze) THEN
! Do not apply negative increments if the temperature will fall below freezing
- WHERE(t_bkginc(A2D(0),jk) > 0.0_wp .OR. &
- & pts(A2D(0),jk,jp_tem,Kmm) + pts(A2D(0),jk,jp_tem,Krhs) + t_bkginc(A2D(0),jk) * wgtiau(it) > fzptnz(:,:,jk) )
- pts(A2D(0),jk,jp_tem,Krhs) = pts(A2D(0),jk,jp_tem,Krhs) + t_bkginc(A2D(0),jk) * zincwgt
+ ! NOTE: @sibylle- I kept this using the old eos_fzp because with the new I have to specify pts(:,:,jk,:,:), which creates a temporary array. I moved the eos_fzp call here (and below in the ln_asmdin part) because then we only need a 2D fzptnz
+ DO_2D( 0, 0, 0, 0 )
+ zdep2d(ji,jj) = gdept(ji,jj,jk,Kmm) ! better solution: define an interface for eos_fzp when gdept(ji,jj,jk,Kmm) is a scalar
+ END_2D
+ CALL eos_fzp( pts(:,:,jk,jp_sal,Kmm), fzptnz(:,:), zdep2d(:,:), kbnd=0 )
+ !
+ WHERE(t_bkginc(T2D(0),jk) > 0.0_wp .OR. &
+ & pts(T2D(0),jk,jp_tem,Kmm) + pts(T2D(0),jk,jp_tem,Krhs) + t_bkginc(T2D(0),jk) * wgtiau(it) > fzptnz(:,:) )
+ pts(T2D(0),jk,jp_tem,Krhs) = pts(T2D(0),jk,jp_tem,Krhs) + t_bkginc(T2D(0),jk) * zincwgt
END WHERE
ELSE
DO_2D( 0, 0, 0, 0 )
@@ -563,9 +560,9 @@ CONTAINS
IF (ln_salfix) THEN
! Do not apply negative increments if the salinity will fall below a specified
! minimum value salfixmin
- WHERE(s_bkginc(A2D(0),jk) > 0.0_wp .OR. &
- & pts(A2D(0),jk,jp_sal,Kmm) + pts(A2D(0),jk,jp_sal,Krhs) + s_bkginc(A2D(0),jk) * wgtiau(it) > salfixmin )
- pts(A2D(0),jk,jp_sal,Krhs) = pts(A2D(0),jk,jp_sal,Krhs) + s_bkginc(A2D(0),jk) * zincwgt
+ WHERE(s_bkginc(T2D(0),jk) > 0.0_wp .OR. &
+ & pts(T2D(0),jk,jp_sal,Kmm) + pts(T2D(0),jk,jp_sal,Krhs) + s_bkginc(T2D(0),jk) * wgtiau(it) > salfixmin )
+ pts(T2D(0),jk,jp_sal,Krhs) = pts(T2D(0),jk,jp_sal,Krhs) + s_bkginc(T2D(0),jk) * zincwgt
END WHERE
ELSE
DO_2D( 0, 0, 0, 0 )
@@ -574,6 +571,8 @@ CONTAINS
ENDIF
END DO
!
+ IF( ln_temnofreeze ) DEALLOCATE( fzptnz, zdep2d )
+ !
ENDIF
!
IF( .NOT. l_istiled .OR. ntile == nijtile ) THEN ! Do only on the last tile
@@ -593,9 +592,20 @@ CONTAINS
! Initialize the now fields with the background + increment
IF (ln_temnofreeze) THEN
! Do not apply negative increments if the temperature will fall below freezing
- WHERE( t_bkginc(:,:,:) > 0.0_wp .OR. pts(:,:,:,jp_tem,Kmm) + t_bkginc(:,:,:) > fzptnz(:,:,:) )
- pts(:,:,:,jp_tem,Kmm) = t_bkg(:,:,:) + t_bkginc(:,:,:)
- END WHERE
+ ALLOCATE( fzptnz(A2D(nn_hls)), zdep2d(T2D(nn_hls)) )
+ !
+ DO jk = 1, jpkm1
+ DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ zdep2d(ji,jj) = gdept(ji,jj,jk,Kmm) ! better solution: define an interface for eos_fzp when gdept(ji,jj,jk,Kmm) is a scalar
+ END_2D
+ CALL eos_fzp( pts(:,:,jk,jp_sal,Kmm), fzptnz(:,:), zdep2d(:,:) )
+ !
+ WHERE( t_bkginc(:,:,jk) > 0.0_wp .OR. pts(:,:,jk,jp_tem,Kmm) + t_bkginc(:,:,jk) > fzptnz(:,:) )
+ pts(:,:,jk,jp_tem,Kmm) = t_bkg(:,:,jk) + t_bkginc(:,:,jk)
+ END WHERE
+ END DO
+ !
+ DEALLOCATE( fzptnz, zdep2d )
ELSE
pts(:,:,:,jp_tem,Kmm) = t_bkg(:,:,:) + t_bkginc(:,:,:)
ENDIF
@@ -610,18 +620,7 @@ CONTAINS
ENDIF
pts(:,:,:,:,Kbb) = pts(:,:,:,:,Kmm) ! Update before fields
-
- CALL eos( pts(:,:,:,:,Kbb), rhd, rhop, gdept_0(:,:,:) ) ! Before potential and in situ densities
-!!gm fabien
-! CALL eos( pts(:,:,:,:,Kbb), rhd, rhop ) ! Before potential and in situ densities
-!!gm
-
- IF( ln_zps .AND. .NOT. ln_c1d .AND. .NOT. ln_isfcav) &
- & CALL zps_hde ( kt, jpts, pts(:,:,:,:,Kbb), gtsu, gtsv, & ! Partial steps: before horizontal gradient
- & rhd, gru , grv ) ! of t, s, rd at the last ocean level
- IF( ln_zps .AND. .NOT. ln_c1d .AND. ln_isfcav) &
- & CALL zps_hde_isf( nit000, jpts, pts(:,:,:,:,Kbb), gtsu, gtsv, gtui, gtvi, & ! Partial steps for top cell (ISF)
- & rhd, gru , grv , grui, grvi ) ! of t, s, rd at the last ocean level
+ CALL eos( pts, Kbb, rhd, rhop ) ! Before potential and in situ densities
DEALLOCATE( t_bkginc )
DEALLOCATE( s_bkginc )
@@ -781,7 +780,7 @@ CONTAINS
ssh(:,:,Kmm) = ssh_bkg(:,:) + ssh_bkginc(:,:) ! Initialize the now fields the background + increment
!
ssh(:,:,Kbb) = ssh(:,:,Kmm) ! Update before fields
-#if ! defined key_qco
+#if ! defined key_qco && ! defined key_linssh
e3t(:,:,:,Kbb) = e3t(:,:,:,Kmm)
#endif
!!gm why not e3u(:,:,:,Kbb), e3v(:,:,:,Kbb), gdept(:,:,:,Kbb) ????
@@ -821,13 +820,13 @@ CONTAINS
CALL ssh_asm_inc( kt, Kbb, Kmm ) !== (calculate increments)
!
IF( ln_linssh ) THEN
- DO_2D_OVR( nn_hls-1, nn_hls, nn_hls-1, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
phdivn(ji,jj,1) = phdivn(ji,jj,1) - ssh_iau(ji,jj) / e3t(ji,jj,1,Kmm) * tmask(ji,jj,1)
END_2D
ELSE
- ALLOCATE( ztim(A2D(nn_hls)) )
- DO_2D_OVR( nn_hls-1, nn_hls, nn_hls-1, nn_hls )
- ztim(ji,jj) = ssh_iau(ji,jj) / ( ht(ji,jj) + 1.0 - ssmask(ji,jj) )
+ ALLOCATE( ztim(T2D(0)) )
+ DO_2D( 0, 0, 0, 0 )
+ ztim(ji,jj) = ssh_iau(ji,jj) / ( ht(ji,jj,Kmm) + 1.0 - ssmask(ji,jj) )
DO jk = 1, jpkm1
phdivn(ji,jj,jk) = phdivn(ji,jj,jk) - ztim(ji,jj) * tmask(ji,jj,jk)
END DO
@@ -858,7 +857,7 @@ CONTAINS
INTEGER :: it
REAL(wp) :: zincwgt ! IAU weight for current time step
#if defined key_si3
- REAL(wp), DIMENSION(A2D(nn_hls)) :: zofrld, zohicif, zseaicendg, zhicifinc
+ REAL(wp), DIMENSION(T2D(0)) :: zofrld, zohicif, zseaicendg, zhicifinc
REAL(wp) :: zhicifmin = 0.5_wp ! ice minimum depth in metres
#endif
!!----------------------------------------------------------------------
@@ -896,8 +895,8 @@ CONTAINS
END_2D
!
! Nudge sea ice depth to bring it up to a required minimum depth
- WHERE( zseaicendg(:,:) > 0.0_wp .AND. hm_i(A2D(0)) < zhicifmin )
- zhicifinc(:,:) = (zhicifmin - hm_i(A2D(0))) * zincwgt
+ WHERE( zseaicendg(:,:) > 0.0_wp .AND. hm_i(T2D(0)) < zhicifmin )
+ zhicifinc(:,:) = (zhicifmin - hm_i(T2D(0))) * zincwgt
ELSEWHERE
zhicifinc(:,:) = 0.0_wp
END WHERE
@@ -956,8 +955,8 @@ CONTAINS
END_2D
!
! Nudge sea ice depth to bring it up to a required minimum depth
- WHERE( zseaicendg(:,:) > 0.0_wp .AND. hm_i(A2D(0)) < zhicifmin )
- zhicifinc(:,:) = zhicifmin - hm_i(A2D(0))
+ WHERE( zseaicendg(:,:) > 0.0_wp .AND. hm_i(T2D(0)) < zhicifmin )
+ zhicifinc(:,:) = zhicifmin - hm_i(T2D(0))
ELSEWHERE
zhicifinc(:,:) = 0.0_wp
END WHERE
diff --git a/src/OCE/BDY/bdydyn.F90 b/src/OCE/BDY/bdydyn.F90
index 61e4d378d12667ffb19f81dd40b40612c89c9e84..8402aba6597ae437ea1dc6ee6c1f6d86a206bc76 100644
--- a/src/OCE/BDY/bdydyn.F90
+++ b/src/OCE/BDY/bdydyn.F90
@@ -22,7 +22,6 @@ MODULE bdydyn
USE bdydyn3d ! open boundary conditions for baroclinic velocities
USE lbclnk ! ocean lateral boundary conditions (or mpp link)
USE in_out_manager !
- USE domvvl ! variable volume
IMPLICIT NONE
PRIVATE
diff --git a/src/OCE/BDY/bdyice.F90 b/src/OCE/BDY/bdyice.F90
index cf2ea3a228184d1318b4ccbba500756f0ddf8295..409e0cadc2213b470cfe119587520af8330799d8 100644
--- a/src/OCE/BDY/bdyice.F90
+++ b/src/OCE/BDY/bdyice.F90
@@ -62,7 +62,7 @@ CONTAINS
! controls
IF( ln_timing ) CALL timing_start('bdy_ice_thd') ! timing
!
- CALL ice_var_glo2eqv
+ CALL ice_var_glo2eqv(2)
!
llsend1(:) = .false. ; llrecv1(:) = .false.
DO ir = 1, 0, -1 ! treat rim 1 before rim 0
@@ -96,14 +96,19 @@ CONTAINS
& , a_ip, 'T', 1._wp, v_ip, 'T', 1._wp, v_il, 'T', 1._wp &
& , kfillmode=jpfillnothing ,lsend=llsend1, lrecv=llrecv1 )
! exchange 4d arrays : third dimension = 1 and then third dimension = jpk
- CALL lbc_lnk('bdyice', t_s , 'T', 1._wp, e_s , 'T', 1._wp, kfillmode=jpfillnothing ,lsend=llsend1, lrecv=llrecv1 )
- CALL lbc_lnk('bdyice', t_i , 'T', 1._wp, e_i , 'T', 1._wp, kfillmode=jpfillnothing ,lsend=llsend1, lrecv=llrecv1 )
+ CALL lbc_lnk('bdyice', t_s , 'T', 1._wp, e_s , 'T', 1._wp, t_i , 'T', 1._wp, e_i , 'T', 1._wp, &
+ & kfillmode=jpfillnothing ,lsend=llsend1, lrecv=llrecv1 )
END IF
END DO ! ir
!
CALL ice_cor( kt , 0 ) ! -- In case categories are out of bounds, do a remapping
! ! i.e. inputs have not the same ice thickness distribution (set by rn_himean)
! ! than the regional simulation
+ ! ! -- lbc_lnk needed because of iceitd_reb that is called in icecor.F90
+ CALL lbc_lnk( 'bdyice', a_i , 'T', 1._wp, v_i , 'T', 1._wp, v_s , 'T', 1._wp, sv_i, 'T', 1._wp, oa_i, 'T', 1._wp, &
+ & t_su, 'T', 1._wp, a_ip, 'T', 1._wp, v_ip, 'T', 1._wp, v_il, 'T', 1._wp )
+ CALL lbc_lnk( 'bdyice', e_i , 'T', 1._wp, e_s , 'T', 1._wp )
+ !
CALL ice_var_agg(1)
!
! controls
diff --git a/src/OCE/BDY/bdyini.F90 b/src/OCE/BDY/bdyini.F90
index 3de3150bc35646f23e78a8d4b8cf85977f7ffb31..e0b1fe6d85d0fd968a65e778b9df0ee6ecf40a2a 100644
--- a/src/OCE/BDY/bdyini.F90
+++ b/src/OCE/BDY/bdyini.F90
@@ -491,10 +491,10 @@ CONTAINS
! Find lenght of boundaries and rim on local mpi domain
!------------------------------------------------------
!
- iwe = mig(1)
- ies = mig(jpi)
- iso = mjg(1)
- ino = mjg(jpj)
+ iwe = mig( 1,nn_hls)
+ ies = mig(jpi,nn_hls)
+ iso = mjg( 1,nn_hls)
+ ino = mjg(jpj,nn_hls)
!
DO ib_bdy = 1, nb_bdy
DO igrd = 1, jpbgrd
@@ -554,8 +554,8 @@ CONTAINS
& nbrdta(ib,igrd,ib_bdy) == ir ) THEN
!
icount = icount + 1
- idx_bdy(ib_bdy)%nbi(icount,igrd) = nbidta(ib,igrd,ib_bdy) - mig(1) + 1 ! global to local indexes
- idx_bdy(ib_bdy)%nbj(icount,igrd) = nbjdta(ib,igrd,ib_bdy) - mjg(1) + 1 ! global to local indexes
+ idx_bdy(ib_bdy)%nbi(icount,igrd) = nbidta(ib,igrd,ib_bdy) - mig(1,nn_hls) + 1 ! global to local indexes
+ idx_bdy(ib_bdy)%nbj(icount,igrd) = nbjdta(ib,igrd,ib_bdy) - mjg(1,nn_hls) + 1 ! global to local indexes
idx_bdy(ib_bdy)%nbr(icount,igrd) = nbrdta(ib,igrd,ib_bdy)
idx_bdy(ib_bdy)%nbmap(icount,igrd) = ib
ENDIF
@@ -1014,7 +1014,7 @@ CONTAINS
DO ib = 1, idx_bdy(ib_bdy)%nblenrim(igrd)
ii = idx_bdy(ib_bdy)%nbi(ib,igrd)
ij = idx_bdy(ib_bdy)%nbj(ib,igrd)
- IF( mig0(ii) > 2 .AND. mig0(ii) < Ni0glo-2 .AND. mjg0(ij) > 2 .AND. mjg0(ij) < Nj0glo-2 ) THEN
+ IF( mig(ii,0) > 2 .AND. mig(ii,0) < Ni0glo-2 .AND. mjg(ij,0) > 2 .AND. mjg(ij,0) < Nj0glo-2 ) THEN
WRITE(ctmp1,*) ' Orlanski is not safe when the open boundaries are on the interior of the computational domain'
CALL ctl_stop( ctmp1 )
END IF
@@ -1090,7 +1090,7 @@ CONTAINS
! This error check only works if you are using the bdyXmask arrays (which are set to 0 on rims)
IF( i_offset == 1 .and. zefl + zwfl == 2._wp ) THEN
icount = icount + 1
- IF(lwp) WRITE(numout,*) 'Problem with igrd = ',igrd,' at (global) nbi, nbj : ',mig(ii),mjg(ij)
+ IF(lwp) WRITE(numout,*) 'Problem with igrd = ',igrd,' at (global) nbi, nbj : ',mig(ii,nn_hls),mjg(ij,nn_hls)
ELSE
ztmp(ii,ij) = -zwfl + zefl
ENDIF
@@ -1130,7 +1130,7 @@ CONTAINS
znfl = zmask(ii,ij+j_offset )
! This error check only works if you are using the bdyXmask arrays (which are set to 0 on rims)
IF( j_offset == 1 .and. znfl + zsfl == 2._wp ) THEN
- IF(lwp) WRITE(numout,*) 'Problem with igrd = ',igrd,' at (global) nbi, nbj : ',mig(ii),mjg(ij)
+ IF(lwp) WRITE(numout,*) 'Problem with igrd = ',igrd,' at (global) nbi, nbj : ',mig(ii,nn_hls),mjg(ij,nn_hls)
icount = icount + 1
ELSE
ztmp(ii,ij) = -zsfl + znfl
@@ -1594,8 +1594,8 @@ CONTAINS
ztestmask(1:2)=0.
DO ji = 1, jpi
DO jj = 1, jpj
- IF( mig0(ji) == jpiwob(ib) .AND. mjg0(jj) == jpjwdt(ib) ) ztestmask(1) = tmask(ji,jj,1)
- IF( mig0(ji) == jpiwob(ib) .AND. mjg0(jj) == jpjwft(ib) ) ztestmask(2) = tmask(ji,jj,1)
+ IF( mig(ji,0) == jpiwob(ib) .AND. mjg(jj,0) == jpjwdt(ib) ) ztestmask(1) = tmask(ji,jj,1)
+ IF( mig(ji,0) == jpiwob(ib) .AND. mjg(jj,0) == jpjwft(ib) ) ztestmask(2) = tmask(ji,jj,1)
END DO
END DO
CALL mpp_sum( 'bdyini', ztestmask, 2 ) ! sum over the global domain
@@ -1630,8 +1630,8 @@ CONTAINS
ztestmask(1:2)=0.
DO ji = 1, jpi
DO jj = 1, jpj
- IF( mig0(ji) == jpieob(ib)+1 .AND. mjg0(jj) == jpjedt(ib) ) ztestmask(1) = tmask(ji,jj,1)
- IF( mig0(ji) == jpieob(ib)+1 .AND. mjg0(jj) == jpjeft(ib) ) ztestmask(2) = tmask(ji,jj,1)
+ IF( mig(ji,0) == jpieob(ib)+1 .AND. mjg(jj,0) == jpjedt(ib) ) ztestmask(1) = tmask(ji,jj,1)
+ IF( mig(ji,0) == jpieob(ib)+1 .AND. mjg(jj,0) == jpjeft(ib) ) ztestmask(2) = tmask(ji,jj,1)
END DO
END DO
CALL mpp_sum( 'bdyini', ztestmask, 2 ) ! sum over the global domain
@@ -1666,8 +1666,8 @@ CONTAINS
ztestmask(1:2)=0.
DO ji = 1, jpi
DO jj = 1, jpj
- IF( mjg0(jj) == jpjsob(ib) .AND. mig0(ji) == jpisdt(ib) ) ztestmask(1) = tmask(ji,jj,1)
- IF( mjg0(jj) == jpjsob(ib) .AND. mig0(ji) == jpisft(ib) ) ztestmask(2) = tmask(ji,jj,1)
+ IF( mjg(jj,0) == jpjsob(ib) .AND. mig(ji,0) == jpisdt(ib) ) ztestmask(1) = tmask(ji,jj,1)
+ IF( mjg(jj,0) == jpjsob(ib) .AND. mig(ji,0) == jpisft(ib) ) ztestmask(2) = tmask(ji,jj,1)
END DO
END DO
CALL mpp_sum( 'bdyini', ztestmask, 2 ) ! sum over the global domain
@@ -1688,8 +1688,8 @@ CONTAINS
ztestmask(1:2)=0.
DO ji = 1, jpi
DO jj = 1, jpj
- IF( mjg0(jj) == jpjnob(ib)+1 .AND. mig0(ji) == jpindt(ib) ) ztestmask(1) = tmask(ji,jj,1)
- IF( mjg0(jj) == jpjnob(ib)+1 .AND. mig0(ji) == jpinft(ib) ) ztestmask(2) = tmask(ji,jj,1)
+ IF( mjg(jj,0) == jpjnob(ib)+1 .AND. mig(ji,0) == jpindt(ib) ) ztestmask(1) = tmask(ji,jj,1)
+ IF( mjg(jj,0) == jpjnob(ib)+1 .AND. mig(ji,0) == jpinft(ib) ) ztestmask(2) = tmask(ji,jj,1)
END DO
END DO
CALL mpp_sum( 'bdyini', ztestmask, 2 ) ! sum over the global domain
diff --git a/src/OCE/BDY/bdyvol.F90 b/src/OCE/BDY/bdyvol.F90
index e058d671be6c229ac823a15b442dfdb9a15c105b..883d27c12919dd18d58ddf993b290f5d8ba4fcea 100644
--- a/src/OCE/BDY/bdyvol.F90
+++ b/src/OCE/BDY/bdyvol.F90
@@ -99,14 +99,16 @@ CONTAINS
ii = idx%nbi(jb,jgrd)
ij = idx%nbj(jb,jgrd)
IF( ii == 1 .OR. ii == jpi .OR. ij == 1 .OR. ij == jpj ) CYCLE ! sum : else halo couted twice
- zubtpecor = zubtpecor + idx%flagu(jb,jgrd) * pua2d(ii,ij) * e2u(ii,ij) * phu(ii,ij) * tmask_i(ii,ij) * tmask_i(ii+1,ij)
+ zubtpecor = zubtpecor + idx%flagu(jb,jgrd) * pua2d(ii,ij) * e2u(ii,ij) * phu(ii,ij) &
+ & * ( tmask_i(ii,ij) * tmask_i(ii+1,ij) )
END DO
jgrd = 3 ! then add v component contribution
DO jb = 1, idx%nblenrim(jgrd)
ii = idx%nbi(jb,jgrd)
ij = idx%nbj(jb,jgrd)
IF( ii == 1 .OR. ii == jpi .OR. ij == 1 .OR. ij == jpj ) CYCLE ! sum : else halo couted twice
- zubtpecor = zubtpecor + idx%flagv(jb,jgrd) * pva2d(ii,ij) * e1v(ii,ij) * phv(ii,ij) * tmask_i(ii,ij) * tmask_i(ii,ij+1)
+ zubtpecor = zubtpecor + idx%flagv(jb,jgrd) * pva2d(ii,ij) * e1v(ii,ij) * phv(ii,ij) &
+ & * ( tmask_i(ii,ij) * tmask_i(ii,ij+1) )
END DO
!
END DO
@@ -128,14 +130,14 @@ CONTAINS
ii = idx%nbi(jb,jgrd)
ij = idx%nbj(jb,jgrd)
!IF( ii == 1 .OR. ii == jpi .OR. ij == 1 .OR. ij == jpj ) CYCLE ! to remove ?
- pua2d(ii,ij) = pua2d(ii,ij) - idx%flagu(jb,jgrd) * zubtpecor * tmask_i(ii,ij) * tmask_i(ii+1,ij)
+ pua2d(ii,ij) = pua2d(ii,ij) - idx%flagu(jb,jgrd) * zubtpecor * ( tmask_i(ii,ij) * tmask_i(ii+1,ij) )
END DO
jgrd = 3 ! correct v component
DO jb = 1, idx%nblenrim(jgrd)
ii = idx%nbi(jb,jgrd)
ij = idx%nbj(jb,jgrd)
!IF( ii == 1 .OR. ii == jpi .OR. ij == 1 .OR. ij == jpj ) CYCLE ! to remove ?
- pva2d(ii,ij) = pva2d(ii,ij) - idx%flagv(jb,jgrd) * zubtpecor * tmask_i(ii,ij) * tmask_i(ii,ij+1)
+ pva2d(ii,ij) = pva2d(ii,ij) - idx%flagv(jb,jgrd) * zubtpecor * ( tmask_i(ii,ij) * tmask_i(ii,ij+1) )
END DO
!
END DO
@@ -154,14 +156,16 @@ CONTAINS
ii = idx%nbi(jb,jgrd)
ij = idx%nbj(jb,jgrd)
IF( ii == 1 .OR. ii == jpi .OR. ij == 1 .OR. ij == jpj ) CYCLE
- ztranst = ztranst + idx%flagu(jb,jgrd) * pua2d(ii,ij) * e2u(ii,ij) * phu(ii,ij) * tmask_i(ii,ij) * tmask_i(ii+1,ij)
+ ztranst = ztranst + idx%flagu(jb,jgrd) * pua2d(ii,ij) * e2u(ii,ij) * phu(ii,ij) &
+ & * ( tmask_i(ii,ij) * tmask_i(ii+1,ij) )
END DO
jgrd = 3 ! correct v component
DO jb = 1, idx%nblenrim(jgrd)
ii = idx%nbi(jb,jgrd)
ij = idx%nbj(jb,jgrd)
IF( ii == 1 .OR. ii == jpi .OR. ij == 1 .OR. ij == jpj ) CYCLE
- ztranst = ztranst + idx%flagv(jb,jgrd) * pva2d(ii,ij) * e1v(ii,ij) * phv(ii,ij) * tmask_i(ii,ij) * tmask_i(ii,ij+1)
+ ztranst = ztranst + idx%flagv(jb,jgrd) * pva2d(ii,ij) * e1v(ii,ij) * phv(ii,ij) &
+ & * ( tmask_i(ii,ij) * tmask_i(ii,ij+1) )
END DO
!
END DO
@@ -204,7 +208,7 @@ CONTAINS
zflagu => idx_bdy(ib_bdy)%flagu(ib,igrd)
bdy_segs_surf = bdy_segs_surf + phu(nbi, nbj) &
& * e2u(nbi, nbj) * ABS( zflagu ) &
- & * tmask_i(nbi, nbj) * tmask_i(nbi+1, nbj)
+ & * ( tmask_i(nbi, nbj) * tmask_i(nbi+1, nbj) )
END DO
END DO
@@ -217,7 +221,7 @@ CONTAINS
zflagv => idx_bdy(ib_bdy)%flagv(ib,igrd)
bdy_segs_surf = bdy_segs_surf + phv(nbi, nbj) &
& * e1v(nbi, nbj) * ABS( zflagv ) &
- & * tmask_i(nbi, nbj) * tmask_i(nbi, nbj+1)
+ & * ( tmask_i(nbi, nbj) * tmask_i(nbi, nbj+1) )
END DO
END DO
!
diff --git a/src/OCE/C1D/dtauvd.F90 b/src/OCE/C1D/dtauvd.F90
index fc64c2583bd213ec5dd3747470854a7ab020d2cc..03adab4babe9610c2b1ef8d6eca9bd506687a059 100644
--- a/src/OCE/C1D/dtauvd.F90
+++ b/src/OCE/C1D/dtauvd.F90
@@ -150,7 +150,7 @@ CONTAINS
pud(:,:,:) = sf_uvd(1)%fnow(:,:,:) ! NO mask
pvd(:,:,:) = sf_uvd(2)%fnow(:,:,:)
!
- IF( ln_sco ) THEN !== s- or mixed s-zps-coordinate ==!
+ IF( l_sco ) THEN !== s- or mixed s-zps-coordinate ==!
!
ALLOCATE( zup(jpk), zvp(jpk) )
!
@@ -193,17 +193,6 @@ CONTAINS
pud(:,:,:) = pud(:,:,:) * umask(:,:,:) ! apply mask
pvd(:,:,:) = pvd(:,:,:) * vmask(:,:,:)
!
- IF( ln_zps ) THEN ! zps-coordinate (partial steps) interpolation at the last ocean level
- DO_2D( 1, 1, 1, 1 )
- ik = mbkt(ji,jj)
- IF( ik > 1 ) THEN
- zl = ( gdept_1d(ik) - gdept_0(ji,jj,ik) ) / ( gdept_1d(ik) - gdept_1d(ik-1) )
- pud(ji,jj,ik) = (1.-zl) * pud(ji,jj,ik) + zl * pud(ji,jj,ik-1)
- pvd(ji,jj,ik) = (1.-zl) * pvd(ji,jj,ik) + zl * pvd(ji,jj,ik-1)
- ENDIF
- END_2D
- ENDIF
- !
ENDIF
!
IF( .NOT. ln_uvd_dyndmp ) THEN !== deallocate U & V current structure ==!
diff --git a/src/OCE/C1D/dyndmp.F90 b/src/OCE/C1D/dyndmp.F90
index 5cfd953c9a7c36ab96d5847893a6c7ae151d5087..06104f3a03795a4b8c924357b04da938e431b396 100644
--- a/src/OCE/C1D/dyndmp.F90
+++ b/src/OCE/C1D/dyndmp.F90
@@ -121,7 +121,7 @@ CONTAINS
!
!Read in mask from file
CALL iom_open ( cn_resto, imask)
- CALL iom_get ( imask, jpdom_auto, 'resto', resto)
+ CALL iom_get ( imask, jpdom_auto, 'resto', resto_uv)
CALL iom_close( imask )
ENDIF
!
diff --git a/src/OCE/CRS/crs.F90 b/src/OCE/CRS/crs.F90
index 652c9f12a02d93301f0c3d2c7f99c085d4c7dd7b..6be2b1076784a9ccd74e43fddebd0b98f813219b 100644
--- a/src/OCE/CRS/crs.F90
+++ b/src/OCE/CRS/crs.F90
@@ -124,7 +124,8 @@ MODULE crs
REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:) :: avs_crs !: salinity vertical diffusivity coeff. [m2/s] at w-point
! Mixing and Mixed Layer Depth
- INTEGER, PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: nmln_crs, hmld_crs, hmlp_crs, hmlpt_crs
+ INTEGER, PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: nmln_crs
+ REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: hmld_crs, hmlp_crs
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
@@ -207,8 +208,8 @@ CONTAINS
ALLOCATE( tsn_crs(jpi_crs,jpj_crs,jpk,jpts), avt_crs(jpi_crs,jpj_crs,jpk), &
& avs_crs(jpi_crs,jpj_crs,jpk), STAT=ierr(13) )
- ALLOCATE( nmln_crs(jpi_crs,jpj_crs) , hmld_crs(jpi_crs,jpj_crs) , &
- & hmlp_crs(jpi_crs,jpj_crs) , hmlpt_crs(jpi_crs,jpj_crs) , STAT=ierr(14) )
+ ALLOCATE( nmln_crs(jpi_crs,jpj_crs), hmld_crs(jpi_crs,jpj_crs) , &
+ & hmlp_crs(jpi_crs,jpj_crs), STAT=ierr(14) )
!!$ ALLOCATE( nimppt_crs (jpnij) , jpiall_crs (jpnij) , nis0all_crs (jpnij) , nie0all_crs (jpnij), &
!!$ & nimppt_full(jpnij) , jpiall_full(jpnij) , nis0all_full(jpnij) , nie0all_full(jpnij), &
diff --git a/src/OCE/CRS/crsfld.F90 b/src/OCE/CRS/crsfld.F90
index b8115048d68e1faff79a13d65c186ca77fb2a250..efa11cf50690eaa4458ab7d57cad81ec47fab453 100644
--- a/src/OCE/CRS/crsfld.F90
+++ b/src/OCE/CRS/crsfld.F90
@@ -211,8 +211,8 @@ CONTAINS
! sbc fields
CALL crs_dom_ope( ssh(:,:,Kmm) , 'VOL', 'T', tmask, sshn_crs , p_e12=e1e2t, p_e3=ze3t , psgn=1.0_wp )
- CALL crs_dom_ope( utau , 'SUM', 'U', umask, utau_crs , p_e12=e2u , p_surf_crs=e2u_crs , psgn=1.0_wp )
- CALL crs_dom_ope( vtau , 'SUM', 'V', vmask, vtau_crs , p_e12=e1v , p_surf_crs=e1v_crs , psgn=1.0_wp )
+ CALL crs_dom_ope( utau , 'SUM', 'T', tmask, utau_crs , p_e12=e2t , p_surf_crs=e2t_crs , psgn=1.0_wp ) !clem tau: check psgn ??
+ CALL crs_dom_ope( vtau , 'SUM', 'T', tmask, vtau_crs , p_e12=e1t , p_surf_crs=e1t_crs , psgn=1.0_wp ) !
CALL crs_dom_ope( wndm , 'SUM', 'T', tmask, wndm_crs , p_e12=e1e2t, p_surf_crs=e1e2t_crs, psgn=1.0_wp )
CALL crs_dom_ope( rnf , 'MAX', 'T', tmask, rnf_crs , psgn=1.0_wp )
CALL crs_dom_ope( qsr , 'SUM', 'T', tmask, qsr_crs , p_e12=e1e2t, p_surf_crs=e1e2t_crs, psgn=1.0_wp )
diff --git a/src/OCE/CRS/crsini.F90 b/src/OCE/CRS/crsini.F90
index f31fad263d538d1250f320ac6614b5d6429179a1..a070ef98cb8cfdc6881e36c818fbcd477a096168 100644
--- a/src/OCE/CRS/crsini.F90
+++ b/src/OCE/CRS/crsini.F90
@@ -74,7 +74,7 @@ CONTAINS
INTEGER :: ji,jj,jk ! dummy indices
INTEGER :: ierr ! allocation error status
INTEGER :: ios ! Local integer output status for namelist read
- REAL(wp), DIMENSION(jpi,jpj,jpk) :: ze3t, ze3u, ze3v, ze3w
+ REAL(wp), DIMENSION(jpi,jpj,jpk) :: ze3t, ze3u, ze3v, ze3w, zdept0, zdepw0
NAMELIST/namcrs/ nn_factx, nn_facty, nn_binref, ln_msh_crs, nn_crs_kz, ln_crs_wn
!!----------------------------------------------------------------------
@@ -210,8 +210,12 @@ CONTAINS
ENDDO
! 3.d.3 Vertical depth (meters)
- CALL crs_dom_ope( gdept_0, 'MAX', 'T', tmask, gdept_crs, p_e3=ze3t, psgn=1.0_wp )
- CALL crs_dom_ope( gdepw_0, 'MAX', 'W', tmask, gdepw_crs, p_e3=ze3w, psgn=1.0_wp )
+ DO jk = 1, jpk
+ zdept0(:,:,jk) = gdept_0(:,:,jk)
+ zdepw0(:,:,jk) = gdepw_0(:,:,jk)
+ END DO
+ CALL crs_dom_ope( zdept0, 'MAX', 'T', tmask, gdept_crs, p_e3=ze3t, psgn=1.0_wp )
+ CALL crs_dom_ope( zdepw0, 'MAX', 'W', tmask, gdepw_crs, p_e3=ze3w, psgn=1.0_wp )
!---------------------------------------------------------
diff --git a/src/OCE/DIA/dia25h.F90 b/src/OCE/DIA/dia25h.F90
index 418f54d16f9f13a50034b29ad5f07fc8dbd43e4b..b9bede46535ba40526e6256636bb09372bc90199 100644
--- a/src/OCE/DIA/dia25h.F90
+++ b/src/OCE/DIA/dia25h.F90
@@ -75,20 +75,20 @@ CONTAINS
! 1 - Allocate memory !
! ------------------- !
! ! ocean arrays
- ALLOCATE( tn_25h (A2D(0),jpk), sn_25h (A2D(0),jpk), sshn_25h(A2D(0)) , &
- & un_25h (A2D(0),jpk), vn_25h (A2D(0),jpk), wn_25h(A2D(0),jpk), &
- & avt_25h(A2D(0),jpk), avm_25h(A2D(0),jpk), STAT=ierror )
+ ALLOCATE( tn_25h (T2D(0),jpk), sn_25h (T2D(0),jpk), sshn_25h(T2D(0)) , &
+ & un_25h (T2D(0),jpk), vn_25h (T2D(0),jpk), wn_25h(T2D(0),jpk), &
+ & avt_25h(T2D(0),jpk), avm_25h(T2D(0),jpk), STAT=ierror )
IF( ierror > 0 ) THEN
CALL ctl_stop( 'dia_25h: unable to allocate ocean arrays' ) ; RETURN
ENDIF
IF( ln_zdftke ) THEN ! TKE physics
- ALLOCATE( en_25h(A2D(0),jpk), STAT=ierror )
+ ALLOCATE( en_25h(T2D(0),jpk), STAT=ierror )
IF( ierror > 0 ) THEN
CALL ctl_stop( 'dia_25h: unable to allocate en_25h' ) ; RETURN
ENDIF
ENDIF
IF( ln_zdfgls ) THEN ! GLS physics
- ALLOCATE( en_25h(A2D(0),jpk), rmxln_25h(A2D(0),jpk), STAT=ierror )
+ ALLOCATE( en_25h(T2D(0),jpk), rmxln_25h(T2D(0),jpk), STAT=ierror )
IF( ierror > 0 ) THEN
CALL ctl_stop( 'dia_25h: unable to allocate en_25h and rmxln_25h' ) ; RETURN
ENDIF
@@ -142,9 +142,9 @@ CONTAINS
LOGICAL :: ll_print = .FALSE. ! =T print and flush numout
REAL(wp) :: zsto, zout, zmax, zjulian, zmdi ! local scalars
INTEGER :: i_steps ! no of timesteps per hour
- REAL(wp), DIMENSION(A2D(0) ) :: zw2d, un_dm, vn_dm ! workspace
- REAL(wp), DIMENSION(A2D(0),jpk) :: zw3d ! workspace
- REAL(wp), DIMENSION(A2D(0),3) :: zwtmb ! workspace
+ REAL(wp), DIMENSION(T2D(0) ) :: zw2d, un_dm, vn_dm ! workspace
+ REAL(wp), DIMENSION(T2D(0),jpk) :: zw3d ! workspace
+ REAL(wp), DIMENSION(T2D(0),3) :: zwtmb ! workspace
!!----------------------------------------------------------------------
! 0. Initialisation
diff --git a/src/OCE/DIA/diaar5.F90 b/src/OCE/DIA/diaar5.F90
index 82fe74e622840226583e015e1227f11568090417..a8eaa2c041b4f920f7af9c9c0ba46485f8b16764 100644
--- a/src/OCE/DIA/diaar5.F90
+++ b/src/OCE/DIA/diaar5.F90
@@ -55,7 +55,7 @@ CONTAINS
INTEGER :: dia_ar5_alloc
!!----------------------------------------------------------------------
!
- ALLOCATE( thick0(jpi,jpj) , sn0(jpi,jpj,jpk), STAT=dia_ar5_alloc )
+ ALLOCATE( thick0(A2D(0)) , sn0(A2D(0),jpk), STAT=dia_ar5_alloc )
!
CALL mpp_sum ( 'diaar5', dia_ar5_alloc )
IF( dia_ar5_alloc /= 0 ) CALL ctl_stop( 'STOP', 'dia_ar5_alloc: failed to allocate arrays' )
@@ -77,20 +77,22 @@ CONTAINS
REAL(wp) :: zvolssh, zvol, zssh_steric, zztmp, zarho, ztemp, zsal, zmass, zsst
REAL(wp) :: zaw, zbw, zrw, ztf
!
- REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zarea_ssh , zbotpres ! 2D workspace
- REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: z2d, zpe ! 2D workspace
- REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: z3d, zrhd, ztpot, zgdept ! 3D workspace (zgdept: needed to use the substitute)
- REAL(wp), ALLOCATABLE, DIMENSION(:,:,:,:) :: ztsn ! 4D workspace
+ REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zarea_ssh ! 2D workspace
+ REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: z2d ! 2D workspace
+ REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: z3d, zrhd ! 3D workspace
+ REAL(wp), ALLOCATABLE, DIMENSION(:,:,:,:,:) :: ztsn ! 5D workspace
!!--------------------------------------------------------------------
IF( ln_timing ) CALL timing_start('dia_ar5')
IF( kt == nit000 ) CALL dia_ar5_init
IF( l_ar5 ) THEN
- ALLOCATE( zarea_ssh(jpi,jpj), zbotpres(jpi,jpj), z2d(jpi,jpj) )
- ALLOCATE( zrhd(jpi,jpj,jpk) )
- ALLOCATE( ztsn(jpi,jpj,jpk,jpts) )
- zarea_ssh(:,:) = e1e2t(:,:) * ssh(:,:,Kmm)
+ ALLOCATE( zarea_ssh(A2D(0)), z2d(A2D(0)), z3d(A2D(0),jpk) )
+ ALLOCATE( zrhd(A2D(0),jpk) )
+ ALLOCATE( ztsn(A2D(0),jpk,jpts,jpt) )
+ zarea_ssh(:,:) = e1e2t(A2D(0)) * ssh(A2D(0),Kmm)
+ ztsn(:,:,:,:,:) = 0._wp
+ zrhd(:,:,:) = 0._wp
ENDIF
!
CALL iom_put( 'e2u' , e2u (:,:) )
@@ -98,19 +100,19 @@ CONTAINS
CALL iom_put( 'areacello', e1e2t(:,:) )
!
IF( iom_use( 'volcello' ) .OR. iom_use( 'masscello' ) ) THEN
- zrhd(:,:,jpk) = 0._wp ! ocean volume ; rhd is used as workspace
- DO jk = 1, jpkm1
- zrhd(:,:,jk) = e1e2t(:,:) * e3t(:,:,jk,Kmm) * tmask(:,:,jk)
- END DO
- DO jk = 1, jpk
- z3d(:,:,jk) = rho0 * e3t(:,:,jk,Kmm) * tmask(:,:,jk)
- END DO
- CALL iom_put( 'volcello' , zrhd(:,:,:) ) ! WARNING not consistent with CMIP DR where volcello is at ca. 2000
+ z3d(:,:,jpk) = 0._wp ! ocean volume ; rhd is used as workspace
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
+ z3d(ji,jj,jk) = e1e2t(ji,jj) * e3t(ji,jj,jk,Kmm) * tmask(ji,jj,jk)
+ END_3D
+ CALL iom_put( 'volcello' , z3d(:,:,:) ) ! WARNING not consistent with CMIP DR where volcello is at ca. 2000
+ DO_3D( 0, 0, 0, 0, 1, jpk )
+ z3d(ji,jj,jk) = rho0 * e3t(ji,jj,jk,Kmm) * tmask(ji,jj,jk)
+ END_3D
CALL iom_put( 'masscello' , z3d (:,:,:) ) ! ocean mass
ENDIF
!
IF( iom_use( 'e3tb' ) ) THEN ! bottom layer thickness
- DO_2D( 1, 1, 1, 1 )
+ DO_2D( 0, 0, 0, 0 )
ikb = mbkt(ji,jj)
z2d(ji,jj) = e3t(ji,jj,ikb,Kmm)
END_2D
@@ -144,92 +146,88 @@ CONTAINS
IF( iom_use( 'botpres' ) .OR. iom_use( 'sshthster' ) .OR. iom_use( 'sshsteric' ) ) THEN
!
- ztsn(:,:,:,jp_tem) = ts(:,:,:,jp_tem,Kmm) ! thermosteric ssh
- ztsn(:,:,:,jp_sal) = sn0(:,:,:)
- ALLOCATE( zgdept(jpi,jpj,jpk) )
- DO jk = 1, jpk
- zgdept(:,:,jk) = gdept(:,:,jk,Kmm)
- END DO
- CALL eos( ztsn, zrhd, zgdept) ! now in situ density using initial salinity
+ ztsn(:,:,:,jp_tem,Kmm) = ts(A2D(0),:,jp_tem,Kmm) ! thermosteric ssh
+ ztsn(:,:,:,jp_sal,Kmm) = sn0(:,:,:)
+ CALL eos( ztsn, Kmm, zrhd, kbnd=0 ) ! now in situ density using initial salinity
!
- zbotpres(:,:) = 0._wp ! no atmospheric surface pressure, levitating sea-ice
- DO jk = 1, jpkm1
- zbotpres(:,:) = zbotpres(:,:) + e3t(:,:,jk,Kmm) * zrhd(:,:,jk)
- END DO
+ z2d(:,:) = 0._wp ! no atmospheric surface pressure, levitating sea-ice
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
+ z2d(ji,jj) = z2d(ji,jj) + e3t(ji,jj,jk,Kmm) * zrhd(ji,jj,jk)
+ END_3D
IF( ln_linssh ) THEN
IF( ln_isfcav ) THEN
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
iks = mikt(ji,jj)
- zbotpres(ji,jj) = zbotpres(ji,jj) + ssh(ji,jj,Kmm) * zrhd(ji,jj,iks) + riceload(ji,jj)
+ z2d(ji,jj) = z2d(ji,jj) + ssh(ji,jj,Kmm) * zrhd(ji,jj,iks) + riceload(ji,jj)
END_2D
ELSE
- zbotpres(:,:) = zbotpres(:,:) + ssh(:,:,Kmm) * zrhd(:,:,1)
+ DO_2D( 0, 0, 0, 0 )
+ z2d(ji,jj) = z2d(ji,jj) + ssh(ji,jj,Kmm) * zrhd(ji,jj,1)
+ END_2D
END IF
!!gm
!!gm riceload should be added in both ln_linssh=T or F, no?
!!gm
END IF
!
- zarho = glob_sum( 'diaar5', e1e2t(:,:) * zbotpres(:,:) )
+ zarho = glob_sum( 'diaar5', e1e2t(A2D(0)) * z2d(:,:) )
zssh_steric = - zarho / area_tot
CALL iom_put( 'sshthster', zssh_steric )
! ! steric sea surface height
- zbotpres(:,:) = 0._wp ! no atmospheric surface pressure, levitating sea-ice
- DO jk = 1, jpkm1
- zbotpres(:,:) = zbotpres(:,:) + e3t(:,:,jk,Kmm) * rhd(:,:,jk)
- END DO
+ z2d(:,:) = 0._wp ! no atmospheric surface pressure, levitating sea-ice
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
+ z2d(ji,jj) = z2d(ji,jj) + e3t(ji,jj,jk,Kmm) * rhd(ji,jj,jk)
+ END_3D
IF( ln_linssh ) THEN
IF ( ln_isfcav ) THEN
- DO ji = 1,jpi
- DO jj = 1,jpj
- iks = mikt(ji,jj)
- zbotpres(ji,jj) = zbotpres(ji,jj) + ssh(ji,jj,Kmm) * rhd(ji,jj,iks) + riceload(ji,jj)
- END DO
- END DO
+ DO_2D( 0, 0, 0, 0 )
+ iks = mikt(ji,jj)
+ z2d(ji,jj) = z2d(ji,jj) + ssh(ji,jj,Kmm) * rhd(ji,jj,iks) + riceload(ji,jj)
+ END_2D
ELSE
- zbotpres(:,:) = zbotpres(:,:) + ssh(:,:,Kmm) * rhd(:,:,1)
+ DO_2D( 0, 0, 0, 0 )
+ z2d(ji,jj) = z2d(ji,jj) + ssh(ji,jj,Kmm) * rhd(ji,jj,1)
+ END_2D
END IF
END IF
!
- zarho = glob_sum( 'diaar5', e1e2t(:,:) * zbotpres(:,:) )
+ zarho = glob_sum( 'diaar5', e1e2t(A2D(0)) * z2d(:,:) )
zssh_steric = - zarho / area_tot
CALL iom_put( 'sshsteric', zssh_steric )
! ! ocean bottom pressure
zztmp = rho0 * grav * 1.e-4_wp ! recover pressure from pressure anomaly and cover to dbar = 1.e4 Pa
- zbotpres(:,:) = zztmp * ( zbotpres(:,:) + ssh(:,:,Kmm) + thick0(:,:) )
- CALL iom_put( 'botpres', zbotpres )
- !
- DEALLOCATE( zgdept )
+ z2d(:,:) = zztmp * ( z2d(:,:) + ssh(A2D(0),Kmm) + thick0(:,:) )
+ CALL iom_put( 'botpres', z2d )
!
ENDIF
IF( iom_use( 'masstot' ) .OR. iom_use( 'temptot' ) .OR. iom_use( 'saltot' ) ) THEN
! ! Mean density anomalie, temperature and salinity
- ztsn(:,:,:,:) = 0._wp ! ztsn(:,:,1,jp_tem/sal) is used here as 2D Workspace for temperature & salinity
- DO_3D( 1, 1, 1, 1, 1, jpkm1 )
+ ztsn(:,:,:,:,Kmm) = 0._wp ! ztsn(:,:,1,jp_tem/sal) is used here as 2D Workspace for temperature & salinity
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
zztmp = e1e2t(ji,jj) * e3t(ji,jj,jk,Kmm)
- ztsn(ji,jj,1,jp_tem) = ztsn(ji,jj,1,jp_tem) + zztmp * ts(ji,jj,jk,jp_tem,Kmm)
- ztsn(ji,jj,1,jp_sal) = ztsn(ji,jj,1,jp_sal) + zztmp * ts(ji,jj,jk,jp_sal,Kmm)
+ ztsn(ji,jj,1,jp_tem,Kmm) = ztsn(ji,jj,1,jp_tem,Kmm) + zztmp * ts(ji,jj,jk,jp_tem,Kmm)
+ ztsn(ji,jj,1,jp_sal,Kmm) = ztsn(ji,jj,1,jp_sal,Kmm) + zztmp * ts(ji,jj,jk,jp_sal,Kmm)
END_3D
IF( ln_linssh ) THEN
IF( ln_isfcav ) THEN
- DO ji = 1, jpi
- DO jj = 1, jpj
- iks = mikt(ji,jj)
- ztsn(ji,jj,1,jp_tem) = ztsn(ji,jj,1,jp_tem) + zarea_ssh(ji,jj) * ts(ji,jj,iks,jp_tem,Kmm)
- ztsn(ji,jj,1,jp_sal) = ztsn(ji,jj,1,jp_sal) + zarea_ssh(ji,jj) * ts(ji,jj,iks,jp_sal,Kmm)
- END DO
- END DO
+ DO_2D( 0, 0, 0, 0 )
+ iks = mikt(ji,jj)
+ ztsn(ji,jj,1,jp_tem,Kmm) = ztsn(ji,jj,1,jp_tem,Kmm) + zarea_ssh(ji,jj) * ts(ji,jj,iks,jp_tem,Kmm)
+ ztsn(ji,jj,1,jp_sal,Kmm) = ztsn(ji,jj,1,jp_sal,Kmm) + zarea_ssh(ji,jj) * ts(ji,jj,iks,jp_sal,Kmm)
+ END_2D
ELSE
- ztsn(:,:,1,jp_tem) = ztsn(:,:,1,jp_tem) + zarea_ssh(:,:) * ts(:,:,1,jp_tem,Kmm)
- ztsn(:,:,1,jp_sal) = ztsn(:,:,1,jp_sal) + zarea_ssh(:,:) * ts(:,:,1,jp_sal,Kmm)
+ DO_2D( 0, 0, 0, 0 )
+ ztsn(ji,jj,1,jp_tem,Kmm) = ztsn(ji,jj,1,jp_tem,Kmm) + zarea_ssh(ji,jj) * ts(ji,jj,1,jp_tem,Kmm)
+ ztsn(ji,jj,1,jp_sal,Kmm) = ztsn(ji,jj,1,jp_sal,Kmm) + zarea_ssh(ji,jj) * ts(ji,jj,1,jp_sal,Kmm)
+ END_2D
END IF
ENDIF
!
- ztemp = glob_sum( 'diaar5', ztsn(:,:,1,jp_tem) )
- zsal = glob_sum( 'diaar5', ztsn(:,:,1,jp_sal) )
+ ztemp = glob_sum( 'diaar5', ztsn(:,:,1,jp_tem,Kmm) )
+ zsal = glob_sum( 'diaar5', ztsn(:,:,1,jp_sal,Kmm) )
zmass = rho0 * ( zarho + zvol )
!
CALL iom_put( 'masstot', zmass )
@@ -242,37 +240,35 @@ CONTAINS
IF( iom_use( 'toce_pot') .OR. iom_use( 'temptot_pot' ) .OR. iom_use( 'sst_pot' ) &
.OR. iom_use( 'ssttot' ) .OR. iom_use( 'tosmint_pot' ) ) THEN
!
- ALLOCATE( ztpot(jpi,jpj,jpk) )
- ztpot(:,:,jpk) = 0._wp
+ z3d(:,:,jpk) = 0._wp
DO jk = 1, jpkm1
- ztpot(:,:,jk) = eos_pt_from_ct( ts(:,:,jk,jp_tem,Kmm), ts(:,:,jk,jp_sal,Kmm) )
+ CALL eos_pt_from_ct( ts(:,:,jk,jp_tem,Kmm), ts(:,:,jk,jp_sal,Kmm), z3d(:,:,jk), kbnd=0 )
END DO
!
- CALL iom_put( 'toce_pot', ztpot(:,:,:) ) ! potential temperature (TEOS-10 case)
- CALL iom_put( 'sst_pot' , ztpot(:,:,1) ) ! surface temperature
+ CALL iom_put( 'toce_pot', z3d(:,:,:) ) ! potential temperature (TEOS-10 case)
+ CALL iom_put( 'sst_pot' , z3d(:,:,1) ) ! surface temperature
!
IF( iom_use( 'temptot_pot' ) ) THEN ! Output potential temperature in case we use TEOS-10
z2d(:,:) = 0._wp
- DO jk = 1, jpkm1
- z2d(:,:) = z2d(:,:) + e1e2t(:,:) * e3t(:,:,jk,Kmm) * ztpot(:,:,jk)
- END DO
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
+ z2d(ji,jj) = z2d(ji,jj) + e1e2t(ji,jj) * e3t(ji,jj,jk,Kmm) * z3d(ji,jj,jk)
+ END_3D
ztemp = glob_sum( 'diaar5', z2d(:,:) )
CALL iom_put( 'temptot_pot', ztemp / zvol )
ENDIF
!
IF( iom_use( 'ssttot' ) ) THEN ! Output potential temperature in case we use TEOS-10
- zsst = glob_sum( 'diaar5', e1e2t(:,:) * ztpot(:,:,1) )
+ zsst = glob_sum( 'diaar5', e1e2t(A2D(0)) * z3d(:,:,1) )
CALL iom_put( 'ssttot', zsst / area_tot )
ENDIF
! Vertical integral of temperature
IF( iom_use( 'tosmint_pot') ) THEN
z2d(:,:) = 0._wp
- DO_3D( 1, 1, 1, 1, 1, jpkm1 )
- z2d(ji,jj) = z2d(ji,jj) + rho0 * e3t(ji,jj,jk,Kmm) * ztpot(ji,jj,jk)
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
+ z2d(ji,jj) = z2d(ji,jj) + rho0 * e3t(ji,jj,jk,Kmm) * z3d(ji,jj,jk)
END_3D
CALL iom_put( 'tosmint_pot', z2d )
ENDIF
- DEALLOCATE( ztpot )
ENDIF
ELSE
IF( iom_use('ssttot') ) THEN ! Output sst in case we use EOS-80
@@ -285,33 +281,31 @@ CONTAINS
! Work done against stratification by vertical mixing
! Exclude points where rn2 is negative as convection kicks in here and
! work is not being done against stratification
- ALLOCATE( zpe(jpi,jpj) )
- zpe(:,:) = 0._wp
+ z2d(:,:) = 0._wp
IF( ln_zdfddm ) THEN
- DO_3D( 1, 1, 1, 1, 2, jpk )
+ DO_3D( 0, 0, 0, 0, 2, jpk )
IF( rn2(ji,jj,jk) > 0._wp ) THEN
zrw = ( gdept(ji,jj,jk,Kmm) - gdepw(ji,jj,jk,Kmm) ) / e3w(ji,jj,jk,Kmm)
!
zaw = rab_n(ji,jj,jk,jp_tem) * (1. - zrw) + rab_n(ji,jj,jk-1,jp_tem)* zrw
zbw = rab_n(ji,jj,jk,jp_sal) * (1. - zrw) + rab_n(ji,jj,jk-1,jp_sal)* zrw
!
- zpe(ji, jj) = zpe(ji,jj) &
+ z2d(ji, jj) = z2d(ji,jj) &
& - grav * ( avt(ji,jj,jk) * zaw * (ts(ji,jj,jk-1,jp_tem,Kmm) - ts(ji,jj,jk,jp_tem,Kmm) ) &
& - avs(ji,jj,jk) * zbw * (ts(ji,jj,jk-1,jp_sal,Kmm) - ts(ji,jj,jk,jp_sal,Kmm) ) )
ENDIF
END_3D
ELSE
- DO_3D( 1, 1, 1, 1, 1, jpk )
- zpe(ji,jj) = zpe(ji,jj) + avt(ji,jj,jk) * MIN(0._wp,rn2(ji,jj,jk)) * rho0 * e3w(ji,jj,jk,Kmm)
+ DO_3D( 0, 0, 0, 0, 1, jpk )
+ z2d(ji,jj) = z2d(ji,jj) + avt(ji,jj,jk) * MIN(0._wp,rn2(ji,jj,jk)) * rho0 * e3w(ji,jj,jk,Kmm)
END_3D
ENDIF
- CALL iom_put( 'tnpeo', zpe )
- DEALLOCATE( zpe )
+ CALL iom_put( 'tnpeo', z2d )
ENDIF
IF( l_ar5 ) THEN
- DEALLOCATE( zarea_ssh , zbotpres, z2d )
- DEALLOCATE( ztsn )
+ DEALLOCATE( zarea_ssh , z2d, z3d )
+ DEALLOCATE( ztsn )
ENDIF
!
IF( ln_timing ) CALL timing_stop('dia_ar5')
@@ -328,37 +322,37 @@ CONTAINS
!!----------------------------------------------------------------------
INTEGER , INTENT(in ) :: ktra ! tracer index
CHARACTER(len=3) , INTENT(in) :: cptr ! transport type 'adv'/'ldf'
- REAL(wp), DIMENSION(A2D(nn_hls),jpk) , INTENT(in) :: puflx ! u-flux of advection/diffusion
- REAL(wp), DIMENSION(A2D(nn_hls),jpk) , INTENT(in) :: pvflx ! v-flux of advection/diffusion
+ REAL(wp), DIMENSION(T2D(nn_hls),jpk) , INTENT(in) :: puflx ! u-flux of advection/diffusion
+ REAL(wp), DIMENSION(T2D(nn_hls),jpk) , INTENT(in) :: pvflx ! v-flux of advection/diffusion
!
INTEGER :: ji, jj, jk
- REAL(wp), DIMENSION(A2D(nn_hls)) :: z2d
+ REAL(wp), DIMENSION(T2D(0)) :: z2d
!!----------------------------------------------------------------------
- z2d(:,:) = puflx(:,:,1)
+ z2d(:,:) = 0._wp
DO_3D( 0, 0, 0, 0, 1, jpkm1 )
z2d(ji,jj) = z2d(ji,jj) + puflx(ji,jj,jk)
END_3D
IF( cptr == 'adv' ) THEN
- IF( ktra == jp_tem ) CALL iom_put( 'uadv_heattr' , rho0_rcp * z2d(:,:) ) ! advective heat transport in i-direction
- IF( ktra == jp_sal ) CALL iom_put( 'uadv_salttr' , rho0 * z2d(:,:) ) ! advective salt transport in i-direction
+ IF( ktra == jp_tem ) CALL iom_put( 'uadv_heattr' , rho0_rcp * z2d(:,:) ) ! advective heat transport in i-direction
+ IF( ktra == jp_sal ) CALL iom_put( 'uadv_salttr' , rho0 * z2d(:,:) ) ! advective salt transport in i-direction
ELSE IF( cptr == 'ldf' ) THEN
- IF( ktra == jp_tem ) CALL iom_put( 'udiff_heattr' , rho0_rcp * z2d(:,:) ) ! diffusive heat transport in i-direction
- IF( ktra == jp_sal ) CALL iom_put( 'udiff_salttr' , rho0 * z2d(:,:) ) ! diffusive salt transport in i-direction
+ IF( ktra == jp_tem ) CALL iom_put( 'udiff_heattr' , rho0_rcp * z2d(:,:) ) ! diffusive heat transport in i-direction
+ IF( ktra == jp_sal ) CALL iom_put( 'udiff_salttr' , rho0 * z2d(:,:) ) ! diffusive salt transport in i-direction
ENDIF
!
- z2d(:,:) = pvflx(:,:,1)
+ z2d(:,:) = 0._wp
DO_3D( 0, 0, 0, 0, 1, jpkm1 )
z2d(ji,jj) = z2d(ji,jj) + pvflx(ji,jj,jk)
END_3D
IF( cptr == 'adv' ) THEN
- IF( ktra == jp_tem ) CALL iom_put( 'vadv_heattr' , rho0_rcp * z2d(:,:) ) ! advective heat transport in j-direction
- IF( ktra == jp_sal ) CALL iom_put( 'vadv_salttr' , rho0 * z2d(:,:) ) ! advective salt transport in j-direction
+ IF( ktra == jp_tem ) CALL iom_put( 'vadv_heattr' , rho0_rcp * z2d(:,:) ) ! advective heat transport in j-direction
+ IF( ktra == jp_sal ) CALL iom_put( 'vadv_salttr' , rho0 * z2d(:,:) ) ! advective salt transport in j-direction
ELSE IF( cptr == 'ldf' ) THEN
- IF( ktra == jp_tem ) CALL iom_put( 'vdiff_heattr' , rho0_rcp * z2d(:,:) ) ! diffusive heat transport in j-direction
- IF( ktra == jp_sal ) CALL iom_put( 'vdiff_salttr' , rho0 * z2d(:,:) ) ! diffusive salt transport in j-direction
+ IF( ktra == jp_tem ) CALL iom_put( 'vdiff_heattr' , rho0_rcp * z2d(:,:) ) ! diffusive heat transport in j-direction
+ IF( ktra == jp_sal ) CALL iom_put( 'vdiff_salttr' , rho0 * z2d(:,:) ) ! diffusive salt transport in j-direction
ENDIF
END SUBROUTINE dia_ar5_hst
@@ -396,10 +390,10 @@ CONTAINS
area_tot = glob_sum( 'diaar5', e1e2t(:,:) )
- ALLOCATE( zvol0(jpi,jpj) )
+ ALLOCATE( zvol0(A2D(0)) )
zvol0 (:,:) = 0._wp
thick0(:,:) = 0._wp
- DO_3D( 1, 1, 1, 1, 1, jpkm1 ) ! interpolation of salinity at the last ocean level (i.e. the partial step)
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 ) ! interpolation of salinity at the last ocean level (i.e. the partial step)
zztmp = tmask(ji,jj,jk) * e3t_0(ji,jj,jk)
zvol0 (ji,jj) = zvol0 (ji,jj) + zztmp * e1e2t(ji,jj)
thick0(ji,jj) = thick0(ji,jj) + zztmp
@@ -408,16 +402,16 @@ CONTAINS
DEALLOCATE( zvol0 )
IF( iom_use( 'sshthster' ) ) THEN
- ALLOCATE( zsaldta(jpi,jpj,jpk,jpts) )
+ ALLOCATE( zsaldta(A2D(0),jpk,jpts) )
CALL iom_open ( 'sali_ref_clim_monthly', inum )
CALL iom_get ( inum, jpdom_global, 'vosaline' , zsaldta(:,:,:,1), 1 )
CALL iom_get ( inum, jpdom_global, 'vosaline' , zsaldta(:,:,:,2), 12 )
CALL iom_close( inum )
sn0(:,:,:) = 0.5_wp * ( zsaldta(:,:,:,1) + zsaldta(:,:,:,2) )
- sn0(:,:,:) = sn0(:,:,:) * tmask(:,:,:)
- IF( ln_zps ) THEN ! z-coord. partial steps
- DO_2D( 1, 1, 1, 1 ) ! interpolation of salinity at the last ocean level (i.e. the partial step)
+ sn0(:,:,:) = sn0(:,:,:) * tmask(A2D(0),:)
+ IF( l_zps ) THEN ! z-coord. partial steps
+ DO_2D( 0, 0, 0, 0 ) ! interpolation of salinity at the last ocean level (i.e. the partial step)
ik = mbkt(ji,jj)
IF( ik > 1 ) THEN
zztmp = ( gdept_1d(ik) - gdept_0(ji,jj,ik) ) / ( gdept_1d(ik) - gdept_1d(ik-1) )
diff --git a/src/OCE/DIA/diacfl.F90 b/src/OCE/DIA/diacfl.F90
index e35764b3b7894d41c45d1d7098dc640d0b5b97f8..6ce2956635364533e3c36d7ff92200fcba22e223 100644
--- a/src/OCE/DIA/diacfl.F90
+++ b/src/OCE/DIA/diacfl.F90
@@ -11,7 +11,6 @@ MODULE diacfl
!!----------------------------------------------------------------------
USE oce ! ocean dynamics and active tracers
USE dom_oce ! ocean space and time domain
- USE domvvl !
!
USE lib_mpp ! distribued memory computing
USE lbclnk ! ocean lateral boundary condition (or mpp link)
@@ -51,19 +50,19 @@ CONTAINS
INTEGER, INTENT(in) :: kt ! ocean time-step index
INTEGER, INTENT(in) :: Kmm ! ocean time level index
!
- INTEGER :: ji, jj, jk ! dummy loop indices
- REAL(wp) :: zCu_max, zCv_max, zCw_max ! local scalars
- INTEGER , DIMENSION(3) :: iloc_u , iloc_v , iloc_w , iloc ! workspace
- REAL(wp), DIMENSION(jpi,jpj,jpk) :: zCu_cfl, zCv_cfl, zCw_cfl ! workspace
- LOGICAL , DIMENSION(jpi,jpj,jpk) :: llmsk
+ INTEGER :: ji, jj, jk ! dummy loop indices
+ REAL(wp) :: zCu_max, zCv_max, zCw_max ! local scalars
+ INTEGER , DIMENSION(3) :: iloc_u , iloc_v , iloc_w , iloc ! workspace
+ REAL(wp), DIMENSION(A2D(0),jpk) :: zCu_cfl, zCv_cfl, zCw_cfl ! workspace
+ LOGICAL , DIMENSION(A2D(0),jpk) :: llmsk
!!----------------------------------------------------------------------
!
IF( ln_timing ) CALL timing_start('dia_cfl')
!
- llmsk( 1:nn_hls,:,:) = .FALSE. ! exclude halos from the checked region
- llmsk(Nie0+1: jpi,:,:) = .FALSE.
- llmsk(:, 1:nn_hls,:) = .FALSE.
- llmsk(:,Nje0+1: jpj,:) = .FALSE.
+ !llmsk( 1:nn_hls,:,:) = .FALSE. ! exclude halos from the checked region
+ !llmsk(Nie0+1: jpi,:,:) = .FALSE.
+ !llmsk(:, 1:nn_hls,:) = .FALSE.
+ !llmsk(:,Nje0+1: jpj,:) = .FALSE.
!
DO_3D( 0, 0, 0, 0, 1, jpk ) ! calculate Courant numbers
zCu_cfl(ji,jj,jk) = ABS( uu(ji,jj,jk,Kmm) ) * rDt / e1u (ji,jj) ! for i-direction
diff --git a/src/OCE/DIA/diadct.F90 b/src/OCE/DIA/diadct.F90
index 4fa5479f4bd09776fc96de18b9919e0a569515f7..31c991cf4d234dead3e8de5efe2375f43d0709d3 100644
--- a/src/OCE/DIA/diadct.F90
+++ b/src/OCE/DIA/diadct.F90
@@ -32,7 +32,6 @@ MODULE diadct
#if defined key_si3
USE ice
#endif
- USE domvvl
USE timing ! preformance summary
IMPLICIT NONE
@@ -414,9 +413,9 @@ CONTAINS
!verify if the point is on the local domain:(1,Nie0)*(1,Nje0)
IF( iiloc >= 1 .AND. iiloc <= Nie0 .AND. &
ijloc >= 1 .AND. ijloc <= Nje0 )THEN
- iptloc = iptloc + 1 ! count local points
- secs(jsec)%listPoint(iptloc) = POINT_SECTION(mi0(iiglo),mj0(ijglo)) ! store local coordinates
- secs(jsec)%direction(iptloc) = directemp(jpt) ! store local direction
+ iptloc = iptloc + 1 ! count local points
+ secs(jsec)%listPoint(iptloc) = POINT_SECTION(mi0(iiglo,nn_hls),mj0(ijglo,nn_hls)) ! store local coordinates
+ secs(jsec)%direction(iptloc) = directemp(jpt) ! store local direction
ENDIF
!
END DO
@@ -1198,7 +1197,7 @@ CONTAINS
ENDIF
- IF( ln_sco )THEN ! s-coordinate case
+ IF( l_sco )THEN ! s-coordinate case
zdepu = ( gdept(ii1,ij1,kk,Kmm) + gdept(ii2,ij2,kk,Kmm) ) * 0.5_wp
zdep1 = gdept(ii1,ij1,kk,Kmm) - zdepu
diff --git a/src/OCE/DIA/diadetide.F90 b/src/OCE/DIA/diadetide.F90
index 9d6760039a2f2443cab467c820fbe58863e3eac1..0669a852cc838f11b8dfa507493162c4a2c0a84f 100644
--- a/src/OCE/DIA/diadetide.F90
+++ b/src/OCE/DIA/diadetide.F90
@@ -5,11 +5,11 @@ MODULE diadetide
!!======================================================================
!! History : ! 2019 (S. Mueller)
!!----------------------------------------------------------------------
- USE par_oce , ONLY : wp, jpi, jpj
- USE in_out_manager , ONLY : lwp, numout
- USE iom , ONLY : iom_put
- USE dom_oce , ONLY : rn_Dt, nsec_day
- USE phycst , ONLY : rpi
+ USE par_oce
+ USE in_out_manager
+ USE iom
+ USE dom_oce
+ USE phycst
USE tide_mod
#if defined key_xios
USE xios
@@ -24,6 +24,8 @@ MODULE diadetide
PUBLIC :: dia_detide_init, dia_detide
+ !! * Substitutions
+# include "do_loop_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2019)
!! $Id$
@@ -90,9 +92,9 @@ CONTAINS
!!----------------------------------------------------------------------
INTEGER, INTENT(in) :: kt
- REAL(wp), DIMENSION(jpi,jpj) :: zwght_2D
+ REAL(wp), DIMENSION(T2D(0)) :: zwght_2D
REAL(wp) :: zwght, ztmp
- INTEGER :: jn
+ INTEGER :: ji, jj, jn
! Compute detiding weight at the current time-step; the daily total weight
! is one, and the daily summation of a diagnosed field multiplied by this
@@ -104,7 +106,10 @@ CONTAINS
zwght = zwght + 1.0_wp / REAL( ndiadetide, KIND=wp )
END IF
END DO
- zwght_2D(:,:) = zwght
+
+ DO_2D( 0, 0, 0, 0 )
+ zwght_2D(ji,jj) = zwght
+ END_2D
CALL iom_put( "diadetide_weight", zwght_2D)
END SUBROUTINE dia_detide
diff --git a/src/OCE/DIA/diahsb.F90 b/src/OCE/DIA/diahsb.F90
index f9307c0af070e90c518583828d0158fa46ea0a0f..6ce30b21972c4a136c3c19195e664661e357eeaa 100644
--- a/src/OCE/DIA/diahsb.F90
+++ b/src/OCE/DIA/diahsb.F90
@@ -18,7 +18,6 @@ MODULE diahsb
USE sbc_oce ! surface thermohaline fluxes
USE isf_oce ! ice shelf fluxes
USE sbcrnf ! river runoff
- USE domvvl ! vertical scale factors
USE traqsr ! penetrative solar radiation
USE trabbc ! bottom boundary condition
USE trabbc ! bottom boundary condition
@@ -50,6 +49,7 @@ MODULE diahsb
REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: tmask_ini
!! * Substitutions
+# include "do_loop_substitute.h90"
# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
@@ -82,42 +82,73 @@ CONTAINS
REAL(wp) :: z_frc_trd_v ! - -
REAL(wp) :: z_wn_trd_t , z_wn_trd_s ! - -
REAL(wp) :: z_ssh_hc , z_ssh_sc ! - -
- REAL(wp), DIMENSION(jpi,jpj,13) :: ztmp
- REAL(wp), DIMENSION(jpi,jpj,jpkm1,4) :: ztmpk
- REAL(wp), DIMENSION(17) :: zbg
+ REAL(wp), DIMENSION(A2D(0),13) :: ztmp
+ REAL(wp), DIMENSION(A2D(0),jpkm1,4) :: ztmpk
+ REAL(wp), DIMENSION(17) :: zbg
!!---------------------------------------------------------------------------
IF( ln_timing ) CALL timing_start('dia_hsb')
!
- ztmp (:,:,:) = 0._wp ! should be better coded
- ztmpk(:,:,:,:) = 0._wp ! should be better coded
- !
- ts(:,:,:,1,Kmm) = ts(:,:,:,1,Kmm) * tmask(:,:,:) ; ts(:,:,:,1,Kbb) = ts(:,:,:,1,Kbb) * tmask(:,:,:) ;
- ts(:,:,:,2,Kmm) = ts(:,:,:,2,Kmm) * tmask(:,:,:) ; ts(:,:,:,2,Kbb) = ts(:,:,:,2,Kbb) * tmask(:,:,:) ;
+ DO_2D( 0, 0, 0, 0 )
+ ztmp (ji,jj,:) = 0._wp ! should be better coded
+ ztmpk(ji,jj,:,:) = 0._wp ! should be better coded
+ !
+ ts(ji,jj,:,1,Kmm) = ts(ji,jj,:,1,Kmm) * tmask(ji,jj,:)
+ ts(ji,jj,:,1,Kbb) = ts(ji,jj,:,1,Kbb) * tmask(ji,jj,:)
+ !
+ ts(ji,jj,:,2,Kmm) = ts(ji,jj,:,2,Kmm) * tmask(ji,jj,:)
+ ts(ji,jj,:,2,Kbb) = ts(ji,jj,:,2,Kbb) * tmask(ji,jj,:)
+ END_2D
!
! ------------------------- !
! 1 - Trends due to forcing !
! ------------------------- !
! prepare trends
- ztmp(:,:,1) = - r1_rho0 * ( emp(:,:) - rnf(:,:) - fwfisf_cav(:,:) - fwfisf_par(:,:) ) * surf(:,:) ! volume
- ztmp(:,:,2) = sbc_tsc(:,:,jp_tem) * surf(:,:) ! heat
- ztmp(:,:,3) = sbc_tsc(:,:,jp_sal) * surf(:,:) ! salt
- IF( ln_rnf ) ztmp(:,:,4) = rnf_tsc(:,:,jp_tem) * surf(:,:) ! runoff temp
- IF( ln_rnf_sal ) ztmp(:,:,5) = rnf_tsc(:,:,jp_sal) * surf(:,:) ! runoff salt
- IF( ln_isf ) ztmp(:,:,6) = ( risf_cav_tsc(:,:,jp_tem) + risf_par_tsc(:,:,jp_tem) ) * surf(:,:) ! isf temp
- IF( ln_traqsr ) ztmp(:,:,7) = r1_rho0_rcp * qsr(:,:) * surf(:,:) ! penetrative solar radiation
- IF( ln_trabbc ) ztmp(:,:,8) = qgh_trd0(:,:) * surf(:,:) ! geothermal heat
+ DO_2D( 0, 0, 0, 0 )
+ ztmp(ji,jj,1) = - r1_rho0 * ( emp(ji,jj) & ! volume
+ & - rnf(ji,jj) &
+ & - fwfisf_cav(ji,jj) &
+ & - fwfisf_par(ji,jj) ) * surf(ji,jj)
+ ztmp(ji,jj,2) = sbc_tsc(ji,jj,jp_tem) * surf(ji,jj) ! heat
+ ztmp(ji,jj,3) = sbc_tsc(ji,jj,jp_sal) * surf(ji,jj) ! salt
+ END_2D
+ IF( ln_rnf ) THEN
+ DO_2D( 0, 0, 0, 0 )
+ ztmp(ji,jj,4) = rnf_tsc(ji,jj,jp_tem) * surf(ji,jj) ! runoff temp
+ END_2D
+ END IF
+ IF( ln_rnf_sal ) THEN
+ DO_2D( 0, 0, 0, 0 )
+ ztmp(ji,jj,5) = rnf_tsc(ji,jj,jp_sal) * surf(ji,jj) ! runoff salt
+ END_2D
+ END IF
+ IF( ln_isf ) THEN
+ DO_2D( 0, 0, 0, 0 )
+ ztmp(ji,jj,6) = ( risf_cav_tsc(ji,jj,jp_tem) &
+ & + risf_par_tsc(ji,jj,jp_tem) ) * surf(ji,jj) ! isf temp
+ END_2D
+ END IF
+ IF( ln_traqsr ) THEN
+ DO_2D( 0, 0, 0, 0 )
+ ztmp(ji,jj,7) = r1_rho0_rcp * qsr(ji,jj) * surf(ji,jj) ! penetrative solar radiation
+ END_2D
+ END IF
+ IF( ln_trabbc ) THEN
+ DO_2D( 0, 0, 0, 0 )
+ ztmp(ji,jj,8) = qgh_trd0(ji,jj) * surf(ji,jj) ! geothermal heat
+ END_2D
+ END IF
!
IF( ln_linssh ) THEN ! Advection flux through fixed surface (z=0)
IF( ln_isfcav ) THEN
- DO ji=1,jpi
- DO jj=1,jpj
- ztmp(ji,jj,9 ) = - surf(ji,jj) * ww(ji,jj,mikt(ji,jj)) * ts(ji,jj,mikt(ji,jj),jp_tem,Kbb)
- ztmp(ji,jj,10) = - surf(ji,jj) * ww(ji,jj,mikt(ji,jj)) * ts(ji,jj,mikt(ji,jj),jp_sal,Kbb)
- END DO
- END DO
+ DO_2D( 0, 0, 0, 0 )
+ ztmp(ji,jj,9 ) = - surf(ji,jj) * ww(ji,jj,mikt(ji,jj)) * ts(ji,jj,mikt(ji,jj),jp_tem,Kbb)
+ ztmp(ji,jj,10) = - surf(ji,jj) * ww(ji,jj,mikt(ji,jj)) * ts(ji,jj,mikt(ji,jj),jp_sal,Kbb)
+ END_2D
ELSE
- ztmp(:,:,9 ) = - surf(:,:) * ww(:,:,1) * ts(:,:,1,jp_tem,Kbb)
- ztmp(:,:,10) = - surf(:,:) * ww(:,:,1) * ts(:,:,1,jp_sal,Kbb)
+ DO_2D( 0, 0, 0, 0 )
+ ztmp(ji,jj,9 ) = - surf(ji,jj) * ww(ji,jj,1) * ts(ji,jj,1,jp_tem,Kbb)
+ ztmp(ji,jj,10) = - surf(ji,jj) * ww(ji,jj,1) * ts(ji,jj,1,jp_sal,Kbb)
+ END_2D
END IF
ENDIF
@@ -152,20 +183,22 @@ CONTAINS
! glob_sum is needed because you keep only the interior domain to compute the sum (iscpl)
!
! ! volume variation (calculated with ssh)
- ztmp(:,:,11) = surf(:,:)*ssh(:,:,Kmm) - surf_ini(:,:)*ssh_ini(:,:)
+ DO_2D( 0, 0, 0, 0 )
+ ztmp(ji,jj,11) = surf(ji,jj)*ssh(ji,jj,Kmm) - surf_ini(ji,jj)*ssh_ini(ji,jj)
+ END_2D
! ! heat & salt content variation (associated with ssh)
IF( ln_linssh ) THEN ! linear free surface case
IF( ln_isfcav ) THEN ! ISF case
- DO ji = 1, jpi
- DO jj = 1, jpj
- ztmp(ji,jj,12) = surf(ji,jj) * ( ts(ji,jj,mikt(ji,jj),jp_tem,Kmm) * ssh(ji,jj,Kmm) - ssh_hc_loc_ini(ji,jj) )
- ztmp(ji,jj,13) = surf(ji,jj) * ( ts(ji,jj,mikt(ji,jj),jp_sal,Kmm) * ssh(ji,jj,Kmm) - ssh_sc_loc_ini(ji,jj) )
- END DO
- END DO
+ DO_2D( 0, 0, 0, 0 )
+ ztmp(ji,jj,12) = surf(ji,jj) * ( ts(ji,jj,mikt(ji,jj),jp_tem,Kmm) * ssh(ji,jj,Kmm) - ssh_hc_loc_ini(ji,jj) )
+ ztmp(ji,jj,13) = surf(ji,jj) * ( ts(ji,jj,mikt(ji,jj),jp_sal,Kmm) * ssh(ji,jj,Kmm) - ssh_sc_loc_ini(ji,jj) )
+ END_2D
ELSE ! no under ice-shelf seas
- ztmp(:,:,12) = surf(:,:) * ( ts(:,:,1,jp_tem,Kmm) * ssh(:,:,Kmm) - ssh_hc_loc_ini(:,:) )
- ztmp(:,:,13) = surf(:,:) * ( ts(:,:,1,jp_sal,Kmm) * ssh(:,:,Kmm) - ssh_sc_loc_ini(:,:) )
+ DO_2D( 0, 0, 0, 0 )
+ ztmp(ji,jj,12) = surf(ji,jj) * ( ts(ji,jj,1,jp_tem,Kmm) * ssh(ji,jj,Kmm) - ssh_hc_loc_ini(ji,jj) )
+ ztmp(ji,jj,13) = surf(ji,jj) * ( ts(ji,jj,1,jp_sal,Kmm) * ssh(ji,jj,Kmm) - ssh_sc_loc_ini(ji,jj) )
+ END_2D
END IF
ENDIF
@@ -185,19 +218,27 @@ CONTAINS
! glob_sum is needed because you keep only the interior domain to compute the sum (iscpl)
!
DO jk = 1, jpkm1 ! volume
- ztmpk(:,:,jk,1) = surf (:,:) * e3t(:,:,jk,Kmm)*tmask(:,:,jk) &
- & - surf_ini(:,:) * e3t_ini(:,:,jk )*tmask_ini(:,:,jk)
+ DO_2D( 0, 0, 0, 0 )
+ ztmpk(ji,jj,jk,1) = surf (ji,jj) * e3t(ji,jj,jk,Kmm)*tmask(ji,jj,jk) &
+ & - surf_ini(ji,jj) * e3t_ini(ji,jj,jk )*tmask_ini(ji,jj,jk)
+ END_2D
END DO
DO jk = 1, jpkm1 ! heat
- ztmpk(:,:,jk,2) = ( surf (:,:) * e3t(:,:,jk,Kmm)*ts(:,:,jk,jp_tem,Kmm) &
- & - surf_ini(:,:) * hc_loc_ini(:,:,jk) )
+ DO_2D( 0, 0, 0, 0 )
+ ztmpk(ji,jj,jk,2) = ( surf (ji,jj) * e3t(ji,jj,jk,Kmm)*ts(ji,jj,jk,jp_tem,Kmm) &
+ & - surf_ini(ji,jj) * hc_loc_ini(ji,jj,jk) )
+ END_2D
END DO
DO jk = 1, jpkm1 ! salt
- ztmpk(:,:,jk,3) = ( surf (:,:) * e3t(:,:,jk,Kmm)*ts(:,:,jk,jp_sal,Kmm) &
- & - surf_ini(:,:) * sc_loc_ini(:,:,jk) )
+ DO_2D( 0, 0, 0, 0 )
+ ztmpk(ji,jj,jk,3) = ( surf (ji,jj) * e3t(ji,jj,jk,Kmm)*ts(ji,jj,jk,jp_sal,Kmm) &
+ & - surf_ini(ji,jj) * sc_loc_ini(ji,jj,jk) )
+ END_2D
END DO
DO jk = 1, jpkm1 ! total ocean volume
- ztmpk(:,:,jk,4) = surf(:,:) * e3t(:,:,jk,Kmm) * tmask(:,:,jk)
+ DO_2D( 0, 0, 0, 0 )
+ ztmpk(ji,jj,jk,4) = surf(ji,jj) * e3t(ji,jj,jk,Kmm) * tmask(ji,jj,jk)
+ END_2D
END DO
! global sum
@@ -315,32 +356,34 @@ CONTAINS
IF(lwp) WRITE(numout,*)
IF(lwp) WRITE(numout,*) ' dia_hsb_rst : initialise hsb at initial state '
IF(lwp) WRITE(numout,*)
- surf_ini(:,:) = e1e2t(:,:) * tmask_i(:,:) ! initial ocean surface
- ssh_ini(:,:) = ssh(:,:,Kmm) ! initial ssh
- DO jk = 1, jpk
- ! if ice sheet/oceqn coupling, need to mask ini variables here (mask could change at the next NEMO instance).
- e3t_ini (:,:,jk) = e3t(:,:,jk,Kmm) * tmask(:,:,jk) ! initial vertical scale factors
- tmask_ini (:,:,jk) = tmask(:,:,jk) ! initial mask
- hc_loc_ini(:,:,jk) = ts(:,:,jk,jp_tem,Kmm) * e3t(:,:,jk,Kmm) * tmask(:,:,jk) ! initial heat content
- sc_loc_ini(:,:,jk) = ts(:,:,jk,jp_sal,Kmm) * e3t(:,:,jk,Kmm) * tmask(:,:,jk) ! initial salt content
- END DO
+ DO_2D( 0, 0, 0, 0 )
+ surf_ini(ji,jj) = e1e2t(ji,jj) * tmask_i(ji,jj) ! initial ocean surface
+ ssh_ini(ji,jj) = ssh(ji,jj,Kmm) ! initial ssh
+ END_2D
+ ! if ice sheet/oceqn coupling, need to mask ini variables here (mask could change at the next NEMO instance).
+ DO_3D( 0, 0, 0, 0, 1, jpk )
+ e3t_ini (ji,jj,jk) = e3t(ji,jj,jk,Kmm) * tmask(ji,jj,jk) ! initial vertical scale factors
+ tmask_ini (ji,jj,jk) = tmask(ji,jj,jk) ! initial mask
+ hc_loc_ini(ji,jj,jk) = ts(ji,jj,jk,jp_tem,Kmm) * e3t(ji,jj,jk,Kmm) * tmask(ji,jj,jk) ! initial heat content
+ sc_loc_ini(ji,jj,jk) = ts(ji,jj,jk,jp_sal,Kmm) * e3t(ji,jj,jk,Kmm) * tmask(ji,jj,jk) ! initial salt content
+ END_3D
frc_v = 0._wp ! volume trend due to forcing
frc_t = 0._wp ! heat content - - - -
frc_s = 0._wp ! salt content - - - -
IF( ln_linssh ) THEN
IF( ln_isfcav ) THEN
- DO ji = 1, jpi
- DO jj = 1, jpj
- ssh_hc_loc_ini(ji,jj) = ts(ji,jj,mikt(ji,jj),jp_tem,Kmm) * ssh(ji,jj,Kmm) ! initial heat content in ssh
- ssh_sc_loc_ini(ji,jj) = ts(ji,jj,mikt(ji,jj),jp_sal,Kmm) * ssh(ji,jj,Kmm) ! initial salt content in ssh
- END DO
- END DO
- ELSE
- ssh_hc_loc_ini(:,:) = ts(:,:,1,jp_tem,Kmm) * ssh(:,:,Kmm) ! initial heat content in ssh
- ssh_sc_loc_ini(:,:) = ts(:,:,1,jp_sal,Kmm) * ssh(:,:,Kmm) ! initial salt content in ssh
+ DO_2D( 0, 0, 0, 0 )
+ ssh_hc_loc_ini(ji,jj) = ts(ji,jj,mikt(ji,jj),jp_tem,Kmm) * ssh(ji,jj,Kmm) ! initial heat content in ssh
+ ssh_sc_loc_ini(ji,jj) = ts(ji,jj,mikt(ji,jj),jp_sal,Kmm) * ssh(ji,jj,Kmm) ! initial salt content in ssh
+ END_2D
+ ELSE
+ DO_2D( 0, 0, 0, 0 )
+ ssh_hc_loc_ini(ji,jj) = ts(ji,jj,1,jp_tem,Kmm) * ssh(ji,jj,Kmm) ! initial heat content in ssh
+ ssh_sc_loc_ini(ji,jj) = ts(ji,jj,1,jp_sal,Kmm) * ssh(ji,jj,Kmm) ! initial salt content in ssh
+ END_2D
END IF
- frc_wn_t = 0._wp ! initial heat content misfit due to free surface
- frc_wn_s = 0._wp ! initial salt content misfit due to free surface
+ frc_wn_t = 0._wp ! initial heat content misfit due to free surface
+ frc_wn_s = 0._wp ! initial salt content misfit due to free surface
ENDIF
ENDIF
!
@@ -388,6 +431,7 @@ CONTAINS
INTEGER, INTENT(in) :: Kmm ! time level index
!
INTEGER :: ierror, ios ! local integer
+ INTEGER :: ji, jj ! loop index
!!
NAMELIST/namhsb/ ln_diahsb
!!----------------------------------------------------------------------
@@ -413,13 +457,13 @@ CONTAINS
! ------------------- !
! 1 - Allocate memory !
! ------------------- !
- ALLOCATE( hc_loc_ini(jpi,jpj,jpk), sc_loc_ini(jpi,jpj,jpk), surf_ini(jpi,jpj), &
- & e3t_ini(jpi,jpj,jpk), surf(jpi,jpj), ssh_ini(jpi,jpj), tmask_ini(jpi,jpj,jpk),STAT=ierror )
+ ALLOCATE( hc_loc_ini(A2D(0),jpk), sc_loc_ini(A2D(0),jpk), surf_ini(A2D(0)), &
+ & e3t_ini(A2D(0),jpk), surf(A2D(0)), ssh_ini(A2D(0)), tmask_ini(A2D(0),jpk),STAT=ierror )
IF( ierror > 0 ) THEN
CALL ctl_stop( 'dia_hsb_init: unable to allocate hc_loc_ini' ) ; RETURN
ENDIF
- IF( ln_linssh ) ALLOCATE( ssh_hc_loc_ini(jpi,jpj), ssh_sc_loc_ini(jpi,jpj),STAT=ierror )
+ IF( ln_linssh ) ALLOCATE( ssh_hc_loc_ini(A2D(0)), ssh_sc_loc_ini(A2D(0)),STAT=ierror )
IF( ierror > 0 ) THEN
CALL ctl_stop( 'dia_hsb: unable to allocate ssh_hc_loc_ini' ) ; RETURN
ENDIF
@@ -427,7 +471,10 @@ CONTAINS
! ----------------------------------------------- !
! 2 - Time independant variables and file opening !
! ----------------------------------------------- !
- surf(:,:) = e1e2t(:,:) * tmask_i(:,:) ! masked surface grid cell area
+
+ DO_2D( 0, 0, 0, 0 )
+ surf(ji,jj) = e1e2t(ji,jj) * smask0_i(ji,jj) ! masked surface grid cell area
+ END_2D
surf_tot = glob_sum( 'diahsb', surf(:,:) ) ! total ocean surface area
IF( ln_bdy ) CALL ctl_warn( 'dia_hsb_init: heat/salt budget does not consider open boundary fluxes' )
diff --git a/src/OCE/DIA/diahth.F90 b/src/OCE/DIA/diahth.F90
index 0b8650acf6c31eacf0ef56eb870ebf898a7aee5f..a20b476aa6a46ad0008c17403664345465a67be2 100644
--- a/src/OCE/DIA/diahth.F90
+++ b/src/OCE/DIA/diahth.F90
@@ -54,8 +54,8 @@ CONTAINS
INTEGER :: dia_hth_alloc
!!---------------------------------------------------------------------
!
- ALLOCATE( hth(jpi,jpj), hd20(jpi,jpj), hd26(jpi,jpj), hd28(jpi,jpj), &
- & htc3(jpi,jpj), htc7(jpi,jpj), htc20(jpi,jpj), STAT=dia_hth_alloc )
+ ALLOCATE( hth(A2D(0)), hd20(A2D(0)), hd26(A2D(0)), hd28(A2D(0)), &
+ & htc3(A2D(0)), htc7(A2D(0)), htc20(A2D(0)), STAT=dia_hth_alloc )
!
CALL mpp_sum ( 'diahth', dia_hth_alloc )
IF(dia_hth_alloc /= 0) CALL ctl_stop( 'STOP', 'dia_hth_alloc: failed to allocate arrays.' )
@@ -86,22 +86,22 @@ CONTAINS
INTEGER, INTENT( in ) :: kt ! ocean time-step index
INTEGER, INTENT( in ) :: Kmm ! ocean time level index
!!
- INTEGER :: ji, jj, jk ! dummy loop arguments
- REAL(wp) :: zrho3 = 0.03_wp ! density criterion for mixed layer depth
- REAL(wp) :: zrho1 = 0.01_wp ! density criterion for mixed layer depth
- REAL(wp) :: ztem2 = 0.2_wp ! temperature criterion for mixed layer depth
- REAL(wp) :: zztmp, zzdep ! temporary scalars inside do loop
- REAL(wp) :: zu, zv, zw, zut, zvt ! temporary workspace
- REAL(wp), DIMENSION(jpi,jpj) :: zabs2 ! MLD: abs( tn - tn(10m) ) = ztem2
- REAL(wp), DIMENSION(jpi,jpj) :: ztm2 ! Top of thermocline: tn = tn(10m) - ztem2
- REAL(wp), DIMENSION(jpi,jpj) :: zrho10_3 ! MLD: rho = rho10m + zrho3
- REAL(wp), DIMENSION(jpi,jpj) :: zpycn ! pycnocline: rho = rho10m + (dr/dT)(T,S,10m)*(-0.2 degC)
- REAL(wp), DIMENSION(jpi,jpj) :: ztinv ! max of temperature inversion
- REAL(wp), DIMENSION(jpi,jpj) :: zdepinv ! depth of temperature inversion
- REAL(wp), DIMENSION(jpi,jpj) :: zrho0_3 ! MLD rho = rho(surf) = 0.03
- REAL(wp), DIMENSION(jpi,jpj) :: zrho0_1 ! MLD rho = rho(surf) = 0.01
- REAL(wp), DIMENSION(jpi,jpj) :: zmaxdzT ! max of dT/dz
- REAL(wp), DIMENSION(jpi,jpj) :: zdelr ! delta rho equivalent to deltaT = 0.2
+ INTEGER :: ji, jj, jk ! dummy loop arguments
+ REAL(wp) :: zrho3 = 0.03_wp ! density criterion for mixed layer depth
+ REAL(wp) :: zrho1 = 0.01_wp ! density criterion for mixed layer depth
+ REAL(wp) :: ztem2 = 0.2_wp ! temperature criterion for mixed layer depth
+ REAL(wp) :: zztmp, zzdep ! temporary scalars inside do loop
+ REAL(wp) :: zu, zv, zw, zut, zvt ! temporary workspace
+ REAL(wp), DIMENSION(A2D(0)) :: zabs2 ! MLD: abs( tn - tn(10m) ) = ztem2
+ REAL(wp), DIMENSION(A2D(0)) :: ztm2 ! Top of thermocline: tn = tn(10m) - ztem2
+ REAL(wp), DIMENSION(A2D(0)) :: zrho10_3 ! MLD: rho = rho10m + zrho3
+ REAL(wp), DIMENSION(A2D(0)) :: zpycn ! pycnocline: rho = rho10m + (dr/dT)(T,S,10m)*(-0.2 degC)
+ REAL(wp), DIMENSION(A2D(0)) :: ztinv ! max of temperature inversion
+ REAL(wp), DIMENSION(A2D(0)) :: zdepinv ! depth of temperature inversion
+ REAL(wp), DIMENSION(A2D(0)) :: zrho0_3 ! MLD rho = rho(surf) = 0.03
+ REAL(wp), DIMENSION(A2D(0)) :: zrho0_1 ! MLD rho = rho(surf) = 0.01
+ REAL(wp), DIMENSION(A2D(0)) :: zmaxdzT ! max of dT/dz
+ REAL(wp), DIMENSION(A2D(0)) :: zdelr ! delta rho equivalent to deltaT = 0.2
!!----------------------------------------------------------------------
IF( ln_timing ) CALL timing_start('dia_hth')
@@ -131,7 +131,7 @@ CONTAINS
IF( iom_use( 'mlddzt' ) ) zmaxdzT(:,:) = 0._wp
IF( iom_use( 'mlddzt' ) .OR. iom_use( 'mld_dt02' ) .OR. iom_use( 'topthdep' ) &
& .OR. iom_use( 'mldr10_3' ) .OR. iom_use( 'pycndep' ) ) THEN
- DO_2D( 1, 1, 1, 1 )
+ DO_2D( 0, 0, 0, 0 )
zztmp = gdepw(ji,jj,mbkt(ji,jj)+1,Kmm)
hth (ji,jj) = zztmp
zabs2 (ji,jj) = zztmp
@@ -142,7 +142,7 @@ CONTAINS
ENDIF
IF( iom_use( 'mldr0_3' ) .OR. iom_use( 'mldr0_1' ) ) THEN
IF( nla10 > 1 ) THEN
- DO_2D( 1, 1, 1, 1 )
+ DO_2D( 0, 0, 0, 0 )
zztmp = gdepw(ji,jj,mbkt(ji,jj)+1,Kmm)
zrho0_3(ji,jj) = zztmp
zrho0_1(ji,jj) = zztmp
@@ -157,7 +157,7 @@ CONTAINS
! MLD: rho = rho(1) + zrho3 !
! MLD: rho = rho(1) + zrho1 !
! ------------------------------------------------------------- !
- DO_3DS( 1, 1, 1, 1, jpkm1, 2, -1 ) ! loop from bottom to 2
+ DO_3DS( 0, 0, 0, 0, jpkm1, 2, -1 ) ! loop from bottom to 2
!
zzdep = gdepw(ji,jj,jk,Kmm)
zztmp = ( ts(ji,jj,jk-1,jp_tem,Kmm) - ts(ji,jj,jk,jp_tem,Kmm) ) &
@@ -189,7 +189,7 @@ CONTAINS
!
! Preliminary computation
! computation of zdelr = (dr/dT)(T,S,10m)*(-0.2 degC)
- DO_2D( 1, 1, 1, 1 )
+ DO_2D( 0, 0, 0, 0 )
IF( tmask(ji,jj,nla10) == 1. ) THEN
zu = 1779.50 + 11.250 * ts(ji,jj,nla10,jp_tem,Kmm) - 3.80 * ts(ji,jj,nla10,jp_sal,Kmm) &
& - 0.0745 * ts(ji,jj,nla10,jp_tem,Kmm) * ts(ji,jj,nla10,jp_tem,Kmm) &
@@ -213,7 +213,7 @@ CONTAINS
! temperature inversion: max( 0, max of tn - tn(10m) ) !
! depth of temperature inversion !
! ------------------------------------------------------------- !
- DO_3DS( 1, 1, 1, 1, jpkm1, nlb10, -1 ) ! loop from bottom to nlb10
+ DO_3DS( 0, 0, 0, 0, jpkm1, nlb10, -1 ) ! loop from bottom to nlb10
!
zzdep = gdepw(ji,jj,jk,Kmm) * tmask(ji,jj,1)
!
@@ -301,17 +301,20 @@ CONTAINS
!
INTEGER , INTENT(in) :: Kmm ! ocean time level index
REAL(wp), INTENT(in) :: ptem
- REAL(wp), DIMENSION(jpi,jpj), INTENT(out) :: pdept
+ REAL(wp), DIMENSION(A2D(0)), INTENT(out) :: pdept
!
INTEGER :: ji, jj, jk, iid
REAL(wp) :: zztmp, zzdep
- INTEGER, DIMENSION(jpi,jpj) :: iktem
+ INTEGER, DIMENSION(A2D(0)) :: iktem
! --------------------------------------- !
! search deepest level above ptem !
! --------------------------------------- !
- iktem(:,:) = 1
- DO_3D( 1, 1, 1, 1, 1, jpkm1 ) ! beware temperature is not always decreasing with depth => loop from top to bottom
+ DO_2D( 0, 0, 0, 0 )
+ iktem(ji,jj) = 1
+ END_2D
+
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 ) ! beware temperature is not always decreasing with depth => loop from top to bottom
zztmp = ts(ji,jj,jk,jp_tem,Kmm)
IF( zztmp >= ptem ) iktem(ji,jj) = jk
END_3D
@@ -319,7 +322,7 @@ CONTAINS
! ------------------------------- !
! Depth of ptem isotherm !
! ------------------------------- !
- DO_2D( 1, 1, 1, 1 )
+ DO_2D( 0, 0, 0, 0 )
!
zzdep = gdepw(ji,jj,mbkt(ji,jj)+1,Kmm) ! depth of the ocean bottom
!
@@ -343,21 +346,32 @@ CONTAINS
INTEGER , INTENT(in) :: Kmm ! ocean time level index
REAL(wp), INTENT(in) :: pdep ! depth over the heat content
REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in) :: pt
- REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: phtc
+ REAL(wp), DIMENSION(A2D(0)), INTENT(inout) :: phtc
!
INTEGER :: ji, jj, jk, ik
- REAL(wp), DIMENSION(jpi,jpj) :: zthick
- INTEGER , DIMENSION(jpi,jpj) :: ilevel
+ REAL(wp), DIMENSION(A2D(0)) :: zthick
+ INTEGER , DIMENSION(A2D(0)) :: ilevel
! surface boundary condition
- IF( .NOT. ln_linssh ) THEN ; zthick(:,:) = 0._wp ; phtc(:,:) = 0._wp
- ELSE ; zthick(:,:) = ssh(:,:,Kmm) ; phtc(:,:) = pt(:,:,1) * ssh(:,:,Kmm) * tmask(:,:,1)
+ IF( .NOT. ln_linssh ) THEN
+ DO_2D( 0, 0, 0, 0 )
+ zthick(ji,jj) = 0._wp
+ phtc (ji,jj) = 0._wp
+ END_2D
+ ELSE
+ DO_2D( 0, 0, 0, 0 )
+ zthick(ji,jj) = ssh(ji,jj,Kmm)
+ phtc (ji,jj) = pt(ji,jj,1) * ssh(ji,jj,Kmm) * tmask(ji,jj,1)
+ END_2D
ENDIF
!
- ilevel(:,:) = 1
- DO_3D( 1, 1, 1, 1, 1, jpkm1 )
+ DO_2D( 0, 0, 0, 0 )
+ ilevel(ji,jj) = 1
+ END_2D
+ !
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
IF( ( gdepw(ji,jj,jk+1,Kmm) < pdep ) .AND. ( tmask(ji,jj,jk) == 1 ) ) THEN
ilevel(ji,jj) = jk+1
zthick(ji,jj) = zthick(ji,jj) + e3t(ji,jj,jk,Kmm)
@@ -365,7 +379,7 @@ CONTAINS
ENDIF
END_3D
!
- DO_2D( 1, 1, 1, 1 )
+ DO_2D( 0, 0, 0, 0 )
ik = ilevel(ji,jj)
IF( tmask(ji,jj,ik) == 1 ) THEN
zthick(ji,jj) = MIN ( gdepw(ji,jj,ik+1,Kmm), pdep ) - zthick(ji,jj) ! remaining thickness to reach dephw pdep
diff --git a/src/OCE/DIA/diamlr.F90 b/src/OCE/DIA/diamlr.F90
index edd8e19f99b0b6da90be9c07bc91a6aa73108144..728e964a3f6bde157e5b72a6de441030d3f9412e 100644
--- a/src/OCE/DIA/diamlr.F90
+++ b/src/OCE/DIA/diamlr.F90
@@ -6,7 +6,7 @@ MODULE diamlr
!! History : 4.0 ! 2019 (S. Mueller) Original code
!!----------------------------------------------------------------------
- USE par_oce , ONLY : wp, jpi, jpj
+ USE par_oce , ONLY : wp, jpi, jpj, ntsi, ntei, ntsj, ntej
USE phycst , ONLY : rpi
USE dom_oce , ONLY : adatrj
USE tide_mod
@@ -407,8 +407,9 @@ CONTAINS
!! ** Purpose : update time used in multiple-linear-regression analysis
!!
!!----------------------------------------------------------------------
- REAL(wp), DIMENSION(jpi,jpj) :: zadatrj2d
+ REAL(wp), DIMENSION(T2D(0)) :: zadatrj2d
!!----------------------------------------------------------------------
+ INTEGER :: ji, jj
IF( ln_timing ) CALL timing_start('dia_mlr')
@@ -417,7 +418,9 @@ CONTAINS
!
! A 2-dimensional field of constant value is sent, and subsequently used directly
! or transformed to a scalar or a constant 3-dimensional field as required.
- zadatrj2d(:,:) = adatrj*86400.0_wp
+ DO_2D( 0, 0, 0, 0 )
+ zadatrj2d(ji,jj) = adatrj*86400.0_wp
+ END_2D
IF ( iom_use('diamlr_time') ) CALL iom_put('diamlr_time', zadatrj2d)
!
IF( ln_timing ) CALL timing_stop('dia_mlr')
diff --git a/src/OCE/DIA/diaptr.F90 b/src/OCE/DIA/diaptr.F90
index 8962bd371022c031c3640f49b1d8847d02eada82..e04e88fef9ff09e86d7e560d63ad15ab00279967 100644
--- a/src/OCE/DIA/diaptr.F90
+++ b/src/OCE/DIA/diaptr.F90
@@ -76,9 +76,9 @@ CONTAINS
!!----------------------------------------------------------------------
!! *** ROUTINE dia_ptr ***
!!----------------------------------------------------------------------
- INTEGER , INTENT(in) :: kt ! ocean time-step index
- INTEGER , INTENT(in) :: Kmm ! time level index
- REAL(wp), DIMENSION(A2D(nn_hls),jpk) , INTENT(in), OPTIONAL :: pvtr ! j-effective transport
+ INTEGER , INTENT(in) :: kt ! ocean time-step index
+ INTEGER , INTENT(in) :: Kmm ! time level index
+ REAL(wp), DIMENSION(T2D(nn_hls),jpk) , INTENT(in), OPTIONAL :: pvtr ! j-effective transport
!!----------------------------------------------------------------------
!
IF( ln_timing ) CALL timing_start('dia_ptr')
@@ -110,13 +110,13 @@ CONTAINS
!!----------------------------------------------------------------------
!! ** Purpose : Calculate diagnostics and send to XIOS
!!----------------------------------------------------------------------
- INTEGER , INTENT(in) :: kt ! ocean time-step index
- INTEGER , INTENT(in) :: Kmm ! time level index
- REAL(wp), DIMENSION(A2D(nn_hls),jpk) , INTENT(in), OPTIONAL :: pvtr ! j-effective transport
+ INTEGER , INTENT(in) :: kt ! ocean time-step index
+ INTEGER , INTENT(in) :: Kmm ! time level index
+ REAL(wp), DIMENSION(:,:,:), INTENT(in), OPTIONAL :: pvtr ! j-effective transport (used only by PRESENT)
!
INTEGER :: ji, jj, jk, jn ! dummy loop indices
- REAL(wp), DIMENSION(jpi,jpj) :: z2d ! 2D workspace
- REAL(wp), DIMENSION(jpj) :: zvsum, ztsum, zssum ! 1D workspace
+ REAL(wp), DIMENSION(A2D(0)) :: z2d ! 2D workspace
+ REAL(wp), DIMENSION(A1Dj(0)) :: zvsum, ztsum, zssum ! 1D workspace
!
!overturning calculation
REAL(wp), DIMENSION(:,:,: ), ALLOCATABLE :: sjk, r1_sjk, v_msf ! i-mean i-k-surface and its inverse
@@ -126,19 +126,19 @@ CONTAINS
REAL(wp), DIMENSION(:,:,: ), ALLOCATABLE :: z3dtr
!!----------------------------------------------------------------------
!
- ALLOCATE( z3dtr(jpi,jpj,nbasin) )
+ ALLOCATE( z3dtr(A2D(0),nbasin) )
IF( PRESENT( pvtr ) ) THEN
IF( iom_use( 'zomsf' ) ) THEN ! effective MSF
- ALLOCATE( z4d1(jpi,jpj,jpk,nbasin) )
+ ALLOCATE( z4d1(A2D(0),jpk,nbasin) )
!
DO jn = 1, nbasin ! by sub-basins
- z4d1(1,:,:,jn) = pvtr_int(:,:,jp_vtr,jn) ! zonal cumulative effective transport excluding closed seas
+ z4d1(Nis0,:,:,jn) = pvtr_int(:,:,jp_vtr,jn) ! zonal cumulative effective transport excluding closed seas
DO jk = jpkm1, 1, -1
- z4d1(1,:,jk,jn) = z4d1(1,:,jk+1,jn) - z4d1(1,:,jk,jn) ! effective j-Stream-Function (MSF)
+ z4d1(Nis0,:,jk,jn) = z4d1(Nis0,:,jk+1,jn) - z4d1(Nis0,:,jk,jn) ! effective j-Stream-Function (MSF)
END DO
- DO ji = 2, jpi
- z4d1(ji,:,:,jn) = z4d1(1,:,:,jn)
+ DO ji = Nis0+1, Nie0
+ z4d1(ji,:,:,jn) = z4d1(Nis0,:,:,jn)
ENDDO
END DO
CALL iom_put( 'zomsf', z4d1 * rc_sv )
@@ -146,8 +146,8 @@ CONTAINS
DEALLOCATE( z4d1 )
ENDIF
IF( iom_use( 'sopstove' ) .OR. iom_use( 'sophtove' ) ) THEN
- ALLOCATE( sjk(jpj,jpk,nbasin), r1_sjk(jpj,jpk,nbasin), v_msf(jpj,jpk,nbasin), &
- & zt_jk(jpj,jpk,nbasin), zs_jk(jpj,jpk,nbasin) )
+ ALLOCATE( sjk( A1Dj(0),jpk,nbasin), r1_sjk(A1Dj(0),jpk,nbasin), v_msf(A1Dj(0),jpk,nbasin), &
+ & zt_jk(A1Dj(0),jpk,nbasin), zs_jk( A1Dj(0),jpk,nbasin) )
!
DO jn = 1, nbasin
sjk(:,:,jn) = pvtr_int(:,:,jp_msk,jn)
@@ -162,16 +162,16 @@ CONTAINS
!
ENDDO
DO jn = 1, nbasin
- z3dtr(1,:,jn) = hstr_ove(:,jp_tem,jn) * rc_pwatt ! (conversion in PW)
- DO ji = 2, jpi
- z3dtr(ji,:,jn) = z3dtr(1,:,jn)
+ z3dtr(Nis0,:,jn) = hstr_ove(:,jp_tem,jn) * rc_pwatt ! (conversion in PW)
+ DO ji = Nis0+1, Nie0
+ z3dtr(ji,:,jn) = z3dtr(Nis0,:,jn)
ENDDO
ENDDO
CALL iom_put( 'sophtove', z3dtr )
DO jn = 1, nbasin
- z3dtr(1,:,jn) = hstr_ove(:,jp_sal,jn) * rc_ggram ! (conversion in Gg)
- DO ji = 2, jpi
- z3dtr(ji,:,jn) = z3dtr(1,:,jn)
+ z3dtr(Nis0,:,jn) = hstr_ove(:,jp_sal,jn) * rc_ggram ! (conversion in Gg)
+ DO ji = Nis0+1, Nie0
+ z3dtr(ji,:,jn) = z3dtr(Nis0,:,jn)
ENDDO
ENDDO
CALL iom_put( 'sopstove', z3dtr )
@@ -181,7 +181,7 @@ CONTAINS
IF( iom_use( 'sopstbtr' ) .OR. iom_use( 'sophtbtr' ) ) THEN
! Calculate barotropic heat and salt transport here
- ALLOCATE( sjk(jpj,1,nbasin), r1_sjk(jpj,1,nbasin) )
+ ALLOCATE( sjk(A1Dj(0),1,nbasin), r1_sjk(A1Dj(0),1,nbasin) )
!
DO jn = 1, nbasin
sjk(:,1,jn) = SUM( pvtr_int(:,:,jp_msk,jn), 2 )
@@ -196,16 +196,16 @@ CONTAINS
!
ENDDO
DO jn = 1, nbasin
- z3dtr(1,:,jn) = hstr_btr(:,jp_tem,jn) * rc_pwatt ! (conversion in PW)
- DO ji = 2, jpi
- z3dtr(ji,:,jn) = z3dtr(1,:,jn)
+ z3dtr(Nis0,:,jn) = hstr_btr(:,jp_tem,jn) * rc_pwatt ! (conversion in PW)
+ DO ji = Nis0+1, Nie0
+ z3dtr(ji,:,jn) = z3dtr(Nis0,:,jn)
ENDDO
ENDDO
CALL iom_put( 'sophtbtr', z3dtr )
DO jn = 1, nbasin
- z3dtr(1,:,jn) = hstr_btr(:,jp_sal,jn) * rc_ggram ! (conversion in Gg)
- DO ji = 2, jpi
- z3dtr(ji,:,jn) = z3dtr(1,:,jn)
+ z3dtr(Nis0,:,jn) = hstr_btr(:,jp_sal,jn) * rc_ggram ! (conversion in Gg)
+ DO ji = Nis0+1, Nie0
+ z3dtr(ji,:,jn) = z3dtr(Nis0,:,jn)
ENDDO
ENDDO
CALL iom_put( 'sopstbtr', z3dtr )
@@ -218,28 +218,28 @@ CONTAINS
pvtr_int(:,:,:,:) = 0._wp
ELSE
IF( iom_use( 'zotem' ) .OR. iom_use( 'zosal' ) .OR. iom_use( 'zosrf' ) ) THEN ! i-mean i-k-surface
- ALLOCATE( z4d1(jpi,jpj,jpk,nbasin), z4d2(jpi,jpj,jpk,nbasin) )
+ ALLOCATE( z4d1(A2D(0),jpk,nbasin), z4d2(A2D(0),jpk,nbasin) )
!
DO jn = 1, nbasin
- z4d1(1,:,:,jn) = pzon_int(:,:,jp_msk,jn)
- DO ji = 2, jpi
- z4d1(ji,:,:,jn) = z4d1(1,:,:,jn)
+ z4d1(Nis0,:,:,jn) = pzon_int(:,:,jp_msk,jn)
+ DO ji = Nis0+1, Nie0
+ z4d1(ji,:,:,jn) = z4d1(Nis0,:,:,jn)
ENDDO
ENDDO
CALL iom_put( 'zosrf', z4d1 )
!
DO jn = 1, nbasin
- z4d2(1,:,:,jn) = pzon_int(:,:,jp_tem,jn) / MAX( z4d1(1,:,:,jn), 10.e-15 )
- DO ji = 2, jpi
- z4d2(ji,:,:,jn) = z4d2(1,:,:,jn)
+ z4d2(Nis0,:,:,jn) = pzon_int(:,:,jp_tem,jn) / MAX( z4d1(Nis0,:,:,jn), 10.e-15 )
+ DO ji = Nis0+1, Nie0
+ z4d2(ji,:,:,jn) = z4d2(Nis0,:,:,jn)
ENDDO
ENDDO
CALL iom_put( 'zotem', z4d2 )
!
DO jn = 1, nbasin
- z4d2(1,:,:,jn) = pzon_int(:,:,jp_sal,jn) / MAX( z4d1(1,:,:,jn), 10.e-15 )
- DO ji = 2, jpi
- z4d2(ji,:,:,jn) = z4d2(1,:,:,jn)
+ z4d2(Nis0,:,:,jn) = pzon_int(:,:,jp_sal,jn) / MAX( z4d1(Nis0,:,:,jn), 10.e-15 )
+ DO ji = Nis0+1, Nie0
+ z4d2(ji,:,:,jn) = z4d2(Nis0,:,:,jn)
ENDDO
ENDDO
CALL iom_put( 'zosal', z4d2 )
@@ -251,16 +251,16 @@ CONTAINS
IF( iom_use( 'sophtadv' ) .OR. iom_use( 'sopstadv' ) ) THEN
!
DO jn = 1, nbasin
- z3dtr(1,:,jn) = hstr_adv(:,jp_tem,jn) * rc_pwatt ! (conversion in PW)
- DO ji = 2, jpi
- z3dtr(ji,:,jn) = z3dtr(1,:,jn)
+ z3dtr(Nis0,:,jn) = hstr_adv(:,jp_tem,jn) * rc_pwatt ! (conversion in PW)
+ DO ji = Nis0+1, Nie0
+ z3dtr(ji,:,jn) = z3dtr(Nis0,:,jn)
ENDDO
ENDDO
CALL iom_put( 'sophtadv', z3dtr )
DO jn = 1, nbasin
- z3dtr(1,:,jn) = hstr_adv(:,jp_sal,jn) * rc_ggram ! (conversion in Gg)
- DO ji = 2, jpi
- z3dtr(ji,:,jn) = z3dtr(1,:,jn)
+ z3dtr(Nis0,:,jn) = hstr_adv(:,jp_sal,jn) * rc_ggram ! (conversion in Gg)
+ DO ji = Nis0+1, Nie0
+ z3dtr(ji,:,jn) = z3dtr(Nis0,:,jn)
ENDDO
ENDDO
CALL iom_put( 'sopstadv', z3dtr )
@@ -269,16 +269,16 @@ CONTAINS
IF( iom_use( 'sophtldf' ) .OR. iom_use( 'sopstldf' ) ) THEN
!
DO jn = 1, nbasin
- z3dtr(1,:,jn) = hstr_ldf(:,jp_tem,jn) * rc_pwatt ! (conversion in PW)
- DO ji = 2, jpi
- z3dtr(ji,:,jn) = z3dtr(1,:,jn)
+ z3dtr(Nis0,:,jn) = hstr_ldf(:,jp_tem,jn) * rc_pwatt ! (conversion in PW)
+ DO ji = Nis0+1, Nie0
+ z3dtr(ji,:,jn) = z3dtr(Nis0,:,jn)
ENDDO
ENDDO
CALL iom_put( 'sophtldf', z3dtr )
DO jn = 1, nbasin
- z3dtr(1,:,jn) = hstr_ldf(:,jp_sal,jn) * rc_ggram ! (conversion in Gg)
- DO ji = 2, jpi
- z3dtr(ji,:,jn) = z3dtr(1,:,jn)
+ z3dtr(Nis0,:,jn) = hstr_ldf(:,jp_sal,jn) * rc_ggram ! (conversion in Gg)
+ DO ji = Nis0+1, Nie0
+ z3dtr(ji,:,jn) = z3dtr(Nis0,:,jn)
ENDDO
ENDDO
CALL iom_put( 'sopstldf', z3dtr )
@@ -287,16 +287,16 @@ CONTAINS
IF( iom_use( 'sophteiv' ) .OR. iom_use( 'sopsteiv' ) ) THEN
!
DO jn = 1, nbasin
- z3dtr(1,:,jn) = hstr_eiv(:,jp_tem,jn) * rc_pwatt ! (conversion in PW)
- DO ji = 2, jpi
- z3dtr(ji,:,jn) = z3dtr(1,:,jn)
+ z3dtr(Nis0,:,jn) = hstr_eiv(:,jp_tem,jn) * rc_pwatt ! (conversion in PW)
+ DO ji = Nis0+1, Nie0
+ z3dtr(ji,:,jn) = z3dtr(Nis0,:,jn)
ENDDO
ENDDO
CALL iom_put( 'sophteiv', z3dtr )
DO jn = 1, nbasin
- z3dtr(1,:,jn) = hstr_eiv(:,jp_sal,jn) * rc_ggram ! (conversion in Gg)
- DO ji = 2, jpi
- z3dtr(ji,:,jn) = z3dtr(1,:,jn)
+ z3dtr(Nis0,:,jn) = hstr_eiv(:,jp_sal,jn) * rc_ggram ! (conversion in Gg)
+ DO ji = Nis0+1, Nie0
+ z3dtr(ji,:,jn) = z3dtr(Nis0,:,jn)
ENDDO
ENDDO
CALL iom_put( 'sopsteiv', z3dtr )
@@ -304,16 +304,16 @@ CONTAINS
!
IF( iom_use( 'sopstvtr' ) .OR. iom_use( 'sophtvtr' ) ) THEN
DO jn = 1, nbasin
- z3dtr(1,:,jn) = hstr_vtr(:,jp_tem,jn) * rc_pwatt ! (conversion in PW)
- DO ji = 2, jpi
- z3dtr(ji,:,jn) = z3dtr(1,:,jn)
+ z3dtr(Nis0,:,jn) = hstr_vtr(:,jp_tem,jn) * rc_pwatt ! (conversion in PW)
+ DO ji = Nis0+1, Nie0
+ z3dtr(ji,:,jn) = z3dtr(Nis0,:,jn)
ENDDO
ENDDO
CALL iom_put( 'sophtvtr', z3dtr )
DO jn = 1, nbasin
- z3dtr(1,:,jn) = hstr_vtr(:,jp_sal,jn) * rc_ggram ! (conversion in Gg)
- DO ji = 2, jpi
- z3dtr(ji,:,jn) = z3dtr(1,:,jn)
+ z3dtr(Nis0,:,jn) = hstr_vtr(:,jp_sal,jn) * rc_ggram ! (conversion in Gg)
+ DO ji = Nis0+1, Nie0
+ z3dtr(ji,:,jn) = z3dtr(Nis0,:,jn)
ENDDO
ENDDO
CALL iom_put( 'sopstvtr', z3dtr )
@@ -349,8 +349,9 @@ CONTAINS
!! ** Action : pvtr_int - terms for volume streamfunction, heat/salt transport barotropic/overturning terms
!! pzon_int - terms for i mean temperature/salinity
!!----------------------------------------------------------------------
- INTEGER , INTENT(in) :: Kmm ! time level index
- REAL(wp), DIMENSION(A2D(nn_hls),jpk), INTENT(in), OPTIONAL :: pvtr ! j-effective transport
+ INTEGER , INTENT(in) :: Kmm ! time level index
+ REAL(wp), DIMENSION(T2D(nn_hls),jpk), INTENT(in), OPTIONAL :: pvtr ! j-effective transport
+ !
REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zmask ! 3D workspace
REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: zts ! 4D workspace
REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: sjk, v_msf ! Zonal sum: i-k surface area, j-effective transport
@@ -362,7 +363,7 @@ CONTAINS
IF( PRESENT( pvtr ) ) THEN
! i sum of effective j transport excluding closed seas
IF( iom_use( 'zomsf' ) .OR. iom_use( 'sopstove' ) .OR. iom_use( 'sophtove' ) ) THEN
- ALLOCATE( v_msf(A1Dj(nn_hls),jpk,nbasin) )
+ ALLOCATE( v_msf(T1Dj(0),jpk,nbasin) )
DO jn = 1, nbasin
v_msf(:,:,jn) = ptr_sjk( pvtr(:,:,:), btmsk34(:,:,jn) )
@@ -374,16 +375,13 @@ CONTAINS
ENDIF
! i sum of j surface area, j surface area - temperature/salinity product on V grid
- IF( iom_use( 'sopstove' ) .OR. iom_use( 'sophtove' ) .OR. &
+ IF( iom_use( 'sopstove' ) .OR. iom_use( 'sophtove' ) .OR. &
& iom_use( 'sopstbtr' ) .OR. iom_use( 'sophtbtr' ) ) THEN
- ALLOCATE( zmask(A2D(nn_hls),jpk), zts(A2D(nn_hls),jpk,jpts), &
- & sjk(A1Dj(nn_hls),jpk,nbasin), &
- & zt_jk(A1Dj(nn_hls),jpk,nbasin), zs_jk(A1Dj(nn_hls),jpk,nbasin) )
-
- zmask(:,:,:) = 0._wp
- zts(:,:,:,:) = 0._wp
+ ALLOCATE( zmask( T2D(0),jpk ), zts( T2D(0),jpk,jpts ), &
+ & sjk( T1Dj(0),jpk,nbasin), &
+ & zt_jk(T1Dj(0),jpk,nbasin), zs_jk(T1Dj(0),jpk,nbasin) )
- DO_3D( 1, 1, 1, 0, 1, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
zvfc = e1v(ji,jj) * e3v(ji,jj,jk,Kmm)
zmask(ji,jj,jk) = vmask(ji,jj,jk) * zvfc
zts(ji,jj,jk,jp_tem) = (ts(ji,jj,jk,jp_tem,Kmm)+ts(ji,jj+1,jk,jp_tem,Kmm)) * 0.5 * zvfc !Tracers averaged onto V grid
@@ -405,14 +403,11 @@ CONTAINS
ELSE
! i sum of j surface area - temperature/salinity product on T grid
IF( iom_use( 'zotem' ) .OR. iom_use( 'zosal' ) .OR. iom_use( 'zosrf' ) ) THEN
- ALLOCATE( zmask(A2D(nn_hls),jpk), zts(A2D(nn_hls),jpk,jpts), &
- & sjk(A1Dj(nn_hls),jpk,nbasin), &
- & zt_jk(A1Dj(nn_hls),jpk,nbasin), zs_jk(A1Dj(nn_hls),jpk,nbasin) )
-
- zmask(:,:,:) = 0._wp
- zts(:,:,:,:) = 0._wp
+ ALLOCATE( zmask( T2D(0),jpk ), zts( T2D(0),jpk,jpts ), &
+ & sjk( T1Dj(0),jpk,nbasin), &
+ & zt_jk(T1Dj(0),jpk,nbasin), zs_jk(T1Dj(0),jpk,nbasin) )
- DO_3D( 1, 1, 1, 1, 1, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
zsfc = e1t(ji,jj) * e3t(ji,jj,jk,Kmm)
zmask(ji,jj,jk) = tmask(ji,jj,jk) * zsfc
zts(ji,jj,jk,jp_tem) = ts(ji,jj,jk,jp_tem,Kmm) * zsfc
@@ -434,11 +429,9 @@ CONTAINS
! i-k sum of j surface area - temperature/salinity product on V grid
IF( iom_use( 'sopstvtr' ) .OR. iom_use( 'sophtvtr' ) ) THEN
- ALLOCATE( zts(A2D(nn_hls),jpk,jpts) )
+ ALLOCATE( zts(T2D(0),jpk,jpts) )
- zts(:,:,:,:) = 0._wp
-
- DO_3D( 1, 1, 1, 0, 1, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
zvfc = e1v(ji,jj) * e3v(ji,jj,jk,Kmm)
zts(ji,jj,jk,jp_tem) = (ts(ji,jj,jk,jp_tem,Kmm)+ts(ji,jj+1,jk,jp_tem,Kmm)) * 0.5 * zvfc !Tracers averaged onto V grid
zts(ji,jj,jk,jp_sal) = (ts(ji,jj,jk,jp_sal,Kmm)+ts(ji,jj+1,jk,jp_sal,Kmm)) * 0.5 * zvfc
@@ -532,17 +525,28 @@ CONTAINS
SUBROUTINE dia_ptr_hst( ktra, cptr, pvflx )
+ !!
+ INTEGER, INTENT(in) :: ktra ! tracer index
+ CHARACTER(len=3), INTENT(in) :: cptr ! transport type 'adv'/'ldf'/'eiv'
+ REAL(wp), DIMENSION(:,:,:), INTENT(in) :: pvflx ! 3D input array of advection/diffusion
+ !!
+ CALL dia_ptr_hst_t( ktra, cptr, pvflx(:,:,:), lbnd_ij(pvflx) )
+ END SUBROUTINE dia_ptr_hst
+
+
+ SUBROUTINE dia_ptr_hst_t( ktra, cptr, pvflx, ktvflx )
!!----------------------------------------------------------------------
!! *** ROUTINE dia_ptr_hst ***
!!----------------------------------------------------------------------
!! Wrapper for heat and salt transport calculations to calculate them for each basin
!! Called from all advection and/or diffusion routines
!!----------------------------------------------------------------------
- INTEGER , INTENT(in ) :: ktra ! tracer index
- CHARACTER(len=3) , INTENT(in) :: cptr ! transport type 'adv'/'ldf'/'eiv'
- REAL(wp), DIMENSION(A2D(nn_hls),jpk) , INTENT(in) :: pvflx ! 3D input array of advection/diffusion
- REAL(wp), DIMENSION(A1Dj(nn_hls),nbasin) :: zsj !
- INTEGER :: jn !
+ INTEGER, DIMENSION(2), INTENT(in) :: ktvflx
+ INTEGER, INTENT(in) :: ktra ! tracer index
+ CHARACTER(len=3), INTENT(in) :: cptr ! transport type 'adv'/'ldf'/'eiv'
+ REAL(wp), DIMENSION(AB2D(ktvflx),JPK), INTENT(in) :: pvflx ! 3D input array of advection/diffusion
+ REAL(wp), DIMENSION(T1Dj(0),nbasin) :: zsj !
+ INTEGER :: jn !
DO jn = 1, nbasin
zsj(:,jn) = ptr_sj( pvflx(:,:,:), btmsk(:,:,jn) )
@@ -562,7 +566,7 @@ CONTAINS
IF( ktra == jp_sal ) CALL ptr_sum( hstr_vtr(:,jp_sal,:), zsj(:,:) )
ENDIF
!
- END SUBROUTINE dia_ptr_hst
+ END SUBROUTINE dia_ptr_hst_t
SUBROUTINE ptr_sum_2d( phstr, pva )
@@ -576,26 +580,28 @@ CONTAINS
!!
!! ** Action : phstr
!!----------------------------------------------------------------------
- REAL(wp), DIMENSION(jpj,nbasin) , INTENT(inout) :: phstr !
- REAL(wp), DIMENSION(A1Dj(nn_hls),nbasin), INTENT(in) :: pva !
- INTEGER :: jj
+ REAL(wp), DIMENSION(A1Dj(0),nbasin), INTENT(inout) :: phstr !
+ REAL(wp), DIMENSION(T1Dj(0),nbasin), INTENT(in ) :: pva !
+ INTEGER :: jj
#if ! defined key_mpi_off
- INTEGER, DIMENSION(1) :: ish1d
- INTEGER, DIMENSION(2) :: ish2d
- REAL(wp), DIMENSION(jpj*nbasin) :: zwork
+ INTEGER, DIMENSION(1) :: ish1d
+ INTEGER, DIMENSION(2) :: ish2d
+ REAL(wp), DIMENSION(:), ALLOCATABLE :: zwork
#endif
- DO jj = ntsj, ntej
+ DO_1Dj( 0, 0 )
phstr(jj,:) = phstr(jj,:) + pva(jj,:)
- END DO
+ END_1D
#if ! defined key_mpi_off
IF( .NOT. l_istiled .OR. ntile == nijtile ) THEN
- ish1d(1) = jpj*nbasin
- ish2d(1) = jpj ; ish2d(2) = nbasin
+ ALLOCATE( zwork(Nj_0*nbasin) )
+ ish1d(1) = Nj_0*nbasin
+ ish2d(1) = Nj_0 ; ish2d(2) = nbasin
zwork(:) = RESHAPE( phstr(:,:), ish1d )
CALL mpp_sum( 'diaptr', zwork, ish1d(1), ncomm_znl )
phstr(:,:) = RESHAPE( zwork, ish2d )
+ DEALLOCATE( zwork )
ENDIF
#endif
END SUBROUTINE ptr_sum_2d
@@ -612,28 +618,30 @@ CONTAINS
!!
!! ** Action : phstr
!!----------------------------------------------------------------------
- REAL(wp), DIMENSION(jpj,jpk,nbasin) , INTENT(inout) :: phstr !
- REAL(wp), DIMENSION(A1Dj(nn_hls),jpk,nbasin), INTENT(in) :: pva !
- INTEGER :: jj, jk
+ REAL(wp), DIMENSION(Njs0:Nje0,jpk,nbasin), INTENT(inout) :: phstr !
+ REAL(wp), DIMENSION(T1Dj(0) ,jpk,nbasin), INTENT(in ) :: pva !
+ INTEGER :: jj, jk
#if ! defined key_mpi_off
- INTEGER, DIMENSION(1) :: ish1d
- INTEGER, DIMENSION(3) :: ish3d
- REAL(wp), DIMENSION(jpj*jpk*nbasin) :: zwork
+ INTEGER, DIMENSION(1) :: ish1d
+ INTEGER, DIMENSION(3) :: ish3d
+ REAL(wp), DIMENSION(:), ALLOCATABLE :: zwork
#endif
DO jk = 1, jpk
- DO jj = ntsj, ntej
+ DO_1Dj( 0, 0 )
phstr(jj,jk,:) = phstr(jj,jk,:) + pva(jj,jk,:)
- END DO
+ END_1D
END DO
#if ! defined key_mpi_off
IF( .NOT. l_istiled .OR. ntile == nijtile ) THEN
- ish1d(1) = jpj*jpk*nbasin
- ish3d(1) = jpj ; ish3d(2) = jpk ; ish3d(3) = nbasin
+ ALLOCATE( zwork(Nj_0*jpk*nbasin) )
+ ish1d(1) = Nj_0*jpk*nbasin
+ ish3d(1) = Nj_0 ; ish3d(2) = jpk ; ish3d(3) = nbasin
zwork(:) = RESHAPE( phstr(:,:,:), ish1d )
CALL mpp_sum( 'diaptr', zwork, ish1d(1), ncomm_znl )
phstr(:,:,:) = RESHAPE( zwork, ish3d )
+ DEALLOCATE( zwork )
ENDIF
#endif
END SUBROUTINE ptr_sum_3d
@@ -651,13 +659,13 @@ CONTAINS
! nbasin has been initialized in iom_init to define the axis "basin"
!
IF( .NOT. ALLOCATED( btmsk ) ) THEN
- ALLOCATE( btmsk(jpi,jpj,nbasin) , btmsk34(jpi,jpj,nbasin), &
- & hstr_adv(jpj,jpts,nbasin), hstr_eiv(jpj,jpts,nbasin), &
- & hstr_ove(jpj,jpts,nbasin), hstr_btr(jpj,jpts,nbasin), &
- & hstr_ldf(jpj,jpts,nbasin), hstr_vtr(jpj,jpts,nbasin), STAT=ierr(1) )
+ ALLOCATE( btmsk(A2D(nn_hls),nbasin) , btmsk34(A2D(nn_hls),nbasin) , &
+ & hstr_adv(A1Dj(0),jpts,nbasin), hstr_eiv(A1Dj(0),jpts,nbasin), &
+ & hstr_ove(A1Dj(0),jpts,nbasin), hstr_btr(A1Dj(0),jpts,nbasin), &
+ & hstr_ldf(A1Dj(0),jpts,nbasin), hstr_vtr(A1Dj(0),jpts,nbasin), STAT=ierr(1) )
!
- ALLOCATE( pvtr_int(jpj,jpk,jpts+2,nbasin), &
- & pzon_int(jpj,jpk,jpts+1,nbasin), STAT=ierr(2) )
+ ALLOCATE( pvtr_int(A1Dj(0),jpk,jpts+2,nbasin), &
+ & pzon_int(A1Dj(0),jpk,jpts+1,nbasin), STAT=ierr(2) )
!
dia_ptr_alloc = MAXVAL( ierr )
CALL mpp_sum( 'diaptr', dia_ptr_alloc )
@@ -667,6 +675,17 @@ CONTAINS
FUNCTION ptr_sj_3d( pvflx, pmsk ) RESULT ( p_fval )
+ !!
+ REAL(wp), INTENT(in), DIMENSION(:,:,:) :: pvflx ! mask flux array at V-point
+ REAL(wp), INTENT(in), DIMENSION(A2D(nn_hls)) :: pmsk ! Optional 2D basin mask
+ !
+ REAL(wp), DIMENSION(T1Dj(0)) :: p_fval ! i-k-mean poleward flux of pvflx
+ !!
+ CALL ptr_sj_3d_t( pvflx(:,:,:), lbnd_ij(pvflx), pmsk(:,:), p_fval(:) )
+ END FUNCTION ptr_sj_3d
+
+
+ SUBROUTINE ptr_sj_3d_t( pvflx, ktvflx, pmsk, p_fval )
!!----------------------------------------------------------------------
!! *** ROUTINE ptr_sj_3d ***
!!
@@ -677,21 +696,33 @@ CONTAINS
!!
!! ** Action : - p_fval: i-k-mean poleward flux of pvflx
!!----------------------------------------------------------------------
- REAL(wp), INTENT(in), DIMENSION(A2D(nn_hls),jpk) :: pvflx ! mask flux array at V-point
- REAL(wp), INTENT(in), DIMENSION(jpi,jpj) :: pmsk ! Optional 2D basin mask
+ INTEGER, INTENT(in ), DIMENSION(2) :: ktvflx
+ REAL(wp), INTENT(in ), DIMENSION(AB2D(ktvflx),JPK) :: pvflx ! mask flux array at V-point
+ REAL(wp), INTENT(in ), DIMENSION(A2D(nn_hls)) :: pmsk ! Optional 2D basin mask
+ REAL(wp), INTENT( out), DIMENSION(T1Dj(0)) :: p_fval ! i-k-mean poleward flux of pvflx
!
- INTEGER :: ji, jj, jk ! dummy loop arguments
- REAL(wp), DIMENSION(A1Dj(nn_hls)) :: p_fval ! function value
+ INTEGER :: ji, jj, jk ! dummy loop arguments
!!--------------------------------------------------------------------
!
p_fval(:) = 0._wp
DO_3D( 0, 0, 0, 0, 1, jpkm1 )
p_fval(jj) = p_fval(jj) + pvflx(ji,jj,jk) * pmsk(ji,jj) * tmask_i(ji,jj)
END_3D
- END FUNCTION ptr_sj_3d
+ END SUBROUTINE ptr_sj_3d_t
FUNCTION ptr_sj_2d( pvflx, pmsk ) RESULT ( p_fval )
+ !!
+ REAL(wp), INTENT(in), DIMENSION(:,:) :: pvflx ! mask flux array at V-point
+ REAL(wp), INTENT(in), DIMENSION(A2D(nn_hls)) :: pmsk ! Optional 2D basin mask
+ !
+ REAL(wp), DIMENSION(T1Dj(0)) :: p_fval ! i-k-mean poleward flux of pvflx
+ !!
+ CALL ptr_sj_2d_t( pvflx(:,:), lbnd_ij(pvflx), pmsk(:,:), p_fval(:) )
+ END FUNCTION ptr_sj_2d
+
+
+ SUBROUTINE ptr_sj_2d_t( pvflx, ktvflx, pmsk, p_fval )
!!----------------------------------------------------------------------
!! *** ROUTINE ptr_sj_2d ***
!!
@@ -702,18 +733,20 @@ CONTAINS
!!
!! ** Action : - p_fval: i-k-mean poleward flux of pvflx
!!----------------------------------------------------------------------
- REAL(wp) , INTENT(in), DIMENSION(A2D(nn_hls)) :: pvflx ! mask flux array at V-point
- REAL(wp) , INTENT(in), DIMENSION(jpi,jpj) :: pmsk ! Optional 2D basin mask
+ INTEGER, INTENT(in ), DIMENSION(2) :: ktvflx
+ REAL(wp), INTENT(in ), DIMENSION(AB2D(ktvflx)) :: pvflx ! mask flux array at V-point
+ REAL(wp), INTENT(in ), DIMENSION(A2D(nn_hls)) :: pmsk ! Optional 2D basin mask
+ REAL(wp), INTENT( out), DIMENSION(T1Dj(0)) :: p_fval ! i-k-mean poleward flux of pvflx
!
- INTEGER :: ji,jj ! dummy loop arguments
- REAL(wp), DIMENSION(A1Dj(nn_hls)) :: p_fval ! function value
+ INTEGER :: ji, jj ! dummy loop arguments
!!--------------------------------------------------------------------
!
p_fval(:) = 0._wp
DO_2D( 0, 0, 0, 0 )
p_fval(jj) = p_fval(jj) + pvflx(ji,jj) * pmsk(ji,jj) * tmask_i(ji,jj)
END_2D
- END FUNCTION ptr_sj_2d
+ END SUBROUTINE ptr_sj_2d_t
+
FUNCTION ptr_ci_2d( pva ) RESULT ( p_fval )
!!----------------------------------------------------------------------
@@ -725,14 +758,13 @@ CONTAINS
!!
!! ** Action : - p_fval: j-cumulated sum of pva
!!----------------------------------------------------------------------
- REAL(wp) , INTENT(in), DIMENSION(jpi,jpj) :: pva ! mask flux array at V-point
+ REAL(wp) , INTENT(in), DIMENSION(T2D(0)) :: pva ! mask flux array at V-point
!
- INTEGER :: ji,jj,jc ! dummy loop arguments
- INTEGER :: ijpj ! ???
- REAL(wp), DIMENSION(jpi,jpj) :: p_fval ! function value
+ INTEGER :: ji,jj,jc ! dummy loop arguments
+ INTEGER :: ijpj ! ???
+ REAL(wp), DIMENSION(T2D(0)) :: p_fval ! function value
!!--------------------------------------------------------------------
!
- ijpj = jpj ! ???
p_fval(:,:) = 0._wp
DO jc = 1, jpnj ! looping over all processors in j axis
DO_2D( 0, 0, 0, 0 )
@@ -743,8 +775,18 @@ CONTAINS
END FUNCTION ptr_ci_2d
-
FUNCTION ptr_sjk( pta, pmsk ) RESULT ( p_fval )
+ !!
+ REAL(wp) , INTENT(in), DIMENSION(:,:,:) :: pta ! mask flux array at V-point
+ REAL(wp) , INTENT(in), DIMENSION(A2D(nn_hls)) :: pmsk ! Optional 2D basin mask
+ !
+ REAL(wp), DIMENSION(T1Dj(0),jpk) :: p_fval ! i-sum of masked field
+ !!
+ CALL ptr_sjk_t( pta(:,:,:), lbnd_ij(pta), pmsk(:,:), p_fval(:,:) )
+ END FUNCTION ptr_sjk
+
+
+ SUBROUTINE ptr_sjk_t( pta, ktta, pmsk, p_fval )
!!----------------------------------------------------------------------
!! *** ROUTINE ptr_sjk ***
!!
@@ -754,13 +796,12 @@ CONTAINS
!!
!! ** Action : - p_fval: i-sum of masked field
!!----------------------------------------------------------------------
- !!
- IMPLICIT none
- REAL(wp) , INTENT(in), DIMENSION(A2D(nn_hls),jpk) :: pta ! mask flux array at V-point
- REAL(wp) , INTENT(in), DIMENSION(jpi,jpj) :: pmsk ! Optional 2D basin mask
- !!
- INTEGER :: ji, jj, jk ! dummy loop arguments
- REAL(wp), DIMENSION(A1Dj(nn_hls),jpk) :: p_fval ! return function value
+ INTEGER, INTENT(in ), DIMENSION(2) :: ktta
+ REAL(wp), INTENT(in ), DIMENSION(AB2D(ktta),JPK) :: pta ! mask flux array at V-point
+ REAL(wp), INTENT(in ), DIMENSION(A2D(nn_hls)) :: pmsk ! Optional 2D basin mask
+ REAL(wp), INTENT( out), DIMENSION(T1Dj(0),jpk) :: p_fval ! i-sum of masked field
+ !
+ INTEGER :: ji, jj, jk ! dummy loop arguments
!!--------------------------------------------------------------------
!
p_fval(:,:) = 0._wp
@@ -768,7 +809,7 @@ CONTAINS
DO_3D( 0, 0, 0, 0, 1, jpkm1 )
p_fval(jj,jk) = p_fval(jj,jk) + pta(ji,jj,jk) * pmsk(ji,jj) * tmask_i(ji,jj)
END_3D
- END FUNCTION ptr_sjk
+ END SUBROUTINE ptr_sjk_t
!!======================================================================
diff --git a/src/OCE/DIA/diawri.F90 b/src/OCE/DIA/diawri.F90
index db5da93a7cc7f9a1d61498a55c689bc90aa7c231..48ab63b5bb996d797055fb20f3c0a2dd9769ac4b 100644
--- a/src/OCE/DIA/diawri.F90
+++ b/src/OCE/DIA/diawri.F90
@@ -122,8 +122,9 @@ CONTAINS
REAL(wp):: zztmp , zztmpx ! local scalar
REAL(wp):: zztmp2, zztmpy ! - -
REAL(wp):: ze3
- REAL(wp), DIMENSION(A2D( 0)) :: z2d ! 2D workspace
- REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: z3d ! 3D workspace
+ REAL(wp), DIMENSION(A2D(0)) :: z2d0 ! 2D workspace
+ REAL(wp), DIMENSION(A2D(0) ,jpk) :: z3d0 ! 3D workspace
+ REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: z3d ! 3D workspace
!!----------------------------------------------------------------------
!
IF( ln_timing ) CALL timing_start('dia_wri')
@@ -135,58 +136,81 @@ CONTAINS
ENDIF
! initialize arrays
- z2d(:,:) = 0._wp
- z3d(:,:,:) = 0._wp
+ z2d0(:,:) = 0._wp
+ z3d0(:,:,:) = 0._wp
+ z3d (:,:,:) = 0._wp
! Output of initial vertical scale factor
- CALL iom_put("e3t_0", e3t_0(:,:,:) )
- CALL iom_put("e3u_0", e3u_0(:,:,:) )
- CALL iom_put("e3v_0", e3v_0(:,:,:) )
- CALL iom_put("e3f_0", e3f_0(:,:,:) )
+ IF( lk_vco_3d ) THEN
+ DO_3D( 0, 0, 0, 0, 1, jpk )
+ z3d(ji,jj,jk) = e3t_0(ji,jj,jk)
+ END_3D
+ CALL iom_put( "e3t_0", z3d )
+ !
+ DO_3D( 0, 0, 0, 0, 1, jpk )
+ z3d(ji,jj,jk) = e3u_0(ji,jj,jk)
+ END_3D
+ CALL iom_put( "e3u_0", z3d )
+ !
+ DO_3D( 0, 0, 0, 0, 1, jpk )
+ z3d(ji,jj,jk) = e3v_0(ji,jj,jk)
+ END_3D
+ CALL iom_put( "e3v_0", z3d )
+ !
+ DO_3D( 0, 0, 0, 0, 1, jpk )
+ z3d(ji,jj,jk) = e3f_0(ji,jj,jk)
+ END_3D
+ CALL iom_put( "e3f_0", z3d )
+ ELSE
+ CALL iom_put( "e3t_0", e3t_0(:,:,:) )
+ CALL iom_put( "e3u_0", e3u_0(:,:,:) )
+ CALL iom_put( "e3v_0", e3v_0(:,:,:) )
+ CALL iom_put( "e3f_0", e3f_0(:,:,:) )
+ ENDIF
!
IF ( iom_use("tpt_dep") ) THEN
DO_3D( 0, 0, 0, 0, 1, jpk )
- z3d(ji,jj,jk) = gdept(ji,jj,jk,Kmm)
+ z3d0(ji,jj,jk) = gdept(ji,jj,jk,Kmm)
END_3D
- CALL iom_put( "tpt_dep", z3d )
+ CALL iom_put( "tpt_dep", z3d0 )
ENDIF
! --- vertical scale factors --- !
IF ( iom_use("e3t") .OR. iom_use("e3tdef") ) THEN ! time-varying e3t
DO_3D( 0, 0, 0, 0, 1, jpk )
- z3d(ji,jj,jk) = e3t(ji,jj,jk,Kmm)
+ z3d0(ji,jj,jk) = e3t(ji,jj,jk,Kmm)
END_3D
- CALL iom_put( "e3t", z3d )
+ CALL iom_put( "e3t", z3d0 )
IF ( iom_use("e3tdef") ) THEN
DO_3D( 0, 0, 0, 0, 1, jpk )
- z3d(ji,jj,jk) = ( ( z3d(ji,jj,jk) - e3t_0(ji,jj,jk) ) / e3t_0(ji,jj,jk) * 100._wp * tmask(ji,jj,jk) ) ** 2
+ z3d0(ji,jj,jk) = ( ( z3d0(ji,jj,jk) - e3t_0(ji,jj,jk) ) / e3t_0(ji,jj,jk) * 100._wp * tmask(ji,jj,jk) ) ** 2
END_3D
- CALL iom_put( "e3tdef", z3d )
+ CALL iom_put( "e3tdef", z3d0 )
ENDIF
ENDIF
IF ( iom_use("e3u") ) THEN ! time-varying e3u
DO_3D( 0, 0, 0, 0, 1, jpk )
- z3d(ji,jj,jk) = e3u(ji,jj,jk,Kmm)
+ z3d0(ji,jj,jk) = e3u(ji,jj,jk,Kmm)
END_3D
- CALL iom_put( "e3u" , z3d )
+ CALL iom_put( "e3u" , z3d0 )
ENDIF
IF ( iom_use("e3v") ) THEN ! time-varying e3v
DO_3D( 0, 0, 0, 0, 1, jpk )
- z3d(ji,jj,jk) = e3v(ji,jj,jk,Kmm)
+ z3d0(ji,jj,jk) = e3v(ji,jj,jk,Kmm)
END_3D
- CALL iom_put( "e3v" , z3d )
+ CALL iom_put( "e3v" , z3d0 )
ENDIF
IF ( iom_use("e3w") ) THEN ! time-varying e3w
DO_3D( 0, 0, 0, 0, 1, jpk )
- z3d(ji,jj,jk) = e3w(ji,jj,jk,Kmm)
+ z3d0(ji,jj,jk) = e3w(ji,jj,jk,Kmm)
END_3D
- CALL iom_put( "e3w" , z3d )
+ CALL iom_put( "e3w" , z3d0 )
ENDIF
IF ( iom_use("e3f") ) THEN ! time-varying e3f caution here at Kaa
DO_3D( 0, 0, 0, 0, 1, jpk )
- z3d(ji,jj,jk) = e3f(ji,jj,jk)
+ z3d0(ji,jj,jk) = e3f(ji,jj,jk)
END_3D
- CALL iom_put( "e3f" , z3d )
+ CALL iom_put( "e3f" , z3d0 )
ENDIF
IF ( iom_use("ssh") ) THEN
@@ -200,7 +224,7 @@ CONTAINS
IF( iom_use("wetdep") ) CALL iom_put( "wetdep" , ht_0(:,:) + ssh(:,:,Kmm) ) ! wet depth
#if defined key_qco
- IF( iom_use("ht") ) CALL iom_put( "ht" , ht(:,:) ) ! water column at t-point
+ IF( iom_use("ht") ) CALL iom_put( "ht" , ht(:,:,Kmm) ) ! water column at t-point
IF( iom_use("hu") ) CALL iom_put( "hu" , hu(:,:,Kmm) ) ! water column at u-point
IF( iom_use("hv") ) CALL iom_put( "hv" , hv(:,:,Kmm) ) ! water column at v-point
IF( iom_use("hf") ) CALL iom_put( "hf" , hf_0(:,:)*( 1._wp + r3f(:,:) ) ) ! water column at f-point (caution here at Naa)
@@ -213,9 +237,9 @@ CONTAINS
IF ( iom_use("sbt") ) THEN
DO_2D( 0, 0, 0, 0 )
ikbot = mbkt(ji,jj)
- z2d(ji,jj) = ts(ji,jj,ikbot,jp_tem,Kmm)
+ z2d0(ji,jj) = ts(ji,jj,ikbot,jp_tem,Kmm)
END_2D
- CALL iom_put( "sbt", z2d ) ! bottom temperature
+ CALL iom_put( "sbt", z2d0 ) ! bottom temperature
ENDIF
CALL iom_put( "soce", ts(:,:,:,jp_sal,Kmm) ) ! 3D salinity
@@ -223,9 +247,9 @@ CONTAINS
IF ( iom_use("sbs") ) THEN
DO_2D( 0, 0, 0, 0 )
ikbot = mbkt(ji,jj)
- z2d(ji,jj) = ts(ji,jj,ikbot,jp_sal,Kmm)
+ z2d0(ji,jj) = ts(ji,jj,ikbot,jp_sal,Kmm)
END_2D
- CALL iom_put( "sbs", z2d ) ! bottom salinity
+ CALL iom_put( "sbs", z2d0 ) ! bottom salinity
ENDIF
IF( .NOT.lk_SWE ) CALL iom_put( "rhop", rhop(:,:,:) ) ! 3D potential density (sigma0)
@@ -233,16 +257,16 @@ CONTAINS
! --- momentum --- !
IF ( iom_use("taubot") ) THEN ! bottom stress
zztmp = rho0 * 0.25_wp
- z2d(:,:) = 0._wp
+ z2d0(:,:) = 0._wp
DO_2D( 0, 0, 0, 0 )
zztmp2 = ( ( rCdU_bot(ji+1,jj)+rCdU_bot(ji ,jj) ) * uu(ji ,jj,mbku(ji ,jj),Kmm) )**2 &
& + ( ( rCdU_bot(ji ,jj)+rCdU_bot(ji-1,jj) ) * uu(ji-1,jj,mbku(ji-1,jj),Kmm) )**2 &
& + ( ( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj ) ) * vv(ji,jj ,mbkv(ji,jj ),Kmm) )**2 &
& + ( ( rCdU_bot(ji,jj )+rCdU_bot(ji,jj-1) ) * vv(ji,jj-1,mbkv(ji,jj-1),Kmm) )**2
- z2d(ji,jj) = zztmp * SQRT( zztmp2 ) * tmask(ji,jj,1)
+ z2d0(ji,jj) = zztmp * SQRT( zztmp2 ) * tmask(ji,jj,1)
!
END_2D
- CALL iom_put( "taubot", z2d )
+ CALL iom_put( "taubot", z2d0 )
ENDIF
CALL iom_put( "uoce", uu(:,:,:,Kmm) ) ! 3D i-current
@@ -250,9 +274,9 @@ CONTAINS
IF ( iom_use("sbu") ) THEN
DO_2D( 0, 0, 0, 0 )
ikbot = mbku(ji,jj)
- z2d(ji,jj) = uu(ji,jj,ikbot,Kmm)
+ z2d0(ji,jj) = uu(ji,jj,ikbot,Kmm)
END_2D
- CALL iom_put( "sbu", z2d ) ! bottom i-current
+ CALL iom_put( "sbu", z2d0 ) ! bottom i-current
ENDIF
CALL iom_put( "voce", vv(:,:,:,Kmm) ) ! 3D j-current
@@ -260,9 +284,9 @@ CONTAINS
IF ( iom_use("sbv") ) THEN
DO_2D( 0, 0, 0, 0 )
ikbot = mbkv(ji,jj)
- z2d(ji,jj) = vv(ji,jj,ikbot,Kmm)
+ z2d0(ji,jj) = vv(ji,jj,ikbot,Kmm)
END_2D
- CALL iom_put( "sbv", z2d ) ! bottom j-current
+ CALL iom_put( "sbv", z2d0 ) ! bottom j-current
ENDIF
! ! vertical velocity
@@ -281,20 +305,20 @@ CONTAINS
! ! Caution: in the VVL case, it only correponds to the baroclinic mass transport.
IF( ln_zad_Aimp ) THEN
DO_3D( 0, 0, 0, 0, 1, jpk )
- z3d(ji,jj,jk) = rho0 * e1e2t(ji,jj) * ( ww(ji,jj,jk) + wi(ji,jj,jk) )
+ z3d0(ji,jj,jk) = rho0 * e1e2t(ji,jj) * ( ww(ji,jj,jk) + wi(ji,jj,jk) )
END_3D
ELSE
DO_3D( 0, 0, 0, 0, 1, jpk )
- z3d(ji,jj,jk) = rho0 * e1e2t(ji,jj) * ww(ji,jj,jk)
+ z3d0(ji,jj,jk) = rho0 * e1e2t(ji,jj) * ww(ji,jj,jk)
END_3D
ENDIF
- CALL iom_put( "w_masstr" , z3d )
- IF( iom_use('w_masstr2') ) CALL iom_put( "w_masstr2", z3d * z3d )
+ CALL iom_put( "w_masstr" , z3d0 )
+ IF( iom_use('w_masstr2') ) CALL iom_put( "w_masstr2", z3d0 * z3d0 )
ENDIF
- CALL iom_put( "avt" , avt ) ! T vert. eddy diff. coef.
- CALL iom_put( "avs" , avs ) ! S vert. eddy diff. coef.
- CALL iom_put( "avm" , avm ) ! T vert. eddy visc. coef.
+ CALL iom_put( "avt" , avt ) ! T vert. eddy diff. coef.
+ CALL iom_put( "avs" , avs ) ! S vert. eddy diff. coef.
+ CALL iom_put( "avm" , avm ) ! T vert. eddy visc. coef.
IF( iom_use('logavt') ) CALL iom_put( "logavt", LOG( MAX( 1.e-20_wp, avt(:,:,:) ) ) )
IF( iom_use('logavs') ) CALL iom_put( "logavs", LOG( MAX( 1.e-20_wp, avs(:,:,:) ) ) )
@@ -304,15 +328,15 @@ CONTAINS
zztmp = ts(ji,jj,1,jp_sal,Kmm)
zztmpx = (ts(ji+1,jj,1,jp_sal,Kmm) - zztmp) * r1_e1u(ji,jj) + (zztmp - ts(ji-1,jj ,1,jp_sal,Kmm)) * r1_e1u(ji-1,jj)
zztmpy = (ts(ji,jj+1,1,jp_sal,Kmm) - zztmp) * r1_e2v(ji,jj) + (zztmp - ts(ji ,jj-1,1,jp_sal,Kmm)) * r1_e2v(ji,jj-1)
- z2d(ji,jj) = 0.25_wp * ( zztmpx * zztmpx + zztmpy * zztmpy ) &
+ z2d0(ji,jj) = 0.25_wp * ( zztmpx * zztmpx + zztmpy * zztmpy ) &
& * umask(ji,jj,1) * umask(ji-1,jj,1) * vmask(ji,jj,1) * vmask(ji,jj-1,1)
END_2D
- CALL iom_put( "sssgrad2", z2d ) ! square of module of sss gradient
+ CALL iom_put( "sssgrad2", z2d0 ) ! square of module of sss gradient
IF ( iom_use("sssgrad") ) THEN
DO_2D( 0, 0, 0, 0 )
- z2d(ji,jj) = SQRT( z2d(ji,jj) )
+ z2d0(ji,jj) = SQRT( z2d0(ji,jj) )
END_2D
- CALL iom_put( "sssgrad", z2d ) ! module of sss gradient
+ CALL iom_put( "sssgrad", z2d0 ) ! module of sss gradient
ENDIF
ENDIF
@@ -321,80 +345,80 @@ CONTAINS
zztmp = ts(ji,jj,1,jp_tem,Kmm)
zztmpx = ( ts(ji+1,jj,1,jp_tem,Kmm) - zztmp ) * r1_e1u(ji,jj) + ( zztmp - ts(ji-1,jj ,1,jp_tem,Kmm) ) * r1_e1u(ji-1,jj)
zztmpy = ( ts(ji,jj+1,1,jp_tem,Kmm) - zztmp ) * r1_e2v(ji,jj) + ( zztmp - ts(ji ,jj-1,1,jp_tem,Kmm) ) * r1_e2v(ji,jj-1)
- z2d(ji,jj) = 0.25_wp * ( zztmpx * zztmpx + zztmpy * zztmpy ) &
+ z2d0(ji,jj) = 0.25_wp * ( zztmpx * zztmpx + zztmpy * zztmpy ) &
& * umask(ji,jj,1) * umask(ji-1,jj,1) * vmask(ji,jj,1) * vmask(ji,jj-1,1)
END_2D
- CALL iom_put( "sstgrad2", z2d ) ! square of module of sst gradient
+ CALL iom_put( "sstgrad2", z2d0 ) ! square of module of sst gradient
IF ( iom_use("sstgrad") ) THEN
DO_2D( 0, 0, 0, 0 )
- z2d(ji,jj) = SQRT( z2d(ji,jj) )
+ z2d0(ji,jj) = SQRT( z2d0(ji,jj) )
END_2D
- CALL iom_put( "sstgrad", z2d ) ! module of sst gradient
+ CALL iom_put( "sstgrad", z2d0 ) ! module of sst gradient
ENDIF
ENDIF
! heat and salt contents
IF( iom_use("heatc") ) THEN
- z2d(:,:) = 0._wp
+ z2d0(:,:) = 0._wp
DO_3D( 0, 0, 0, 0, 1, jpkm1 )
- z2d(ji,jj) = z2d(ji,jj) + e3t(ji,jj,jk,Kmm) * ts(ji,jj,jk,jp_tem,Kmm) * tmask(ji,jj,jk)
+ z2d0(ji,jj) = z2d0(ji,jj) + e3t(ji,jj,jk,Kmm) * ts(ji,jj,jk,jp_tem,Kmm) * tmask(ji,jj,jk)
END_3D
- CALL iom_put( "heatc", rho0_rcp * z2d ) ! vertically integrated heat content (J/m2)
+ CALL iom_put( "heatc", rho0_rcp * z2d0 ) ! vertically integrated heat content (J/m2)
ENDIF
IF( iom_use("saltc") ) THEN
- z2d(:,:) = 0._wp
+ z2d0(:,:) = 0._wp
DO_3D( 0, 0, 0, 0, 1, jpkm1 )
- z2d(ji,jj) = z2d(ji,jj) + e3t(ji,jj,jk,Kmm) * ts(ji,jj,jk,jp_sal,Kmm) * tmask(ji,jj,jk)
+ z2d0(ji,jj) = z2d0(ji,jj) + e3t(ji,jj,jk,Kmm) * ts(ji,jj,jk,jp_sal,Kmm) * tmask(ji,jj,jk)
END_3D
- CALL iom_put( "saltc", rho0 * z2d ) ! vertically integrated salt content (PSU*kg/m2)
+ CALL iom_put( "saltc", rho0 * z2d0 ) ! vertically integrated salt content (PSU*kg/m2)
ENDIF
!
IF( iom_use("salt2c") ) THEN
- z2d(:,:) = 0._wp
+ z2d0(:,:) = 0._wp
DO_3D( 0, 0, 0, 0, 1, jpkm1 )
- z2d(ji,jj) = z2d(ji,jj) + e3t(ji,jj,jk,Kmm) * ts(ji,jj,jk,jp_sal,Kmm) * ts(ji,jj,jk,jp_sal,Kmm) * tmask(ji,jj,jk)
+ z2d0(ji,jj) = z2d0(ji,jj) + e3t(ji,jj,jk,Kmm) * ts(ji,jj,jk,jp_sal,Kmm) * ts(ji,jj,jk,jp_sal,Kmm) * tmask(ji,jj,jk)
END_3D
- CALL iom_put( "salt2c", rho0 * z2d ) ! vertically integrated square of salt content (PSU2*kg/m2)
+ CALL iom_put( "salt2c", rho0 * z2d0 ) ! vertically integrated square of salt content (PSU2*kg/m2)
ENDIF
!
IF ( iom_use("ke") .OR. iom_use("ke_int") ) THEN
DO_3D( 0, 0, 0, 0, 1, jpk )
zztmpx = uu(ji-1,jj ,jk,Kmm) + uu(ji,jj,jk,Kmm)
zztmpy = vv(ji ,jj-1,jk,Kmm) + vv(ji,jj,jk,Kmm)
- z3d(ji,jj,jk) = 0.25_wp * ( zztmpx*zztmpx + zztmpy*zztmpy )
+ z3d0(ji,jj,jk) = 0.25_wp * ( zztmpx*zztmpx + zztmpy*zztmpy )
END_3D
- CALL iom_put( "ke", z3d ) ! kinetic energy
+ CALL iom_put( "ke", z3d0 ) ! kinetic energy
- z2d(:,:) = 0._wp
+ z2d0(:,:) = 0._wp
DO_3D( 0, 0, 0, 0, 1, jpkm1 )
- z2d(ji,jj) = z2d(ji,jj) + e3t(ji,jj,jk,Kmm) * z3d(ji,jj,jk) * e1e2t(ji,jj) * tmask(ji,jj,jk)
+ z2d0(ji,jj) = z2d0(ji,jj) + e3t(ji,jj,jk,Kmm) * z3d0(ji,jj,jk) * e1e2t(ji,jj) * tmask(ji,jj,jk)
END_3D
- CALL iom_put( "ke_int", z2d ) ! vertically integrated kinetic energy
+ CALL iom_put( "ke_int", z2d0 ) ! vertically integrated kinetic energy
ENDIF
!
IF ( iom_use("sKE") ) THEN ! surface kinetic energy at T point
- z2d(:,:) = 0._wp
+ z2d0(:,:) = 0._wp
DO_2D( 0, 0, 0, 0 )
- z2d(ji,jj) = 0.25_wp * ( uu(ji ,jj,1,Kmm) * uu(ji ,jj,1,Kmm) * e1e2u(ji ,jj) * e3u(ji ,jj,1,Kmm) &
+ z2d0(ji,jj) = 0.25_wp * ( uu(ji ,jj,1,Kmm) * uu(ji ,jj,1,Kmm) * e1e2u(ji ,jj) * e3u(ji ,jj,1,Kmm) &
& + uu(ji-1,jj,1,Kmm) * uu(ji-1,jj,1,Kmm) * e1e2u(ji-1,jj) * e3u(ji-1,jj,1,Kmm) &
& + vv(ji,jj ,1,Kmm) * vv(ji,jj ,1,Kmm) * e1e2v(ji,jj ) * e3v(ji,jj ,1,Kmm) &
& + vv(ji,jj-1,1,Kmm) * vv(ji,jj-1,1,Kmm) * e1e2v(ji,jj-1) * e3v(ji,jj-1,1,Kmm) ) &
& * r1_e1e2t(ji,jj) / e3t(ji,jj,1,Kmm) * ssmask(ji,jj)
END_2D
- IF ( iom_use("sKE" ) ) CALL iom_put( "sKE" , z2d )
+ IF ( iom_use("sKE" ) ) CALL iom_put( "sKE" , z2d0 )
ENDIF
!
IF ( iom_use("ssKEf") ) THEN ! surface kinetic energy at F point
- z2d(:,:) = 0._wp ! CAUTION : only valid in SWE, not with bathymetry
+ z2d0(:,:) = 0._wp ! CAUTION : only valid in SWE, not with bathymetry
DO_2D( 0, 0, 0, 0 )
- z2d(ji,jj) = 0.25_wp * ( uu(ji,jj ,1,Kmm) * uu(ji,jj ,1,Kmm) * e1e2u(ji,jj ) * e3u(ji,jj ,1,Kmm) &
+ z2d0(ji,jj) = 0.25_wp * ( uu(ji,jj ,1,Kmm) * uu(ji,jj ,1,Kmm) * e1e2u(ji,jj ) * e3u(ji,jj ,1,Kmm) &
& + uu(ji,jj+1,1,Kmm) * uu(ji,jj+1,1,Kmm) * e1e2u(ji,jj+1) * e3u(ji,jj+1,1,Kmm) &
& + vv(ji ,jj,1,Kmm) * vv(ji,jj ,1,Kmm) * e1e2v(ji ,jj) * e3v(ji ,jj,1,Kmm) &
& + vv(ji+1,jj,1,Kmm) * vv(ji+1,jj,1,Kmm) * e1e2v(ji+1,jj) * e3v(ji+1,jj,1,Kmm) ) &
& * r1_e1e2f(ji,jj) / e3f(ji,jj,1) * ssfmask(ji,jj)
END_2D
- CALL iom_put( "ssKEf", z2d )
+ CALL iom_put( "ssKEf", z2d0 )
ENDIF
!
CALL iom_put( "hdiv", hdiv ) ! Horizontal divergence
@@ -402,31 +426,31 @@ CONTAINS
IF( iom_use("u_masstr") .OR. iom_use("u_masstr_vint") .OR. iom_use("u_heattr") .OR. iom_use("u_salttr") ) THEN
DO_3D( 0, 0, 0, 0, 1, jpk )
- z3d(ji,jj,jk) = rho0 * uu(ji,jj,jk,Kmm) * e2u(ji,jj) * e3u(ji,jj,jk,Kmm) * umask(ji,jj,jk)
+ z3d0(ji,jj,jk) = rho0 * uu(ji,jj,jk,Kmm) * e2u(ji,jj) * e3u(ji,jj,jk,Kmm) * umask(ji,jj,jk)
END_3D
- CALL iom_put( "u_masstr" , z3d ) ! mass transport in i-direction
+ CALL iom_put( "u_masstr" , z3d0 ) ! mass transport in i-direction
IF( iom_use("u_masstr_vint") ) THEN
- z2d(:,:) = 0._wp
+ z2d0(:,:) = 0._wp
DO_3D( 0, 0, 0, 0, 1, jpkm1 )
- z2d(ji,jj) = z2d(ji,jj) + z3d(ji,jj,jk)
+ z2d0(ji,jj) = z2d0(ji,jj) + z3d0(ji,jj,jk)
END_3D
- CALL iom_put( "u_masstr_vint", z2d ) ! mass transport in i-direction vertical sum
+ CALL iom_put( "u_masstr_vint", z2d0 ) ! mass transport in i-direction vertical sum
ENDIF
IF( iom_use("u_heattr") ) THEN
- z2d(:,:) = 0._wp
+ z2d0(:,:) = 0._wp
zztmp = 0.5_wp * rcp
DO_3D( 0, 0, 0, 0, 1, jpkm1 )
- z2d(ji,jj) = z2d(ji,jj) + zztmp * z3d(ji,jj,jk) * ( ts(ji,jj,jk,jp_tem,Kmm) + ts(ji+1,jj,jk,jp_tem,Kmm) )
+ z2d0(ji,jj) = z2d0(ji,jj) + zztmp * z3d0(ji,jj,jk) * ( ts(ji,jj,jk,jp_tem,Kmm) + ts(ji+1,jj,jk,jp_tem,Kmm) )
END_3D
- CALL iom_put( "u_heattr", z2d ) ! heat transport in i-direction
+ CALL iom_put( "u_heattr", z2d0 ) ! heat transport in i-direction
ENDIF
IF( iom_use("u_salttr") ) THEN
- z2d(:,:) = 0._wp
+ z2d0(:,:) = 0._wp
DO_3D( 0, 0, 0, 0, 1, jpkm1 )
- z2d(ji,jj) = z2d(ji,jj) + 0.5 * z3d(ji,jj,jk) * ( ts(ji,jj,jk,jp_sal,Kmm) + ts(ji+1,jj,jk,jp_sal,Kmm) )
+ z2d0(ji,jj) = z2d0(ji,jj) + 0.5 * z3d0(ji,jj,jk) * ( ts(ji,jj,jk,jp_sal,Kmm) + ts(ji+1,jj,jk,jp_sal,Kmm) )
END_3D
- CALL iom_put( "u_salttr", z2d ) ! heat transport in i-direction
+ CALL iom_put( "u_salttr", z2d0 ) ! heat transport in i-direction
ENDIF
ENDIF
@@ -434,41 +458,41 @@ CONTAINS
IF( iom_use("v_masstr") .OR. iom_use("v_heattr") .OR. iom_use("v_salttr") ) THEN
DO_3D( 0, 0, 0, 0, 1, jpk )
- z3d(ji,jj,jk) = rho0 * vv(ji,jj,jk,Kmm) * e1v(ji,jj) * e3v(ji,jj,jk,Kmm) * vmask(ji,jj,jk)
+ z3d0(ji,jj,jk) = rho0 * vv(ji,jj,jk,Kmm) * e1v(ji,jj) * e3v(ji,jj,jk,Kmm) * vmask(ji,jj,jk)
END_3D
- CALL iom_put( "v_masstr", z3d ) ! mass transport in j-direction
+ CALL iom_put( "v_masstr", z3d0 ) ! mass transport in j-direction
IF( iom_use("v_heattr") ) THEN
- z2d(:,:) = 0._wp
+ z2d0(:,:) = 0._wp
zztmp = 0.5_wp * rcp
DO_3D( 0, 0, 0, 0, 1, jpkm1 )
- z2d(ji,jj) = z2d(ji,jj) + zztmp * z3d(ji,jj,jk) * ( ts(ji,jj,jk,jp_tem,Kmm) + ts(ji,jj+1,jk,jp_tem,Kmm) )
+ z2d0(ji,jj) = z2d0(ji,jj) + zztmp * z3d0(ji,jj,jk) * ( ts(ji,jj,jk,jp_tem,Kmm) + ts(ji,jj+1,jk,jp_tem,Kmm) )
END_3D
- CALL iom_put( "v_heattr", z2d ) ! heat transport in j-direction
+ CALL iom_put( "v_heattr", z2d0 ) ! heat transport in j-direction
ENDIF
IF( iom_use("v_salttr") ) THEN
- z2d(:,:) = 0._wp
+ z2d0(:,:) = 0._wp
DO_3D( 0, 0, 0, 0, 1, jpkm1 )
- z2d(ji,jj) = z2d(ji,jj) + 0.5 * z3d(ji,jj,jk) * ( ts(ji,jj,jk,jp_sal,Kmm) + ts(ji,jj+1,jk,jp_sal,Kmm) )
+ z2d0(ji,jj) = z2d0(ji,jj) + 0.5 * z3d0(ji,jj,jk) * ( ts(ji,jj,jk,jp_sal,Kmm) + ts(ji,jj+1,jk,jp_sal,Kmm) )
END_3D
- CALL iom_put( "v_salttr", z2d ) ! heat transport in j-direction
+ CALL iom_put( "v_salttr", z2d0 ) ! heat transport in j-direction
ENDIF
ENDIF
IF( iom_use("tosmint") ) THEN
- z2d(:,:) = 0._wp
+ z2d0(:,:) = 0._wp
DO_3D( 0, 0, 0, 0, 1, jpkm1 )
- z2d(ji,jj) = z2d(ji,jj) + rho0 * e3t(ji,jj,jk,Kmm) * ts(ji,jj,jk,jp_tem,Kmm)
+ z2d0(ji,jj) = z2d0(ji,jj) + rho0 * e3t(ji,jj,jk,Kmm) * ts(ji,jj,jk,jp_tem,Kmm)
END_3D
- CALL iom_put( "tosmint", z2d ) ! Vertical integral of temperature
+ CALL iom_put( "tosmint", z2d0 ) ! Vertical integral of temperature
ENDIF
IF( iom_use("somint") ) THEN
- z2d(:,:) = 0._wp
+ z2d0(:,:) = 0._wp
DO_3D( 0, 0, 0, 0, 1, jpkm1 )
- z2d(ji,jj) = z2d(ji,jj) + rho0 * e3t(ji,jj,jk,Kmm) * ts(ji,jj,jk,jp_sal,Kmm)
+ z2d0(ji,jj) = z2d0(ji,jj) + rho0 * e3t(ji,jj,jk,Kmm) * ts(ji,jj,jk,jp_sal,Kmm)
END_3D
- CALL iom_put( "somint", z2d ) ! Vertical integral of salinity
+ CALL iom_put( "somint", z2d0 ) ! Vertical integral of salinity
ENDIF
CALL iom_put( "bn2", rn2 ) ! Brunt-Vaisala buoyancy frequency (N^2)
@@ -477,45 +501,47 @@ CONTAINS
! Output of surface vorticity terms
!
- CALL iom_put( "ssplavor", ff_f ) ! planetary vorticity ( f )
- !
- IF ( iom_use("ssrelvor") .OR. iom_use("ssEns") .OR. &
+ IF ( iom_use("ssplavor") .OR. iom_use("ssrelvor") .OR. iom_use("ssEns") .OR. &
& iom_use("ssrelpotvor") .OR. iom_use("ssabspotvor") ) THEN
!
- z2d(:,:) = 0._wp
DO_2D( 0, 0, 0, 0 )
- z2d(ji,jj) = ( e2v(ji+1,jj ) * vv(ji+1,jj ,1,Kmm) - e2v(ji,jj) * vv(ji,jj,1,Kmm) &
+ z2d0(ji,jj) = ff_f(ji,jj)
+ END_2D
+ CALL iom_put( "ssplavor", z2d0 ) ! planetary vorticity ( f )
+
+ DO_2D( 0, 0, 0, 0 )
+ z2d0(ji,jj) = ( e2v(ji+1,jj ) * vv(ji+1,jj ,1,Kmm) - e2v(ji,jj) * vv(ji,jj,1,Kmm) &
& - e1u(ji ,jj+1) * uu(ji ,jj+1,1,Kmm) + e1u(ji,jj) * uu(ji,jj,1,Kmm) ) * r1_e1e2f(ji,jj)
END_2D
- CALL iom_put( "ssrelvor", z2d ) ! relative vorticity ( zeta )
+ CALL iom_put( "ssrelvor", z2d0 ) ! relative vorticity ( zeta )
!
IF ( iom_use("ssEns") .OR. iom_use("ssrelpotvor") .OR. iom_use("ssabspotvor") ) THEN
DO_2D( 0, 0, 0, 0 )
ze3 = ( e3t(ji,jj+1,1,Kmm) * e1e2t(ji,jj+1) + e3t(ji+1,jj+1,1,Kmm) * e1e2t(ji+1,jj+1) &
- & + e3t(ji,jj ,1,Kmm) * e1e2t(ji,jj ) + e3t(ji+1,jj ,1,Kmm) * e1e2t(ji+1,jj ) ) * r1_e1e2f(ji,jj)
+ & + e3t(ji,jj ,1,Kmm) * e1e2t(ji,jj ) + e3t(ji+1,jj ,1,Kmm) * e1e2t(ji+1,jj ) ) * r1_e1e2f(ji,jj)
IF( ze3 /= 0._wp ) THEN ; ze3 = 4._wp / ze3
ELSE ; ze3 = 0._wp
ENDIF
- z2d(ji,jj) = ze3 * z2d(ji,jj)
+ z2d0(ji,jj) = ze3 * z2d0(ji,jj)
END_2D
- CALL iom_put( "ssrelpotvor", z2d ) ! relative potential vorticity (zeta/h)
+ CALL iom_put( "ssrelpotvor", z2d0 ) ! relative potential vorticity (zeta/h)
!
IF ( iom_use("ssEns") .OR. iom_use("ssabspotvor") ) THEN
DO_2D( 0, 0, 0, 0 )
ze3 = ( e3t(ji,jj+1,1,Kmm) * e1e2t(ji,jj+1) + e3t(ji+1,jj+1,1,Kmm) * e1e2t(ji+1,jj+1) &
- & + e3t(ji,jj ,1,Kmm) * e1e2t(ji,jj ) + e3t(ji+1,jj ,1,Kmm) * e1e2t(ji+1,jj ) ) * r1_e1e2f(ji,jj)
+ & + e3t(ji,jj ,1,Kmm) * e1e2t(ji,jj ) + e3t(ji+1,jj ,1,Kmm) * e1e2t(ji+1,jj ) ) * r1_e1e2f(ji,jj)
IF( ze3 /= 0._wp ) THEN ; ze3 = 4._wp / ze3
ELSE ; ze3 = 0._wp
ENDIF
- z2d(ji,jj) = ze3 * ff_f(ji,jj) + z2d(ji,jj)
+ z2d0(ji,jj) = ze3 * ff_f(ji,jj) + z2d0(ji,jj)
END_2D
- CALL iom_put( "ssabspotvor", z2d ) ! absolute potential vorticity ( q )
+ CALL iom_put( "ssabspotvor", z2d0 ) ! absolute potential vorticity ( q )
!
IF ( iom_use("ssEns") ) THEN
DO_2D( 0, 0, 0, 0 )
- z2d(ji,jj) = 0.5_wp * z2d(ji,jj) * z2d(ji,jj)
+ z2d0(ji,jj) = 0.5_wp * z2d0(ji,jj) * z2d0(ji,jj)
END_2D
- CALL iom_put( "ssEns", z2d ) ! potential enstrophy ( 1/2*q2 )
+ CALL iom_put( "ssEns", z2d0 ) ! potential enstrophy ( 1/2*q2 )
ENDIF
ENDIF
ENDIF
@@ -582,8 +608,8 @@ CONTAINS
INTEGER :: jn, ierror ! local integers
REAL(wp) :: zsto, zout, zmax, zjulian ! local scalars
!
- REAL(wp), DIMENSION(jpi,jpj ) :: z2d ! 2D workspace
- REAL(wp), DIMENSION(jpi,jpj,jpk) :: z3d ! 3D workspace
+ REAL(wp), DIMENSION(jpi,jpj ) :: z2d0 ! 2D workspace
+ REAL(wp), DIMENSION(jpi,jpj,jpk) :: z3d0 ! 3D workspace
REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zw3d_abl ! ABL 3D workspace
!!----------------------------------------------------------------------
!
@@ -868,7 +894,11 @@ CONTAINS
CALL histdef( nid_T, "sohtc300", "Heat content 300 m" , "J/m2" , & ! htc3
& jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout )
#endif
-
+ CALL histdef( nid_T, "sozotaux", "Wind Stress along i-axis" , "N/m2" , & ! utau
+ & jpi, jpj, nh_T, 1 , 1, 1 , - 99, 32, clop, zsto, zout )
+ CALL histdef( nid_T, "sometauy", "Wind Stress along j-axis" , "N/m2" , & ! vtau
+ & jpi, jpj, nh_T, 1 , 1, 1 , - 99, 32, clop, zsto, zout )
+ !
CALL histend( nid_T, snc4chunks=snc4set )
! !!! nid_U : 3D
@@ -878,10 +908,7 @@ CONTAINS
CALL histdef( nid_U, "sdzocrtx", "Stokes Drift Zonal Current" , "m/s" , & ! usd
& jpi, jpj, nh_U, ipk, 1, ipk, nz_U, 32, clop, zsto, zout )
ENDIF
- ! !!! nid_U : 2D
- CALL histdef( nid_U, "sozotaux", "Wind Stress along i-axis" , "N/m2" , & ! utau
- & jpi, jpj, nh_U, 1 , 1, 1 , - 99, 32, clop, zsto, zout )
-
+ !
CALL histend( nid_U, snc4chunks=snc4set )
! !!! nid_V : 3D
@@ -891,10 +918,7 @@ CONTAINS
CALL histdef( nid_V, "sdmecrty", "Stokes Drift Meridional Current" , "m/s" , & ! vsd
& jpi, jpj, nh_V, ipk, 1, ipk, nz_V, 32, clop, zsto, zout )
ENDIF
- ! !!! nid_V : 2D
- CALL histdef( nid_V, "sometauy", "Wind Stress along j-axis" , "N/m2" , & ! vtau
- & jpi, jpj, nh_V, 1 , 1, 1 , - 99, 32, clop, zsto, zout )
-
+ !
CALL histend( nid_V, snc4chunks=snc4set )
! !!! nid_W : 3D
@@ -937,21 +961,21 @@ CONTAINS
IF( .NOT.ln_linssh ) THEN
DO_3D( 0, 0, 0, 0, 1, jpk )
- z3d(ji,jj,jk) = ts(ji,jj,jk,jp_tem,Kmm) * e3t(ji,jj,jk,Kmm)
+ z3d0(ji,jj,jk) = ts(ji,jj,jk,jp_tem,Kmm) * e3t(ji,jj,jk,Kmm)
END_3D
- CALL histwrite( nid_T, "votemper", it, z3d, ndim_T , ndex_T ) ! heat content
+ CALL histwrite( nid_T, "votemper", it, z3d0, ndim_T , ndex_T ) ! heat content
DO_3D( 0, 0, 0, 0, 1, jpk )
- z3d(ji,jj,jk) = ts(ji,jj,jk,jp_sal,Kmm) * e3t(ji,jj,jk,Kmm)
+ z3d0(ji,jj,jk) = ts(ji,jj,jk,jp_sal,Kmm) * e3t(ji,jj,jk,Kmm)
END_3D
- CALL histwrite( nid_T, "vosaline", it, z3d, ndim_T , ndex_T ) ! salt content
+ CALL histwrite( nid_T, "vosaline", it, z3d0, ndim_T , ndex_T ) ! salt content
DO_2D( 0, 0, 0, 0 )
- z2d(ji,jj ) = ts(ji,jj, 1,jp_tem,Kmm) * e3t(ji,jj, 1,Kmm)
+ z2d0(ji,jj ) = ts(ji,jj, 1,jp_tem,Kmm) * e3t(ji,jj, 1,Kmm)
END_2D
- CALL histwrite( nid_T, "sosstsst", it, z2d, ndim_hT, ndex_hT ) ! sea surface heat content
+ CALL histwrite( nid_T, "sosstsst", it, z2d0, ndim_hT, ndex_hT ) ! sea surface heat content
DO_2D( 0, 0, 0, 0 )
- z2d(ji,jj ) = ts(ji,jj, 1,jp_sal,Kmm) * e3t(ji,jj, 1,Kmm)
+ z2d0(ji,jj ) = ts(ji,jj, 1,jp_sal,Kmm) * e3t(ji,jj, 1,Kmm)
END_2D
- CALL histwrite( nid_T, "sosaline", it, z2d, ndim_hT, ndex_hT ) ! sea surface salinity content
+ CALL histwrite( nid_T, "sosaline", it, z2d0, ndim_hT, ndex_hT ) ! sea surface salinity content
ELSE
CALL histwrite( nid_T, "votemper", it, ts(:,:,:,jp_tem,Kmm) , ndim_T , ndex_T ) ! temperature
CALL histwrite( nid_T, "vosaline", it, ts(:,:,:,jp_sal,Kmm) , ndim_T , ndex_T ) ! salinity
@@ -960,41 +984,41 @@ CONTAINS
ENDIF
IF( .NOT.ln_linssh ) THEN
DO_3D( 0, 0, 0, 0, 1, jpk )
- z3d(ji,jj,jk) = e3t(ji,jj,jk,Kmm) ! 3D workspace for qco substitution
+ z3d0(ji,jj,jk) = e3t(ji,jj,jk,Kmm) ! 3D workspace for qco substitution
END_3D
- CALL histwrite( nid_T, "vovvle3t", it, z3d , ndim_T , ndex_T ) ! level thickness
+ CALL histwrite( nid_T, "vovvle3t", it, z3d0 , ndim_T , ndex_T ) ! level thickness
DO_3D( 0, 0, 0, 0, 1, jpk )
- z3d(ji,jj,jk) = gdept(ji,jj,jk,Kmm) ! 3D workspace for qco substitution
+ z3d0(ji,jj,jk) = gdept(ji,jj,jk,Kmm) ! 3D workspace for qco substitution
END_3D
- CALL histwrite( nid_T, "vovvldep", it, z3d , ndim_T , ndex_T ) ! t-point depth
+ CALL histwrite( nid_T, "vovvldep", it, z3d0 , ndim_T , ndex_T ) ! t-point depth
DO_3D( 0, 0, 0, 0, 1, jpk )
- z3d(ji,jj,jk) = ( ( e3t(ji,jj,jk,Kmm) - e3t_0(ji,jj,jk) ) / e3t_0(ji,jj,jk) * 100._wp * tmask(ji,jj,jk) ) ** 2
+ z3d0(ji,jj,jk) = ( ( e3t(ji,jj,jk,Kmm) - e3t_0(ji,jj,jk) ) / e3t_0(ji,jj,jk) * 100._wp * tmask(ji,jj,jk) ) ** 2
END_3D
- CALL histwrite( nid_T, "vovvldef", it, z3d , ndim_T , ndex_T ) ! level thickness deformation
+ CALL histwrite( nid_T, "vovvldef", it, z3d0 , ndim_T , ndex_T ) ! level thickness deformation
ENDIF
CALL histwrite( nid_T, "sossheig", it, ssh(:,:,Kmm) , ndim_hT, ndex_hT ) ! sea surface height
DO_2D( 0, 0, 0, 0 )
- z2d(ji,jj) = emp(ji,jj) - rnf(ji,jj)
+ z2d0(ji,jj) = emp(ji,jj) - rnf(ji,jj)
END_2D
- CALL histwrite( nid_T, "sowaflup", it, z2d , ndim_hT, ndex_hT ) ! upward water flux
+ CALL histwrite( nid_T, "sowaflup", it, z2d0 , ndim_hT, ndex_hT ) ! upward water flux
CALL histwrite( nid_T, "sorunoff", it, rnf , ndim_hT, ndex_hT ) ! river runoffs
CALL histwrite( nid_T, "sosfldow", it, sfx , ndim_hT, ndex_hT ) ! downward salt flux
! (includes virtual salt flux beneath ice
! in linear free surface case)
IF( ln_linssh ) THEN
DO_2D( 0, 0, 0, 0 )
- z2d(ji,jj) = emp (ji,jj) * ts(ji,jj,1,jp_tem,Kmm)
+ z2d0(ji,jj) = emp (ji,jj) * ts(ji,jj,1,jp_tem,Kmm)
END_2D
- CALL histwrite( nid_T, "sosst_cd", it, z2d, ndim_hT, ndex_hT ) ! c/d term on sst
+ CALL histwrite( nid_T, "sosst_cd", it, z2d0, ndim_hT, ndex_hT ) ! c/d term on sst
DO_2D( 0, 0, 0, 0 )
- z2d(ji,jj) = emp (ji,jj) * ts(ji,jj,1,jp_sal,Kmm)
+ z2d0(ji,jj) = emp (ji,jj) * ts(ji,jj,1,jp_sal,Kmm)
END_2D
- CALL histwrite( nid_T, "sosss_cd", it, z2d, ndim_hT, ndex_hT ) ! c/d term on sss
+ CALL histwrite( nid_T, "sosss_cd", it, z2d0, ndim_hT, ndex_hT ) ! c/d term on sss
ENDIF
DO_2D( 0, 0, 0, 0 )
- z2d(ji,jj) = qsr(ji,jj) + qns(ji,jj)
+ z2d0(ji,jj) = qsr(ji,jj) + qns(ji,jj)
END_2D
- CALL histwrite( nid_T, "sohefldo", it, z2d , ndim_hT, ndex_hT ) ! total heat flux
+ CALL histwrite( nid_T, "sohefldo", it, z2d0 , ndim_hT, ndex_hT ) ! total heat flux
CALL histwrite( nid_T, "soshfldo", it, qsr , ndim_hT, ndex_hT ) ! solar heat flux
IF( ALLOCATED(hmld) ) THEN ! zdf_mxl not called by SWE
CALL histwrite( nid_T, "somixhgt", it, hmld , ndim_hT, ndex_hT ) ! turbocline depth
@@ -1053,9 +1077,9 @@ CONTAINS
CALL histwrite( nid_T, "sohefldp", it, qrp , ndim_hT, ndex_hT ) ! heat flux damping
CALL histwrite( nid_T, "sowafldp", it, erp , ndim_hT, ndex_hT ) ! freshwater flux damping
DO_2D( 0, 0, 0, 0 )
- z2d(ji,jj) = erp(ji,jj) * ts(ji,jj,1,jp_sal,Kmm) * tmask(ji,jj,1)
+ z2d0(ji,jj) = erp(ji,jj) * ts(ji,jj,1,jp_sal,Kmm) * tmask(ji,jj,1)
END_2D
- CALL histwrite( nid_T, "sosafldp", it, z2d , ndim_hT, ndex_hT ) ! salt flux damping
+ CALL histwrite( nid_T, "sosafldp", it, z2d0 , ndim_hT, ndex_hT ) ! salt flux damping
ENDIF
! zw2d(:,:) = FLOAT( nmln(:,:) ) * tmask(:,:,1)
! CALL histwrite( nid_T, "sobowlin", it, zw2d , ndim_hT, ndex_hT ) ! ???
@@ -1066,18 +1090,18 @@ CONTAINS
CALL histwrite( nid_T, "so28chgt", it, hd28 , ndim_hT, ndex_hT ) ! depth of the 28 isotherm
CALL histwrite( nid_T, "sohtc300", it, htc3 , ndim_hT, ndex_hT ) ! first 300m heaat content
#endif
+ CALL histwrite( nid_T, "sozotaux", it, utau , ndim_hT, ndex_hT ) ! i-wind stress
+ CALL histwrite( nid_T, "sometauy", it, vtau , ndim_hT, ndex_hT ) ! j-wind stress
CALL histwrite( nid_U, "vozocrtx", it, uu(:,:,:,Kmm) , ndim_U , ndex_U ) ! i-current
- CALL histwrite( nid_U, "sozotaux", it, utau , ndim_hU, ndex_hU ) ! i-wind stress
CALL histwrite( nid_V, "vomecrty", it, vv(:,:,:,Kmm) , ndim_V , ndex_V ) ! j-current
- CALL histwrite( nid_V, "sometauy", it, vtau , ndim_hV, ndex_hV ) ! j-wind stress
IF( ln_zad_Aimp ) THEN
DO_3D( 0, 0, 0, 0, 1, jpk )
- z3d(ji,jj,jk) = ww(ji,jj,jk) + wi(ji,jj,jk)
+ z3d0(ji,jj,jk) = ww(ji,jj,jk) + wi(ji,jj,jk)
END_3D
- CALL histwrite( nid_W, "vovecrtz", it, z3d , ndim_T, ndex_T ) ! vert. current
+ CALL histwrite( nid_W, "vovecrtz", it, z3d0 , ndim_T, ndex_T ) ! vert. current
ELSE
CALL histwrite( nid_W, "vovecrtz", it, ww , ndim_T, ndex_T ) ! vert. current
ENDIF
@@ -1126,8 +1150,8 @@ CONTAINS
!!
INTEGER :: ji, jj, jk ! dummy loop indices
INTEGER :: inum
- REAL(wp), DIMENSION(jpi,jpj) :: z2d
- REAL(wp), DIMENSION(jpi,jpj,jpk) :: z3d
+ REAL(wp), DIMENSION(A2D(0)) :: z2d0
+ REAL(wp), DIMENSION(A2D(0),jpk) :: z3d0
!!----------------------------------------------------------------------
!
IF(lwp) THEN
@@ -1146,14 +1170,14 @@ CONTAINS
CALL iom_rstput( 0, 0, inum, 'vomecrty', vv(:,:,:,Kmm) ) ! now j-velocity
IF( ln_zad_Aimp ) THEN
DO_3D( 0, 0, 0, 0, 1, jpk )
- z3d(ji,jj,jk) = ww(ji,jj,jk) + wi(ji,jj,jk)
+ z3d0(ji,jj,jk) = ww(ji,jj,jk) + wi(ji,jj,jk)
END_3D
- CALL iom_rstput( 0, 0, inum, 'vovecrtz', z3d ) ! now k-velocity
+ CALL iom_rstput( 0, 0, inum, 'vovecrtz', z3d0 ) ! now k-velocity
ELSE
CALL iom_rstput( 0, 0, inum, 'vovecrtz', ww ) ! now k-velocity
ENDIF
CALL iom_rstput( 0, 0, inum, 'risfdep', risfdep )
- CALL iom_rstput( 0, 0, inum, 'ht' , ht(:,:) ) ! now water column height
+ CALL iom_rstput( 0, 0, inum, 'ht' , ht(:,:,Kmm) ) ! now water column height
!
IF ( ln_isf ) THEN
IF (ln_isfcav_mlt) THEN
@@ -1184,26 +1208,26 @@ CONTAINS
CALL iom_rstput( 0, 0, inum, 'ahmf', ahmf ) ! ahmf at v-point
ENDIF
DO_2D( 0, 0, 0, 0 )
- z2d(ji,jj) = emp(ji,jj) - rnf(ji,jj)
+ z2d0(ji,jj) = emp(ji,jj) - rnf(ji,jj)
END_2D
- CALL iom_rstput( 0, 0, inum, 'sowaflup', z2d ) ! freshwater budget
+ CALL iom_rstput( 0, 0, inum, 'sowaflup', z2d0 ) ! freshwater budget
DO_2D( 0, 0, 0, 0 )
- z2d(ji,jj) = qsr(ji,jj) + qns(ji,jj)
+ z2d0(ji,jj) = qsr(ji,jj) + qns(ji,jj)
END_2D
- CALL iom_rstput( 0, 0, inum, 'sohefldo', z2d ) ! total heat flux
+ CALL iom_rstput( 0, 0, inum, 'sohefldo', z2d0 ) ! total heat flux
CALL iom_rstput( 0, 0, inum, 'soshfldo', qsr ) ! solar heat flux
CALL iom_rstput( 0, 0, inum, 'soicecov', fr_i ) ! ice fraction
CALL iom_rstput( 0, 0, inum, 'sozotaux', utau ) ! i-wind stress
CALL iom_rstput( 0, 0, inum, 'sometauy', vtau ) ! j-wind stress
IF( .NOT.ln_linssh ) THEN
DO_3D( 0, 0, 0, 0, 1, jpk )
- z3d(ji,jj,jk) = gdept(ji,jj,jk,Kmm) ! 3D workspace for qco substitution
+ z3d0(ji,jj,jk) = gdept(ji,jj,jk,Kmm) ! 3D workspace for qco substitution
END_3D
- CALL iom_rstput( 0, 0, inum, 'vovvldep', z3d ) ! T-cell depth
+ CALL iom_rstput( 0, 0, inum, 'vovvldep', z3d0 ) ! T-cell depth
DO_3D( 0, 0, 0, 0, 1, jpk )
- z3d(ji,jj,jk) = e3t(ji,jj,jk,Kmm) ! 3D workspace for qco substitution
+ z3d0(ji,jj,jk) = e3t(ji,jj,jk,Kmm) ! 3D workspace for qco substitution
END_3D
- CALL iom_rstput( 0, 0, inum, 'vovvle3t', z3d ) ! T-cell thickness
+ CALL iom_rstput( 0, 0, inum, 'vovvle3t', z3d0 ) ! T-cell thickness
END IF
IF( ln_wave .AND. ln_sdw ) THEN
CALL iom_rstput( 0, 0, inum, 'sdzocrtx', usd ) ! now StokesDrift i-velocity
@@ -1217,14 +1241,14 @@ CONTAINS
CALL iom_rstput ( 0, 0, inum, "qz1_abl", tq_abl(:,:,2,nt_a,2) ) ! now first level humidity
ENDIF
IF( ln_zdfosm ) THEN
- CALL iom_rstput( 0, 0, inum, 'hbl', hbl*tmask(:,:,1) ) ! now boundary-layer depth
- CALL iom_rstput( 0, 0, inum, 'hml', hml*tmask(:,:,1) ) ! now mixed-layer depth
- CALL iom_rstput( 0, 0, inum, 'avt_k', avt_k*wmask ) ! w-level diffusion
- CALL iom_rstput( 0, 0, inum, 'avm_k', avm_k*wmask ) ! now w-level viscosity
- CALL iom_rstput( 0, 0, inum, 'ghamt', ghamt*wmask ) ! non-local t forcing
- CALL iom_rstput( 0, 0, inum, 'ghams', ghams*wmask ) ! non-local s forcing
- CALL iom_rstput( 0, 0, inum, 'ghamu', ghamu*umask ) ! non-local u forcing
- CALL iom_rstput( 0, 0, inum, 'ghamv', ghamv*vmask ) ! non-local v forcing
+ CALL iom_rstput( 0, 0, inum, 'hbl', hbl*tmask(:,:,1) ) ! now boundary-layer depth
+ CALL iom_rstput( 0, 0, inum, 'hml', hml*tmask(:,:,1) ) ! now mixed-layer depth
+ CALL iom_rstput( 0, 0, inum, 'avt_k', avt_k*wmask(A2D(0),:) ) ! w-level diffusion
+ CALL iom_rstput( 0, 0, inum, 'avm_k', avm_k*wmask ) ! now w-level viscosity
+ CALL iom_rstput( 0, 0, inum, 'ghamt', ghamt*wmask ) ! non-local t forcing
+ CALL iom_rstput( 0, 0, inum, 'ghams', ghams*wmask ) ! non-local s forcing
+ CALL iom_rstput( 0, 0, inum, 'ghamu', ghamu*umask ) ! non-local u forcing
+ CALL iom_rstput( 0, 0, inum, 'ghamv', ghamv*vmask ) ! non-local v forcing
IF( ln_osm_mle ) THEN
CALL iom_rstput( 0, 0, inum, 'hmle', hmle*tmask(:,:,1) ) ! now transition-layer depth
END IF
diff --git a/src/OCE/DIU/diu_bulk.F90 b/src/OCE/DIU/diu_bulk.F90
index af1e5adfe07324c0879beae01aab78fab3d9ab9a..aa7e96004cf3ddcd59c296244a0079c798dacc37 100644
--- a/src/OCE/DIU/diu_bulk.F90
+++ b/src/OCE/DIU/diu_bulk.F90
@@ -64,7 +64,7 @@ CONTAINS
IF( ln_diurnal ) THEN
!
- ALLOCATE( x_dsst(jpi,jpj), x_solfrac(jpi,jpj) )
+ ALLOCATE( x_dsst(A2D(0)), x_solfrac(A2D(0)) )
!
x_solfrac = 0._wp ! Initialise the solar fraction
x_dsst = 0._wp
@@ -92,25 +92,25 @@ CONTAINS
!! ** Reference : Refinements to a prognostic scheme of skin sea surface
!! temperature, Takaya et al, JGR, 2010
!!----------------------------------------------------------------------
- INTEGER , INTENT(in) :: kt ! time step
- REAL(wp), DIMENSION(jpi,jpj) , INTENT(in) :: psolflux ! solar flux (Watts)
- REAL(wp), DIMENSION(jpi,jpj) , INTENT(in) :: pqflux ! heat (non-solar) flux (Watts)
- REAL(wp), DIMENSION(jpi,jpj) , INTENT(in) :: ptauflux ! wind stress (kg/ m s^2)
- REAL(wp), DIMENSION(jpi,jpj) , INTENT(in) :: prho ! water density (kg/m^3)
- REAL(wp) , INTENT(in) :: p_rdt ! time-step
- REAL(wp), DIMENSION(jpi,jpj), OPTIONAL, INTENT(in) :: pLa ! Langmuir number
- REAL(wp), DIMENSION(jpi,jpj), OPTIONAL, INTENT(in) :: pthick ! warm layer thickness (m)
- REAL(wp), DIMENSION(jpi,jpj), OPTIONAL, INTENT(in) :: pcoolthick ! cool skin thickness (m)
- REAL(wp), DIMENSION(jpi,jpj), OPTIONAL, INTENT(in) :: pmu ! mu parameter
- REAL(wp), DIMENSION(jpi,jpj), OPTIONAL, INTENT(in) :: p_hflux_bkginc ! increment to the heat flux
- REAL(wp), DIMENSION(jpi,jpj), OPTIONAL, INTENT(in) :: p_fvel_bkginc ! increment to the friction velocity
+ INTEGER , INTENT(in) :: kt ! time step
+ REAL(wp), DIMENSION(A2D(0)) , INTENT(in) :: psolflux ! solar flux (Watts)
+ REAL(wp), DIMENSION(A2D(0)) , INTENT(in) :: pqflux ! heat (non-solar) flux (Watts)
+ REAL(wp), DIMENSION(A2D(0)) , INTENT(in) :: ptauflux ! wind stress (kg/ m s^2)
+ REAL(wp), DIMENSION(jpi,jpj) , INTENT(in) :: prho ! water density (kg/m^3)
+ REAL(wp) , INTENT(in) :: p_rdt ! time-step
+ REAL(wp), DIMENSION(A2D(0)), OPTIONAL, INTENT(in) :: pLa ! Langmuir number
+ REAL(wp), DIMENSION(A2D(0)), OPTIONAL, INTENT(in) :: pthick ! warm layer thickness (m)
+ REAL(wp), DIMENSION(A2D(0)), OPTIONAL, INTENT(in) :: pcoolthick ! cool skin thickness (m)
+ REAL(wp), DIMENSION(A2D(0)), OPTIONAL, INTENT(in) :: pmu ! mu parameter
+ REAL(wp), DIMENSION(A2D(0)), OPTIONAL, INTENT(in) :: p_hflux_bkginc ! increment to the heat flux
+ REAL(wp), DIMENSION(A2D(0)), OPTIONAL, INTENT(in) :: p_fvel_bkginc ! increment to the friction velocity
!
INTEGER :: ji,jj
LOGICAL :: ll_calcfrac
- REAL(wp), DIMENSION(jpi,jpj) :: z_fvel ! friction velocity
- REAL(wp), DIMENSION(jpi,jpj) :: zthick, zcoolthick, zmu, zla
- REAL(wp), DIMENSION(jpi,jpj) :: z_abflux ! absorbed flux
- REAL(wp), DIMENSION(jpi,jpj) :: z_fla ! Langmuir function value
+ REAL(wp), DIMENSION(A2D(0)) :: z_fvel ! friction velocity
+ REAL(wp), DIMENSION(A2D(0)) :: zthick, zcoolthick, zmu, zla
+ REAL(wp), DIMENSION(A2D(0)) :: z_abflux ! absorbed flux
+ REAL(wp), DIMENSION(A2D(0)) :: z_fla ! Langmuir function value
!!----------------------------------------------------------------------
! Set optional arguments to their defaults
@@ -129,14 +129,14 @@ CONTAINS
! If not done already, calculate the solar fraction
IF ( kt==nit000 ) THEN
- DO_2D( 1, 1, 1, 1 )
- IF( ( x_solfrac(ji,jj) == 0._wp ) .AND. ( tmask(ji,jj,1) == 1._wp ) ) &
+ DO_2D( 0, 0, 0, 0 )
+ IF( ( x_solfrac(ji,jj) == 0._wp ) .AND. ( smask0(ji,jj) == 1._wp ) ) &
& x_solfrac(ji,jj) = solfrac( zcoolthick(ji,jj),zthick(ji,jj) )
END_2D
ENDIF
! convert solar flux and heat flux to absorbed flux
- WHERE ( tmask(:,:,1) == 1._wp)
+ WHERE ( smask0(:,:) == 1._wp)
z_abflux(:,:) = ( x_solfrac(:,:) * psolflux (:,:)) + pqflux(:,:)
ELSEWHERE
z_abflux(:,:) = 0._wp
@@ -147,8 +147,8 @@ CONTAINS
ENDWHERE
! Calculate the friction velocity
- WHERE ( (ptauflux /= 0) .AND. ( tmask(:,:,1) == 1.) )
- z_fvel(:,:) = SQRT( ptauflux(:,:) / prho(:,:) )
+ WHERE ( (ptauflux(:,:) /= 0) .AND. ( smask0(:,:) == 1.) )
+ z_fvel(:,:) = SQRT( ptauflux(:,:) / prho(A2D(0)) )
ELSEWHERE
z_fvel(:,:) = 0._wp
ENDWHERE
@@ -157,7 +157,7 @@ CONTAINS
! Calculate the Langmuir function value
- WHERE ( tmask(:,:,1) == 1.)
+ WHERE ( smask0(:,:) == 1.)
z_fla(:,:) = MAX( 1._wp, zla(:,:)**( -2._wp / 3._wp ) )
ELSEWHERE
z_fla(:,:) = 0._wp
@@ -176,16 +176,16 @@ CONTAINS
IMPLICIT NONE
! Function definition
- REAL(wp), DIMENSION(jpi,jpj) :: t_imp
+ REAL(wp), DIMENSION(A2D(0)) :: t_imp
! Dummy variables
- REAL(wp), DIMENSION(jpi,jpj), INTENT(IN) :: p_dsst ! Delta SST
- REAL(wp), INTENT(IN) :: p_rdt ! Time-step
- REAL(wp), DIMENSION(jpi,jpj), INTENT(IN) :: p_abflux ! Heat forcing
- REAL(wp), DIMENSION(jpi,jpj), INTENT(IN) :: p_fvel ! Friction velocity
- REAL(wp), DIMENSION(jpi,jpj), INTENT(IN) :: p_fla ! Langmuir number
- REAL(wp), DIMENSION(jpi,jpj), INTENT(IN) :: pmu ! Structure parameter
- REAL(wp), DIMENSION(jpi,jpj), INTENT(IN) :: pthick ! Layer thickness
- REAL(wp), DIMENSION(jpi,jpj), INTENT(IN) :: prho ! Water density
+ REAL(wp), DIMENSION(A2D(0)), INTENT(IN) :: p_dsst ! Delta SST
+ REAL(wp), INTENT(IN) :: p_rdt ! Time-step
+ REAL(wp), DIMENSION(A2D(0)), INTENT(IN) :: p_abflux ! Heat forcing
+ REAL(wp), DIMENSION(A2D(0)), INTENT(IN) :: p_fvel ! Friction velocity
+ REAL(wp), DIMENSION(A2D(0)), INTENT(IN) :: p_fla ! Langmuir number
+ REAL(wp), DIMENSION(A2D(0)), INTENT(IN) :: pmu ! Structure parameter
+ REAL(wp), DIMENSION(A2D(0)), INTENT(IN) :: pthick ! Layer thickness
+ REAL(wp), DIMENSION(jpi,jpj),INTENT(IN) :: prho ! Water density
! Local variables
REAL(wp) :: z_olength ! Obukhov length
@@ -198,10 +198,10 @@ CONTAINS
INTEGER :: ji,jj
- DO_2D( 1, 1, 1, 1 )
+ DO_2D( 0, 0, 0, 0 )
! Only calculate outside tmask
- IF ( tmask(ji,jj,1) /= 1._wp ) THEN
+ IF ( smask0(ji,jj) /= 1._wp ) THEN
t_imp(ji,jj) = 0._wp
CYCLE
END IF
diff --git a/src/OCE/DIU/diu_coolskin.F90 b/src/OCE/DIU/diu_coolskin.F90
index 594a8b13ade4ae1d7739574244cd3f5b547a1e73..92ec5e84b4ff2164b91511b62dc53710e279b7c8 100644
--- a/src/OCE/DIU/diu_coolskin.F90
+++ b/src/OCE/DIU/diu_coolskin.F90
@@ -59,7 +59,7 @@ MODULE diu_coolskin
!! ** Reference :
!!
!!----------------------------------------------------------------------
- ALLOCATE( x_csdsst(jpi,jpj), x_csthick(jpi,jpj) )
+ ALLOCATE( x_csdsst(A2D(0)), x_csthick(A2D(0)) )
x_csdsst = 0.
x_csthick = 0.
!
@@ -77,16 +77,16 @@ MODULE diu_coolskin
!! ** Reference :
!!----------------------------------------------------------------------
! Dummy variables
- REAL(wp), INTENT(IN), DIMENSION(jpi,jpj) :: psqflux ! Heat (non-solar)(Watts)
- REAL(wp), INTENT(IN), DIMENSION(jpi,jpj) :: pstauflux ! Wind stress (kg/ m s^2)
+ REAL(wp), INTENT(IN), DIMENSION(A2D(0)) :: psqflux ! Heat (non-solar)(Watts)
+ REAL(wp), INTENT(IN), DIMENSION(A2D(0)) :: pstauflux ! Wind stress (kg/ m s^2)
REAL(wp), INTENT(IN), DIMENSION(jpi,jpj) :: psrho ! Water density (kg/m^3)
REAL(wp), INTENT(IN) :: pDt ! Time-step
! Local variables
- REAL(wp), DIMENSION(jpi,jpj) :: z_fv ! Friction velocity
- REAL(wp), DIMENSION(jpi,jpj) :: z_gamma ! Dimensionless function of wind speed
- REAL(wp), DIMENSION(jpi,jpj) :: z_lamda ! Sauders (dimensionless) proportionality constant
- REAL(wp), DIMENSION(jpi,jpj) :: z_wspd ! Wind speed (m/s)
+ REAL(wp), DIMENSION(A2D(0)) :: z_fv ! Friction velocity
+ REAL(wp), DIMENSION(A2D(0)) :: z_gamma ! Dimensionless function of wind speed
+ REAL(wp), DIMENSION(A2D(0)) :: z_lamda ! Sauders (dimensionless) proportionality constant
+ REAL(wp), DIMENSION(A2D(0)) :: z_wspd ! Wind speed (m/s)
REAL(wp) :: z_ztx ! Temporary u wind stress
REAL(wp) :: z_zty ! Temporary v wind stress
REAL(wp) :: z_zmod ! Temporary total wind stress
@@ -96,10 +96,10 @@ MODULE diu_coolskin
!
IF( .NOT. (ln_blk .OR. ln_abl) ) CALL ctl_stop("diu_coolskin.f90: diurnal flux processing only implemented for bulk forcing")
!
- DO_2D( 1, 1, 1, 1 )
+ DO_2D( 0, 0, 0, 0 )
!
! Calcualte wind speed from wind stress and friction velocity
- IF( tmask(ji,jj,1) == 1. .AND. pstauflux(ji,jj) /= 0 .AND. psrho(ji,jj) /=0 ) THEN
+ IF( smask0(ji,jj) == 1. .AND. pstauflux(ji,jj) /= 0 .AND. psrho(ji,jj) /=0 ) THEN
z_fv(ji,jj) = SQRT( pstauflux(ji,jj) / psrho(ji,jj) )
z_wspd(ji,jj) = SQRT( pstauflux(ji,jj) / ( pp_cda * pp_rhoa ) )
ELSE
@@ -108,28 +108,28 @@ MODULE diu_coolskin
ENDIF
!
! Calculate gamma function which is dependent upon wind speed
- IF( tmask(ji,jj,1) == 1. ) THEN
+ IF( smask0(ji,jj) == 1. ) THEN
IF( ( z_wspd(ji,jj) <= 7.5 ) ) z_gamma(ji,jj) = ( 0.2 * z_wspd(ji,jj) ) + 0.5
IF( ( z_wspd(ji,jj) > 7.5 ) .AND. ( z_wspd(ji,jj) < 10. ) ) z_gamma(ji,jj) = ( 1.6 * z_wspd(ji,jj) ) - 10.
IF( ( z_wspd(ji,jj) >= 10. ) ) z_gamma(ji,jj) = 6.
ENDIF
!
! Calculate lamda function
- IF( tmask(ji,jj,1) == 1. .AND. z_fv(ji,jj) /= 0 ) THEN
+ IF( smask0(ji,jj) == 1. .AND. z_fv(ji,jj) /= 0 ) THEN
z_lamda(ji,jj) = ( z_fv(ji,jj) * pp_k * pp_C ) / ( z_gamma(ji,jj) * psrho(ji,jj) * pp_cw * pp_h * pp_v )
ELSE
z_lamda(ji,jj) = 0.
ENDIF
!
! Calculate the cool skin thickness - only when heat flux is out of the ocean
- IF( tmask(ji,jj,1) == 1. .AND. z_fv(ji,jj) /= 0 .AND. psqflux(ji,jj) < 0 ) THEN
+ IF( smask0(ji,jj) == 1. .AND. z_fv(ji,jj) /= 0 .AND. psqflux(ji,jj) < 0 ) THEN
x_csthick(ji,jj) = ( z_lamda(ji,jj) * pp_v ) / z_fv(ji,jj)
ELSE
x_csthick(ji,jj) = 0.
ENDIF
!
! Calculate the cool skin correction - only when the heat flux is out of the ocean
- IF( tmask(ji,jj,1) == 1. .AND. x_csthick(ji,jj) /= 0. .AND. psqflux(ji,jj) < 0. ) THEN
+ IF( smask0(ji,jj) == 1. .AND. x_csthick(ji,jj) /= 0. .AND. psqflux(ji,jj) < 0. ) THEN
x_csdsst(ji,jj) = ( psqflux(ji,jj) * x_csthick(ji,jj) ) / pp_k
ELSE
x_csdsst(ji,jj) = 0.
diff --git a/src/OCE/DIU/step_diu.F90 b/src/OCE/DIU/step_diu.F90
index ed8baa71733d7265dd1576070314173223b30d8c..a4b44e38d72cfdd4d2e1f5f6b06c9e0eaf2e2bb8 100644
--- a/src/OCE/DIU/step_diu.F90
+++ b/src/OCE/DIU/step_diu.F90
@@ -46,8 +46,7 @@ MODULE step_diu
!!----------------------------------------------------------------------
INTEGER :: jk ! dummy loop indices
INTEGER :: indic ! error indicator if < 0
- REAL(wp), DIMENSION(jpi,jpj) :: z_fvel_bkginc, z_hflux_bkginc
- INTEGER :: Nbb, Nnn, Naa, Nrhs ! local definitions as placeholders for now
+ INTEGER :: Nbb, Nnn, Naa, Nrhs ! local definitions as placeholders for now
!! ---------------------------------------------------------------------
IF(ln_diurnal_only) THEN
diff --git a/src/OCE/DOM/closea.F90 b/src/OCE/DOM/closea.F90
index eb523c63cc6067ec513a5d2cf23378fcc2b2d80f..3505bb0f7e4d81156123a08b84a81523099c3e17 100644
--- a/src/OCE/DOM/closea.F90
+++ b/src/OCE/DOM/closea.F90
@@ -51,6 +51,8 @@ MODULE closea
INTEGER, PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:,:) :: mask_csrnf , mask_csgrprnf !: mask of integers defining closed seas rnf mappings
INTEGER, PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:,:) :: mask_csemp , mask_csgrpemp !: mask of integers defining closed seas empmr mappings
+ !! * Substitutions
+# include "do_loop_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
!! $Id: closea.F90 13558 2020-10-02 15:30:22Z smasson $
@@ -173,17 +175,17 @@ CONTAINS
!! ** Action : update (p_)mskrnf (set 1 at closed sea outflow)
!!----------------------------------------------------------------------
!! subroutine parameter
- REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: p_rnfmsk ! river runoff mask (rnfmsk array)
- !!
+ REAL(wp), DIMENSION(A2D(0)), INTENT(inout) :: p_rnfmsk ! river runoff mask (rnfmsk array)
!! local variables
- REAL(wp), DIMENSION(jpi,jpj) :: zmsk
+ INTEGER :: ji, jj
+ INTEGER :: zmsk
!!----------------------------------------------------------------------
!
! zmsk > 0 where cs river mouth defined (case rnf and emp)
- zmsk(:,:) = ( mask_csgrprnf (:,:) + mask_csgrpemp(:,:) ) * mask_opnsea(:,:)
- WHERE( zmsk(:,:) > 0 )
- p_rnfmsk(:,:) = 1.0_wp
- END WHERE
+ DO_2D( 0, 0, 0, 0 )
+ zmsk = ( mask_csgrprnf(ji,jj) + mask_csgrpemp(ji,jj) ) * mask_opnsea(ji,jj)
+ IF( zmsk > 0 ) p_rnfmsk(ji,jj) = 1.0_wp
+ END_2D
!
END SUBROUTINE clo_rnf
diff --git a/src/OCE/DOM/dom_oce.F90 b/src/OCE/DOM/dom_oce.F90
index cb50b13560d118f597c7d90340529ee53d7690c0..75a49ead299134443aee836af7b784786424b812 100644
--- a/src/OCE/DOM/dom_oce.F90
+++ b/src/OCE/DOM/dom_oce.F90
@@ -27,6 +27,8 @@ MODULE dom_oce
PUBLIC dom_oce_alloc ! Called from nemogcm.F90
+ !! * Substitutions
+# include "do_loop_substitute.h90"
!!----------------------------------------------------------------------
!! time & space domain namelist
!! ----------------------------
@@ -38,6 +40,11 @@ MODULE dom_oce
LOGICAL , PUBLIC :: ln_1st_euler !: =T start with forward time step or not (=F)
LOGICAL , PUBLIC :: ln_crs !: Apply grid coarsening to dynamical model output or online passive tracers
LOGICAL , PUBLIC :: ln_c1d !: =T single column domain (1x1 pt)
+#if defined key_RK3
+ LOGICAL, PUBLIC, PARAMETER :: lk_RK3 = .TRUE. !: RK3 key flag
+#else
+ LOGICAL, PUBLIC, PARAMETER :: lk_RK3 = .FALSE. !: RK3 key flag
+#endif
!! Free surface parameters
!! =======================
@@ -74,10 +81,10 @@ MODULE dom_oce
INTEGER :: nn_ltile_i, nn_ltile_j
! Domain tiling
- INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: ntsi_a !: start of internal part of tile domain
- INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: ntsj_a !
- INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: ntei_a !: end of internal part of tile domain
- INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: ntej_a !
+ INTEGER, PUBLIC, ALLOCATABLE, DIMENSION(:) :: ntsi_a !: start of internal part of tile domain
+ INTEGER, PUBLIC, ALLOCATABLE, DIMENSION(:) :: ntsj_a !
+ INTEGER, PUBLIC, ALLOCATABLE, DIMENSION(:) :: ntei_a !: end of internal part of tile domain
+ INTEGER, PUBLIC, ALLOCATABLE, DIMENSION(:) :: ntej_a !
LOGICAL, PUBLIC :: l_istiled ! whether tiling is currently active or not
! !: domain MPP decomposition parameters
@@ -85,32 +92,30 @@ MODULE dom_oce
INTEGER , PUBLIC :: narea !: number for local area (starting at 1) = MPI rank + 1
INTEGER, PUBLIC :: nidom !: IOIPSL things...
- INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: mig !: local ==> global domain, including halos (jpiglo), i-index
- INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: mjg !: local ==> global domain, including halos (jpjglo), j-index
- INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: mig0 !: local ==> global domain, excluding halos (Ni0glo), i-index
- INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: mjg0 !: local ==> global domain, excluding halos (Nj0glo), j-index
- INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: mi0, mi1 !: global, including halos (jpiglo) ==> local domain i-index
+ INTEGER, PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: mig !: local ==> global domain, i-index
+ INTEGER, PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: mjg !: local ==> global domain, j-index
+ INTEGER, PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: mi0, mi1 !: global ==> local domain, i-index
! !: (mi0=1 and mi1=0 if global index not in local domain)
- INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: mj0, mj1 !: global, including halos (jpjglo) ==> local domain j-index
+ INTEGER, PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: mj0, mj1 !: global ==> local domain, j-index
! !: (mj0=1 and mj1=0 if global index not in local domain)
- INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: nfimpp, nfproc, nfjpi
+ INTEGER, PUBLIC, ALLOCATABLE, DIMENSION(:) :: nfimpp, nfproc, nfjpi, nfni_0
!!----------------------------------------------------------------------
!! horizontal curvilinear coordinate and scale factors
!! ---------------------------------------------------------------------
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE , DIMENSION(:,:) :: glamt , glamu, glamv , glamf !: longitude at t, u, v, f-points [degree]
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE , DIMENSION(:,:) :: gphit , gphiu, gphiv , gphif !: latitude at t, u, v, f-points [degree]
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, TARGET, DIMENSION(:,:) :: e1t , e2t , r1_e1t, r1_e2t !: t-point horizontal scale factors [m]
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, TARGET, DIMENSION(:,:) :: e1u , e2u , r1_e1u, r1_e2u !: horizontal scale factors at u-point [m]
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, TARGET, DIMENSION(:,:) :: e1v , e2v , r1_e1v, r1_e2v !: horizontal scale factors at v-point [m]
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, TARGET, DIMENSION(:,:) :: e1f , e2f , r1_e1f, r1_e2f !: horizontal scale factors at f-point [m]
+ REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: glamt , glamu, glamv , glamf !: longitude at t, u, v, f-points [degree]
+ REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: gphit , gphiu, gphiv , gphif !: latitude at t, u, v, f-points [degree]
+ REAL(wp), PUBLIC, ALLOCATABLE, TARGET, DIMENSION(:,:) :: e1t , e2t , r1_e1t, r1_e2t !: t-point horizontal scale factors [m]
+ REAL(wp), PUBLIC, ALLOCATABLE, TARGET, DIMENSION(:,:) :: e1u , e2u , r1_e1u, r1_e2u !: horizontal scale factors at u-point [m]
+ REAL(wp), PUBLIC, ALLOCATABLE, TARGET, DIMENSION(:,:) :: e1v , e2v , r1_e1v, r1_e2v !: horizontal scale factors at v-point [m]
+ REAL(wp), PUBLIC, ALLOCATABLE, TARGET, DIMENSION(:,:) :: e1f , e2f , r1_e1f, r1_e2f !: horizontal scale factors at f-point [m]
!
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE , DIMENSION(:,:) :: e1e2t , r1_e1e2t !: associated metrics at t-point
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE , DIMENSION(:,:) :: e1e2u , r1_e1e2u , e2_e1u !: associated metrics at u-point
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE , DIMENSION(:,:) :: e1e2v , r1_e1e2v , e1_e2v !: associated metrics at v-point
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE , DIMENSION(:,:) :: e1e2f , r1_e1e2f !: associated metrics at f-point
+ REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: e1e2t , r1_e1e2t !: associated metrics at t-point
+ REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: e1e2u , r1_e1e2u , e2_e1u !: associated metrics at u-point
+ REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: e1e2v , r1_e1e2v , e1_e2v !: associated metrics at v-point
+ REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: e1e2f , r1_e1e2f !: associated metrics at f-point
!
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ff_f , ff_t !: Coriolis factor at f- & t-points [1/s]
+ REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: ff_f , ff_t !: Coriolis factor at f- & t-points [1/s]
!!----------------------------------------------------------------------
!! vertical coordinate and scale factors
@@ -125,60 +130,105 @@ MODULE dom_oce
#else
LOGICAL, PUBLIC, PARAMETER :: lk_linssh = .FALSE. !: linssh key flag
#endif
- LOGICAL, PUBLIC :: ln_zco !: z-coordinate - full step
- LOGICAL, PUBLIC :: ln_zps !: z-coordinate - partial step
- LOGICAL, PUBLIC :: ln_sco !: s-coordinate or hybrid z-s coordinate
- LOGICAL, PUBLIC :: ln_isfcav !: presence of ISF
- ! ! reference scale factors
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: e3t_0 !: t- vert. scale factor [m]
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: e3u_0 !: u- vert. scale factor [m]
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: e3v_0 !: v- vert. scale factor [m]
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: e3f_0 !: f- vert. scale factor [m]
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: e3w_0 !: w- vert. scale factor [m]
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: e3uw_0 !: uw-vert. scale factor [m]
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: e3vw_0 !: vw-vert. scale factor [m]
-
- ! ! time-dependent scale factors (domvvl)
-#if defined key_qco || defined key_linssh
+#if defined key_ALE
+ LOGICAL, PUBLIC, PARAMETER :: lk_ALE = .TRUE. !: ALE key flag
#else
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: e3t, e3u, e3v, e3w, e3uw, e3vw !: vert. scale factor [m]
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: e3f !: F-point vert. scale factor [m]
+ LOGICAL, PUBLIC, PARAMETER :: lk_ALE = .FALSE. !: ALE key flag
#endif
- ! ! time-dependent ratio ssh / h_0 (domqco)
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: r3t, r3u, r3v !: time-dependent ratio at t-, u- and v-point [-]
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: r3f !: mid-time-level ratio at f-point [-]
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: r3t_f, r3u_f, r3v_f !: now time-filtered ratio at t-, u- and v-point [-]
-
- ! ! reference depths of cells
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: gdept_0 !: t- depth [m]
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: gdepw_0 !: w- depth [m]
-
- ! ! time-dependent depths of cells (domvvl)
-#if defined key_qco || defined key_linssh
+#if defined key_vco_1d
+ LOGICAL, PUBLIC, PARAMETER :: lk_vco_1d = .TRUE. !: zco key flag
#else
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: gde3w_0, gde3w !: w- depth (sum of e3w) [m]
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: gdept, gdepw
+ LOGICAL, PUBLIC, PARAMETER :: lk_vco_1d = .FALSE. !: zco key flag
#endif
- ! ! reference heights of ocean water column and its inverse
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ht_0, r1_ht_0 !: t-depth [m] and [1/m]
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hu_0, r1_hu_0 !: u-depth [m] and [1/m]
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hv_0, r1_hv_0 !: v-depth [m] and [1/m]
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hf_0, r1_hf_0 !: f-depth [m] and [1/m]
-
- ! ! time-dependent heights of ocean water column (domvvl)
-#if defined key_qco || defined key_linssh
+#if defined key_vco_1d3d
+ LOGICAL, PUBLIC, PARAMETER :: lk_vco_1d3d = .TRUE. !: zps key flag
+#else
+ LOGICAL, PUBLIC, PARAMETER :: lk_vco_1d3d = .FALSE. !: zps key flag
+#endif
+#if defined key_vco_3d
+ LOGICAL, PUBLIC, PARAMETER :: lk_vco_3d = .TRUE. !: sco key flag
#else
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ht !: t-points [m]
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: hu, r1_hu !: u-depth [m] and [1/m]
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: hv, r1_hv !: v-depth [m] and [1/m]
+ LOGICAL, PUBLIC, PARAMETER :: lk_vco_3d = .FALSE. !: sco key flag
#endif
+
+!!gm obsolescent feature replaced by key_xxx ==>>> to be removed when z-tilde and or ALE key added (and domvvl removed)
+ LOGICAL, PUBLIC :: l_zco !: z-coordinate - full step
+ LOGICAL, PUBLIC :: l_zps !: z-coordinate - partial step
+ LOGICAL, PUBLIC :: l_sco !: s-coordinate or hybrid z-s coordinate
+!!st for unknown reason this is init at TRUE in dbg mode LOGICAL, PUBLIC :: ln_isfcav !: presence of ISF
+!!gm end
+
+ ! !-----------------------------------!
+ ! ! split of time & space variation ! coord(i,j,k,t) = coord_0(i,j,k) * (1+rt(i,j,t))
+ ! !-----------------------------------!
+
+ ! !== reference thickness of ocean water column and its inverse ==! (all coord. except ALE/z-tilde)
+ !
+ REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: ht_0, r1_ht_0 !: t-depth [m] and [1/m]
+ REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: hu_0, r1_hu_0 !: u-depth [m] and [1/m]
+ REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: hv_0, r1_hv_0 !: v-depth [m] and [1/m]
+ REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: hf_0, r1_hf_0 !: f-depth [m] and [1/m]
+
+
+ ! !== 1D reference coordinate ==! used in zco and zps cases (z- or z-partial cell coord.)
+ !
+ REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:) :: gdept_1d, e3t_1d !: reference depth & scale factor of T-level points [m]
+ REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:) :: gdepw_1d, e3w_1d !: reference depth & scale factor of W-level points [m]
+
+
+ ! !== 3D reference coordinate ==! used in zps and sco cases (z-partial cell ans s- coord.)
+ !
+ REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:) :: gdept_3d !: t- depth [m]
+ REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:) :: gdepw_3d !: w- depth [m]
+ !
+ REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:) :: e3t_3d !: t- vert. scale factor [m]
+ REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:) :: e3u_3d !: u- vert. scale factor [m]
+ REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:) :: e3v_3d !: v- vert. scale factor [m]
+ REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:) :: e3f_3d !: f- vert. scale factor [m]
+ REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:) :: e3w_3d !: w- vert. scale factor [m]
+ REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:) :: e3uw_3d !: uw-vert. scale factor [m]
+ REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:) :: e3vw_3d !: vw-vert. scale factor [m]
+
+ ! !== time varying factor ==! used in qco case (quasi-eulerian coordinate)
+ ! !!! time-dependent ratio ssh / h_0 (domqco)
+ REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:) :: r3t, r3u, r3v !: time-dependent ratio at t-, u- and v-point [-]
+ REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: r3f !: mid-time-level ratio at f-point [-]
+ REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: r3t_f, r3u_f, r3v_f !: now time-filtered ratio at t-, u- and v-point [-]
+
+ ! !----------------------------------------!
+ ! ! combined of time & space variations ! coord(i,j,k,t)
+ ! !----------------------------------------!
+
+ ! !== z-tilde or ALE case ==! default : time-dependent coord. (currently use of domvvl old staff)
+ !
+ REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:) :: ht !: t-points [m]
+ REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:) :: hu, r1_hu !: u-depth [m] and [1/m]
+ REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:) :: hv, r1_hv !: v-depth [m] and [1/m]
+ !
+ REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:,:) :: gdept !: t- depth [m]
+ REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:,:) :: gdepw !: w- depth [m]
+ !
+ REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:,:) :: e3t !: t- vert. scale factor [m]
+ REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:,:) :: e3u !: u- vert. scale factor [m]
+ REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:,:) :: e3v !: v- vert. scale factor [m]
+ REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:) :: e3f !: f- vert. scale factor [m] (only need at Nmm)
+ REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:,:) :: e3w !: w- vert. scale factor [m]
+ REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:,:) :: e3uw !: uw-vert. scale factor [m]
+ REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:,:) :: e3vw !: vw-vert. scale factor [m]
+
+
+!!gm this is to be replaced by a 2D field for sco
INTEGER, PUBLIC :: nla10 !: deepest W level Above ~10m (nlb10 - 1)
INTEGER, PUBLIC :: nlb10 !: shallowest W level Bellow ~10m (nla10 + 1)
- !! 1D reference vertical coordinate
- !! =-----------------====------
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: gdept_1d, gdepw_1d !: reference depth of t- and w-points (m)
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: e3t_1d , e3w_1d !: reference vertical scale factors at T- and W-pts (m)
+!!gm bathy should be removed use ht_0 or ht-ssh
+#if defined key_isf
+ LOGICAL, PUBLIC, PARAMETER :: lk_isf = .TRUE. !: isf key flag
+#else
+ LOGICAL, PUBLIC, PARAMETER :: lk_isf = .FALSE. !: isf key flag
+#endif
+ LOGICAL, PUBLIC :: ln_isfcav = .FALSE. !: absence of ISF (init for debug mode)
+
REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: risfdep, bathy
@@ -186,20 +236,22 @@ MODULE dom_oce
!! masks, top and bottom ocean point position
!! ---------------------------------------------------------------------
!!gm Proposition of new name for top/bottom vertical indices
-! INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: mtk_t, mtk_u, mtk_v !: top first wet T-, U-, and V-level (ISF)
-! INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: mbk_t, mbk_u, mbk_v !: bottom last wet T-, U-, and V-level
+! INTEGER , PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: mtk_t, mtk_u, mtk_v !: top first wet T-, U-, and V-level (ISF)
+! INTEGER , PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: mbk_t, mbk_u, mbk_v !: bottom last wet T-, U-, and V-level
!!gm
- INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: mbkt, mbku, mbkv, mbkf !: bottom last wet T-, U-, V- and F-level
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: tmask_i !: interior (excluding halos+duplicated points) domain T-point mask
+ INTEGER , PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: mbkt, mbku, mbkv, mbkf !: bottom last wet T-, U-, V- and F-level
+ REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: tmask_i !: interior (excluding halos+duplicated points) domain T-point mask
- INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: mikt, miku, mikv, mikf !: top first wet T-, U-, V-, F-level (ISF)
+ INTEGER , PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: mikt, miku, mikv, mikf !: top first wet T-, U-, V-, F-level (ISF)
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ssmask, ssumask, ssvmask, ssfmask !: surface mask at T-,U-, V- and F-pts
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:), TARGET :: tmask, umask, vmask, wmask, fmask !: land/ocean mask at T-, U-, V-, W- and F-pts
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:), TARGET :: wumask, wvmask !: land/ocean mask at WU- and WV-pts
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:), TARGET :: fe3mask !: land/ocean mask at F-pts
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: tmask_upd, umask_upd, vmask_upd !: agrif mask defining barotropic update
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: tmask_agrif !: agrif mask at T-points excluding ghosts and updated areas
+ REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: smask0 !: surface mask at T-pts on inner domain
+ REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: smask0_i !: equivalent of tmask_i for inner domain
+ REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: ssmask, ssumask, ssvmask, ssfmask !: surface mask at T-,U-, V- and F-pts
+ REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:), TARGET :: tmask, umask, vmask, wmask, fmask !: land/ocean mask at T-, U-, V-, W- and F-pts
+ REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:), TARGET :: wumask, wvmask !: land/ocean mask at WU- and WV-pts
+ REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:), TARGET :: fe3mask !: land/ocean mask at F-pts
+ REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: tmask_upd, umask_upd, vmask_upd !: land/ocean mask at F-pts
+ REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: tmask_agrif !: agrif mask at T-points excluding ghosts and updated areas
!!----------------------------------------------------------------------
!! calendar variables
@@ -284,50 +336,76 @@ CONTAINS
& e1e2v(jpi,jpj) , r1_e1e2v(jpi,jpj) , e1_e2v(jpi,jpj) , &
& e1e2f(jpi,jpj) , r1_e1e2f(jpi,jpj) , &
& ff_f (jpi,jpj) , ff_t (jpi,jpj) , STAT=ierr(ii) )
+ !
+ ! !=====================!
+ ! !== vertical mesh ==! gdep and e3 arrays allocation
+ ! !=====================!
+ ! !-----------------------------------!
+ IF( lk_qco .OR. lk_linssh ) THEN !- split time & space variations -! qco or linear ssh
+ ! !-----------------------------------!
+ ii = ii+1
+ ALLOCATE( ht_0(jpi,jpj) , hu_0(jpi,jpj) , hv_0(jpi,jpj) , hf_0(jpi,jpj) , &
+ & r1_ht_0(jpi,jpj) , r1_hu_0(jpi,jpj) , r1_hv_0(jpi,jpj), r1_hf_0(jpi,jpj) , STAT=ierr(ii) )
!
- ii = ii+1
- ALLOCATE( gdept_0 (jpi,jpj,jpk) , gdepw_0 (jpi,jpj,jpk) , &
- & gdept_1d( jpk) , gdepw_1d( jpk) , STAT=ierr(ii) )
- !
- ii = ii+1
- ALLOCATE( e3t_0 (jpi,jpj,jpk) , e3u_0 (jpi,jpj,jpk) , e3v_0 (jpi,jpj,jpk) , e3f_0(jpi,jpj,jpk) , &
- & e3w_0 (jpi,jpj,jpk) , e3uw_0(jpi,jpj,jpk) , e3vw_0(jpi,jpj,jpk) , &
- & e3t_1d( jpk) , e3w_1d( jpk) , STAT=ierr(ii) )
- !
- ii = ii+1
- ALLOCATE( ht_0(jpi,jpj) , hu_0(jpi,jpj) , hv_0(jpi,jpj) , hf_0(jpi,jpj) , &
- & r1_ht_0(jpi,jpj) , r1_hu_0(jpi,jpj) , r1_hv_0(jpi,jpj), r1_hf_0(jpi,jpj) , STAT=ierr(ii) )
- !
-#if defined key_qco
- ! qco : ssh to h ratio and specific fmask
- ii = ii+1
- ALLOCATE( r3t (jpi,jpj,jpt) , r3u (jpi,jpj,jpt) , r3v (jpi,jpj,jpt) , r3f (jpi,jpj) , &
- & r3t_f(jpi,jpj) , r3u_f(jpi,jpj) , r3v_f(jpi,jpj) , STAT=ierr(ii) )
+ IF( lk_qco ) THEN !* qco only : time variation factor (ssh/h ratio)
+ ii = ii+1
+ ALLOCATE( r3t(jpi,jpj,jpt) , r3u(jpi,jpj,jpt) , r3v(jpi,jpj,jpt) , r3f(jpi,jpj) , STAT=ierr(ii) )
+ !
+ IF( .NOT. lk_RK3 ) THEN ! + MLF : Asselin filter applied to r3. at f-point
+ ii = ii+1
+ ALLOCATE( r3t_f(jpi,jpj) , r3u_f(jpi,jpj) , r3v_f(jpi,jpj) , STAT=ierr(ii) )
+ ENDIF
+ ENDIF
!
- ii = ii+1
+ ii = ii+1
+ IF( lk_vco_1d ) THEN !* zco : allocate 1d vertical arrays for all gdep and e3 fields
+ !
+ ALLOCATE( gdept_1d(jpk) , gdepw_1d(jpk) , &
+ & e3t_1d(jpk) , e3w_1d(jpk) , STAT=ierr(ii) )
+ !
+ ELSEIF( lk_vco_1d3d ) THEN !* zps : allocate 1d vertical arrays, except t-level e3 !!st WHT not ???
+ !
+ ALLOCATE( gdept_1d(jpk) , gdepw_1d(jpk) , &
+ & e3t_1d(jpk) , e3w_1d(jpk) , &
+ & e3t_3d(jpi,jpj,jpk) , e3u_3d(jpi,jpj,jpk) , &
+ & e3v_3d(jpi,jpj,jpk) , e3f_3d(jpi,jpj,jpk) , STAT=ierr(ii) )
+ ELSEIF( lk_vco_3d ) THEN
+ ! !* sco : allocate 3d vertical arrays for all gdep and e3 fields (no more _1d) !!st WHT not ???
+ ALLOCATE( gdept_1d(jpk) , gdepw_1d(jpk) , &
+ & e3t_1d(jpk) , e3w_1d(jpk) , &
+ & gdept_3d(jpi,jpj,jpk) ,gdepw_3d(jpi,jpj,jpk) , &
+ & e3t_3d(jpi,jpj,jpk) , e3u_3d(jpi,jpj,jpk) , &
+ & e3v_3d(jpi,jpj,jpk) , e3f_3d(jpi,jpj,jpk) , &
+ & e3w_3d(jpi,jpj,jpk) , e3uw_3d(jpi,jpj,jpk) , &
+ & e3vw_3d(jpi,jpj,jpk) , STAT=ierr(ii) )
+ ENDIF !!st on ne devrait pas mettre un STOP/WARNING quelque part si aucune clé de coordonnée n'est spécifiée ?
+ ! !-------------------------------------!
+ ELSEIF( lk_ALE ) THEN !- combine time & space variations -! (vertical ALE coordinate)
+ ! !-------------------------------------! NOT yet implemented
+ !!st ca ne devrait pas etre des *_0 qui varient dans le temps ?
+ ii = ii+1
+ ALLOCATE( ht(jpi,jpj,jpt) , hu(jpi,jpj,jpt) , hv(jpi,jpj,jpt) , &
+ & r1_hu(jpi,jpj,jpt) , r1_hv (jpi,jpj,jpt) , STAT=ierr(ii) )
!
-#elif defined key_linssh
- ! linear ssh no time varying coordinate arrays
-#else
- ! vvl : time varation for all vertical coordinate variables
- ii = ii+1
- ALLOCATE( gdept (jpi,jpj,jpk,jpt) , gdepw (jpi,jpj,jpk,jpt) , &
- & gde3w_0(jpi,jpj,jpk) , gde3w (jpi,jpj,jpk) , STAT=ierr(ii) )
+ ii = ii+1
+ ALLOCATE( gdept(jpi,jpj,jpk,jpt) , gdepw(jpi,jpj,jpk,jpt) , &
+ & e3t(jpi,jpj,jpk,jpt) , e3u(jpi,jpj,jpk,jpt) , &
+ & e3v(jpi,jpj,jpk,jpt) , e3f(jpi,jpj,jpk) , &
+ & e3w(jpi,jpj,jpk,jpt) , e3uw(jpi,jpj,jpk,jpt) , &
+ & e3vw(jpi,jpj,jpk,jpt) , STAT=ierr(ii) )
+ ! !-------------------------------------!
+ ELSE !- use old domvvl module -! (default : old z-tilde coord)
+ ! !-------------------------------------!
!
- ii = ii+1
- ALLOCATE( e3t(jpi,jpj,jpk,jpt) , e3u (jpi,jpj,jpk,jpt) , e3v (jpi,jpj,jpk,jpt) , e3f(jpi,jpj,jpk) , &
- & e3w(jpi,jpj,jpk,jpt) , e3uw(jpi,jpj,jpk,jpt) , e3vw(jpi,jpj,jpk,jpt) , STAT=ierr(ii) )
+ ! mettre un STOP/WARNING
!
- ii = ii+1
- ALLOCATE( ht (jpi,jpj) , hu (jpi,jpj,jpt), hv (jpi,jpj,jpt) , &
- & r1_hu (jpi,jpj,jpt), r1_hv (jpi,jpj,jpt) , STAT=ierr(ii) )
-#endif
+ ENDIF
!
ii = ii+1
ALLOCATE( risfdep(jpi,jpj) , bathy(jpi,jpj) , STAT=ierr(ii) )
!
ii = ii+1
- ALLOCATE( tmask_i(jpi,jpj) , &
+ ALLOCATE( tmask_i(jpi,jpj) , smask0(A2D(0)) , smask0_i(A2D(0)) , &
& ssmask (jpi,jpj) , ssumask(jpi,jpj) , ssvmask(jpi,jpj) , ssfmask(jpi,jpj) , &
& mbkt (jpi,jpj) , mbku (jpi,jpj) , mbkv (jpi,jpj) , mbkf(jpi,jpj) , STAT=ierr(ii) )
!
diff --git a/src/OCE/DOM/domain.F90 b/src/OCE/DOM/domain.F90
index dbbe4a9031aa13452c7ef3a83f7ad708b72407d1..07d5d884f56df7b9860e3ebb49f1e4703c5001e5 100644
--- a/src/OCE/DOM/domain.F90
+++ b/src/OCE/DOM/domain.F90
@@ -31,8 +31,6 @@ MODULE domain
USE domqco ! quasi-eulerian coord.
#elif defined key_linssh
! ! fix in time coord.
-#else
- USE domvvl ! variable volume coord.
#endif
#if defined key_agrif
USE agrif_oce_interp, ONLY : Agrif_istate_ssh ! ssh interpolated from parent
@@ -65,6 +63,7 @@ MODULE domain
!! * Substitutions
# include "do_loop_substitute.h90"
+# include "domzgr_substitute.h90"
!!-------------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
!! $Id: domain.F90 14547 2021-02-25 17:07:15Z techene $
@@ -195,39 +194,6 @@ CONTAINS
IF( .NOT.l_offline ) CALL dom_qco_init( Kbb, Kmm, Kaa )
#elif defined key_linssh
! != Fix in time : key_linssh case, set through domzgr_substitute.h90
-#else
- !
- IF( ln_linssh ) THEN != Fix in time : set to the reference one for all
- !
- DO jt = 1, jpt ! depth of t- and w-grid-points
- gdept(:,:,:,jt) = gdept_0(:,:,:)
- gdepw(:,:,:,jt) = gdepw_0(:,:,:)
- END DO
- gde3w(:,:,:) = gde3w_0(:,:,:) ! = gdept as the sum of e3t
- !
- DO jt = 1, jpt ! vertical scale factors
- e3t (:,:,:,jt) = e3t_0(:,:,:)
- e3u (:,:,:,jt) = e3u_0(:,:,:)
- e3v (:,:,:,jt) = e3v_0(:,:,:)
- e3w (:,:,:,jt) = e3w_0(:,:,:)
- e3uw(:,:,:,jt) = e3uw_0(:,:,:)
- e3vw(:,:,:,jt) = e3vw_0(:,:,:)
- END DO
- e3f (:,:,:) = e3f_0(:,:,:)
- !
- DO jt = 1, jpt ! water column thickness and its inverse
- hu(:,:,jt) = hu_0(:,:)
- hv(:,:,jt) = hv_0(:,:)
- r1_hu(:,:,jt) = r1_hu_0(:,:)
- r1_hv(:,:,jt) = r1_hv_0(:,:)
- END DO
- ht (:,:) = ht_0(:,:)
- !
- ELSE != Time varying : initialize before/now/after variables
- !
- IF( .NOT.l_offline ) CALL dom_vvl_init( Kbb, Kmm, Kaa )
- !
- ENDIF
#endif
!
@@ -263,7 +229,7 @@ CONTAINS
!!----------------------------------------------------------------------
USE ioipsl
!!
- INTEGER :: ios ! Local integer
+ INTEGER :: ios, imax ! Local integer
REAL(wp):: zrdt
!!----------------------------------------------------------------------
!
@@ -515,8 +481,40 @@ CONTAINS
WRITE(numout,*)
WRITE(numout,*) ' Namelist : namtile --- Domain tiling decomposition'
WRITE(numout,*) ' Tiling (T) or not (F) ln_tile = ', ln_tile
- WRITE(numout,*) ' Length of tile in i nn_ltile_i = ', nn_ltile_i
- WRITE(numout,*) ' Length of tile in j nn_ltile_j = ', nn_ltile_j
+ ENDIF
+
+ ! is_tile in domutl uses the array size to determine if the array represents a tile or the full domain.
+ ! To avoid ambiguity, either the tile must be the size of the full domain (i.e. nn_ltile_i = Ni_0), or the largest
+ ! possible tile array (internal and halo points) must be smaller than the internal area of the full domain
+ IF( ln_tile ) THEN
+ IF(lwp) WRITE(numout,*) ' Length of tile in i nn_ltile_i = ', nn_ltile_i
+
+ imax = Ni_0 - (2 * nn_hls) - 1
+ IF( imax < 1 ) imax = Ni_0 ! Avoid zero tile size for small domains
+ IF( nn_ltile_i > imax .AND. nn_ltile_i /= Ni_0 ) THEN
+ IF( nn_ltile_i < Ni_0 ) THEN
+ nn_ltile_i = MIN( nn_ltile_i, imax ) ! 2+ tiles
+ ELSE
+ nn_ltile_i = MIN( nn_ltile_i, Ni_0 ) ! 1 tile
+ ENDIF
+ IF(lwp) WRITE(numout,*) ' ===> Reduced to size ', nn_ltile_i
+ ENDIF
+
+ IF(lwp) WRITE(numout,*) ' Length of tile in j nn_ltile_j = ', nn_ltile_j
+
+ imax = Nj_0 - (2 * nn_hls) - 1
+ IF( imax < 1 ) imax = Nj_0 ! Avoid zero tile size for small domains
+ IF( nn_ltile_j > imax .AND. nn_ltile_j /= Nj_0 ) THEN
+ IF( nn_ltile_j < Nj_0 ) THEN
+ nn_ltile_j = MIN( nn_ltile_j, imax ) ! 2+ tiles
+ ELSE
+ nn_ltile_j = MIN( nn_ltile_j, Nj_0 ) ! 1 tile
+ ENDIF
+ IF(lwp) WRITE(numout,*) ' ===> Reduced to size ', nn_ltile_j
+ ENDIF
+ ENDIF
+
+ IF(lwp) THEN
WRITE(numout,*)
IF( ln_tile ) THEN
WRITE(numout,*) ' The domain will be decomposed into tiles of size', nn_ltile_i, 'x', nn_ltile_j
@@ -707,6 +705,7 @@ CONTAINS
INTEGER :: inum ! local units
CHARACTER(len=21) :: clnam ! filename (mesh and mask informations)
REAL(wp), DIMENSION(jpi,jpj) :: z2d ! workspace
+ REAL(wp), DIMENSION(jpi,jpj,jpk) :: z3d ! workspace
!!----------------------------------------------------------------------
!
IF(lwp) WRITE(numout,*)
@@ -734,9 +733,9 @@ CONTAINS
CALL iom_putatt( inum, 'NFtype', c_NFtype )
! ! type of vertical coordinate
- IF(ln_zco) CALL iom_putatt( inum, 'VertCoord', 'zco' )
- IF(ln_zps) CALL iom_putatt( inum, 'VertCoord', 'zps' )
- IF(ln_sco) CALL iom_putatt( inum, 'VertCoord', 'sco' )
+ IF(l_zco) CALL iom_putatt( inum, 'VertCoord', 'zco' )
+ IF(l_zps) CALL iom_putatt( inum, 'VertCoord', 'zps' )
+ IF(l_sco) CALL iom_putatt( inum, 'VertCoord', 'sco' )
! ! ocean cavities under iceshelves
CALL iom_putatt( inum, 'IsfCav', COUNT( (/ln_isfcav/) ) )
@@ -771,20 +770,41 @@ CONTAINS
CALL iom_rstput( 0, 0, inum, 'e3t_1d' , e3t_1d , ktype = jp_r8 ) ! reference 1D-coordinate
CALL iom_rstput( 0, 0, inum, 'e3w_1d' , e3w_1d , ktype = jp_r8 )
!
- CALL iom_rstput( 0, 0, inum, 'e3t_0' , e3t_0 , ktype = jp_r8 ) ! vertical scale factors
- CALL iom_rstput( 0, 0, inum, 'e3u_0' , e3u_0 , ktype = jp_r8 )
- CALL iom_rstput( 0, 0, inum, 'e3v_0' , e3v_0 , ktype = jp_r8 )
- CALL iom_rstput( 0, 0, inum, 'e3f_0' , e3f_0 , ktype = jp_r8 )
- CALL iom_rstput( 0, 0, inum, 'e3w_0' , e3w_0 , ktype = jp_r8 )
- CALL iom_rstput( 0, 0, inum, 'e3uw_0' , e3uw_0 , ktype = jp_r8 )
- CALL iom_rstput( 0, 0, inum, 'e3vw_0' , e3vw_0 , ktype = jp_r8 )
+ DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpk )
+ z3d(ji,jj,jk) = e3t_0(ji,jj,jk)
+ END_3D
+ CALL iom_rstput( 0, 0, inum, 'e3t_0' , z3d , ktype = jp_r8 ) ! vertical scale factors
+ DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpk )
+ z3d(ji,jj,jk) = e3u_0(ji,jj,jk)
+ END_3D
+ CALL iom_rstput( 0, 0, inum, 'e3u_0' , z3d , ktype = jp_r8 )
+ DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpk )
+ z3d(ji,jj,jk) = e3v_0(ji,jj,jk)
+ END_3D
+ CALL iom_rstput( 0, 0, inum, 'e3v_0' , z3d , ktype = jp_r8 )
+ DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpk )
+ z3d(ji,jj,jk) = e3f_0(ji,jj,jk)
+ END_3D
+ CALL iom_rstput( 0, 0, inum, 'e3f_0' , z3d , ktype = jp_r8 )
+ DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpk )
+ z3d(ji,jj,jk) = e3w_0(ji,jj,jk)
+ END_3D
+ CALL iom_rstput( 0, 0, inum, 'e3w_0' , z3d , ktype = jp_r8 )
+ DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpk )
+ z3d(ji,jj,jk) = e3uw_0(ji,jj,jk)
+ END_3D
+ CALL iom_rstput( 0, 0, inum, 'e3uw_0' , z3d , ktype = jp_r8 )
+ DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpk )
+ z3d(ji,jj,jk) = e3vw_0(ji,jj,jk)
+ END_3D
+ CALL iom_rstput( 0, 0, inum, 'e3vw_0' , z3d , ktype = jp_r8 )
!
! !== wet top and bottom level ==! (caution: multiplied by ssmask)
!
CALL iom_rstput( 0, 0, inum, 'top_level' , REAL( mikt, wp )*ssmask , ktype = jp_i4 ) ! nb of ocean T-points (ISF)
CALL iom_rstput( 0, 0, inum, 'bottom_level' , REAL( mbkt, wp )*ssmask , ktype = jp_i4 ) ! nb of ocean T-points
!
- IF( ln_sco ) THEN ! s-coordinate: store grid stiffness ratio (Not required anyway)
+ IF( l_sco ) THEN ! s-coordinate: store grid stiffness ratio (Not required anyway)
CALL dom_stiff( z2d )
CALL iom_rstput( 0, 0, inum, 'stiffness', z2d ) ! ! Max. grid stiffness ratio
ENDIF
diff --git a/src/OCE/DOM/dommsk.F90 b/src/OCE/DOM/dommsk.F90
index 362b11e3e48d4bfad0279a14b9b72c8847554aeb..77fcef6078ee907c11924e954a7980aaeaefa987 100644
--- a/src/OCE/DOM/dommsk.F90
+++ b/src/OCE/DOM/dommsk.F90
@@ -144,7 +144,8 @@ CONTAINS
tmask(ji,jj,jk) = tmask(ji,jj,jk) * bdytmask(ji,jj)
END_3D
ENDIF
-
+ smask0(:,:) = tmask(A2D(0),1)
+
! Ocean/land mask at u-, v-, and f-points (computed from tmask)
! ----------------------------------------
! NB: at this point, fmask is designed for free slip lateral boundary condition
@@ -203,7 +204,8 @@ CONTAINS
! --------------------
!
CALL dom_uniq( tmask_i, 'T' )
- tmask_i(:,:) = ssmask(:,:) * tmask_i(:,:)
+ tmask_i (:,:) = ssmask(:,:) * tmask_i(:,:)
+ smask0_i(:,:) = tmask_i(A2D(0))
! Lateral boundary conditions on velocity (modify fmask)
! ---------------------------------------
diff --git a/src/OCE/DOM/domqco.F90 b/src/OCE/DOM/domqco.F90
index 5944f59c1057780287cc63828673d090415ce239..678fd864db49e27b9bca9dc2a2a07b04b88a7a86 100644
--- a/src/OCE/DOM/domqco.F90
+++ b/src/OCE/DOM/domqco.F90
@@ -180,9 +180,9 @@ CONTAINS
! round brackets added to fix the order of floating point operations
! needed to ensure halo 1 - halo 2 compatibility
pr3f(ji,jj) = 0.25_wp * ( ( e1e2t(ji ,jj ) * pssh(ji ,jj ) &
- & + e1e2t(ji+1,jj ) * pssh(ji+1,jj ) ) & ! bracket for halo 1 - halo 2 compatibility
+ & + e1e2t(ji+1,jj ) * pssh(ji+1,jj ) ) & ! add () for NP reproducibility
& + ( e1e2t(ji ,jj+1) * pssh(ji ,jj+1) &
- & + e1e2t(ji+1,jj+1) * pssh(ji+1,jj+1) ) & ! bracket for halo 1 - halo 2 compatibility
+ & + e1e2t(ji+1,jj+1) * pssh(ji+1,jj+1) ) & ! add () for NP reproducibility
& ) * r1_hf_0(ji,jj) * r1_e1e2f(ji,jj)
END_2D
! ! lbc on ratio at u-,v-,f-points
@@ -247,9 +247,9 @@ CONTAINS
! round brackets added to fix the order of floating point operations
! needed to ensure halo 1 - halo 2 compatibility
pr3f(ji,jj) = 0.25_wp * ( ( e1e2t(ji ,jj ) * pssh(ji ,jj ) &
- & + e1e2t(ji+1,jj ) * pssh(ji+1,jj ) ) & ! bracket for halo 1 - halo 2 compatibility
+ & + e1e2t(ji+1,jj ) * pssh(ji+1,jj ) ) & ! add () for NP reproducibility
& + ( e1e2t(ji ,jj+1) * pssh(ji ,jj+1) &
- & + e1e2t(ji+1,jj+1) * pssh(ji+1,jj+1) ) & ! bracket for halo 1 - halo 2 compatibility
+ & + e1e2t(ji+1,jj+1) * pssh(ji+1,jj+1) ) & ! add () for NP reproducibility
& ) * r1_hf_0(ji,jj) * r1_e1e2f(ji,jj)
END_2D
!!st ELSE !- Flux Form (simple averaging)
@@ -258,7 +258,7 @@ CONTAINS
! round brackets added to fix the order of floating point operations
! needed to ensure halo 1 - halo 2 compatibility
pr3f(ji,jj) = 0.25_wp * ( ( pssh(ji,jj ) + pssh(ji+1,jj ) ) &
- & + ( pssh(ji,jj+1) + pssh(ji+1,jj+1) ) & ! bracket for halo 1 - halo 2 compatibility
+ & + ( pssh(ji,jj+1) + pssh(ji+1,jj+1) ) & ! add () for NP reproducibility
& ) * r1_hf_0(ji,jj)
END_2D
!!st ENDIF
diff --git a/src/OCE/DOM/domutl.F90 b/src/OCE/DOM/domutl.F90
index 0c56f8f1f62c20228376775406b3d356d5529d0b..0af7f93f99a3892fda4e1abc753a86f49f1e8fae 100644
--- a/src/OCE/DOM/domutl.F90
+++ b/src/OCE/DOM/domutl.F90
@@ -20,13 +20,17 @@ MODULE domutl
IMPLICIT NONE
PRIVATE
- INTERFACE is_tile
- MODULE PROCEDURE is_tile_2d_sp, is_tile_3d_sp, is_tile_4d_sp, is_tile_2d_dp, is_tile_3d_dp, is_tile_4d_dp
- END INTERFACE is_tile
+ INTERFACE lbnd_ij
+ MODULE PROCEDURE arr_lbnd_2d_i, arr_lbnd_3d_i, arr_lbnd_4d_i, arr_lbnd_5d_i, &
+ & arr_lbnd_2d_sp, arr_lbnd_3d_sp, arr_lbnd_4d_sp, arr_lbnd_5d_sp, &
+ & arr_lbnd_2d_dp, arr_lbnd_3d_dp, arr_lbnd_4d_dp, arr_lbnd_5d_dp
+ END INTERFACE lbnd_ij
PUBLIC dom_ngb ! routine called in iom.F90 module
PUBLIC dom_uniq ! Called by dommsk and domwri
PUBLIC is_tile
+ PUBLIC lbnd_ij
+ PUBLIC arr_hls
!!----------------------------------------------------------------------
!! NEMO/OCE 4.2 , NEMO Consortium (2020)
@@ -115,69 +119,199 @@ CONTAINS
END SUBROUTINE dom_uniq
- INTEGER FUNCTION is_tile_2d_sp( pt )
- REAL(sp), DIMENSION(:,:), INTENT(in) :: pt
-
- IF( l_istiled .AND. (SIZE(pt, 1) < jpi .OR. SIZE(pt, 2) < jpj) ) THEN
- is_tile_2d_sp = 1
+ FUNCTION arr_lbnd( kasi, kasj, ldtile ) RESULT(kbnd)
+ !!----------------------------------------------------------------------
+ !! *** FUNCTION arr_lbnd ***
+ !!
+ !! ** Purpose : Determine the lower bounds of an array's internal area from its i-j shape
+ !!
+ !! ** Method : 1) Identify whether the array shape corresponds to a tile or MPI domain (is_tile)
+ !! 2) Compare the array shape to the internal area shape to get the halo size
+ !! 3) Determine the lower bounds of the internal area
+ !!----------------------------------------------------------------------
+ INTEGER, INTENT(in) :: kasi, kasj ! Size of i, j dimensions
+ LOGICAL, INTENT(in), OPTIONAL :: ldtile ! Is the array on the tile (T) or MPI (F) domain?
+ !
+ INTEGER, DIMENSION(2) :: kbnd ! Lower bounds of i, j dimensions
+ INTEGER, DIMENSION(2) :: ihls ! Halo size along i, j dimensions
+ LOGICAL :: lltile ! Is the array on the tile (T) or MPI (F) domain?
+ !!----------------------------------------------------------------------
+ ! Is this array on the tile or MPI domain?
+ IF( PRESENT(ldtile) ) THEN
+ lltile = ldtile
ELSE
- is_tile_2d_sp = 0
+ lltile = is_tile(kasi, kasj)
ENDIF
- END FUNCTION is_tile_2d_sp
+ ! Halo size
+ ihls = arr_hls(kasi, kasj, ldtile=lltile, ldsize=.TRUE.)
- INTEGER FUNCTION is_tile_2d_dp( pt )
- REAL(dp), DIMENSION(:,:), INTENT(in) :: pt
+ ! Lower bounds
+ IF( lltile ) THEN ! Tile domain
+ kbnd(1) = ntsi - ihls(1)
+ kbnd(2) = ntsj - ihls(2)
+ ELSE ! MPI domain
+ kbnd(1) = Nis0 - ihls(1)
+ kbnd(2) = Njs0 - ihls(2)
+ ENDIF
+ END FUNCTION arr_lbnd
+
+
+ FUNCTION arr_hls( kasi, kasj, ldtile, ldsize ) RESULT(khls)
+ !!----------------------------------------------------------------------
+ !! *** FUNCTION arr_hls ***
+ !!
+ !! ** Purpose : Determine the halo size or number of halo points in an array from its i-j shape
+ !!
+ !! ** Method : Compare the array shape to that of the MPI domain internal area
+ !!----------------------------------------------------------------------
+ INTEGER, INTENT(in) :: kasi, kasj ! Size of i, j dimensions
+ LOGICAL, INTENT(in), OPTIONAL :: ldtile ! Is the array on the tile (T) or MPI (F) domain?
+ LOGICAL, INTENT(in), OPTIONAL :: ldsize ! Return the halo size (T) or total number of halo points (F)
+ !
+ INTEGER, DIMENSION(2) :: khls ! No. halo points or halo size along i, j dimensions
+ LOGICAL :: lltile, llsize
+ !!----------------------------------------------------------------------
+ llsize = .FALSE.
+ IF( PRESENT(ldsize) ) llsize = ldsize
- IF( l_istiled .AND. (SIZE(pt, 1) < jpi .OR. SIZE(pt, 2) < jpj) ) THEN
- is_tile_2d_dp = 1
+ IF( PRESENT(ldtile) ) THEN ! Is this array on the tile or MPI domain?
+ lltile = ldtile
ELSE
- is_tile_2d_dp = 0
+ lltile = is_tile(kasi, kasj)
+ ENDIF
+
+ ! Number of halo points
+ IF( lltile ) THEN ! Tile domain (smaller than MPI domain internal area)
+ khls(1) = kasi - (ntei - ntsi + 1)
+ khls(2) = kasj - (ntej - ntsj + 1)
+ ELSE ! MPI domain
+ khls(1) = kasi - Ni_0
+ khls(2) = kasj - Nj_0
ENDIF
- END FUNCTION is_tile_2d_dp
+
+ ! Halo size
+ IF( llsize ) THEN
+ IF( MOD(khls(1), 2) == 1 .OR. MOD(khls(2), 2) == 1 ) THEN
+ WRITE(ctmp1,*) 'Cannot determine halo size of an array with an odd number of i-j halo points:'
+ WRITE(ctmp2,*) khls(1), 'x', khls(2)
+ CALL ctl_stop('STOP', ctmp1, ctmp2) ! Stop before out of bounds errors
+ ELSE
+ khls(1) = khls(1) / 2
+ khls(2) = khls(2) / 2
+ ENDIF
+ ENDIF
+ END FUNCTION arr_hls
+
+
+ LOGICAL FUNCTION is_tile( kasi, kasj )
+ !!----------------------------------------------------------------------
+ !! *** FUNCTION is_tile ***
+ !!
+ !! ** Purpose : Determine whether an array's shape corresponds to a tile or MPI domain
+ !!
+ !! ** Method : Compare the array shape to that of the MPI domain internal area.
+ !! The maximum tile size is limited (in domain.F90) to ensure this is not ambiguous.
+ !!----------------------------------------------------------------------
+ INTEGER, INTENT(in) :: kasi, kasj ! Size of i, j dimensions
+ !!----------------------------------------------------------------------
+ is_tile = l_istiled .AND. (kasi < Ni_0 .OR. kasj < Nj_0)
+ END FUNCTION is_tile
+
+
+ FUNCTION arr_lbnd_2d_i( pt ) RESULT(kbnd)
+ INTEGER, DIMENSION(:,:), INTENT(in) :: pt
+ INTEGER, DIMENSION(2) :: kbnd
+
+ kbnd = arr_lbnd(SIZE(pt, 1), SIZE(pt, 2))
+ END FUNCTION arr_lbnd_2d_i
- INTEGER FUNCTION is_tile_3d_sp( pt )
+ FUNCTION arr_lbnd_2d_sp( pt ) RESULT(kbnd)
+ REAL(sp), DIMENSION(:,:), INTENT(in) :: pt
+ INTEGER, DIMENSION(2) :: kbnd
+
+ kbnd = arr_lbnd(SIZE(pt, 1), SIZE(pt, 2))
+ END FUNCTION arr_lbnd_2d_sp
+
+
+ FUNCTION arr_lbnd_2d_dp( pt ) RESULT(kbnd)
+ REAL(dp), DIMENSION(:,:), INTENT(in) :: pt
+ INTEGER, DIMENSION(2) :: kbnd
+
+ kbnd = arr_lbnd(SIZE(pt, 1), SIZE(pt, 2))
+ END FUNCTION arr_lbnd_2d_dp
+
+
+ FUNCTION arr_lbnd_3d_i( pt ) RESULT(kbnd)
+ INTEGER, DIMENSION(:,:,:), INTENT(in) :: pt
+ INTEGER, DIMENSION(2) :: kbnd
+
+ kbnd = arr_lbnd(SIZE(pt, 1), SIZE(pt, 2))
+ END FUNCTION arr_lbnd_3d_i
+
+
+ FUNCTION arr_lbnd_3d_sp( pt ) RESULT(kbnd)
REAL(sp), DIMENSION(:,:,:), INTENT(in) :: pt
+ INTEGER, DIMENSION(2) :: kbnd
- IF( l_istiled .AND. (SIZE(pt, 1) < jpi .OR. SIZE(pt, 2) < jpj) ) THEN
- is_tile_3d_sp = 1
- ELSE
- is_tile_3d_sp = 0
- ENDIF
- END FUNCTION is_tile_3d_sp
+ kbnd = arr_lbnd(SIZE(pt, 1), SIZE(pt, 2))
+ END FUNCTION arr_lbnd_3d_sp
- INTEGER FUNCTION is_tile_3d_dp( pt )
+ FUNCTION arr_lbnd_3d_dp( pt ) RESULT(kbnd)
REAL(dp), DIMENSION(:,:,:), INTENT(in) :: pt
+ INTEGER, DIMENSION(2) :: kbnd
+
+ kbnd = arr_lbnd(SIZE(pt, 1), SIZE(pt, 2))
+ END FUNCTION arr_lbnd_3d_dp
- IF( l_istiled .AND. (SIZE(pt, 1) < jpi .OR. SIZE(pt, 2) < jpj) ) THEN
- is_tile_3d_dp = 1
- ELSE
- is_tile_3d_dp = 0
- ENDIF
- END FUNCTION is_tile_3d_dp
+ FUNCTION arr_lbnd_4d_i( pt ) RESULT(kbnd)
+ INTEGER, DIMENSION(:,:,:,:), INTENT(in) :: pt
+ INTEGER, DIMENSION(2) :: kbnd
- INTEGER FUNCTION is_tile_4d_sp( pt )
+ kbnd = arr_lbnd(SIZE(pt, 1), SIZE(pt, 2))
+ END FUNCTION arr_lbnd_4d_i
+
+
+ FUNCTION arr_lbnd_4d_sp( pt ) RESULT(kbnd)
REAL(sp), DIMENSION(:,:,:,:), INTENT(in) :: pt
+ INTEGER, DIMENSION(2) :: kbnd
- IF( l_istiled .AND. (SIZE(pt, 1) < jpi .OR. SIZE(pt, 2) < jpj) ) THEN
- is_tile_4d_sp = 1
- ELSE
- is_tile_4d_sp = 0
- ENDIF
- END FUNCTION is_tile_4d_sp
+ kbnd = arr_lbnd(SIZE(pt, 1), SIZE(pt, 2))
+ END FUNCTION arr_lbnd_4d_sp
- INTEGER FUNCTION is_tile_4d_dp( pt )
+ FUNCTION arr_lbnd_4d_dp( pt ) RESULT(kbnd)
REAL(dp), DIMENSION(:,:,:,:), INTENT(in) :: pt
+ INTEGER, DIMENSION(2) :: kbnd
- IF( l_istiled .AND. (SIZE(pt, 1) < jpi .OR. SIZE(pt, 2) < jpj) ) THEN
- is_tile_4d_dp = 1
- ELSE
- is_tile_4d_dp = 0
- ENDIF
- END FUNCTION is_tile_4d_dp
+ kbnd = arr_lbnd(SIZE(pt, 1), SIZE(pt, 2))
+ END FUNCTION arr_lbnd_4d_dp
+
+
+ FUNCTION arr_lbnd_5d_i( pt ) RESULT(kbnd)
+ INTEGER, DIMENSION(:,:,:,:,:), INTENT(in) :: pt
+ INTEGER, DIMENSION(2) :: kbnd
+
+ kbnd = arr_lbnd(SIZE(pt, 1), SIZE(pt, 2))
+ END FUNCTION arr_lbnd_5d_i
+
+
+ FUNCTION arr_lbnd_5d_sp( pt ) RESULT(kbnd)
+ REAL(sp), DIMENSION(:,:,:,:,:), INTENT(in) :: pt
+ INTEGER, DIMENSION(2) :: kbnd
+
+ kbnd = arr_lbnd(SIZE(pt, 1), SIZE(pt, 2))
+ END FUNCTION arr_lbnd_5d_sp
+
+
+ FUNCTION arr_lbnd_5d_dp( pt ) RESULT(kbnd)
+ REAL(dp), DIMENSION(:,:,:,:,:), INTENT(in) :: pt
+ INTEGER, DIMENSION(2) :: kbnd
+
+ kbnd = arr_lbnd(SIZE(pt, 1), SIZE(pt, 2))
+ END FUNCTION arr_lbnd_5d_dp
!!======================================================================
END MODULE domutl
diff --git a/src/OCE/DOM/domvvl.F90 b/src/OCE/DOM/domvvl.F90
deleted file mode 100644
index 94bf1ce8bcdd4c34669d864d3dae504db32807a8..0000000000000000000000000000000000000000
--- a/src/OCE/DOM/domvvl.F90
+++ /dev/null
@@ -1,1105 +0,0 @@
-MODULE domvvl
- !!======================================================================
- !! *** MODULE domvvl ***
- !! Ocean :
- !!======================================================================
- !! History : 2.0 ! 2006-06 (B. Levier, L. Marie) original code
- !! 3.1 ! 2009-02 (G. Madec, M. Leclair, R. Benshila) pure z* coordinate
- !! 3.3 ! 2011-10 (M. Leclair) totally rewrote domvvl: vvl option includes z_star and z_tilde coordinates
- !! 3.6 ! 2014-11 (P. Mathiot) add ice shelf capability
- !! 4.1 ! 2019-08 (A. Coward, D. Storkey) rename dom_vvl_sf_swp -> dom_vvl_sf_update for new timestepping
- !! - ! 2020-02 (G. Madec, S. Techene) introduce ssh to h0 ratio
- !!----------------------------------------------------------------------
-
- USE oce ! ocean dynamics and tracers
- USE phycst ! physical constant
- USE dom_oce ! ocean space and time domain
- USE sbc_oce ! ocean surface boundary condition
- USE wet_dry ! wetting and drying
- USE usrdef_istate ! user defined initial state (wad only)
- USE restart ! ocean restart
- !
- USE in_out_manager ! I/O manager
- USE iom ! I/O manager library
- USE lib_mpp ! distributed memory computing library
- USE lbclnk ! ocean lateral boundary conditions (or mpp link)
- USE timing ! Timing
-
- IMPLICIT NONE
- PRIVATE
-
- ! !!* Namelist nam_vvl
- LOGICAL , PUBLIC :: ln_vvl_zstar = .FALSE. ! zstar vertical coordinate
- LOGICAL , PUBLIC :: ln_vvl_ztilde = .FALSE. ! ztilde vertical coordinate
- LOGICAL , PUBLIC :: ln_vvl_layer = .FALSE. ! level vertical coordinate
- LOGICAL , PUBLIC :: ln_vvl_ztilde_as_zstar = .FALSE. ! ztilde vertical coordinate
- LOGICAL , PUBLIC :: ln_vvl_zstar_at_eqtor = .FALSE. ! ztilde vertical coordinate
- LOGICAL , PUBLIC :: ln_vvl_kepe = .FALSE. ! kinetic/potential energy transfer
- !
- INTEGER :: nn_vvl_interp = 0 ! scale factors anomaly interpolation method at U-V-F points
- ! =0 linear with no bottom correction over steps (old)
- ! =1 linear with bottom correction over steps
- ! =2 "qco like", i.e. proportional to thicknesses at rest
- !
- ! ! conservation: not used yet
- REAL(wp) :: rn_ahe3 ! thickness diffusion coefficient
- REAL(wp) :: rn_rst_e3t ! ztilde to zstar restoration timescale [days]
- REAL(wp) :: rn_lf_cutoff ! cutoff frequency for low-pass filter [days]
- REAL(wp) :: rn_zdef_max ! maximum fractional e3t deformation
- LOGICAL , PUBLIC :: ln_vvl_dbg = .FALSE. ! debug control prints
-
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: un_td, vn_td ! thickness diffusion transport
- REAL(wp) , ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: hdiv_lf ! low frequency part of hz divergence
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: tilde_e3t_b, tilde_e3t_n ! baroclinic scale factors
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: tilde_e3t_a, dtilde_e3t_a ! baroclinic scale factors
- REAL(wp) , ALLOCATABLE, SAVE, DIMENSION(:,:) :: frq_rst_e3t ! retoring period for scale factors
- REAL(wp) , ALLOCATABLE, SAVE, DIMENSION(:,:) :: frq_rst_hdv ! retoring period for low freq. divergence
-
-#if defined key_qco || defined key_linssh
- !!----------------------------------------------------------------------
- !! 'key_qco' Quasi-Eulerian vertical coordinate
- !! OR EMPTY MODULE
- !! 'key_linssh' Fix in time vertical coordinate
- !!----------------------------------------------------------------------
-#else
- !!----------------------------------------------------------------------
- !! Default key Old management of time varying vertical coordinate
- !!----------------------------------------------------------------------
-
- !!----------------------------------------------------------------------
- !! dom_vvl_init : define initial vertical scale factors, depths and column thickness
- !! dom_vvl_sf_nxt : Compute next vertical scale factors
- !! dom_vvl_sf_update : Swap vertical scale factors and update the vertical grid
- !! dom_vvl_interpol : Interpolate vertical scale factors from one grid point to another
- !! dom_vvl_rst : read/write restart file
- !! dom_vvl_ctl : Check the vvl options
- !!----------------------------------------------------------------------
-
- PUBLIC dom_vvl_init ! called by domain.F90
- PUBLIC dom_vvl_zgr ! called by isfcpl.F90
- PUBLIC dom_vvl_sf_nxt ! called by step.F90
- PUBLIC dom_vvl_sf_update ! called by step.F90
- PUBLIC dom_vvl_interpol ! called by dynnxt.F90
-
- !! * Substitutions
-# include "do_loop_substitute.h90"
- !!----------------------------------------------------------------------
- !! NEMO/OCE 4.0 , NEMO Consortium (2018)
- !! $Id: domvvl.F90 15471 2021-11-04 16:28:56Z jchanut $
- !! Software governed by the CeCILL license (see ./LICENSE)
- !!----------------------------------------------------------------------
-CONTAINS
-
- INTEGER FUNCTION dom_vvl_alloc()
- !!----------------------------------------------------------------------
- !! *** FUNCTION dom_vvl_alloc ***
- !!----------------------------------------------------------------------
- IF( ln_vvl_zstar ) dom_vvl_alloc = 0
- IF( ln_vvl_ztilde .OR. ln_vvl_layer ) THEN
- ALLOCATE( tilde_e3t_b(jpi,jpj,jpk) , tilde_e3t_n(jpi,jpj,jpk) , tilde_e3t_a(jpi,jpj,jpk) , &
- & dtilde_e3t_a(jpi,jpj,jpk) , un_td (jpi,jpj,jpk) , vn_td (jpi,jpj,jpk) , &
- & STAT = dom_vvl_alloc )
- CALL mpp_sum ( 'domvvl', dom_vvl_alloc )
- IF( dom_vvl_alloc /= 0 ) CALL ctl_stop( 'STOP', 'dom_vvl_alloc: failed to allocate arrays' )
- un_td = 0._wp
- vn_td = 0._wp
- ENDIF
- IF( ln_vvl_ztilde ) THEN
- ALLOCATE( frq_rst_e3t(jpi,jpj) , frq_rst_hdv(jpi,jpj) , hdiv_lf(jpi,jpj,jpk) , STAT= dom_vvl_alloc )
- CALL mpp_sum ( 'domvvl', dom_vvl_alloc )
- IF( dom_vvl_alloc /= 0 ) CALL ctl_stop( 'STOP', 'dom_vvl_alloc: failed to allocate arrays' )
- ENDIF
- !
- END FUNCTION dom_vvl_alloc
-
-
- SUBROUTINE dom_vvl_init( Kbb, Kmm, Kaa )
- !!----------------------------------------------------------------------
- !! *** ROUTINE dom_vvl_init ***
- !!
- !! ** Purpose : Initialization of all scale factors, depths
- !! and water column heights
- !!
- !! ** Method : - use restart file and/or initialize
- !! - interpolate scale factors
- !!
- !! ** Action : - e3t_(n/b) and tilde_e3t_(n/b)
- !! - Regrid: e3[u/v](:,:,:,Kmm)
- !! e3[u/v](:,:,:,Kmm)
- !! e3w(:,:,:,Kmm)
- !! e3[u/v]w_b
- !! e3[u/v]w_n
- !! gdept(:,:,:,Kmm), gdepw(:,:,:,Kmm) and gde3w
- !! - h(t/u/v)_0
- !! - frq_rst_e3t and frq_rst_hdv
- !!
- !! Reference : Leclair, M., and G. Madec, 2011, Ocean Modelling.
- !!----------------------------------------------------------------------
- INTEGER, INTENT(in) :: Kbb, Kmm, Kaa
- !
- IF(lwp) WRITE(numout,*)
- IF(lwp) WRITE(numout,*) 'dom_vvl_init : Variable volume activated'
- IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~'
- !
- CALL dom_vvl_ctl ! choose vertical coordinate (z_star, z_tilde or layer)
- !
- ! ! Allocate module arrays
- IF( dom_vvl_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'dom_vvl_init : unable to allocate arrays' )
- !
- ! ! Read or initialize e3t_(b/n), tilde_e3t_(b/n) and hdiv_lf
- CALL dom_vvl_rst( nit000, Kbb, Kmm, 'READ' )
- e3t(:,:,jpk,Kaa) = e3t_0(:,:,jpk) ! last level always inside the sea floor set one for all
- !
- CALL dom_vvl_zgr(Kbb, Kmm, Kaa) ! interpolation scale factor, depth and water column
- !
- END SUBROUTINE dom_vvl_init
-
-
- SUBROUTINE dom_vvl_zgr(Kbb, Kmm, Kaa)
- !!----------------------------------------------------------------------
- !! *** ROUTINE dom_vvl_init ***
- !!
- !! ** Purpose : Interpolation of all scale factors,
- !! depths and water column heights
- !!
- !! ** Method : - interpolate scale factors
- !!
- !! ** Action : - e3t_(n/b) and tilde_e3t_(n/b)
- !! - Regrid: e3(u/v)_n
- !! e3(u/v)_b
- !! e3w_n
- !! e3(u/v)w_b
- !! e3(u/v)w_n
- !! gdept_n, gdepw_n and gde3w_n
- !! - h(t/u/v)_0
- !! - frq_rst_e3t and frq_rst_hdv
- !!
- !! Reference : Leclair, M., and G. Madec, 2011, Ocean Modelling.
- !!----------------------------------------------------------------------
- INTEGER, INTENT(in) :: Kbb, Kmm, Kaa
- !!----------------------------------------------------------------------
- INTEGER :: ji, jj, jk
- INTEGER :: ii0, ii1, ij0, ij1
- REAL(wp):: zcoef
- !!----------------------------------------------------------------------
- !
- ! !== Set of all other vertical scale factors ==! (now and before)
- ! ! Horizontal interpolation of e3t
- CALL dom_vvl_interpol( e3t(:,:,:,Kbb), e3u(:,:,:,Kbb), 'U' ) ! from T to U
- CALL dom_vvl_interpol( e3t(:,:,:,Kmm), e3u(:,:,:,Kmm), 'U' )
- CALL dom_vvl_interpol( e3t(:,:,:,Kbb), e3v(:,:,:,Kbb), 'V' ) ! from T to V
- CALL dom_vvl_interpol( e3t(:,:,:,Kmm), e3v(:,:,:,Kmm), 'V' )
- CALL dom_vvl_interpol( e3u(:,:,:,Kmm), e3f(:,:,:), 'F' ) ! from U to F
- ! ! Vertical interpolation of e3t,u,v
- CALL dom_vvl_interpol( e3t(:,:,:,Kmm), e3w (:,:,:,Kmm), 'W' ) ! from T to W
- CALL dom_vvl_interpol( e3t(:,:,:,Kbb), e3w (:,:,:,Kbb), 'W' )
- CALL dom_vvl_interpol( e3u(:,:,:,Kmm), e3uw(:,:,:,Kmm), 'UW' ) ! from U to UW
- CALL dom_vvl_interpol( e3u(:,:,:,Kbb), e3uw(:,:,:,Kbb), 'UW' )
- CALL dom_vvl_interpol( e3v(:,:,:,Kmm), e3vw(:,:,:,Kmm), 'VW' ) ! from V to UW
- CALL dom_vvl_interpol( e3v(:,:,:,Kbb), e3vw(:,:,:,Kbb), 'VW' )
-
- ! We need to define e3[tuv]_a for AGRIF initialisation (should not be a problem for the restartability...)
- e3t(:,:,:,Kaa) = e3t(:,:,:,Kmm)
- e3u(:,:,:,Kaa) = e3u(:,:,:,Kmm)
- e3v(:,:,:,Kaa) = e3v(:,:,:,Kmm)
- !
- ! !== depth of t and w-point ==! (set the isf depth as it is in the initial timestep)
- gdept(:,:,1,Kmm) = 0.5_wp * e3w(:,:,1,Kmm) ! reference to the ocean surface (used for MLD and light penetration)
- gdepw(:,:,1,Kmm) = 0.0_wp
- gde3w(:,:,1) = gdept(:,:,1,Kmm) - ssh(:,:,Kmm) ! reference to a common level z=0 for hpg
- gdept(:,:,1,Kbb) = 0.5_wp * e3w(:,:,1,Kbb)
- gdepw(:,:,1,Kbb) = 0.0_wp
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 2, jpk ) ! vertical sum
- ! zcoef = tmask - wmask ! 0 everywhere tmask = wmask, ie everywhere expect at jk = mikt
- ! ! 1 everywhere from mbkt to mikt + 1 or 1 (if no isf)
- ! ! 0.5 where jk = mikt
-!!gm ??????? BUG ? gdept(:,:,:,Kmm) as well as gde3w does not include the thickness of ISF ??
- zcoef = ( tmask(ji,jj,jk) - wmask(ji,jj,jk) )
- gdepw(ji,jj,jk,Kmm) = gdepw(ji,jj,jk-1,Kmm) + e3t(ji,jj,jk-1,Kmm)
- gdept(ji,jj,jk,Kmm) = zcoef * ( gdepw(ji,jj,jk ,Kmm) + 0.5 * e3w(ji,jj,jk,Kmm)) &
- & + (1-zcoef) * ( gdept(ji,jj,jk-1,Kmm) + e3w(ji,jj,jk,Kmm))
- gde3w(ji,jj,jk) = gdept(ji,jj,jk,Kmm) - ssh(ji,jj,Kmm)
- gdepw(ji,jj,jk,Kbb) = gdepw(ji,jj,jk-1,Kbb) + e3t(ji,jj,jk-1,Kbb)
- gdept(ji,jj,jk,Kbb) = zcoef * ( gdepw(ji,jj,jk ,Kbb) + 0.5 * e3w(ji,jj,jk,Kbb)) &
- & + (1-zcoef) * ( gdept(ji,jj,jk-1,Kbb) + e3w(ji,jj,jk,Kbb))
- END_3D
- !
- ! !== thickness of the water column !! (ocean portion only)
- ht(:,:) = e3t(:,:,1,Kmm) * tmask(:,:,1) !!gm BUG : this should be 1/2 * e3w(k=1) ....
- hu(:,:,Kbb) = e3u(:,:,1,Kbb) * umask(:,:,1)
- hu(:,:,Kmm) = e3u(:,:,1,Kmm) * umask(:,:,1)
- hv(:,:,Kbb) = e3v(:,:,1,Kbb) * vmask(:,:,1)
- hv(:,:,Kmm) = e3v(:,:,1,Kmm) * vmask(:,:,1)
- DO jk = 2, jpkm1
- ht(:,:) = ht(:,:) + e3t(:,:,jk,Kmm) * tmask(:,:,jk)
- hu(:,:,Kbb) = hu(:,:,Kbb) + e3u(:,:,jk,Kbb) * umask(:,:,jk)
- hu(:,:,Kmm) = hu(:,:,Kmm) + e3u(:,:,jk,Kmm) * umask(:,:,jk)
- hv(:,:,Kbb) = hv(:,:,Kbb) + e3v(:,:,jk,Kbb) * vmask(:,:,jk)
- hv(:,:,Kmm) = hv(:,:,Kmm) + e3v(:,:,jk,Kmm) * vmask(:,:,jk)
- END DO
- !
- ! !== inverse of water column thickness ==! (u- and v- points)
- r1_hu(:,:,Kbb) = ssumask(:,:) / ( hu(:,:,Kbb) + 1._wp - ssumask(:,:) ) ! _i mask due to ISF
- r1_hu(:,:,Kmm) = ssumask(:,:) / ( hu(:,:,Kmm) + 1._wp - ssumask(:,:) )
- r1_hv(:,:,Kbb) = ssvmask(:,:) / ( hv(:,:,Kbb) + 1._wp - ssvmask(:,:) )
- r1_hv(:,:,Kmm) = ssvmask(:,:) / ( hv(:,:,Kmm) + 1._wp - ssvmask(:,:) )
-
- ! !== z_tilde coordinate case ==! (Restoring frequencies)
- IF( ln_vvl_ztilde ) THEN
-!!gm : idea: add here a READ in a file of custumized restoring frequency
- ! ! Values in days provided via the namelist
- ! ! use rsmall to avoid possible division by zero errors with faulty settings
- frq_rst_e3t(:,:) = 2._wp * rpi / ( MAX( rn_rst_e3t , rsmall ) * 86400.0_wp )
- frq_rst_hdv(:,:) = 2._wp * rpi / ( MAX( rn_lf_cutoff, rsmall ) * 86400.0_wp )
- !
- IF( ln_vvl_ztilde_as_zstar ) THEN ! z-star emulation using z-tile
- frq_rst_e3t(:,:) = 0._wp !Ignore namelist settings
- frq_rst_hdv(:,:) = 1._wp / rn_Dt
- ENDIF
- IF ( ln_vvl_zstar_at_eqtor ) THEN ! use z-star in vicinity of the Equator
- DO_2D( 1, 1, 1, 1 )
-!!gm case |gphi| >= 6 degrees is useless initialized just above by default
- IF( ABS(gphit(ji,jj)) >= 6.) THEN
- ! values outside the equatorial band and transition zone (ztilde)
- frq_rst_e3t(ji,jj) = 2.0_wp * rpi / ( MAX( rn_rst_e3t , rsmall ) * 86400.e0_wp )
- frq_rst_hdv(ji,jj) = 2.0_wp * rpi / ( MAX( rn_lf_cutoff, rsmall ) * 86400.e0_wp )
- ELSEIF( ABS(gphit(ji,jj)) <= 2.5) THEN ! Equator strip ==> z-star
- ! values inside the equatorial band (ztilde as zstar)
- frq_rst_e3t(ji,jj) = 0.0_wp
- frq_rst_hdv(ji,jj) = 1.0_wp / rn_Dt
- ELSE ! transition band (2.5 to 6 degrees N/S)
- ! ! (linearly transition from z-tilde to z-star)
- frq_rst_e3t(ji,jj) = 0.0_wp + (frq_rst_e3t(ji,jj)-0.0_wp)*0.5_wp &
- & * ( 1.0_wp - COS( rad*(ABS(gphit(ji,jj))-2.5_wp) &
- & * 180._wp / 3.5_wp ) )
- frq_rst_hdv(ji,jj) = (1.0_wp / rn_Dt) &
- & + ( frq_rst_hdv(ji,jj)-(1.e0_wp / rn_Dt) )*0.5_wp &
- & * ( 1._wp - COS( rad*(ABS(gphit(ji,jj))-2.5_wp) &
- & * 180._wp / 3.5_wp ) )
- ENDIF
- END_2D
- IF( cn_cfg == "orca" .OR. cn_cfg == "ORCA" ) THEN
- IF( nn_cfg == 3 ) THEN ! ORCA2: Suppress ztilde in the Foxe Basin for ORCA2
- ii0 = 103 + nn_hls - 1 ; ii1 = 111 + nn_hls - 1
- ij0 = 128 + nn_hls ; ij1 = 135 + nn_hls
- frq_rst_e3t( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 0.0_wp
- frq_rst_hdv( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 1.e0_wp / rn_Dt
- ENDIF
- ENDIF
- ENDIF
- ENDIF
- !
- END SUBROUTINE dom_vvl_zgr
-
-
- SUBROUTINE dom_vvl_sf_nxt( kt, Kbb, Kmm, Kaa, kcall )
- !!----------------------------------------------------------------------
- !! *** ROUTINE dom_vvl_sf_nxt ***
- !!
- !! ** Purpose : - compute the after scale factors used in tra_zdf, dynnxt,
- !! tranxt and dynspg routines
- !!
- !! ** Method : - z_star case: Repartition of ssh INCREMENT proportionnaly to the level thickness.
- !! - z_tilde_case: after scale factor increment =
- !! high frequency part of horizontal divergence
- !! + retsoring towards the background grid
- !! + thickness difusion
- !! Then repartition of ssh INCREMENT proportionnaly
- !! to the "baroclinic" level thickness.
- !!
- !! ** Action : - hdiv_lf : restoring towards full baroclinic divergence in z_tilde case
- !! - tilde_e3t_a: after increment of vertical scale factor
- !! in z_tilde case
- !! - e3(t/u/v)_a
- !!
- !! Reference : Leclair, M., and Madec, G. 2011, Ocean Modelling.
- !!----------------------------------------------------------------------
- INTEGER, INTENT( in ) :: kt ! time step
- INTEGER, INTENT( in ) :: Kbb, Kmm, Kaa ! time step
- INTEGER, INTENT( in ), OPTIONAL :: kcall ! optional argument indicating call sequence
- !
- INTEGER :: ji, jj, jk ! dummy loop indices
- INTEGER , DIMENSION(3) :: ijk_max, ijk_min ! temporary integers
- REAL(wp) :: z_tmin, z_tmax ! local scalars
- LOGICAL :: ll_do_bclinic ! local logical
- REAL(wp), DIMENSION(jpi,jpj) :: zht, z_scale, zwu, zwv, zhdiv
- REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: ze3t
- LOGICAL , DIMENSION(:,:,:), ALLOCATABLE :: llmsk
- !!----------------------------------------------------------------------
- !
- IF( ln_linssh ) RETURN ! No calculation in linear free surface
- !
- IF( ln_timing ) CALL timing_start('dom_vvl_sf_nxt')
- !
- IF( kt == nit000 ) THEN
- IF(lwp) WRITE(numout,*)
- IF(lwp) WRITE(numout,*) 'dom_vvl_sf_nxt : compute after scale factors'
- IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~~'
- ENDIF
-
- ll_do_bclinic = .TRUE.
- IF( PRESENT(kcall) ) THEN
- IF( kcall == 2 .AND. ln_vvl_ztilde ) ll_do_bclinic = .FALSE.
- ENDIF
-
- ! ******************************* !
- ! After acale factors at t-points !
- ! ******************************* !
- ! ! --------------------------------------------- !
- ! ! z_star coordinate and barotropic z-tilde part !
- ! ! --------------------------------------------- !
- !
- z_scale(:,:) = ( ssh(:,:,Kaa) - ssh(:,:,Kbb) ) * ssmask(:,:) / ( ht_0(:,:) + ssh(:,:,Kmm) + 1. - ssmask(:,:) )
- DO jk = 1, jpkm1
- ! formally this is the same as e3t(:,:,:,Kaa) = e3t_0*(1+ssha/ht_0)
- e3t(:,:,jk,Kaa) = e3t(:,:,jk,Kbb) + e3t(:,:,jk,Kmm) * z_scale(:,:) * tmask(:,:,jk)
- END DO
- !
- IF( (ln_vvl_ztilde .OR. ln_vvl_layer) .AND. ll_do_bclinic ) THEN ! z_tilde or layer coordinate !
- ! ! ------baroclinic part------ !
- ! I - initialization
- ! ==================
-
- ! 1 - barotropic divergence
- ! -------------------------
- zhdiv(:,:) = 0._wp
- zht(:,:) = 0._wp
- DO jk = 1, jpkm1
- zhdiv(:,:) = zhdiv(:,:) + e3t(:,:,jk,Kmm) * hdiv(:,:,jk)
- zht (:,:) = zht (:,:) + e3t(:,:,jk,Kmm) * tmask(:,:,jk)
- END DO
- zhdiv(:,:) = zhdiv(:,:) / ( zht(:,:) + 1. - tmask_i(:,:) )
-
- ! 2 - Low frequency baroclinic horizontal divergence (z-tilde case only)
- ! --------------------------------------------------
- IF( ln_vvl_ztilde ) THEN
- IF( kt > nit000 ) THEN
- DO jk = 1, jpkm1
- hdiv_lf(:,:,jk) = hdiv_lf(:,:,jk) - rn_Dt * frq_rst_hdv(:,:) &
- & * ( hdiv_lf(:,:,jk) - e3t(:,:,jk,Kmm) * ( hdiv(:,:,jk) - zhdiv(:,:) ) )
- END DO
- ENDIF
- ENDIF
-
- ! II - after z_tilde increments of vertical scale factors
- ! =======================================================
- tilde_e3t_a(:,:,:) = 0._wp ! tilde_e3t_a used to store tendency terms
-
- ! 1 - High frequency divergence term
- ! ----------------------------------
- IF( ln_vvl_ztilde ) THEN ! z_tilde case
- DO jk = 1, jpkm1
- tilde_e3t_a(:,:,jk) = tilde_e3t_a(:,:,jk) - ( e3t(:,:,jk,Kmm) * ( hdiv(:,:,jk) - zhdiv(:,:) ) - hdiv_lf(:,:,jk) )
- END DO
- ELSE ! layer case
- DO jk = 1, jpkm1
- tilde_e3t_a(:,:,jk) = tilde_e3t_a(:,:,jk) - e3t(:,:,jk,Kmm) * ( hdiv(:,:,jk) - zhdiv(:,:) ) * tmask(:,:,jk)
- END DO
- ENDIF
-
- ! 2 - Restoring term (z-tilde case only)
- ! ------------------
- IF( ln_vvl_ztilde ) THEN
- DO jk = 1, jpk
- tilde_e3t_a(:,:,jk) = tilde_e3t_a(:,:,jk) - frq_rst_e3t(:,:) * tilde_e3t_b(:,:,jk)
- END DO
- ENDIF
-
- ! 3 - Thickness diffusion term
- ! ----------------------------
- zwu(:,:) = 0._wp
- zwv(:,:) = 0._wp
- DO_3D( nn_hls, nn_hls-1, nn_hls, nn_hls-1, 1, jpkm1 ) ! a - first derivative: diffusive fluxes
- un_td(ji,jj,jk) = rn_ahe3 * umask(ji,jj,jk) * e2_e1u(ji,jj) &
- & * ( tilde_e3t_b(ji,jj,jk) - tilde_e3t_b(ji+1,jj ,jk) )
- vn_td(ji,jj,jk) = rn_ahe3 * vmask(ji,jj,jk) * e1_e2v(ji,jj) &
- & * ( tilde_e3t_b(ji,jj,jk) - tilde_e3t_b(ji ,jj+1,jk) )
- zwu(ji,jj) = zwu(ji,jj) + un_td(ji,jj,jk)
- zwv(ji,jj) = zwv(ji,jj) + vn_td(ji,jj,jk)
- END_3D
- DO_2D( nn_hls, nn_hls-1, nn_hls, nn_hls-1 ) ! b - correction for last oceanic u-v points
- un_td(ji,jj,mbku(ji,jj)) = un_td(ji,jj,mbku(ji,jj)) - zwu(ji,jj)
- vn_td(ji,jj,mbkv(ji,jj)) = vn_td(ji,jj,mbkv(ji,jj)) - zwv(ji,jj)
- END_2D
- DO_3D( 0, 0, 0, 0, 1, jpkm1 ) ! c - second derivative: divergence of diffusive fluxes
- tilde_e3t_a(ji,jj,jk) = tilde_e3t_a(ji,jj,jk) + ( un_td(ji-1,jj ,jk) - un_td(ji,jj,jk) &
- & + vn_td(ji ,jj-1,jk) - vn_td(ji,jj,jk) &
- & ) * r1_e1e2t(ji,jj)
- END_3D
- ! ! d - thickness diffusion transport: boundary conditions
- ! (stored for tracer advction and continuity equation)
- IF( nn_hls == 1 ) CALL lbc_lnk( 'domvvl', un_td , 'U' , -1._wp, vn_td , 'V' , -1._wp)
- ! 4 - Time stepping of baroclinic scale factors
- ! ---------------------------------------------
- CALL lbc_lnk( 'domvvl', tilde_e3t_a(:,:,:), 'T', 1._wp )
- tilde_e3t_a(:,:,:) = tilde_e3t_b(:,:,:) + rDt * tmask(:,:,:) * tilde_e3t_a(:,:,:)
-
- ! Maximum deformation control
- ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~
- ALLOCATE( ze3t(jpi,jpj,jpk), llmsk(jpi,jpj,jpk) )
- DO_3D( 0, 0, 0, 0, 1, jpkm1 )
- ze3t(ji,jj,jk) = tilde_e3t_a(ji,jj,jk) / e3t_0(ji,jj,jk) * tmask(ji,jj,jk) * tmask_i(ji,jj)
- END_3D
- !
- llmsk( 1:nn_hls,:,:) = .FALSE. ! exclude halos from the checked region
- llmsk(Nie0+1: jpi,:,:) = .FALSE.
- llmsk(:, 1:nn_hls,:) = .FALSE.
- llmsk(:,Nje0+1: jpj,:) = .FALSE.
- !
- llmsk(Nis0:Nie0,Njs0:Nje0,:) = tmask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp ! define only the inner domain
- z_tmax = MAXVAL( ze3t(:,:,:), mask = llmsk ) ; CALL mpp_max( 'domvvl', z_tmax ) ! max over the global domain
- z_tmin = MINVAL( ze3t(:,:,:), mask = llmsk ) ; CALL mpp_min( 'domvvl', z_tmin ) ! min over the global domain
- ! - ML - test: for the moment, stop simulation for too large e3_t variations
- IF( ( z_tmax > rn_zdef_max ) .OR. ( z_tmin < - rn_zdef_max ) ) THEN
- CALL mpp_maxloc( 'domvvl', ze3t, llmsk, z_tmax, ijk_max )
- CALL mpp_minloc( 'domvvl', ze3t, llmsk, z_tmin, ijk_min )
- IF (lwp) THEN
- WRITE(numout, *) 'MAX( tilde_e3t_a(:,:,:) / e3t_0(:,:,:) ) =', z_tmax
- WRITE(numout, *) 'at i, j, k=', ijk_max
- WRITE(numout, *) 'MIN( tilde_e3t_a(:,:,:) / e3t_0(:,:,:) ) =', z_tmin
- WRITE(numout, *) 'at i, j, k=', ijk_min
- CALL ctl_stop( 'STOP', 'MAX( ABS( tilde_e3t_a(:,:,: ) ) / e3t_0(:,:,:) ) too high')
- ENDIF
- ENDIF
- DEALLOCATE( ze3t, llmsk )
- ! - ML - end test
- ! - ML - Imposing these limits will cause a baroclinicity error which is corrected for below
- tilde_e3t_a(:,:,:) = MIN( tilde_e3t_a(:,:,:), rn_zdef_max * e3t_0(:,:,:) )
- tilde_e3t_a(:,:,:) = MAX( tilde_e3t_a(:,:,:), - rn_zdef_max * e3t_0(:,:,:) )
-
- !
- ! "tilda" change in the after scale factor
- ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
- DO jk = 1, jpkm1
- dtilde_e3t_a(:,:,jk) = tilde_e3t_a(:,:,jk) - tilde_e3t_b(:,:,jk)
- END DO
- ! III - Barotropic repartition of the sea surface height over the baroclinic profile
- ! ==================================================================================
- ! add ( ssh increment + "baroclinicity error" ) proportionly to e3t(n)
- ! - ML - baroclinicity error should be better treated in the future
- ! i.e. locally and not spread over the water column.
- ! (keep in mind that the idea is to reduce Eulerian velocity as much as possible)
- zht(:,:) = 0.
- DO jk = 1, jpkm1
- zht(:,:) = zht(:,:) + tilde_e3t_a(:,:,jk) * tmask(:,:,jk)
- END DO
- z_scale(:,:) = - zht(:,:) / ( ht_0(:,:) + ssh(:,:,Kmm) + 1. - ssmask(:,:) )
- DO jk = 1, jpkm1
- dtilde_e3t_a(:,:,jk) = dtilde_e3t_a(:,:,jk) + e3t(:,:,jk,Kmm) * z_scale(:,:) * tmask(:,:,jk)
- END DO
-
- ENDIF
-
- IF( ln_vvl_ztilde .OR. ln_vvl_layer ) THEN ! z_tilde or layer coordinate !
- ! ! ---baroclinic part--------- !
- DO jk = 1, jpkm1
- e3t(:,:,jk,Kaa) = e3t(:,:,jk,Kaa) + dtilde_e3t_a(:,:,jk) * tmask(:,:,jk)
- END DO
- ENDIF
-
- IF( ln_vvl_dbg .AND. .NOT. ll_do_bclinic ) THEN ! - ML - test: control prints for debuging
- !
- IF( lwp ) WRITE(numout, *) 'kt =', kt
- IF ( ln_vvl_ztilde .OR. ln_vvl_layer ) THEN
- z_tmax = MAXVAL( tmask(:,:,1) * tmask_i(:,:) * ABS( zht(:,:) ) )
- CALL mpp_max( 'domvvl', z_tmax ) ! max over the global domain
- IF( lwp ) WRITE(numout, *) kt,' MAXVAL(abs(SUM(tilde_e3t_a))) =', z_tmax
- END IF
- !
- zht(:,:) = 0.0_wp
- DO jk = 1, jpkm1
- zht(:,:) = zht(:,:) + e3t(:,:,jk,Kmm) * tmask(:,:,jk)
- END DO
- z_tmax = MAXVAL( tmask(:,:,1) * tmask_i(:,:) * ABS( ht_0(:,:) + ssh(:,:,Kmm) - zht(:,:) ) )
- CALL mpp_max( 'domvvl', z_tmax ) ! max over the global domain
- IF( lwp ) WRITE(numout, *) kt,' MAXVAL(abs(ht_0+sshn-SUM(e3t(:,:,:,Kmm)))) =', z_tmax
- !
- zht(:,:) = 0.0_wp
- DO jk = 1, jpkm1
- zht(:,:) = zht(:,:) + e3t(:,:,jk,Kaa) * tmask(:,:,jk)
- END DO
- z_tmax = MAXVAL( tmask(:,:,1) * tmask_i(:,:) * ABS( ht_0(:,:) + ssh(:,:,Kaa) - zht(:,:) ) )
- CALL mpp_max( 'domvvl', z_tmax ) ! max over the global domain
- IF( lwp ) WRITE(numout, *) kt,' MAXVAL(abs(ht_0+ssha-SUM(e3t(:,:,:,Kaa)))) =', z_tmax
- !
- zht(:,:) = 0.0_wp
- DO jk = 1, jpkm1
- zht(:,:) = zht(:,:) + e3t(:,:,jk,Kbb) * tmask(:,:,jk)
- END DO
- z_tmax = MAXVAL( tmask(:,:,1) * tmask_i(:,:) * ABS( ht_0(:,:) + ssh(:,:,Kbb) - zht(:,:) ) )
- CALL mpp_max( 'domvvl', z_tmax ) ! max over the global domain
- IF( lwp ) WRITE(numout, *) kt,' MAXVAL(abs(ht_0+sshb-SUM(e3t(:,:,:,Kbb)))) =', z_tmax
- !
- z_tmax = MAXVAL( tmask(:,:,1) * ABS( ssh(:,:,Kbb) ) )
- CALL mpp_max( 'domvvl', z_tmax ) ! max over the global domain
- IF( lwp ) WRITE(numout, *) kt,' MAXVAL(abs(ssh(:,:,Kbb)))) =', z_tmax
- !
- z_tmax = MAXVAL( tmask(:,:,1) * ABS( ssh(:,:,Kmm) ) )
- CALL mpp_max( 'domvvl', z_tmax ) ! max over the global domain
- IF( lwp ) WRITE(numout, *) kt,' MAXVAL(abs(ssh(:,:,Kmm)))) =', z_tmax
- !
- z_tmax = MAXVAL( tmask(:,:,1) * ABS( ssh(:,:,Kaa) ) )
- CALL mpp_max( 'domvvl', z_tmax ) ! max over the global domain
- IF( lwp ) WRITE(numout, *) kt,' MAXVAL(abs(ssh(:,:,Kaa)))) =', z_tmax
- END IF
-
-#if defined key_agrif
- ! *********************************** !
- ! After scale factors at w- points !
- ! *********************************** !
- ! At some point, "after" depths at T-points may be required
- ! for AGRIF vertical remap. To prevent from saving an
- ! additional array, re-compute depths from e3w when needed
- CALL dom_vvl_interpol( e3t(:,:,:,Kaa), e3w(:,:,:,Kaa), 'W' )
-#endif
- ! *********************************** !
- ! After scale factors at u- v- points !
- ! *********************************** !
-
- CALL dom_vvl_interpol( e3t(:,:,:,Kaa), e3u(:,:,:,Kaa), 'U' )
- CALL dom_vvl_interpol( e3t(:,:,:,Kaa), e3v(:,:,:,Kaa), 'V' )
-
- ! *********************************** !
- ! After depths at u- v points !
- ! *********************************** !
-
- hu(:,:,Kaa) = e3u(:,:,1,Kaa) * umask(:,:,1)
- hv(:,:,Kaa) = e3v(:,:,1,Kaa) * vmask(:,:,1)
- DO jk = 2, jpkm1
- hu(:,:,Kaa) = hu(:,:,Kaa) + e3u(:,:,jk,Kaa) * umask(:,:,jk)
- hv(:,:,Kaa) = hv(:,:,Kaa) + e3v(:,:,jk,Kaa) * vmask(:,:,jk)
- END DO
- ! ! Inverse of the local depth
-!!gm BUG ? don't understand the use of umask_i here .....
- r1_hu(:,:,Kaa) = ssumask(:,:) / ( hu(:,:,Kaa) + 1._wp - ssumask(:,:) )
- r1_hv(:,:,Kaa) = ssvmask(:,:) / ( hv(:,:,Kaa) + 1._wp - ssvmask(:,:) )
- !
- IF( ln_timing ) CALL timing_stop('dom_vvl_sf_nxt')
- !
- END SUBROUTINE dom_vvl_sf_nxt
-
-
- SUBROUTINE dom_vvl_sf_update( kt, Kbb, Kmm, Kaa )
- !!----------------------------------------------------------------------
- !! *** ROUTINE dom_vvl_sf_update ***
- !!
- !! ** Purpose : for z tilde case: compute time filter and swap of scale factors
- !! compute all depths and related variables for next time step
- !! write outputs and restart file
- !!
- !! ** Method : - swap of e3t with trick for volume/tracer conservation (ONLY FOR Z TILDE CASE)
- !! - reconstruct scale factor at other grid points (interpolate)
- !! - recompute depths and water height fields
- !!
- !! ** Action : - tilde_e3t_(b/n) ready for next time step
- !! - Recompute:
- !! e3(u/v)_b
- !! e3w(:,:,:,Kmm)
- !! e3(u/v)w_b
- !! e3(u/v)w_n
- !! gdept(:,:,:,Kmm), gdepw(:,:,:,Kmm) and gde3w
- !! h(u/v) and h(u/v)r
- !!
- !! Reference : Leclair, M., and G. Madec, 2009, Ocean Modelling.
- !! Leclair, M., and G. Madec, 2011, Ocean Modelling.
- !!----------------------------------------------------------------------
- INTEGER, INTENT( in ) :: kt ! time step
- INTEGER, INTENT( in ) :: Kbb, Kmm, Kaa ! time level indices
- !
- INTEGER :: ji, jj, jk ! dummy loop indices
- REAL(wp) :: zcoef ! local scalar
- !!----------------------------------------------------------------------
- !
- IF( ln_linssh ) RETURN ! No calculation in linear free surface
- !
- IF( ln_timing ) CALL timing_start('dom_vvl_sf_update')
- !
- IF( kt == nit000 ) THEN
- IF(lwp) WRITE(numout,*)
- IF(lwp) WRITE(numout,*) 'dom_vvl_sf_update : - interpolate scale factors and compute depths for next time step'
- IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~~~~~'
- ENDIF
- !
- ! Time filter and swap of scale factors
- ! =====================================
- ! - ML - e3(t/u/v)_b are allready computed in dynnxt.
- IF( ln_vvl_ztilde .OR. ln_vvl_layer ) THEN
- IF( l_1st_euler ) THEN
- tilde_e3t_b(:,:,:) = tilde_e3t_n(:,:,:)
- ELSE
- tilde_e3t_b(:,:,:) = tilde_e3t_n(:,:,:) &
- & + rn_atfp * ( tilde_e3t_b(:,:,:) - 2.0_wp * tilde_e3t_n(:,:,:) + tilde_e3t_a(:,:,:) )
- ENDIF
- tilde_e3t_n(:,:,:) = tilde_e3t_a(:,:,:)
- ENDIF
-
- ! Compute all missing vertical scale factor and depths
- ! ====================================================
- ! Horizontal scale factor interpolations
- ! --------------------------------------
- ! - ML - e3u(:,:,:,Kbb) and e3v(:,:,:,Kbb) are already computed in dynnxt
- ! - JC - hu(:,:,:,Kbb), hv(:,:,:,:,Kbb), hur_b, hvr_b also
-
- CALL dom_vvl_interpol( e3u(:,:,:,Kmm), e3f(:,:,:), 'F' )
-
- ! Vertical scale factor interpolations
- CALL dom_vvl_interpol( e3t(:,:,:,Kmm), e3w(:,:,:,Kmm), 'W' )
- CALL dom_vvl_interpol( e3u(:,:,:,Kmm), e3uw(:,:,:,Kmm), 'UW' )
- CALL dom_vvl_interpol( e3v(:,:,:,Kmm), e3vw(:,:,:,Kmm), 'VW' )
- CALL dom_vvl_interpol( e3t(:,:,:,Kbb), e3w(:,:,:,Kbb), 'W' )
- CALL dom_vvl_interpol( e3u(:,:,:,Kbb), e3uw(:,:,:,Kbb), 'UW' )
- CALL dom_vvl_interpol( e3v(:,:,:,Kbb), e3vw(:,:,:,Kbb), 'VW' )
-
- ! t- and w- points depth (set the isf depth as it is in the initial step)
- gdept(:,:,1,Kmm) = 0.5_wp * e3w(:,:,1,Kmm)
- gdepw(:,:,1,Kmm) = 0.0_wp
- gde3w(:,:,1) = gdept(:,:,1,Kmm) - ssh(:,:,Kmm)
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 2, jpk )
- ! zcoef = (tmask(ji,jj,jk) - wmask(ji,jj,jk)) ! 0 everywhere tmask = wmask, ie everywhere expect at jk = mikt
- ! 1 for jk = mikt
- zcoef = (tmask(ji,jj,jk) - wmask(ji,jj,jk))
- gdepw(ji,jj,jk,Kmm) = gdepw(ji,jj,jk-1,Kmm) + e3t(ji,jj,jk-1,Kmm)
- gdept(ji,jj,jk,Kmm) = zcoef * ( gdepw(ji,jj,jk ,Kmm) + 0.5 * e3w(ji,jj,jk,Kmm) ) &
- & + (1-zcoef) * ( gdept(ji,jj,jk-1,Kmm) + e3w(ji,jj,jk,Kmm) )
- gde3w(ji,jj,jk) = gdept(ji,jj,jk,Kmm) - ssh(ji,jj,Kmm)
- END_3D
-
- ! Local depth and Inverse of the local depth of the water
- ! -------------------------------------------------------
- !
- ht(:,:) = e3t(:,:,1,Kmm) * tmask(:,:,1)
- DO jk = 2, jpkm1
- ht(:,:) = ht(:,:) + e3t(:,:,jk,Kmm) * tmask(:,:,jk)
- END DO
-
- ! write restart file
- ! ==================
- IF( lrst_oce ) CALL dom_vvl_rst( kt, Kbb, Kmm, 'WRITE' )
- !
- IF( ln_timing ) CALL timing_stop('dom_vvl_sf_update')
- !
- END SUBROUTINE dom_vvl_sf_update
-
-
- SUBROUTINE dom_vvl_interpol( pe3_in, pe3_out, pout )
- !!---------------------------------------------------------------------
- !! *** ROUTINE dom_vvl__interpol ***
- !!
- !! ** Purpose : interpolate scale factors from one grid point to another
- !!
- !! ** Method : e3_out = e3_0 + interpolation(e3_in - e3_0)
- !! - horizontal interpolation: grid cell surface averaging
- !! - vertical interpolation: simple averaging
- !!----------------------------------------------------------------------
- REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in ) :: pe3_in ! input e3 to be interpolated
- REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pe3_out ! output interpolated e3
- CHARACTER(LEN=*) , INTENT(in ) :: pout ! grid point of out scale factors
- ! ! = 'U', 'V', 'W, 'F', 'UW' or 'VW'
- !
- INTEGER :: ji, jj, jk ! dummy loop indices
- INTEGER :: iku, ikum1, ikv, ikvm1, ikf, ikfm1
- REAL(wp) :: zlnwd ! =1./0. when ln_wd_il = T/F
- REAL(wp), DIMENSION(jpi,jpj) :: zssh ! work array to retrieve ssh (nn_vvl_interp > 1)
- !!----------------------------------------------------------------------
- !
- IF(ln_wd_il) THEN
- zlnwd = 1.0_wp
- ELSE
- zlnwd = 0.0_wp
- END IF
- !
- SELECT CASE ( pout ) !== type of interpolation ==!
- !
- CASE( 'U' ) !* from T- to U-point : hor. surface weighted mean
- SELECT CASE ( nn_vvl_interp )
- CASE ( 0 )
- !
- DO_3D( 1, 0, 1, 0, 1, jpk )
- pe3_out(ji,jj,jk) = 0.5_wp * ( umask(ji,jj,jk) * (1.0_wp - zlnwd) + zlnwd ) * r1_e1e2u(ji,jj) &
- & * ( e1e2t(ji ,jj) * ( pe3_in(ji ,jj,jk) - e3t_0(ji ,jj,jk) ) &
- & + e1e2t(ji+1,jj) * ( pe3_in(ji+1,jj,jk) - e3t_0(ji+1,jj,jk) ) )
- END_3D
- !
- CASE ( 1 )
- !
- DO_3D( 1, 0, 1, 0, 1, jpk )
- pe3_out(ji,jj,jk) = 0.5_wp * ( umask(ji,jj,jk) * (1.0_wp - zlnwd) + zlnwd ) * r1_e1e2u(ji,jj) &
- & * ( e1e2t(ji ,jj) * ( pe3_in(ji ,jj,jk) - e3t_0(ji ,jj,jk) ) &
- & + e1e2t(ji+1,jj) * ( pe3_in(ji+1,jj,jk) - e3t_0(ji+1,jj,jk) ) )
- END_3D
- !
- ! Bottom correction:
- DO_2D( 1, 0, 1, 0 )
- iku = mbku(ji ,jj)
- ikum1 = iku - 1
- pe3_out(ji,jj,iku) = ( umask(ji,jj,iku) * (1.0_wp - zlnwd) + zlnwd ) &
- & * ( 0.5_wp * r1_e1e2u(ji,jj) &
- & * ( e1e2t(ji ,jj) * ( SUM(tmask(ji ,jj,:)*(pe3_in(ji ,jj,:) - e3t_0(ji ,jj,:))) ) &
- & + e1e2t(ji+1,jj) * ( SUM(tmask(ji+1,jj,:)*(pe3_in(ji+1,jj,:) - e3t_0(ji+1,jj,:))) ) ) &
- & - SUM(pe3_out(ji,jj,1:ikum1)))
- END_2D
- !
- CASE ( 2 )
- zssh(:,:) = SUM(tmask(:,:,:)*(pe3_in(:,:,:)-e3t_0(:,:,:)), DIM=3)
- !
- DO_3D( 1, 0, 1, 0, 1, jpk )
- pe3_out(ji,jj,jk) = 0.5_wp * ( umask(ji,jj,jk) * (1.0_wp - zlnwd) + zlnwd ) * r1_e1e2u(ji,jj) &
- & * ( e1e2t(ji ,jj) * zssh(ji ,jj) + e1e2t(ji+1,jj) * zssh(ji+1,jj)) &
- & * e3u_0(ji,jj,jk) / ( hu_0(ji,jj) + 1._wp - ssumask(ji,jj) )
- END_3D
- !
- END SELECT
- !
- CALL lbc_lnk( 'domvvl', pe3_out(:,:,:), 'U', 1._wp )
- pe3_out(:,:,:) = pe3_out(:,:,:) + e3u_0(:,:,:)
- !
- CASE( 'V' ) !* from T- to V-point : hor. surface weighted mean
- SELECT CASE ( nn_vvl_interp )
- CASE ( 0 )
- !
- DO_3D( 1, 0, 1, 0, 1, jpk )
- pe3_out(ji,jj,jk) = 0.5_wp * ( vmask(ji,jj,jk) * (1.0_wp - zlnwd) + zlnwd ) * r1_e1e2v(ji,jj) &
- & * ( e1e2t(ji,jj ) * ( pe3_in(ji,jj ,jk) - e3t_0(ji,jj ,jk) ) &
- & + e1e2t(ji,jj+1) * ( pe3_in(ji,jj+1,jk) - e3t_0(ji,jj+1,jk) ) )
- END_3D
- !
- CASE ( 1 )
- !
- DO_3D( 1, 0, 1, 0, 1, jpk )
- pe3_out(ji,jj,jk) = 0.5_wp * ( vmask(ji,jj,jk) * (1.0_wp - zlnwd) + zlnwd ) * r1_e1e2v(ji,jj) &
- & * ( e1e2t(ji,jj ) * ( pe3_in(ji,jj ,jk) - e3t_0(ji,jj ,jk) ) &
- & + e1e2t(ji,jj+1) * ( pe3_in(ji,jj+1,jk) - e3t_0(ji,jj+1,jk) ) )
- END_3D
- !
- ! Bottom correction:
- DO_2D( 1, 0, 1, 0 )
- ikv = mbkv(ji ,jj)
- ikvm1 = ikv - 1
- pe3_out(ji,jj,ikv) = ( vmask(ji,jj,ikv) * (1.0_wp - zlnwd) + zlnwd ) &
- & * ( 0.5_wp * r1_e1e2v(ji,jj) &
- & * ( e1e2t(ji,jj ) * ( SUM(tmask(ji,jj ,:)*(pe3_in(ji,jj ,:) - e3t_0(ji,jj ,:))) ) &
- & + e1e2t(ji,jj+1) * ( SUM(tmask(ji,jj+1,:)*(pe3_in(ji,jj+1,:) - e3t_0(ji,jj+1,:))) ) ) &
- & - SUM(pe3_out(ji,jj,1:ikvm1)))
- END_2D
- !
- CASE ( 2 )
- zssh(:,:) = SUM(tmask(:,:,:)*(pe3_in(:,:,:)-e3t_0(:,:,:)), DIM=3)
- !
- DO_3D( 1, 0, 1, 0, 1, jpk )
- pe3_out(ji,jj,jk) = 0.5_wp * ( vmask(ji,jj,jk) * (1.0_wp - zlnwd) + zlnwd ) * r1_e1e2v(ji,jj) &
- & * ( e1e2t(ji ,jj) * zssh(ji ,jj) + e1e2t(ji,jj+1) * zssh(ji,jj+1)) &
- & * e3v_0(ji,jj,jk) / ( hv_0(ji,jj) + 1._wp - ssvmask(ji,jj) )
- END_3D
- !
- END SELECT
- !
- CALL lbc_lnk( 'domvvl', pe3_out(:,:,:), 'V', 1._wp )
- pe3_out(:,:,:) = pe3_out(:,:,:) + e3v_0(:,:,:)
- !
- CASE( 'F' ) !* from U-point to F-point : hor. surface weighted mean
- SELECT CASE ( nn_vvl_interp )
- CASE ( 0 )
- !
- DO_3D( 0, 0, 0, 0, 1, jpk )
- pe3_out(ji,jj,jk) = 0.5_wp * ( umask(ji,jj,jk) * umask(ji,jj+1,jk) * (1.0_wp - zlnwd) + zlnwd ) &
- & * r1_e1e2f(ji,jj) &
- & * ( e1e2u(ji,jj ) * ( pe3_in(ji,jj ,jk) - e3u_0(ji,jj ,jk) ) &
- & + e1e2u(ji,jj+1) * ( pe3_in(ji,jj+1,jk) - e3u_0(ji,jj+1,jk) ) )
- END_3D
- !
- CASE ( 1 )
- !
- DO_3D( 0, 0, 0, 0, 1, jpk )
- pe3_out(ji,jj,jk) = 0.5_wp * ( umask(ji,jj,jk) * umask(ji,jj+1,jk) * (1.0_wp - zlnwd) + zlnwd ) &
- & * r1_e1e2f(ji,jj) &
- & * ( e1e2u(ji,jj ) * ( pe3_in(ji,jj ,jk) - e3u_0(ji,jj ,jk) ) &
- & + e1e2u(ji,jj+1) * ( pe3_in(ji,jj+1,jk) - e3u_0(ji,jj+1,jk) ) )
- END_3D
- !
- ! Bottom correction:
- DO_2D( 0, 0, 0, 0 )
- ikf = MIN(mbku(ji ,jj),mbku(ji,jj+1))
- ikfm1 = ikf - 1
- pe3_out(ji,jj,ikf) = ( umask(ji,jj,ikf) * umask(ji,jj+1,ikf) * (1.0_wp - zlnwd) + zlnwd ) &
- & * ( 0.5_wp * r1_e1e2f(ji,jj) &
- & * ( e1e2u(ji,jj ) * ( SUM(umask(ji,jj ,:)*(pe3_in(ji,jj ,:) - e3u_0(ji,jj ,:))) ) &
- & + e1e2u(ji,jj+1) * ( SUM(umask(ji,jj+1,:)*(pe3_in(ji,jj+1,:) - e3u_0(ji,jj+1,:))) ) ) &
- & - SUM(pe3_out(ji,jj,1:ikfm1)))
- END_2D
- !
- CASE ( 2 )
- zssh(:,:) = SUM(umask(:,:,:)*(pe3_in(:,:,:)-e3u_0(:,:,:)), DIM=3)
- !
- DO_3D( 0, 0, 0, 0, 1, jpk )
- pe3_out(ji,jj,jk) = ( umask(ji,jj,jk)* umask(ji,jj+1,jk) * (1.0_wp - zlnwd) + zlnwd ) &
- & * 0.5_wp * r1_e1e2f(ji,jj) &
- & * (e1e2u(ji ,jj) * zssh(ji ,jj) + e1e2u(ji,jj+1) * zssh(ji,jj+1)) &
- & * e3f_0(ji,jj,jk) / ( hf_0(ji,jj) + 1._wp - ssumask(ji,jj)*ssumask(ji,jj+1) )
- END_3D
- !
- END SELECT
- !
- CALL lbc_lnk( 'domvvl', pe3_out(:,:,:), 'F', 1._wp )
- pe3_out(:,:,:) = pe3_out(:,:,:) + e3f_0(:,:,:)
- !
- CASE( 'W' ) !* from T- to W-point : vertical simple mean
- !
- pe3_out(:,:,1) = e3w_0(:,:,1) + pe3_in(:,:,1) - e3t_0(:,:,1)
- ! - ML - The use of mask in this formulea enables the special treatment of the last w-point without indirect adressing
-!!gm BUG? use here wmask in case of ISF ? to be checked
- DO jk = 2, jpk
- pe3_out(:,:,jk) = e3w_0(:,:,jk) + ( 1.0_wp - 0.5_wp * ( tmask(:,:,jk) * (1.0_wp - zlnwd) + zlnwd ) ) &
- & * ( pe3_in(:,:,jk-1) - e3t_0(:,:,jk-1) ) &
- & + 0.5_wp * ( tmask(:,:,jk) * (1.0_wp - zlnwd) + zlnwd ) &
- & * ( pe3_in(:,:,jk ) - e3t_0(:,:,jk ) )
- END DO
- !
- CASE( 'UW' ) !* from U- to UW-point : vertical simple mean
- !
- pe3_out(:,:,1) = e3uw_0(:,:,1) + pe3_in(:,:,1) - e3u_0(:,:,1)
- ! - ML - The use of mask in this formaula enables the special treatment of the last w- point without indirect adressing
-!!gm BUG? use here wumask in case of ISF ? to be checked
- DO jk = 2, jpk
- pe3_out(:,:,jk) = e3uw_0(:,:,jk) + ( 1.0_wp - 0.5_wp * ( umask(:,:,jk) * (1.0_wp - zlnwd) + zlnwd ) ) &
- & * ( pe3_in(:,:,jk-1) - e3u_0(:,:,jk-1) ) &
- & + 0.5_wp * ( umask(:,:,jk) * (1.0_wp - zlnwd) + zlnwd ) &
- & * ( pe3_in(:,:,jk ) - e3u_0(:,:,jk ) )
- END DO
- !
- CASE( 'VW' ) !* from V- to VW-point : vertical simple mean
- !
- pe3_out(:,:,1) = e3vw_0(:,:,1) + pe3_in(:,:,1) - e3v_0(:,:,1)
- ! - ML - The use of mask in this formaula enables the special treatment of the last w- point without indirect adressing
-!!gm BUG? use here wvmask in case of ISF ? to be checked
- DO jk = 2, jpk
- pe3_out(:,:,jk) = e3vw_0(:,:,jk) + ( 1.0_wp - 0.5_wp * ( vmask(:,:,jk) * (1.0_wp - zlnwd) + zlnwd ) ) &
- & * ( pe3_in(:,:,jk-1) - e3v_0(:,:,jk-1) ) &
- & + 0.5_wp * ( vmask(:,:,jk) * (1.0_wp - zlnwd) + zlnwd ) &
- & * ( pe3_in(:,:,jk ) - e3v_0(:,:,jk ) )
- END DO
- END SELECT
- !
- END SUBROUTINE dom_vvl_interpol
-
-
- SUBROUTINE dom_vvl_rst( kt, Kbb, Kmm, cdrw )
- !!---------------------------------------------------------------------
- !! *** ROUTINE dom_vvl_rst ***
- !!
- !! ** Purpose : Read or write VVL file in restart file
- !!
- !! ** Method : * restart comes from a linear ssh simulation :
- !! an attempt to read e3t_n stops simulation
- !! * restart comes from a z-star, z-tilde, or layer :
- !! read e3t_n and e3t_b
- !! * restart comes from a z-star :
- !! set tilde_e3t_n, tilde_e3t_n, and hdiv_lf to 0
- !! * restart comes from layer :
- !! read tilde_e3t_n and tilde_e3t_b
- !! set hdiv_lf to 0
- !! * restart comes from a z-tilde:
- !! read tilde_e3t_n, tilde_e3t_b, and hdiv_lf
- !!
- !! NB: if l_1st_euler = T (ln_1st_euler or ssh_b not found)
- !! Kbb fields set to Kmm ones
- !!----------------------------------------------------------------------
- INTEGER , INTENT(in) :: kt ! ocean time-step
- INTEGER , INTENT(in) :: Kbb, Kmm ! ocean time level indices
- CHARACTER(len=*), INTENT(in) :: cdrw ! "READ"/"WRITE" flag
- !
- INTEGER :: ji, jj, jk ! dummy loop indices
- INTEGER :: id2, id3, id4, id5 ! local integers
- !!----------------------------------------------------------------------
- !
- ! !=====================!
- IF( TRIM(cdrw) == 'READ' ) THEN ! Read / initialise !
- ! !=====================!
- !
- IF( ln_rstart ) THEN !== Read the restart file ==!
- !
- CALL rst_read_open !* open the restart file if necessary
- ! ! --------- !
- ! ! all cases !
- ! ! --------- !
- !
- id2 = iom_varid( numror, 'e3t_n' , ldstop = .FALSE. ) !* check presence
- id3 = iom_varid( numror, 'tilde_e3t_b', ldstop = .FALSE. )
- id4 = iom_varid( numror, 'tilde_e3t_n', ldstop = .FALSE. )
- id5 = iom_varid( numror, 'hdiv_lf' , ldstop = .FALSE. )
- !
- ! !* scale factors
- ! hot restart case with zstar coordinate:
- IF ( id2 > 0 ) THEN
- IF(lwp) WRITE(numout,*) ' Kmm scale factor read in the restart file'
- CALL iom_get( numror, jpdom_auto, 'e3t_n', e3t(:,:,:,Kmm) )
- WHERE ( tmask(:,:,:) == 0.0_wp )
- e3t(:,:,:,Kmm) = e3t_0(:,:,:)
- END WHERE
- ELSE
- DO jk = 1, jpk
- e3t(:,:,jk,Kmm) = e3t_0(:,:,jk) * ( 1._wp + ssh(:,:,Kmm) * r1_ht_0(:,:) * tmask(:,:,jk) )
- END DO
- ENDIF
-
- IF( l_1st_euler ) THEN ! euler
- IF(lwp) WRITE(numout,*) ' Euler first time step : e3t(Kbb) = e3t(Kmm)'
- e3t(:,:,:,Kbb) = e3t(:,:,:,Kmm)
- ELSE ! leap frog
- IF(lwp) WRITE(numout,*) ' Kbb scale factor read in the restart file'
- CALL iom_get( numror, jpdom_auto, 'e3t_b', e3t(:,:,:,Kbb) )
- WHERE ( tmask(:,:,:) == 0.0_wp )
- e3t(:,:,:,Kbb) = e3t_0(:,:,:)
- END WHERE
- ENDIF
- ! ! ------------ !
- IF( ln_vvl_zstar ) THEN ! z_star case !
- ! ! ------------ !
- IF( MIN( id3, id4 ) > 0 ) THEN
- CALL ctl_stop( 'dom_vvl_rst: z_star cannot restart from a z_tilde or layer run' )
- ENDIF
- ! ! ------------------------ !
- ELSE ! z_tilde and layer cases !
- ! ! ------------------------ !
- !
- IF( id4 > 0 ) THEN !* scale factor increments
- IF(lwp) WRITE(numout,*) ' Kmm scale factor increments read in the restart file'
- CALL iom_get( numror, jpdom_auto, 'tilde_e3t_n', tilde_e3t_n(:,:,:) )
- IF( l_1st_euler ) THEN ! euler
- IF(lwp) WRITE(numout,*) ' Euler first time step : tilde_e3t(Kbb) = tilde_e3t(Kmm)'
- tilde_e3t_b(:,:,:) = tilde_e3t_n(:,:,:)
- ELSE ! leap frog
- IF(lwp) WRITE(numout,*) ' Kbb scale factor increments read in the restart file'
- CALL iom_get( numror, jpdom_auto, 'tilde_e3t_b', tilde_e3t_b(:,:,:) )
- ENDIF
- ELSE
- tilde_e3t_b(:,:,:) = 0.0_wp
- tilde_e3t_n(:,:,:) = 0.0_wp
- ENDIF
- ! ! ------------ !
- IF( ln_vvl_ztilde ) THEN ! z_tilde case !
- ! ! ------------ !
- IF( id5 > 0 ) THEN ! required array exists
- CALL iom_get( numror, jpdom_auto, 'hdiv_lf', hdiv_lf(:,:,:) )
- ELSE ! array is missing
- hdiv_lf(:,:,:) = 0.0_wp
- ENDIF
- ENDIF
- ENDIF
- !
- ELSE !== Initialize at "rest" with ssh ==!
- !
- DO jk = 1, jpk
- e3t(:,:,jk,Kmm) = e3t_0(:,:,jk) * ( 1._wp + ssh(:,:,Kmm) * r1_ht_0(:,:) * tmask(:,:,jk) )
- END DO
- e3t(:,:,:,Kbb) = e3t(:,:,:,Kmm)
- !
- IF( ln_vvl_ztilde .OR. ln_vvl_layer) THEN
- tilde_e3t_b(:,:,:) = 0._wp
- tilde_e3t_n(:,:,:) = 0._wp
- IF( ln_vvl_ztilde ) hdiv_lf(:,:,:) = 0._wp
- ENDIF
- ENDIF
- ! !=======================!
- ELSEIF( TRIM(cdrw) == 'WRITE' ) THEN ! Create restart file !
- ! !=======================!
- !
- IF(lwp) WRITE(numout,*) '---- dom_vvl_rst ----'
- ! ! --------- !
- ! ! all cases !
- ! ! --------- !
- CALL iom_rstput( kt, nitrst, numrow, 'e3t_b', e3t(:,:,:,Kbb) )
- CALL iom_rstput( kt, nitrst, numrow, 'e3t_n', e3t(:,:,:,Kmm) )
- ! ! ----------------------- !
- IF( ln_vvl_ztilde .OR. ln_vvl_layer ) THEN ! z_tilde and layer cases !
- ! ! ----------------------- !
- CALL iom_rstput( kt, nitrst, numrow, 'tilde_e3t_b', tilde_e3t_b(:,:,:))
- CALL iom_rstput( kt, nitrst, numrow, 'tilde_e3t_n', tilde_e3t_n(:,:,:))
- END IF
- ! ! -------------!
- IF( ln_vvl_ztilde ) THEN ! z_tilde case !
- ! ! ------------ !
- CALL iom_rstput( kt, nitrst, numrow, 'hdiv_lf', hdiv_lf(:,:,:))
- ENDIF
- !
- ENDIF
- !
- END SUBROUTINE dom_vvl_rst
-
-
- SUBROUTINE dom_vvl_ctl
- !!---------------------------------------------------------------------
- !! *** ROUTINE dom_vvl_ctl ***
- !!
- !! ** Purpose : Control the consistency between namelist options
- !! for vertical coordinate
- !!----------------------------------------------------------------------
- INTEGER :: ioptio, ios
- !!
- NAMELIST/nam_vvl/ ln_vvl_zstar, ln_vvl_ztilde, ln_vvl_layer, ln_vvl_ztilde_as_zstar, &
- & ln_vvl_zstar_at_eqtor , rn_ahe3 , rn_rst_e3t , &
- & rn_lf_cutoff , rn_zdef_max , ln_vvl_dbg , & ! not yet implemented: ln_vvl_kepe
- & nn_vvl_interp
- !!----------------------------------------------------------------------
- !
- READ ( numnam_ref, nam_vvl, IOSTAT = ios, ERR = 901)
-901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nam_vvl in reference namelist' )
- READ ( numnam_cfg, nam_vvl, IOSTAT = ios, ERR = 902 )
-902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nam_vvl in configuration namelist' )
- IF(lwm) WRITE ( numond, nam_vvl )
- !
- IF(lwp) THEN ! Namelist print
- WRITE(numout,*)
- WRITE(numout,*) 'dom_vvl_ctl : choice/control of the variable vertical coordinate'
- WRITE(numout,*) '~~~~~~~~~~~'
- WRITE(numout,*) ' Namelist nam_vvl : chose a vertical coordinate'
- WRITE(numout,*) ' zstar ln_vvl_zstar = ', ln_vvl_zstar
- WRITE(numout,*) ' ztilde ln_vvl_ztilde = ', ln_vvl_ztilde
- WRITE(numout,*) ' layer ln_vvl_layer = ', ln_vvl_layer
- WRITE(numout,*) ' ztilde as zstar ln_vvl_ztilde_as_zstar = ', ln_vvl_ztilde_as_zstar
- WRITE(numout,*) ' ztilde near the equator ln_vvl_zstar_at_eqtor = ', ln_vvl_zstar_at_eqtor
- WRITE(numout,*) ' !'
- WRITE(numout,*) ' thickness diffusion coefficient rn_ahe3 = ', rn_ahe3
- WRITE(numout,*) ' maximum e3t deformation fractional change rn_zdef_max = ', rn_zdef_max
- IF( ln_vvl_ztilde_as_zstar ) THEN
- WRITE(numout,*) ' ztilde running in zstar emulation mode (ln_vvl_ztilde_as_zstar=T) '
- WRITE(numout,*) ' ignoring namelist timescale parameters and using:'
- WRITE(numout,*) ' hard-wired : z-tilde to zstar restoration timescale (days)'
- WRITE(numout,*) ' rn_rst_e3t = 0.e0'
- WRITE(numout,*) ' hard-wired : z-tilde cutoff frequency of low-pass filter (days)'
- WRITE(numout,*) ' rn_lf_cutoff = 1.0/rn_Dt'
- ELSE
- WRITE(numout,*) ' z-tilde to zstar restoration timescale (days) rn_rst_e3t = ', rn_rst_e3t
- WRITE(numout,*) ' z-tilde cutoff frequency of low-pass filter (days) rn_lf_cutoff = ', rn_lf_cutoff
- ENDIF
- WRITE(numout,*) ' debug prints flag ln_vvl_dbg = ', ln_vvl_dbg
- WRITE(numout,*) ' Method to compute scale factors anomaly at U/V/F points nn_vvl_interp = ', nn_vvl_interp
- ENDIF
- !
- ioptio = 0 ! Parameter control
- IF( ln_vvl_ztilde_as_zstar ) ln_vvl_ztilde = .true.
- IF( ln_vvl_zstar ) ioptio = ioptio + 1
- IF( ln_vvl_ztilde ) ioptio = ioptio + 1
- IF( ln_vvl_layer ) ioptio = ioptio + 1
- !
- IF( ioptio /= 1 ) CALL ctl_stop( 'Choose ONE vertical coordinate in namelist nam_vvl' )
- !
- IF( .NOT. ln_vvl_zstar .AND. (nn_vvl_interp==2 ) ) CALL ctl_stop( 'nn_vvl_interp must be < 2 if ln_vvl_zstar=F' )
- !
- IF(lwp) THEN ! Print the choice
- WRITE(numout,*)
- IF( ln_vvl_zstar ) WRITE(numout,*) ' ==>>> zstar vertical coordinate is used'
- IF( ln_vvl_ztilde ) WRITE(numout,*) ' ==>>> ztilde vertical coordinate is used'
- IF( ln_vvl_layer ) WRITE(numout,*) ' ==>>> layer vertical coordinate is used'
- IF( ln_vvl_ztilde_as_zstar ) WRITE(numout,*) ' ==>>> to emulate a zstar coordinate'
- ENDIF
- !
-#if defined key_agrif
- IF( (.NOT.Agrif_Root()).AND.(.NOT.ln_vvl_zstar) ) CALL ctl_stop( 'AGRIF is implemented with zstar coordinate only' )
-#endif
- !
- END SUBROUTINE dom_vvl_ctl
-
-#endif
-
- !!======================================================================
-END MODULE domvvl
diff --git a/src/OCE/DOM/domwri.F90 b/src/OCE/DOM/domwri.F90
index 9e797e247c2ea4d381f7f11e2f45169c1be38d8e..1616f18e4940505ce1abca50e89615a0d012507a 100644
--- a/src/OCE/DOM/domwri.F90
+++ b/src/OCE/DOM/domwri.F90
@@ -33,6 +33,7 @@ MODULE domwri
!! * Substitutions
# include "do_loop_substitute.h90"
+# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
!! $Id: domwri.F90 15033 2021-06-21 10:24:45Z smasson $
@@ -80,9 +81,9 @@ CONTAINS
CALL iom_putatt( inum, 'NFold', COUNT( (/l_NFold /) ) )
CALL iom_putatt( inum, 'NFtype', c_NFtype )
! ! type of vertical coordinate
- IF(ln_zco) CALL iom_putatt( inum, 'VertCoord', 'zco' )
- IF(ln_zps) CALL iom_putatt( inum, 'VertCoord', 'zps' )
- IF(ln_sco) CALL iom_putatt( inum, 'VertCoord', 'sco' )
+ IF(l_zco) CALL iom_putatt( inum, 'VertCoord', 'zco' )
+ IF(l_zps) CALL iom_putatt( inum, 'VertCoord', 'zps' )
+ IF(l_sco) CALL iom_putatt( inum, 'VertCoord', 'sco' )
! ! ocean cavities under iceshelves
CALL iom_putatt( inum, 'IsfCav', COUNT( (/ln_isfcav/) ) )
! ! masks
@@ -146,26 +147,30 @@ CONTAINS
CALL iom_rstput( 0, 0, inum, 'mbathy', zprt, ktype = jp_i4 ) ! ! nb of ocean T-points
zprt(:,:) = REAL( mikt(:,:) , wp )
CALL iom_rstput( 0, 0, inum, 'misf', zprt, ktype = jp_i4 ) ! ! nb of ocean T-points
- ! ! vertical mesh
- CALL iom_rstput( 0, 0, inum, 'e3t_1d', e3t_1d, ktype = jp_r8 ) ! ! scale factors
- CALL iom_rstput( 0, 0, inum, 'e3w_1d', e3w_1d, ktype = jp_r8 )
- CALL iom_rstput( 0, 0, inum, 'e3t_0' , e3t_0 , ktype = jp_r8 )
- CALL iom_rstput( 0, 0, inum, 'e3u_0' , e3u_0 , ktype = jp_r8 )
- CALL iom_rstput( 0, 0, inum, 'e3v_0' , e3v_0 , ktype = jp_r8 )
- CALL iom_rstput( 0, 0, inum, 'e3f_0' , e3f_0 , ktype = jp_r8 )
- CALL iom_rstput( 0, 0, inum, 'e3w_0' , e3w_0 , ktype = jp_r8 )
- CALL iom_rstput( 0, 0, inum, 'e3uw_0', e3uw_0, ktype = jp_r8 )
- CALL iom_rstput( 0, 0, inum, 'e3vw_0', e3vw_0, ktype = jp_r8 )
+ ! ! vertical mesh
+ CALL iom_rstput( 0, 0, inum, 'e3t_1d', e3t_1d, ktype = jp_r8 ) ! ! 1d scale factors
+ CALL iom_rstput( 0, 0, inum, 'e3w_1d', e3w_1d, ktype = jp_r8 )
!
CALL iom_rstput( 0, 0, inum, 'gdept_1d' , gdept_1d , ktype = jp_r8 ) ! stretched system
CALL iom_rstput( 0, 0, inum, 'gdepw_1d' , gdepw_1d , ktype = jp_r8 )
- CALL iom_rstput( 0, 0, inum, 'gdept_0' , gdept_0 , ktype = jp_r8 )
- CALL iom_rstput( 0, 0, inum, 'gdepw_0' , gdepw_0 , ktype = jp_r8 )
!
- IF( ln_sco ) THEN ! s-coordinate stiffness
+ IF( lk_vco_1d3d .OR. lk_vco_3d ) THEN ! 3d scale factors
+ CALL iom_rstput( 0, 0, inum, 'e3t_0' , e3t_3d , ktype = jp_r8 )
+ CALL iom_rstput( 0, 0, inum, 'e3u_0' , e3u_3d , ktype = jp_r8 )
+ CALL iom_rstput( 0, 0, inum, 'e3v_0' , e3v_3d , ktype = jp_r8 )
+ CALL iom_rstput( 0, 0, inum, 'e3f_0' , e3f_3d , ktype = jp_r8 )
+ ENDIF
+ IF( lk_vco_3d ) THEN
+ CALL iom_rstput( 0, 0, inum, 'e3w_0' , e3w_3d , ktype = jp_r8 )
+ CALL iom_rstput( 0, 0, inum, 'e3uw_0', e3uw_3d, ktype = jp_r8 )
+ CALL iom_rstput( 0, 0, inum, 'e3vw_0', e3vw_3d, ktype = jp_r8 )
+ !
+ CALL iom_rstput( 0, 0, inum, 'gdept_0', gdept_3d, ktype = jp_r8 ) ! 3d depth
+ CALL iom_rstput( 0, 0, inum, 'gdepw_0', gdepw_3d, ktype = jp_r8 )
+ ! ! s-coordinate stiffness
CALL dom_stiff( zprt )
- CALL iom_rstput( 0, 0, inum, 'stiffness', zprt ) ! Max. grid stiffness ratio
+ CALL iom_rstput( 0, 0, inum, 'stiffness', zprt ) ! Max. grid stiffness ratio
ENDIF
!
IF( ll_wd ) CALL iom_rstput( 0, 0, inum, 'ht_0' , ht_0 , ktype = jp_r8 )
diff --git a/src/OCE/DOM/domzgr.F90 b/src/OCE/DOM/domzgr.F90
index 85f89ed2c9b67d30da99d6ad550cf09c8d31cfdb..a151f2f46ab25b4a05bfdbe81b034e5a5d32f0b5 100644
--- a/src/OCE/DOM/domzgr.F90
+++ b/src/OCE/DOM/domzgr.F90
@@ -62,9 +62,9 @@ CONTAINS
!! - read/set ocean depth and ocean levels (bathy, mbathy)
!! - vertical coordinate (gdep., e3.) depending on the
!! coordinate chosen :
- !! ln_zco=T z-coordinate
- !! ln_zps=T z-coordinate with partial steps
- !! ln_zco=T s-coordinate
+ !! l_zco=T z-coordinate
+ !! l_zps=T z-coordinate with partial steps
+ !! l_zco=T s-coordinate
!!
!! ** Action : define gdep., e3., mbathy and bathy
!!----------------------------------------------------------------------
@@ -72,10 +72,12 @@ CONTAINS
!
INTEGER :: ji,jj,jk ! dummy loop index
INTEGER :: ikt, ikb ! top/bot index
- INTEGER :: ioptio, ibat, ios ! local integer
+ INTEGER :: ioptio, inum, iatt ! local integer
INTEGER :: is_mbkuvf ! ==0 if mbku, mbkv, mbkf to be computed
REAL(wp) :: zrefdep ! depth of the reference level (~10m)
- REAL(wp), DIMENSION(jpi,jpj ) :: zmsk
+ REAL(WP) :: z_zco, z_zps, z_sco, z_cav
+ CHARACTER(len=7) :: catt ! 'zco', 'zps, 'sco' or 'UNKNOWN'
+ REAL(wp), DIMENSION(jpi,jpj) :: zmsk, z2d
REAL(wp), DIMENSION(jpi,jpj,2) :: ztopbot
!!----------------------------------------------------------------------
!
@@ -83,40 +85,192 @@ CONTAINS
WRITE(numout,*)
WRITE(numout,*) 'dom_zgr : vertical coordinate'
WRITE(numout,*) '~~~~~~~'
+ IF( ln_linssh ) WRITE(numout,*) ' linear free surface: the vertical mesh does not change in time'
ENDIF
-
- IF( ln_linssh .AND. lwp) WRITE(numout,*) ' linear free surface: the vertical mesh does not change in time'
-
-
- IF( ln_read_cfg ) THEN !== read in mesh_mask.nc file ==!
+CALL FLUSH(numout)
+ ! !==============================!
+ IF( ln_read_cfg ) THEN !== read in domcfg.nc file ==!
+ ! !==============================!
IF(lwp) WRITE(numout,*)
IF(lwp) WRITE(numout,*) ' ==>>> Read vertical mesh in ', TRIM( cn_domcfg ), ' file'
+ is_mbkuvf = 0
+ !
+ CALL iom_open( cn_domcfg, inum ) ! open domcfg file
+ !
+!!st set ln_isfcav
+ IF( lk_isf ) THEN
+ CALL iom_getatt( inum, 'IsfCav', iatt ) ! returns -999 if not found
+ ln_isfcav = iatt == 1 ! default = .false.
+ !
+ ! ------- keep compatibility with OLD VERSION... start -------
+ IF( iatt == -999 ) THEN
+ CALL iom_get( inum, 'ln_isfcav', z_cav ) ; ln_isfcav = z_cav /= 0._wp
+ ENDIF
+ ENDIF
+ ! !* type of vertical coordinate
+ CALL iom_getatt( inum, 'VertCoord', catt ) ! returns 'UNKNOWN' if not found
+ l_zco = catt == 'zco' ! default = .false.
+ l_zps = catt == 'zps' ! default = .false.
+ l_sco = catt == 'sco' ! default = .false.
+ !
+ ! ------- keep compatibility with OLD VERSION... start -------
+ IF( catt == 'UNKNOWN' ) THEN
+ CALL iom_get( inum, 'ln_zco', z_zco ) ; l_zco = z_zco /= 0._wp
+ CALL iom_get( inum, 'ln_zps', z_zps ) ; l_zps = z_zps /= 0._wp
+ CALL iom_get( inum, 'ln_sco', z_sco ) ; l_sco = z_sco /= 0._wp
+ ENDIF
+ ! !------------------------------!
+ ! !-- all coordinate systems --! 1D depth and e3 (needed in netcdf files)
+ ! !------------------------------!
+ !
+ CALL iom_get( inum, jpdom_unknown, 'e3t_1d' , e3t_1d ) ! 1D reference coordinate
+ CALL iom_get( inum, jpdom_unknown, 'e3w_1d' , e3w_1d )
+ CALL e3_to_depth( e3t_1d, e3w_1d, gdept_1d, gdepw_1d ) ! 1D reference depth deduced from e3
+!!st NEED to deduce e3 from gdep
+!!st CALL iom_get( inum, jpdom_unknown, 'gdept_1d', gdept_1d ) ! 1D depth read
+!!st CALL iom_get( inum, jpdom_unknown, 'gdepw_1d', gdepw_1d )
+!!st CALL depth_to_e3( gdept_1d, gdepw_1d, e3t_1d, e3w_1d ) ! 1D e3 deduced from depth
+ !
+ ! !- ocean top and bottom k-indices
+ CALL iom_get( inum, jpdom_global, 'top_level' , z2d(:,:) ) ! 1st wet T-points (ISF)
+ k_top(:,:) = NINT( z2d(:,:) )
+ CALL iom_get( inum, jpdom_global, 'bottom_level' , z2d(:,:) ) ! last wet T-points
+ k_bot(:,:) = NINT( z2d(:,:) )
!
- CALL zgr_read ( ln_zco , ln_zps , ln_sco, ln_isfcav, &
- & gdept_1d, gdepw_1d, e3t_1d, e3w_1d , & ! 1D gridpoints depth
- & gdept_0 , gdepw_0 , & ! gridpoints depth
- & e3t_0 , e3u_0 , e3v_0 , e3f_0 , & ! vertical scale factors
- & e3w_0 , e3uw_0 , e3vw_0 , & ! vertical scale factors
- & k_top , k_bot , & ! 1st & last ocean level
- & is_mbkuvf, mbku, mbkv, mbkf ) ! U/V/F points bottom levels
+ ! !--------------------!
+ IF( lk_vco_1d ) THEN !-- z-coordinate --! use only 1D arrays for all gdep and e3 fields
+ ! !--------------------!
+ l_zco = .TRUE. ! old logical ==> to be removed
+ l_zps = .FALSE.
+ l_sco = .FALSE.
+ !
+ ! !-----------------------!
+ ELSEIF( lk_vco_1d3d ) THEN !-- z-partial cells --! use 3D t-level e3
+ ! !-----------------------!
+ l_zco = .TRUE.
+ l_zps = .FALSE. ! old logical ==> to be removed
+ l_sco = .FALSE.
+ !
+ ! ! t-level: 3D reference (include partial cell)
+ CALL iom_get( inum, jpdom_global, 'e3t_0' , e3t_3d, cd_type = 'T', psgn = 1._wp, kfill = jpfillcopy )
+ CALL iom_get( inum, jpdom_global, 'e3u_0' , e3u_3d, cd_type = 'U', psgn = 1._wp, kfill = jpfillcopy )
+ CALL iom_get( inum, jpdom_global, 'e3v_0' , e3v_3d, cd_type = 'V', psgn = 1._wp, kfill = jpfillcopy )
+ CALL iom_get( inum, jpdom_global, 'e3f_0' , e3f_3d, cd_type = 'F', psgn = 1._wp, kfill = jpfillcopy )
+ !
+ ! !--------------------!
+ ELSEIF( lk_vco_3d ) THEN !-- s-coordinate --! use 3D for all gdep and e3 fields
+ ! !--------------------!
+ l_zco = .FALSE.
+ l_zps = .FALSE.
+ l_sco = .TRUE. ! old logical ==> to be removed
+ !
+ ! !* depth : 3D reference (without partial cell)
+!!st no gdep._0 in ORCA_domcfg.nc from sette
+!!st CALL iom_get( inum, jpdom_global , 'gdept_0' , gdept_0, kfill = jpfillcopy )
+!!st CALL iom_get( inum, jpdom_global , 'gdepw_0' , gdepw_0, kfill = jpfillcopy )
+ !
+ ! !* scale factors : 3D reference (can include partial cell)
+ CALL iom_get( inum, jpdom_global, 'e3t_0' , e3t_3d , cd_type = 'T', psgn = 1._wp, kfill = jpfillcopy )
+ CALL iom_get( inum, jpdom_global, 'e3u_0' , e3u_3d , cd_type = 'U', psgn = 1._wp, kfill = jpfillcopy )
+ CALL iom_get( inum, jpdom_global, 'e3v_0' , e3v_3d , cd_type = 'V', psgn = 1._wp, kfill = jpfillcopy )
+ CALL iom_get( inum, jpdom_global, 'e3f_0' , e3f_3d , cd_type = 'F', psgn = 1._wp, kfill = jpfillcopy )
+ CALL iom_get( inum, jpdom_global, 'e3w_0' , e3w_3d , cd_type = 'W', psgn = 1._wp, kfill = jpfillcopy )
+ CALL iom_get( inum, jpdom_global, 'e3uw_0' , e3uw_3d, cd_type = 'U', psgn = 1._wp, kfill = jpfillcopy )
+ CALL iom_get( inum, jpdom_global, 'e3vw_0' , e3vw_3d, cd_type = 'V', psgn = 1._wp, kfill = jpfillcopy )
+ !
+!!st PATCH for ORCA see above no gdep._0 in ORCA_domcfg.nc
+ IF( iom_varid( inum, 'gdept_0' , ldstop = .FALSE. ) > 0 .AND. &
+ & iom_varid( inum, 'gdepw_0' , ldstop = .FALSE. ) > 0 ) THEN
+ CALL ctl_warn( 'zgr_read : old definition of depths and scale factors used ', &
+ & ' depths at t- and w-points read in the domain configuration file')
+ CALL iom_get( inum, jpdom_global , 'gdept_0' , gdept_3d, kfill = jpfillcopy )
+ CALL iom_get( inum, jpdom_global , 'gdepw_0' , gdepw_3d, kfill = jpfillcopy )
+ !
+ ELSE !- depths computed from e3. scale factors
+ CALL e3_to_depth( e3t_3d , e3w_3d , gdept_3d , gdepw_3d ) ! 3D depths
+ ENDIF
+!!st
+ ! !* reference depth for negative bathy (wetting and drying only)
+ IF( ll_wd ) CALL iom_get( inum, 'rn_wd_ref_depth' , ssh_ref )
!
+ ! !----------------------!
+ ELSEIF( lk_ALE ) THEN !-- ALE-coordinate --! combine time & space variations
+ ! !----------------------!
+ !!gm
+ ! to be done : no restart read the 3D ref coord in domcfg to set coordinate at Nbb (and Nnn in MLF case)
+ ! : restart read the 3D ref coord when restart at Nbb (and Nnn in MLF case)
+ !
+ ! Initialisation only (NO restart)
+ ! !* depth : 4D fields (without partial cell)
+! CALL iom_get( inum, jpdom_global , 'gdept' , gdept(:,:,:,Kbb), kfill = jpfillcopy )
+! CALL iom_get( inum, jpdom_global , 'gdepw' , gdepw, kfill = jpfillcopy )
+! !
+! ! !* scale factors : 4D fields (can include partial cell)
+! CALL iom_get( inum, jpdom_global, 'e3t_0' , e3t(:,:,:,Kbb), cd_type = 'T', psgn = 1._wp, kfill = jpfillcopy )
+! CALL iom_get( inum, jpdom_global, 'e3u_0' , e3u(:,:,:,Kbb), cd_type = 'U', psgn = 1._wp, kfill = jpfillcopy )
+! CALL iom_get( inum, jpdom_global, 'e3v_0' , e3v(:,:,:,Kbb), cd_type = 'V', psgn = 1._wp, kfill = jpfillcopy )
+! CALL iom_get( inum, jpdom_global, 'e3f_0' , e3f(:,:,:,Kbb), cd_type = 'F', psgn = 1._wp, kfill = jpfillcopy )
+! CALL iom_get( inum, jpdom_global, 'e3w_0' , e3w(:,:,:,Kbb), cd_type = 'W', psgn = 1._wp, kfill = jpfillcopy )
+! CALL iom_get( inum, jpdom_global, 'e3uw_0' , e3uw(:,:,:,Kbb), cd_type = 'U', psgn = 1._wp, kfill = jpfillcopy )
+! CALL iom_get( inum, jpdom_global, 'e3vw_0' , e3vw(:,:,:,Kbb), cd_type = 'V', psgn = 1._wp, kfill = jpfillcopy )
+ !!gm
+ ENDIF
+ !
+ CALL iom_close( inum ) ! close domcfg file
+ !
+ ! !==================================!
ELSE !== User defined configuration ==!
+ ! !==================================!
IF(lwp) WRITE(numout,*)
IF(lwp) WRITE(numout,*) ' User defined vertical mesh (usr_def_zgr)'
is_mbkuvf = 0
!
- CALL usr_def_zgr( ln_zco , ln_zps , ln_sco, ln_isfcav, &
- & gdept_1d, gdepw_1d, e3t_1d, e3w_1d , & ! 1D gridpoints depth
- & gdept_0 , gdepw_0 , & ! gridpoints depth
- & e3t_0 , e3u_0 , e3v_0 , e3f_0 , & ! vertical scale factors
- & e3w_0 , e3uw_0 , e3vw_0 , & ! vertical scale factors
- & k_top , k_bot ) ! 1st & last ocean level
- !
- ! make sure that periodicities are properly applied
- CALL lbc_lnk( 'dom_zgr', gdept_0, 'T', 1._wp, gdepw_0, 'W', 1._wp, &
- & e3t_0, 'T', 1._wp, e3u_0, 'U', 1._wp, e3v_0, 'V', 1._wp, e3f_0, 'F', 1._wp, &
- & e3w_0, 'W', 1._wp, e3uw_0, 'U', 1._wp, e3vw_0, 'V', 1._wp, &
- & kfillmode = jpfillcopy ) ! do not put 0 over closed boundaries
+ IF( lk_linssh .OR. lk_qco ) THEN
+ ! !--------------------!
+ IF( lk_vco_1d ) THEN !-- z-coordinate --! use only 1D arrays for all gdep and e3 fields
+ ! !--------------------!
+ l_zco = .TRUE. ! old logical ==> to be removed
+ l_zps = .FALSE.
+ l_sco = .FALSE.
+ !
+ CALL usr_def_zgr( l_zco , l_zps , l_sco, ln_isfcav, &
+ & k_top , k_bot , & ! 1st & last ocean level
+ & gdept_1d, gdepw_1d, e3t_1d, e3w_1d ) ! 1D gridpoints depth
+ ! !-----------------------!
+ ELSEIF( lk_vco_1d3d ) THEN !-- z-partial cells --! use 3D t-level e3
+ ! !-----------------------!
+ l_zco = .FALSE. ! old logical ==> to be removed
+ l_zps = .TRUE.
+ l_sco = .FALSE.
+ !
+ CALL usr_def_zgr( l_zco , l_zps , l_sco, ln_isfcav, &
+ & k_top , k_bot , & ! 1st & last ocean level
+ & gdept_1d, gdepw_1d, e3t_1d, e3w_1d , & ! 1D gridpoints depth
+ & e3t_3d , e3u_3d , e3v_3d, e3f_3d ) ! vertical scale factors
+ !
+ ! make sure that periodicities are properly applied
+ CALL lbc_lnk( 'dom_zgr', e3t_3d, 'T', 1._wp, e3u_3d, 'U', 1._wp, e3v_3d, 'V', 1._wp, e3f_3d, 'F', 1._wp, &
+ & kfillmode = jpfillcopy ) ! do not put 0 over closed boundaries
+
+ ! !--------------------!
+ ELSEIF( lk_vco_3d ) THEN !-- s-coordinate --! use 3D for all gdep and e3 fields
+ ! !--------------------!
+ l_zco = .FALSE. ! old logical ==> to be removed
+ l_zps = .FALSE.
+ l_sco = .TRUE.
+ !
+ CALL usr_def_zgr( l_zco , l_zps , l_sco, ln_isfcav, &
+ & k_top , k_bot , & ! 1st & last ocean level
+ & gdept_1d, gdepw_1d, e3t_1d, e3w_1d , & ! 1D gridpoints depth
+ & e3t_3d , e3u_3d , e3v_3d, e3f_3d , & ! vertical scale factors
+ & gdept_3d, gdepw_3d , & ! gridpoints depth
+ & e3w_3d , e3uw_3d , e3vw_3d ) ! vertical scale factors
+ CALL lbc_lnk( 'dom_zgr', gdept_3d, 'T', 1._wp, gdepw_3d, 'W', 1._wp, &
+ & e3t_3d, 'T', 1._wp, e3u_3d, 'U', 1._wp, e3v_3d, 'V', 1._wp, e3f_3d, 'F', 1._wp, &
+ & e3w_3d, 'W', 1._wp, e3uw_3d, 'U', 1._wp, e3vw_3d, 'V', 1._wp, &
+ & kfillmode = jpfillcopy ) ! do not put 0 over closed boundaries
+ ENDIF
+ ENDIF
ztopbot(:,:,1) = REAL(k_top, wp)
ztopbot(:,:,2) = REAL(k_bot, wp)
CALL lbc_lnk( 'dom_zgr', ztopbot, 'T', 1._wp, kfillmode = jpfillcopy ) ! do not put 0 over closed boundaries
@@ -130,30 +284,18 @@ CONTAINS
!
zmsk(:,:) = 1._wp ! default: no closed boundaries
IF( .NOT. l_Iperio ) THEN ! E-W closed:
- zmsk( mi0( 1+nn_hls):mi1( 1+nn_hls),:) = 0._wp ! first column of inner global domain at 0
- zmsk( mi0(jpiglo-nn_hls):mi1(jpiglo-nn_hls),:) = 0._wp ! last column of inner global domain at 0
+ zmsk( mi0( 1+nn_hls,nn_hls):mi1( 1+nn_hls,nn_hls),:) = 0._wp ! first column of inner global domain at 0
+ zmsk( mi0(jpiglo-nn_hls,nn_hls):mi1(jpiglo-nn_hls,nn_hls),:) = 0._wp ! last column of inner global domain at 0
ENDIF
IF( .NOT. l_Jperio ) THEN ! S closed:
- zmsk(:,mj0( 1+nn_hls):mj1( 1+nn_hls) ) = 0._wp ! first line of inner global domain at 0
+ zmsk(:,mj0( 1+nn_hls,nn_hls):mj1( 1+nn_hls,nn_hls) ) = 0._wp ! first line of inner global domain at 0
ENDIF
IF( .NOT. ( l_Jperio .OR. l_NFold ) ) THEN ! N closed:
- zmsk(:,mj0(jpjglo-nn_hls):mj1(jpjglo-nn_hls) ) = 0._wp ! last line of inner global domain at 0
+ zmsk(:,mj0(jpjglo-nn_hls,nn_hls):mj1(jpjglo-nn_hls,nn_hls) ) = 0._wp ! last line of inner global domain at 0
ENDIF
CALL lbc_lnk( 'usrdef_zgr', zmsk, 'T', 1. ) ! set halos
k_top(:,:) = k_top(:,:) * NINT( zmsk(:,:) )
!
-#if ! defined key_qco && ! defined key_linssh
- ! OLD implementation of coordinate (not with 'key_qco' or 'key_linssh')
- ! gde3w_0 has to be defined
-!!gm to be remove when removing the OLD definition of e3 scale factors so that gde3w_0=gdept_0
-!!gm therefore gde3w_0 disappears
- ! Compute gde3w_0 (vertical sum of e3w)
- gde3w_0(:,:,1) = 0.5_wp * e3w_0(:,:,1)
- DO jk = 2, jpk
- gde3w_0(:,:,jk) = gde3w_0(:,:,jk-1) + e3w_0(:,:,jk)
- END DO
-#endif
- !
! Any closed seas (defined by closea_mask > 0 in domain_cfg file) to be filled
! in at runtime if ln_closea=.false.
IF( ln_closea ) THEN
@@ -170,29 +312,39 @@ CONTAINS
IF(lwp) THEN ! Control print
WRITE(numout,*)
WRITE(numout,*) ' Type of vertical coordinate (read in ', TRIM( cn_domcfg ), ' file or set in userdef_nam) :'
- WRITE(numout,*) ' z-coordinate - full steps ln_zco = ', ln_zco
- WRITE(numout,*) ' z-coordinate - partial steps ln_zps = ', ln_zps
- WRITE(numout,*) ' s- or hybrid z-s-coordinate ln_sco = ', ln_sco
+ WRITE(numout,*) ' z-coordinate - full steps l_zco = ', l_zco
+ WRITE(numout,*) ' z-coordinate - partial steps l_zps = ', l_zps
+ WRITE(numout,*) ' s- or hybrid z-s-coordinate l_sco = ', l_sco
WRITE(numout,*) ' ice shelf cavities ln_isfcav = ', ln_isfcav
ENDIF
ioptio = 0 ! Check Vertical coordinate options
- IF( ln_zco ) ioptio = ioptio + 1
- IF( ln_zps ) ioptio = ioptio + 1
- IF( ln_sco ) ioptio = ioptio + 1
+ IF( l_zco ) ioptio = ioptio + 1
+ IF( l_zps ) ioptio = ioptio + 1
+ IF( l_sco ) ioptio = ioptio + 1
IF( ioptio /= 1 ) CALL ctl_stop( ' none or several vertical coordinate options used' )
! ! top/bottom ocean level indices for t-, u- and v-points (f-point also for top)
CALL zgr_top_bot( k_top, k_bot, is_mbkuvf ) ! with a minimum value set to 1
!
- ! ! ice shelf draft and bathymetry
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
- ikt = mikt(ji,jj)
- ikb = mbkt(ji,jj)
- bathy (ji,jj) = gdepw_0(ji,jj,ikb+1)
- risfdep(ji,jj) = gdepw_0(ji,jj,ikt )
- END_2D
+ IF( lk_vco_3d ) THEN
+ ! ! ice shelf draft and bathymetry
+ DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ ikt = mikt(ji,jj)
+ ikb = mbkt(ji,jj)
+ bathy (ji,jj) = gdepw_3d(ji,jj,ikb+1)
+ risfdep(ji,jj) = gdepw_3d(ji,jj,ikt )
+ END_2D
+ ELSE
+ ! ! ice shelf draft and bathymetry
+ DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ ikt = mikt(ji,jj)
+ ikb = mbkt(ji,jj)
+ bathy (ji,jj) = gdepw_1d(ikb+1)
+ risfdep(ji,jj) = gdepw_1d(ikt )
+ END_2D
+ ENDIF
!
! ! deepest/shallowest W level Above/Below ~10m
!!gm BUG in s-coordinate this does not work!
@@ -204,25 +356,25 @@ CONTAINS
IF( lwp ) THEN
WRITE(numout,*) ' MIN val k_top ', MINVAL( k_top(:,:) ), ' MAX ', MAXVAL( k_top(:,:) )
WRITE(numout,*) ' MIN val k_bot ', MINVAL( k_bot(:,:) ), ' MAX ', MAXVAL( k_bot(:,:) )
- WRITE(numout,*) ' MIN val depth t ', MINVAL( gdept_0(:,:,:) ), &
-#if ! defined key_qco && ! defined key_linssh
- & '3w ', MINVAL( gde3w_0(:,:,:) ), &
-#endif
- & ' w ', MINVAL( gdepw_0(:,:,:) )
- WRITE(numout,*) ' MIN val e3 t ', MINVAL( e3t_0(:,:,:) ), ' f ', MINVAL( e3f_0(:,:,:) ), &
- & ' u ', MINVAL( e3u_0(:,:,:) ), ' u ', MINVAL( e3v_0(:,:,:) ), &
- & ' uw', MINVAL( e3uw_0(:,:,:) ), ' vw', MINVAL( e3vw_0(:,:,:)), &
- & ' w ', MINVAL( e3w_0(:,:,:) )
-
- WRITE(numout,*) ' MAX val depth t ', MAXVAL( gdept_0(:,:,:) ), &
-#if ! defined key_qco && ! defined key_linssh
- & '3w ', MINVAL( gde3w_0(:,:,:) ), &
-#endif
- & ' w ', MINVAL( gdepw_0(:,:,:) )
- WRITE(numout,*) ' MAX val e3 t ', MAXVAL( e3t_0(:,:,:) ), ' f ', MAXVAL( e3f_0(:,:,:) ), &
- & ' u ', MAXVAL( e3u_0(:,:,:) ), ' u ', MAXVAL( e3v_0(:,:,:) ), &
- & ' uw', MAXVAL( e3uw_0(:,:,:) ), ' vw', MAXVAL( e3vw_0(:,:,:) ), &
- & ' w ', MAXVAL( e3w_0(:,:,:) )
+ IF( lk_vco_1d3d ) THEN
+ WRITE(numout,*) ' MIN val e3 t ', MINVAL( e3t_3d(:,:,:) ), ' f ', MINVAL( e3f_3d(:,:,:) ), &
+ & ' u ', MINVAL( e3u_3d(:,:,:) ), ' u ', MINVAL( e3v_3d(:,:,:) )
+ WRITE(numout,*) ' MAX val e3 t ', MAXVAL( e3t_3d(:,:,:) ), ' f ', MAXVAL( e3f_3d(:,:,:) ), &
+ & ' u ', MAXVAL( e3u_3d(:,:,:) ), ' u ', MAXVAL( e3v_3d(:,:,:) )
+ ELSEIF( lk_vco_3d ) THEN
+ WRITE(numout,*) ' MIN val depth t ', MINVAL( gdept_3d(:,:,:) ), &
+ & ' w ', MINVAL( gdepw_3d(:,:,:) )
+ WRITE(numout,*) ' MIN val e3 t ', MINVAL( e3t_3d(:,:,:) ), ' f ', MINVAL( e3f_3d(:,:,:) ), &
+ & ' u ', MINVAL( e3u_3d(:,:,:) ), ' u ', MINVAL( e3v_3d(:,:,:) ), &
+ & ' uw', MINVAL( e3uw_3d(:,:,:) ), ' vw', MINVAL( e3vw_3d(:,:,:)), &
+ & ' w ', MINVAL( e3w_3d(:,:,:) )
+ WRITE(numout,*) ' MAX val depth t ', MAXVAL( gdept_3d(:,:,:) ), &
+ & ' w ', MINVAL( gdepw_3d(:,:,:) )
+ WRITE(numout,*) ' MAX val e3 t ', MAXVAL( e3t_3d(:,:,:) ), ' f ', MAXVAL( e3f_3d(:,:,:) ), &
+ & ' u ', MAXVAL( e3u_3d(:,:,:) ), ' u ', MAXVAL( e3v_3d(:,:,:) ), &
+ & ' uw', MAXVAL( e3uw_3d(:,:,:) ), ' vw', MAXVAL( e3vw_3d(:,:,:) ), &
+ & ' w ', MAXVAL( e3w_3d(:,:,:) )
+ ENDIF
ENDIF
!
END SUBROUTINE dom_zgr
diff --git a/src/OCE/DOM/domzgr_substitute.h90 b/src/OCE/DOM/domzgr_substitute.h90
index 35173ccb8d24651892c617e16bedbf25ad59a67f..333e231c15d9f8b7da94ada66f3339277b024780 100644
--- a/src/OCE/DOM/domzgr_substitute.h90
+++ b/src/OCE/DOM/domzgr_substitute.h90
@@ -1,3 +1,5 @@
+#if defined show_comments
+! These comments are not intended to be retained during preprocessing; i.e. do not define "show_comments"
!!----------------------------------------------------------------------
!! *** domzgr_substitute.h90 ***
!!----------------------------------------------------------------------
@@ -5,49 +7,753 @@
!! factors depending on the vertical coord. used, using CPP macro.
!!----------------------------------------------------------------------
!! History : 4.2 ! 2020-02 (S. Techene, G. Madec) star coordinate
+!! 4.5 ! 2022-08 (S. Techene, G. Madec) simplified formulation
!!----------------------------------------------------------------------
!! NEMO/OCE 4.2 , NEMO Consortium (2020)
!! $Id$
!! Software governed by the CeCILL license (see ./LICENSE)
!!----------------------------------------------------------------------
-#if defined key_qco
-# define e3t(i,j,k,t) (e3t_0(i,j,k)*(1._wp+r3t(i,j,t)*tmask(i,j,k)))
-# define e3u(i,j,k,t) (e3u_0(i,j,k)*(1._wp+r3u(i,j,t)*umask(i,j,k)))
-# define e3v(i,j,k,t) (e3v_0(i,j,k)*(1._wp+r3v(i,j,t)*vmask(i,j,k)))
-# define e3f(i,j,k) (e3f_0(i,j,k)*(1._wp+r3f(i,j)*fe3mask(i,j,k)))
-# define e3f_vor(i,j,k) (e3f_0vor(i,j,k)*(1._wp+r3f(i,j)*fe3mask(i,j,k)))
-# define e3w(i,j,k,t) (e3w_0(i,j,k)*(1._wp+r3t(i,j,t)))
-# define e3uw(i,j,k,t) (e3uw_0(i,j,k)*(1._wp+r3u(i,j,t)))
-# define e3vw(i,j,k,t) (e3vw_0(i,j,k)*(1._wp+r3v(i,j,t)))
-# define ht(i,j) (ht_0(i,j)*(1._wp+r3t(i,j,Kmm)))
-# define hu(i,j,t) (hu_0(i,j)*(1._wp+r3u(i,j,t)))
-# define hv(i,j,t) (hv_0(i,j)*(1._wp+r3v(i,j,t)))
-# define r1_hu(i,j,t) (r1_hu_0(i,j)/(1._wp+r3u(i,j,t)))
-# define r1_hv(i,j,t) (r1_hv_0(i,j)/(1._wp+r3v(i,j,t)))
-# if defined key_isf
-# define gdept(i,j,k,t) ((gdept_0(i,j,k)-risfdep(i,j))*(1._wp+r3t(i,j,t))+risfdep(i,j))
-# define gdepw(i,j,k,t) ((gdepw_0(i,j,k)-risfdep(i,j))*(1._wp+r3t(i,j,t))+risfdep(i,j))
-# else
-# define gdept(i,j,k,t) (gdept_0(i,j,k)*(1._wp+r3t(i,j,t)))
-# define gdepw(i,j,k,t) (gdepw_0(i,j,k)*(1._wp+r3t(i,j,t)))
+!
+! key_qco : e3#(i,j,k,t) = (E3#_0(i,j,k)*(1._wp+r3#(i,j,t)#mask(i,j,k))) = (E3#_0(i,j,k) Tmsk(r3#,#mask))
+!
+! key_lin : e3#(i,j,k,t) = (E3#_0(i,j,k))
+!
+! key_qco : gdep#(i,j,k,t) = (gdep#_0(i,j,k)*(1._wp+r3#(i,j,t))) = (gdep#_0(i,j,k) Time(r3#)
+! + isf gdep#(i,j,k,t) = ((gdept_0(i,j,k)-risfdep(i,j))*(1._wp+r3#(i,j,t))+risfdep(i,j)) = ((gdep#_0(i,j,k) Tisf(r3#,risfdep)
+!
+! key_lin : gdep#(i,j,k,t) = (gdep#_0(i,j,k))
+!
+! NEW keys
+!
+! key_zco : E3#_0(i,j,k) = e3#_1d(k)
+! DEP#_0(i,j,k) = gdep#_0(k)
+! key_zps : At a T-level partial-step point e3 are reduced (use 3D fields), not at a W-level (use 1D fields)
+! E3#_0(i,j,k) = e3#_0(i,j,k) for t-,u-,v-,f-points
+! E3#_0(i,j,k) = e3#_1d(k) for # = w-,uw-,vw-points
+! but both gdept, gdepw remain at the 1D reference depth:
+! DEP#_0(i,j,k) = gdep#_1d(k)
+! key_sco : gdep# and e3# vary with ocean depth : use 3D fields
+! E3#_0(i,j,k) = e3#_1d(i,j,k)
+! DEP#_0(i,j,k) = gdep#_0(i,j,k)
+! key_ALE : gdep# and e3# vary in space AND time thus no substitution is required
+! NB: key_ALE currently not available (and thus key_ztilde)
+!
+!
+! CAUTION e3fvor calculation at each timestep ==>>> not in a DO_3D ....
+!!----------------------------------------------------------------------
+#endif
+
+# if defined key_qco
+# define Tmsk(r3,msk,i,j,k,t) *(1._wp+r3(i,j,t)*msk(i,j,k))
+!!st - this should desapear (a terme r3f aura un indice temporel)
+# define Tmskf(r3,msk,i,j,k,t) *(1._wp+r3(i,j)*msk(i,j,k))
+!st
+# define Time(r3,i,j,t) *(1._wp+r3(i,j,t))
+# define Divi(r3,i,j,t) /(1._wp+r3(i,j,t))
+# define DEPT_z0(i,j,k,t) gdept(i,j,k,t)-ssh(i,j,t)
+# if defined key_isf
+# define Tisf(r3,isf,i,j,t) -isf(i,j)) Time(r3,i,j,t)+isf(i,j)
+# else
+# define Tisf(r3,isf,i,j,t) ) Time(r3,i,j,t)
+# endif
+# elif defined key_linssh
+# define Tmsk(r3,msk,i,j,k,t)
+# define Tmskf(r3,msk,i,j,k,t)
+# define Time(r3,i,j,t)
+# define Divi(r3,i,j,t)
+# define DEPT_z0(i,j,k,t) gdept(i,j,k,Kmm)
+# if defined key_isf
+# define Tisf(r3,isf,i,j,t)
+# else
+# define Tisf(r3,isf,i,j,t) )
+# endif
+# endif
+
+#if defined key_vco_1d || defined key_vco_1d3d
+# define E3w_0(i,j,k) e3w_1d(k)
+# define E3uw_0(i,j,k) e3w_1d(k)
+# define E3vw_0(i,j,k) e3w_1d(k)
+# define DEPt_0(i,j,k) gdept_1d(k)
+# define DEPw_0(i,j,k) gdepw_1d(k)
+# define E3fv_0(i,j,k) e3f_0vor(i,j,k)
+# define gdept_0(i,j,k) gdept_1d(k)
+# define gdepw_0(i,j,k) gdepw_1d(k)
+# define e3w_0(i,j,k) e3w_1d(k)
+# define e3uw_0(i,j,k) e3w_1d(k)
+# define e3vw_0(i,j,k) e3w_1d(k)
+# if defined key_vco_1d
+# define E3t_0(i,j,k) e3t_1d(k)
+# define E3u_0(i,j,k) e3t_1d(k)
+# define E3v_0(i,j,k) e3t_1d(k)
+# define E3f_0(i,j,k) e3t_1d(k)
+# define e3t_0(i,j,k) e3t_1d(k)
+# define e3u_0(i,j,k) e3t_1d(k)
+# define e3v_0(i,j,k) e3t_1d(k)
+# define e3f_0(i,j,k) e3t_1d(k)
+# elif defined key_vco_1d3d
+# define E3t_0(i,j,k) e3t_3d(i,j,k)
+# define E3u_0(i,j,k) e3u_3d(i,j,k)
+# define E3v_0(i,j,k) e3v_3d(i,j,k)
+# define E3f_0(i,j,k) e3f_3d(i,j,k)
+# define e3t_0(i,j,k) e3t_3d(i,j,k)
+# define e3u_0(i,j,k) e3u_3d(i,j,k)
+# define e3v_0(i,j,k) e3v_3d(i,j,k)
+# define e3f_0(i,j,k) e3f_3d(i,j,k)
# endif
-# define gde3w(i,j,k) (gdept(i,j,k,Kmm)-ssh(i,j,Kmm))
-#elif defined key_linssh
-# define e3t(i,j,k,t) e3t_0(i,j,k)
-# define e3u(i,j,k,t) e3u_0(i,j,k)
-# define e3v(i,j,k,t) e3v_0(i,j,k)
-# define e3f(i,j,k) e3f_0(i,j,k)
-# define e3f_vor(i,j,k) e3f_0vor(i,j,k)
-# define e3w(i,j,k,t) e3w_0(i,j,k)
-# define e3uw(i,j,k,t) e3uw_0(i,j,k)
-# define e3vw(i,j,k,t) e3vw_0(i,j,k)
-# define ht(i,j) ht_0(i,j)
-# define hu(i,j,t) hu_0(i,j)
-# define hv(i,j,t) hv_0(i,j)
-# define r1_hu(i,j,t) r1_hu_0(i,j)
-# define r1_hv(i,j,t) r1_hv_0(i,j)
-# define gdept(i,j,k,t) gdept_0(i,j,k)
-# define gdepw(i,j,k,t) gdepw_0(i,j,k)
-# define gde3w(i,j,k) gdept_0(i,j,k)
+#elif defined key_vco_3d
+# define E3w_0(i,j,k) e3w_3d(i,j,k)
+# define E3uw_0(i,j,k) e3uw_3d(i,j,k)
+# define E3vw_0(i,j,k) e3vw_3d(i,j,k)
+# define DEPt_0(i,j,k) gdept_3d(i,j,k)
+# define DEPw_0(i,j,k) gdepw_3d(i,j,k)
+# define e3w_0(i,j,k) e3w_3d(i,j,k)
+# define e3uw_0(i,j,k) e3uw_3d(i,j,k)
+# define e3vw_0(i,j,k) e3vw_3d(i,j,k)
+# define gdept_0(i,j,k) gdept_3d(i,j,k)
+# define gdepw_0(i,j,k) gdepw_3d(i,j,k)
+!
+# define E3t_0(i,j,k) e3t_3d(i,j,k)
+# define E3u_0(i,j,k) e3u_3d(i,j,k)
+# define E3v_0(i,j,k) e3v_3d(i,j,k)
+# define E3f_0(i,j,k) e3f_3d(i,j,k)
+# define E3fv_0(i,j,k) e3f_0vor(i,j,k)
+# define e3t_0(i,j,k) e3t_3d(i,j,k)
+# define e3u_0(i,j,k) e3u_3d(i,j,k)
+# define e3v_0(i,j,k) e3v_3d(i,j,k)
+# define e3f_0(i,j,k) e3f_3d(i,j,k)
+#endif
+!
+#if defined key_qco || defined key_linssh || defined key_vco_1d || defined key_vco_1d3d || defined key_vco_3d
+# define e3t(i,j,k,t) (E3t_0(i,j,k) Tmsk(r3t,tmask,i,j,k,t))
+# define e3u(i,j,k,t) (E3u_0(i,j,k) Tmsk(r3u,umask,i,j,k,t))
+# define e3v(i,j,k,t) (E3v_0(i,j,k) Tmsk(r3v,vmask,i,j,k,t))
+# define e3f(i,j,k) (E3f_0(i,j,k) Tmskf(r3f,fe3mask,i,j,k,t))
+# define e3f_vor(i,j,k) (E3fv_0(i,j,k) Tmskf(r3f,fe3mask,i,j,k,t))
+# define e3w(i,j,k,t) (E3w_0(i,j,k) Time(r3t,i,j,t))
+# define e3uw(i,j,k,t) (E3uw_0(i,j,k) Time(r3u,i,j,t))
+# define e3vw(i,j,k,t) (E3vw_0(i,j,k) Time(r3v,i,j,t))
+# define ht(i,j,t) (ht_0(i,j) Time(r3t,i,j,t))
+# define hu(i,j,t) (hu_0(i,j) Time(r3u,i,j,t))
+# define hv(i,j,t) (hv_0(i,j) Time(r3v,i,j,t))
+# define r1_hu(i,j,t) (r1_hu_0(i,j) Divi(r3u,i,j,t))
+# define r1_hv(i,j,t) (r1_hv_0(i,j) Divi(r3v,i,j,t))
+# define gdept(i,j,k,t) ((DEPt_0(i,j,k) Tisf(r3t,risfdep,i,j,t))
+# define gdepw(i,j,k,t) ((DEPw_0(i,j,k) Tisf(r3t,risfdep,i,j,t))
+#endif
+# define gdept_z0(i,j,k,t) (gdept(i,j,k,t)-ssh(i,j,t))
+
+#if defined show_comments
+!!!!----------------------------------------------------------------------
+!!!!----------------------------------------------------------------------
+!!!
+!!! zps + qco
+!!!
+!!e3t(ji,jj,jk,kt)
+!!e3u(ji,jj,jk,kt)
+!!e3v(ji,jj,jk,kt)
+!!e3f(ji,jj,jk)
+!!e3f_vor(ji,jj,jk)
+!!e3w(ji,jj,jk,kt)
+!!e3uw(ji,jj,jk,kt)
+!!e3vw(ji,jj,jk,kt)
+!!ht(ji,jj,kt)
+!!hu(ji,jj,kt)
+!!hv(ji,jj,kt)
+!!r1_hu(ji,jj,kt)
+!!r1_hv(ji,jj,kt)
+!!gdept(ji,jj,jk,kt)
+!!gdepw(ji,jj,jk,kt)
+!!gdept_z0(ji,jj,jk,kt)
+!!!
+!!#undef Tmsk
+!!#undef Time
+!!#undef Divi
+!!#undef DEPT_z0
+!!#undef Tisf
+!!#undef E3w_0
+!!#undef E3uw_0
+!!#undef E3vw_0
+!!#undef E3t_0
+!!#undef E3u_0
+!!#undef E3v_0
+!!#undef E3f_0
+!!#undef DEPt_0
+!!#undef DEPw_0
+!!#undef E3fv_0
+!!!
+!!#undef key_zps
+!!#define key_zco
+!!!
+!!! zco + qco
+!!!
+!!# if defined key_qco
+!!# define Tmsk(r3,msk,i,j,k,t) *(1._wp+r3(i,j,t)*msk(i,j,k))
+!!# define Time(r3,i,j,t) *(1._wp+r3(i,j,t))
+!!# define Divi(r3,i,j,t) /(1._wp+r3(i,j,t))
+!!# define DEPT_z0(i,j,k,t) gdept(i,j,k,t)-ssh(i,j,t)
+!!# if defined key_isf
+!!# define Tisf(r3,isf,i,j,t) -isf(i,j)) Time(r3,i,j,t)+isf(i,j)
+!!# else
+!!# define Tisf(r3,isf,i,j,t) ) Time(r3,i,j,t)
+!!# endif
+!!# elif defined key_linssh
+!!# define Tmsk(r3,msk,i,j,k,t)
+!!# define Time(r3,i,j,t)
+!!# define Divi(r3,i,j,t)
+!!# define DEPT_z0(i,j,k,t) gdept(i,j,k,Kmm)
+!!# if defined key_isf
+!!# define Tisf(r3,isf,i,j,t)
+!!# else
+!!# define Tisf(r3,isf,i,j,t) )
+!!# endif
+!!# endif
+!!
+!!#if defined key_zco || defined key_zps
+!!# define E3w_0(i,j,k) e3w_1d(k)
+!!# define E3uw_0(i,j,k) e3uw_1d(k)
+!!# define E3vw_0(i,j,k) e3vw_1d(k)
+!!# define DEPt_0(i,j,k) gdept_1d(k)
+!!# define DEPw_0(i,j,k) gdepw_1d(k)
+!!# define E3fv_0(i,j,k) e3fvor_0(i,j,k)
+!!# if defined key_zco
+!!# define E3t_0(i,j,k) e3t_1d(k)
+!!# define E3u_0(i,j,k) e3t_1d(k)
+!!# define E3v_0(i,j,k) e3t_1d(k)
+!!# define E3f_0(i,j,k) e3t_1d(k)
+!!# elif defined key_zps
+!!# define E3t_0(i,j,k) e3t_0(i,j,k)
+!!# define E3u_0(i,j,k) e3u_0(i,j,k)
+!!# define E3v_0(i,j,k) e3v_0(i,j,k)
+!!# define E3f_0(i,j,k) e3f_0(i,j,k)
+!!# endif
+!!#elif defined key_sco
+!!# define E3w_0(i,j,k) e3w_0(i,j,k)
+!!# define E3uw_0(i,j,k) e3uw_0(i,j,k)
+!!# define E3vw_0(i,j,k) e3vw_0(i,j,k)
+!!# define DEPt_0(i,j,k) gdept_0(i,j,k)
+!!# define DEPw_0(i,j,k) gdepw_0(i,j,k)
+!! !
+!!# define E3t_0(i,j,k) e3t_0(i,j,k)
+!!# define E3u_0(i,j,k) e3u_0(i,j,k)
+!!# define E3v_0(i,j,k) e3v_0(i,j,k)
+!!# define E3f_0(i,j,k) e3f_0(i,j,k)
+!!# define E3fv_0(i,j,k) e3fvor_0(i,j,k)
+!!#endif
+!!!
+!!e3t(ji,jj,jk,kt)
+!!e3u(ji,jj,jk,kt)
+!!e3v(ji,jj,jk,kt)
+!!e3f(ji,jj,jk)
+!!e3f_vor(ji,jj,jk)
+!!e3w(ji,jj,jk,kt)
+!!e3uw(ji,jj,jk,kt)
+!!e3vw(ji,jj,jk,kt)
+!!ht(ji,jj,kt)
+!!hu(ji,jj,kt)
+!!hv(ji,jj,kt)
+!!r1_hu(ji,jj,kt)
+!!r1_hv(ji,jj,kt)
+!!gdept(ji,jj,jk,kt)
+!!gdepw(ji,jj,jk,kt)
+!!gdept_z0(ji,jj,jk,kt)
+!!!
+!!#undef Tmsk
+!!#undef Time
+!!#undef Divi
+!!#undef DEPT_z0
+!!#undef Tisf
+!!#undef E3w_0
+!!#undef E3uw_0
+!!#undef E3vw_0
+!!#undef E3t_0
+!!#undef E3u_0
+!!#undef E3v_0
+!!#undef E3f_0
+!!#undef DEPt_0
+!!#undef DEPw_0
+!!#undef E3fv_0
+!!!
+!!#undef key_zco
+!!#define key_sco
+!!!
+!!! sco + qco
+!!!
+!!# if defined key_qco
+!!# define Tmsk(r3,msk,i,j,k,t) *(1._wp+r3(i,j,t)*msk(i,j,k))
+!!# define Time(r3,i,j,t) *(1._wp+r3(i,j,t))
+!!# define Divi(r3,i,j,t) /(1._wp+r3(i,j,t))
+!!# define DEPT_z0(i,j,k,t) gdept(i,j,k,t)-ssh(i,j,t)
+!!# if defined key_isf
+!!# define Tisf(r3,isf,i,j,t) -isf(i,j)) Time(r3,i,j,t)+isf(i,j)
+!!# else
+!!# define Tisf(r3,isf,i,j,t) ) Time(r3,i,j,t)
+!!# endif
+!!# elif defined key_linssh
+!!# define Tmsk(r3,msk,i,j,k,t)
+!!# define Time(r3,i,j,t)
+!!# define Divi(r3,i,j,t)
+!!# define DEPT_z0(i,j,k,t) gdept(i,j,k,Kmm)
+!!# if defined key_isf
+!!# define Tisf(r3,isf,i,j,t)
+!!# else
+!!# define Tisf(r3,isf,i,j,t) )
+!!# endif
+!!# endif
+!!
+!!#if defined key_zco || defined key_zps
+!!# define E3w_0(i,j,k) e3w_1d(k)
+!!# define E3uw_0(i,j,k) e3uw_1d(k)
+!!# define E3vw_0(i,j,k) e3vw_1d(k)
+!!# define DEPt_0(i,j,k) gdept_1d(k)
+!!# define DEPw_0(i,j,k) gdepw_1d(k)
+!!# define E3fv_0(i,j,k) e3fvor_0(i,j,k)
+!!# if defined key_zco
+!!# define E3t_0(i,j,k) e3t_1d(k)
+!!# define E3u_0(i,j,k) e3t_1d(k)
+!!# define E3v_0(i,j,k) e3t_1d(k)
+!!# define E3f_0(i,j,k) e3t_1d(k)
+!!# elif defined key_zps
+!!# define E3t_0(i,j,k) e3t_0(i,j,k)
+!!# define E3u_0(i,j,k) e3u_0(i,j,k)
+!!# define E3v_0(i,j,k) e3v_0(i,j,k)
+!!# define E3f_0(i,j,k) e3f_0(i,j,k)
+!!# endif
+!!#elif defined key_sco
+!!# define E3w_0(i,j,k) e3w_0(i,j,k)
+!!# define E3uw_0(i,j,k) e3uw_0(i,j,k)
+!!# define E3vw_0(i,j,k) e3vw_0(i,j,k)
+!!# define DEPt_0(i,j,k) gdept_0(i,j,k)
+!!# define DEPw_0(i,j,k) gdepw_0(i,j,k)
+!! !
+!!# define E3t_0(i,j,k) e3t_0(i,j,k)
+!!# define E3u_0(i,j,k) e3u_0(i,j,k)
+!!# define E3v_0(i,j,k) e3v_0(i,j,k)
+!!# define E3f_0(i,j,k) e3f_0(i,j,k)
+!!# define E3fv_0(i,j,k) e3fvor_0(i,j,k)
+!!#endif
+!!!
+!!e3t(ji,jj,jk,kt)
+!!e3u(ji,jj,jk,kt)
+!!e3v(ji,jj,jk,kt)
+!!e3f(ji,jj,jk)
+!!e3f_vor(ji,jj,jk)
+!!e3w(ji,jj,jk,kt)
+!!e3uw(ji,jj,jk,kt)
+!!e3vw(ji,jj,jk,kt)
+!!ht(ji,jj,kt)
+!!hu(ji,jj,kt)
+!!hv(ji,jj,kt)
+!!r1_hu(ji,jj,kt)
+!!r1_hv(ji,jj,kt)
+!!gdept(ji,jj,jk,kt)
+!!gdepw(ji,jj,jk,kt)
+!!gdept_z0(ji,jj,jk,kt)
+!!!!----------------------------------------------------------------------
+!!#undef key_qco
+!!#define key_linssh
+!!!
+!!#undef Tmsk
+!!#undef Time
+!!#undef Divi
+!!#undef DEPT_z0
+!!#undef Tisf
+!!#undef E3w_0
+!!#undef E3uw_0
+!!#undef E3vw_0
+!!#undef E3t_0
+!!#undef E3u_0
+!!#undef E3v_0
+!!#undef E3f_0
+!!#undef DEPt_0
+!!#undef DEPw_0
+!!#undef E3fv_0
+!!!
+!!#undef key_sco
+!!#define key_zps
+!!!
+!!! zps + linssh
+!!!
+!!# if defined key_qco
+!!# define Tmsk(r3,msk,i,j,k,t) *(1._wp+r3(i,j,t)*msk(i,j,k))
+!!# define Time(r3,i,j,t) *(1._wp+r3(i,j,t))
+!!# define Divi(r3,i,j,t) /(1._wp+r3(i,j,t))
+!!# define DEPT_z0(i,j,k,t) gdept(i,j,k,t)-ssh(i,j,t)
+!!# if defined key_isf
+!!# define Tisf(r3,isf,i,j,t) -isf(i,j)) Time(r3,i,j,t)+isf(i,j)
+!!# else
+!!# define Tisf(r3,isf,i,j,t) ) Time(r3,i,j,t)
+!!# endif
+!!# elif defined key_linssh
+!!# define Tmsk(r3,msk,i,j,k,t)
+!!# define Time(r3,i,j,t)
+!!# define Divi(r3,i,j,t)
+!!# define DEPT_z0(i,j,k,t) gdept(i,j,k,Kmm)
+!!# if defined key_isf
+!!# define Tisf(r3,isf,i,j,t)
+!!# else
+!!# define Tisf(r3,isf,i,j,t) )
+!!# endif
+!!# endif
+!!
+!!#if defined key_zco || defined key_zps
+!!# define E3w_0(i,j,k) e3w_1d(k)
+!!# define E3uw_0(i,j,k) e3uw_1d(k)
+!!# define E3vw_0(i,j,k) e3vw_1d(k)
+!!# define DEPt_0(i,j,k) gdept_1d(k)
+!!# define DEPw_0(i,j,k) gdepw_1d(k)
+!!# define E3fv_0(i,j,k) e3fvor_0(i,j,k)
+!!# if defined key_zco
+!!# define E3t_0(i,j,k) e3t_1d(k)
+!!# define E3u_0(i,j,k) e3t_1d(k)
+!!# define E3v_0(i,j,k) e3t_1d(k)
+!!# define E3f_0(i,j,k) e3t_1d(k)
+!!# elif defined key_zps
+!!# define E3t_0(i,j,k) e3t_0(i,j,k)
+!!# define E3u_0(i,j,k) e3u_0(i,j,k)
+!!# define E3v_0(i,j,k) e3v_0(i,j,k)
+!!# define E3f_0(i,j,k) e3f_0(i,j,k)
+!!# endif
+!!#elif defined key_sco
+!!# define E3w_0(i,j,k) e3w_0(i,j,k)
+!!# define E3uw_0(i,j,k) e3uw_0(i,j,k)
+!!# define E3vw_0(i,j,k) e3vw_0(i,j,k)
+!!# define DEPt_0(i,j,k) gdept_0(i,j,k)
+!!# define DEPw_0(i,j,k) gdepw_0(i,j,k)
+!! !
+!!# define E3t_0(i,j,k) e3t_0(i,j,k)
+!!# define E3u_0(i,j,k) e3u_0(i,j,k)
+!!# define E3v_0(i,j,k) e3v_0(i,j,k)
+!!# define E3f_0(i,j,k) e3f_0(i,j,k)
+!!# define E3fv_0(i,j,k) e3fvor_0(i,j,k)
+!!#endif
+!!!
+!!e3t(ji,jj,jk,kt)
+!!e3u(ji,jj,jk,kt)
+!!e3v(ji,jj,jk,kt)
+!!e3f(ji,jj,jk)
+!!e3f_vor(ji,jj,jk)
+!!e3w(ji,jj,jk,kt)
+!!e3uw(ji,jj,jk,kt)
+!!e3vw(ji,jj,jk,kt)
+!!ht(ji,jj,kt)
+!!hu(ji,jj,kt)
+!!hv(ji,jj,kt)
+!!r1_hu(ji,jj,kt)
+!!r1_hv(ji,jj,kt)
+!!gdept(ji,jj,jk,kt)
+!!gdepw(ji,jj,jk,kt)
+!!gdept_z0(ji,jj,jk,kt)
+!!!
+!!#undef Tmsk
+!!#undef Time
+!!#undef Divi
+!!#undef DEPT_z0
+!!#undef Tisf
+!!#undef E3w_0
+!!#undef E3uw_0
+!!#undef E3vw_0
+!!#undef E3t_0
+!!#undef E3u_0
+!!#undef E3v_0
+!!#undef E3f_0
+!!#undef DEPt_0
+!!#undef DEPw_0
+!!#undef E3fv_0
+!!!
+!!#undef key_zps
+!!#define key_zco
+!!!
+!!! zco + linssh
+!!!
+!!# if defined key_qco
+!!# define Tmsk(r3,msk,i,j,k,t) *(1._wp+r3(i,j,t)*msk(i,j,k))
+!!# define Time(r3,i,j,t) *(1._wp+r3(i,j,t))
+!!# define Divi(r3,i,j,t) /(1._wp+r3(i,j,t))
+!!# define DEPT_z0(i,j,k,t) gdept(i,j,k,t)-ssh(i,j,t)
+!!# if defined key_isf
+!!# define Tisf(r3,isf,i,j,t) -isf(i,j)) Time(r3,i,j,t)+isf(i,j)
+!!# else
+!!# define Tisf(r3,isf,i,j,t) ) Time(r3,i,j,t)
+!!# endif
+!!# elif defined key_linssh
+!!# define Tmsk(r3,msk,i,j,k,t)
+!!# define Time(r3,i,j,t)
+!!# define Divi(r3,i,j,t)
+!!# define DEPT_z0(i,j,k,t) gdept(i,j,k,Kmm)
+!!# if defined key_isf
+!!# define Tisf(r3,isf,i,j,t)
+!!# else
+!!# define Tisf(r3,isf,i,j,t) )
+!!# endif
+!!# endif
+!!
+!!#if defined key_zco || defined key_zps
+!!# define E3w_0(i,j,k) e3w_1d(k)
+!!# define E3uw_0(i,j,k) e3uw_1d(k)
+!!# define E3vw_0(i,j,k) e3vw_1d(k)
+!!# define DEPt_0(i,j,k) gdept_1d(k)
+!!# define DEPw_0(i,j,k) gdepw_1d(k)
+!!# define E3fv_0(i,j,k) e3fvor_0(i,j,k)
+!!# if defined key_zco
+!!# define E3t_0(i,j,k) e3t_1d(k)
+!!# define E3u_0(i,j,k) e3t_1d(k)
+!!# define E3v_0(i,j,k) e3t_1d(k)
+!!# define E3f_0(i,j,k) e3t_1d(k)
+!!# elif defined key_zps
+!!# define E3t_0(i,j,k) e3t_0(i,j,k)
+!!# define E3u_0(i,j,k) e3u_0(i,j,k)
+!!# define E3v_0(i,j,k) e3v_0(i,j,k)
+!!# define E3f_0(i,j,k) e3f_0(i,j,k)
+!!# endif
+!!#elif defined key_sco
+!!# define E3w_0(i,j,k) e3w_0(i,j,k)
+!!# define E3uw_0(i,j,k) e3uw_0(i,j,k)
+!!# define E3vw_0(i,j,k) e3vw_0(i,j,k)
+!!# define DEPt_0(i,j,k) gdept_0(i,j,k)
+!!# define DEPw_0(i,j,k) gdepw_0(i,j,k)
+!! !
+!!# define E3t_0(i,j,k) e3t_0(i,j,k)
+!!# define E3u_0(i,j,k) e3u_0(i,j,k)
+!!# define E3v_0(i,j,k) e3v_0(i,j,k)
+!!# define E3f_0(i,j,k) e3f_0(i,j,k)
+!!# define E3fv_0(i,j,k) e3fvor_0(i,j,k)
+!!#endif
+!!!
+!!e3t(ji,jj,jk,kt)
+!!e3u(ji,jj,jk,kt)
+!!e3v(ji,jj,jk,kt)
+!!e3f(ji,jj,jk)
+!!e3f_vor(ji,jj,jk)
+!!e3w(ji,jj,jk,kt)
+!!e3uw(ji,jj,jk,kt)
+!!e3vw(ji,jj,jk,kt)
+!!ht(ji,jj,kt)
+!!hu(ji,jj,kt)
+!!hv(ji,jj,kt)
+!!r1_hu(ji,jj,kt)
+!!r1_hv(ji,jj,kt)
+!!gdept(ji,jj,jk,kt)
+!!gdepw(ji,jj,jk,kt)
+!!gdept_z0(ji,jj,jk,kt)
+!!!
+!!#undef Tmsk
+!!#undef Time
+!!#undef Divi
+!!#undef DEPT_z0
+!!#undef Tisf
+!!#undef E3w_0
+!!#undef E3uw_0
+!!#undef E3vw_0
+!!#undef E3t_0
+!!#undef E3u_0
+!!#undef E3v_0
+!!#undef E3f_0
+!!#undef DEPt_0
+!!#undef DEPw_0
+!!#undef E3fv_0
+!!!
+!!#undef key_zco
+!!#define key_sco
+!!!
+!!! sco + linssh
+!!!
+!!# if defined key_qco
+!!# define Tmsk(r3,msk,i,j,k,t) *(1._wp+r3(i,j,t)*msk(i,j,k))
+!!# define Time(r3,i,j,t) *(1._wp+r3(i,j,t))
+!!# define Divi(r3,i,j,t) /(1._wp+r3(i,j,t))
+!!# define DEPT_z0(i,j,k,t) gdept(i,j,k,t)-ssh(i,j,t)
+!!# if defined key_isf
+!!# define Tisf(r3,isf,i,j,t) -isf(i,j)) Time(r3,i,j,t)+isf(i,j)
+!!# else
+!!# define Tisf(r3,isf,i,j,t) ) Time(r3,i,j,t)
+!!# endif
+!!# elif defined key_linssh
+!!# define Tmsk(r3,msk,i,j,k,t)
+!!# define Time(r3,i,j,t)
+!!# define Divi(r3,i,j,t)
+!!# define DEPT_z0(i,j,k,t) gdept(i,j,k,Kmm)
+!!# if defined key_isf
+!!# define Tisf(r3,isf,i,j,t)
+!!# else
+!!# define Tisf(r3,isf,i,j,t) )
+!!# endif
+!!# endif
+!!
+!!#if defined key_zco || defined key_zps
+!!# define E3w_0(i,j,k) e3w_1d(k)
+!!# define E3uw_0(i,j,k) e3uw_1d(k)
+!!# define E3vw_0(i,j,k) e3vw_1d(k)
+!!# define DEPt_0(i,j,k) gdept_1d(k)
+!!# define DEPw_0(i,j,k) gdepw_1d(k)
+!!# define E3fv_0(i,j,k) e3fvor_0(i,j,k)
+!!# if defined key_zco
+!!# define E3t_0(i,j,k) e3t_1d(k)
+!!# define E3u_0(i,j,k) e3t_1d(k)
+!!# define E3v_0(i,j,k) e3t_1d(k)
+!!# define E3f_0(i,j,k) e3t_1d(k)
+!!# elif defined key_zps
+!!# define E3t_0(i,j,k) e3t_0(i,j,k)
+!!# define E3u_0(i,j,k) e3u_0(i,j,k)
+!!# define E3v_0(i,j,k) e3v_0(i,j,k)
+!!# define E3f_0(i,j,k) e3f_0(i,j,k)
+!!# endif
+!!#elif defined key_sco
+!!# define E3w_0(i,j,k) e3w_0(i,j,k)
+!!# define E3uw_0(i,j,k) e3uw_0(i,j,k)
+!!# define E3vw_0(i,j,k) e3vw_0(i,j,k)
+!!# define DEPt_0(i,j,k) gdept_0(i,j,k)
+!!# define DEPw_0(i,j,k) gdepw_0(i,j,k)
+!! !
+!!# define E3t_0(i,j,k) e3t_0(i,j,k)
+!!# define E3u_0(i,j,k) e3u_0(i,j,k)
+!!# define E3v_0(i,j,k) e3v_0(i,j,k)
+!!# define E3f_0(i,j,k) e3f_0(i,j,k)
+!!# define E3fv_0(i,j,k) e3fvor_0(i,j,k)
+!!#endif
+!!!
+!!e3t(ji,jj,jk,kt)
+!!e3u(ji,jj,jk,kt)
+!!e3v(ji,jj,jk,kt)
+!!e3f(ji,jj,jk)
+!!e3f_vor(ji,jj,jk)
+!!e3w(ji,jj,jk,kt)
+!!e3uw(ji,jj,jk,kt)
+!!e3vw(ji,jj,jk,kt)
+!!ht(ji,jj,kt)
+!!hu(ji,jj,kt)
+!!hv(ji,jj,kt)
+!!r1_hu(ji,jj,kt)
+!!r1_hv(ji,jj,kt)
+!!gdept(ji,jj,jk,kt)
+!!gdepw(ji,jj,jk,kt)
+!!gdept_z0(ji,jj,jk,kt)
+!!!
+!!#undef Tmsk
+!!#undef Time
+!!#undef Divi
+!!#undef DEPT_z0
+!!#undef Tisf
+!!#undef E3w_0
+!!#undef E3uw_0
+!!#undef E3vw_0
+!!#undef E3t_0
+!!#undef E3u_0
+!!#undef E3v_0
+!!#undef E3f_0
+!!#undef DEPt_0
+!!#undef DEPw_0
+!!#undef E3fv_0
+!!#undef e3w
+!!#undef e3uw
+!!#undef e3vw
+!!#undef e3t
+!!#undef e3u
+!!#undef e3v
+!!#undef e3f
+!!#undef e3f_vor
+!!#undef ht
+!!#undef hu
+!!#undef hv
+!!#undef r1_hu
+!!#undef r1_hv
+!!#undef gdept
+!!#undef gdepw
+!!!
+!!#undef key_sco
+!!#undef key_linssh
+!!!
+!!! default case
+!!!
+!!# if defined key_qco
+!!# define Tmsk(r3,msk,i,j,k,t) *(1._wp+r3(i,j,t)*msk(i,j,k))
+!!# define Time(r3,i,j,t) *(1._wp+r3(i,j,t))
+!!# define Divi(r3,i,j,t) /(1._wp+r3(i,j,t))
+!!# define DEPT_z0(i,j,k,t) gdept(i,j,k,t)-ssh(i,j,t)
+!!# if defined key_isf
+!!# define Tisf(r3,isf,i,j,t) -isf(i,j)) Time(r3,i,j,t)+isf(i,j)
+!!# else
+!!# define Tisf(r3,isf,i,j,t) ) Time(r3,i,j,t)
+!!# endif
+!!# elif defined key_linssh
+!!# define Tmsk(r3,msk,i,j,k,t)
+!!# define Time(r3,i,j,t)
+!!# define Divi(r3,i,j,t)
+!!# define DEPT_z0(i,j,k,t) gdept(i,j,k,Kmm)
+!!# if defined key_isf
+!!# define Tisf(r3,isf,i,j,t)
+!!# else
+!!# define Tisf(r3,isf,i,j,t) )
+!!# endif
+!!# endif
+!!
+!!#if defined key_zco || defined key_zps
+!!# define E3w_0(i,j,k) e3w_1d(k)
+!!# define E3uw_0(i,j,k) e3uw_1d(k)
+!!# define E3vw_0(i,j,k) e3vw_1d(k)
+!!# define DEPt_0(i,j,k) gdept_1d(k)
+!!# define DEPw_0(i,j,k) gdepw_1d(k)
+!!# define E3fv_0(i,j,k) e3fvor_0(i,j,k)
+!!# if defined key_zco
+!!# define E3t_0(i,j,k) e3t_1d(k)
+!!# define E3u_0(i,j,k) e3t_1d(k)
+!!# define E3v_0(i,j,k) e3t_1d(k)
+!!# define E3f_0(i,j,k) e3t_1d(k)
+!!# elif defined key_zps
+!!# define E3t_0(i,j,k) e3t_0(i,j,k)
+!!# define E3u_0(i,j,k) e3u_0(i,j,k)
+!!# define E3v_0(i,j,k) e3v_0(i,j,k)
+!!# define E3f_0(i,j,k) e3f_0(i,j,k)
+!!# endif
+!!#elif defined key_sco
+!!# define E3w_0(i,j,k) e3w_0(i,j,k)
+!!# define E3uw_0(i,j,k) e3uw_0(i,j,k)
+!!# define E3vw_0(i,j,k) e3vw_0(i,j,k)
+!!# define DEPt_0(i,j,k) gdept_0(i,j,k)
+!!# define DEPw_0(i,j,k) gdepw_0(i,j,k)
+!! !
+!!# define E3t_0(i,j,k) e3t_0(i,j,k)
+!!# define E3u_0(i,j,k) e3u_0(i,j,k)
+!!# define E3v_0(i,j,k) e3v_0(i,j,k)
+!!# define E3f_0(i,j,k) e3f_0(i,j,k)
+!!# define E3fv_0(i,j,k) e3fvor_0(i,j,k)
+!!#endif
+!!#if defined key_qco || defined key_linssh || defined key_zco || defined key_zps || defined key_sco
+!!# define e3t(i,j,k,t) (E3t_0(i,j,k) Tmsk(r3t,tmask,i,j,k,t))
+!!# define e3u(i,j,k,t) (E3u_0(i,j,k) Tmsk(r3u,umask,i,j,k,t))
+!!# define e3v(i,j,k,t) (E3v_0(i,j,k) Tmsk(r3v,vmask,i,j,k,t))
+!!# define e3f(i,j,k) (E3f_0(i,j,k) Tmsk(r3f,fe3mask,i,j,k,t))
+!!# define e3f_vor(i,j,k) (E3fv_0(i,j,k) Tmsk(r3f,fe3mask,i,j,k,t))
+!!# define e3w(i,j,k,t) (E3w_0(i,j,k) Time(r3t,i,j,t))
+!!# define e3uw(i,j,k,t) (E3uw_0(i,j,k) Time(r3u,i,j,t))
+!!# define e3vw(i,j,k,t) (E3vw_0(i,j,k) Time(r3v,i,j,t))
+!!# define ht(i,j,t) (ht_0(i,j) Time(r3t,i,j,t))
+!!# define hu(i,j,t) (hu_0(i,j) Time(r3u,i,j,t))
+!!# define hv(i,j,t) (hv_0(i,j) Time(r3v,i,j,t))
+!!# define r1_hu(i,j,t) (r1_hu_0(i,j) Divi(r3u,i,j,t))
+!!# define r1_hv(i,j,t) (r1_hv_0(i,j) Divi(r3v,i,j,t))
+!!# define gdept(i,j,k,t) ((DEPt_0(i,j,k) Tisf(r3t,risfdep,i,j,t))
+!!# define gdepw(i,j,k,t) ((DEPw_0(i,j,k) Tisf(r3t,risfdep,i,j,t))
+!!#endif
+!!# define gdept_z0(i,j,k,t) (gdept(i,j,k,t)-ssh(i,j,t))
+!!!
+!!e3t(ji,jj,jk,kt)
+!!e3u(ji,jj,jk,kt)
+!!e3v(ji,jj,jk,kt)
+!!e3f(ji,jj,jk)
+!!e3f_vor(ji,jj,jk)
+!!e3w(ji,jj,jk,kt)
+!!e3uw(ji,jj,jk,kt)
+!!e3vw(ji,jj,jk,kt)
+!!ht(ji,jj,kt)
+!!hu(ji,jj,kt)
+!!hv(ji,jj,kt)
+!!r1_hu(ji,jj,kt)
+!!r1_hv(ji,jj,kt)
+!!gdept(ji,jj,jk,kt)
+!!gdepw(ji,jj,jk,kt)
+!!gdept_z0(ji,jj,jk,kt)
+
+
+
+
#endif
-!!----------------------------------------------------------------------
diff --git a/src/OCE/DOM/dtatsd.F90 b/src/OCE/DOM/dtatsd.F90
index 5863789cc4d8e4c1f09657a00610197ef9c7c599..bc00b222fc465d7bcbded45134bc5f13fdad5f38 100644
--- a/src/OCE/DOM/dtatsd.F90
+++ b/src/OCE/DOM/dtatsd.F90
@@ -37,6 +37,7 @@ MODULE dtatsd
!! * Substitutions
# include "do_loop_substitute.h90"
+# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
!! $Id: dtatsd.F90 14834 2021-05-11 09:24:44Z hadcv $
@@ -135,7 +136,7 @@ CONTAINS
!! ** Action : ptsd T-S data on medl mesh and interpolated at time-step kt
!!----------------------------------------------------------------------
INTEGER , INTENT(in ) :: kt ! ocean time-step
- REAL(wp), DIMENSION(A2D(nn_hls),jpk,jpts), INTENT( out) :: ptsd ! T & S data
+ REAL(wp), DIMENSION(T2D(nn_hls),jpk,jpts), INTENT( out) :: ptsd ! T & S data
!
INTEGER :: ji, jj, jk, jl, jkk ! dummy loop indicies
INTEGER :: ik, il0, il1, ii0, ii1, ij0, ij1 ! local integers
@@ -161,8 +162,8 @@ CONTAINS
ij0 = 101 + nn_hls ; ij1 = 109 + nn_hls ! Reduced T & S in the Alboran Sea
ii0 = 141 + nn_hls - 1 ; ii1 = 155 + nn_hls - 1
IF( sf_tsd(jp_tem)%ln_tint .OR. irec_n(jp_tem) /= irec_b(jp_tem) ) THEN
- DO jj = mj0(ij0), mj1(ij1)
- DO ji = mi0(ii0), mi1(ii1)
+ DO jj = mj0(ij0,nn_hls), mj1(ij1,nn_hls)
+ DO ji = mi0(ii0,nn_hls), mi1(ii1,nn_hls)
sf_tsd(jp_tem)%fnow(ji,jj,13:13) = sf_tsd(jp_tem)%fnow(ji,jj,13:13) - 0.20_wp
sf_tsd(jp_tem)%fnow(ji,jj,14:15) = sf_tsd(jp_tem)%fnow(ji,jj,14:15) - 0.35_wp
sf_tsd(jp_tem)%fnow(ji,jj,16:25) = sf_tsd(jp_tem)%fnow(ji,jj,16:25) - 0.40_wp
@@ -172,8 +173,8 @@ CONTAINS
ENDIF
!
IF( sf_tsd(jp_sal)%ln_tint .OR. irec_n(jp_sal) /= irec_b(jp_sal) ) THEN
- DO jj = mj0(ij0), mj1(ij1)
- DO ji = mi0(ii0), mi1(ii1)
+ DO jj = mj0(ij0,nn_hls), mj1(ij1,nn_hls)
+ DO ji = mi0(ii0,nn_hls), mi1(ii1,nn_hls)
sf_tsd(jp_sal)%fnow(ji,jj,13:13) = sf_tsd(jp_sal)%fnow(ji,jj,13:13) - 0.15_wp
sf_tsd(jp_sal)%fnow(ji,jj,14:15) = sf_tsd(jp_sal)%fnow(ji,jj,14:15) - 0.25_wp
sf_tsd(jp_sal)%fnow(ji,jj,16:17) = sf_tsd(jp_sal)%fnow(ji,jj,16:17) - 0.30_wp
@@ -185,9 +186,9 @@ CONTAINS
!
ij0 = 87 + nn_hls ; ij1 = 96 + nn_hls ! Reduced temperature in Red Sea
ii0 = 148 + nn_hls - 1 ; ii1 = 160 + nn_hls - 1
- sf_tsd(jp_tem)%fnow( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , 4:10 ) = 7.0_wp
- sf_tsd(jp_tem)%fnow( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , 11:13 ) = 6.5_wp
- sf_tsd(jp_tem)%fnow( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , 14:20 ) = 6.0_wp
+ sf_tsd(jp_tem)%fnow( mi0(ii0,nn_hls):mi1(ii1,nn_hls) , mj0(ij0,nn_hls):mj1(ij1,nn_hls) , 4:10 ) = 7.0_wp
+ sf_tsd(jp_tem)%fnow( mi0(ii0,nn_hls):mi1(ii1,nn_hls) , mj0(ij0,nn_hls):mj1(ij1,nn_hls) , 11:13 ) = 6.5_wp
+ sf_tsd(jp_tem)%fnow( mi0(ii0,nn_hls):mi1(ii1,nn_hls) , mj0(ij0,nn_hls):mj1(ij1,nn_hls) , 14:20 ) = 6.0_wp
ENDIF
ENDIF
!!gm end
@@ -199,7 +200,7 @@ CONTAINS
ptsd(ji,jj,jk,jp_sal) = sf_tsd(jp_sal)%fnow(ji,jj,jk)
END_3D
!
- IF( ln_sco ) THEN !== s- or mixed s-zps-coordinate ==!
+ IF( l_sco ) THEN !== s- or mixed s-zps-coordinate ==!
!
IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile
IF( kt == nit000 .AND. lwp )THEN
@@ -210,7 +211,7 @@ CONTAINS
!
DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) ! vertical interpolation of T & S
DO jk = 1, jpk ! determines the intepolated T-S profiles at each (i,j) points
- zl = gdept_0(ji,jj,jk)
+ zl = gdept_3d(ji,jj,jk)
IF( zl < gdept_1d(1 ) ) THEN ! above the first level of data
ztp(jk) = ptsd(ji,jj,1 ,jp_tem)
zsp(jk) = ptsd(ji,jj,1 ,jp_sal)
@@ -218,7 +219,7 @@ CONTAINS
ztp(jk) = ptsd(ji,jj,jpkm1,jp_tem)
zsp(jk) = ptsd(ji,jj,jpkm1,jp_sal)
ELSE ! inbetween : vertical interpolation between jkk & jkk+1
- DO jkk = 1, jpkm1 ! when gdept(jkk) < zl < gdept(jkk+1)
+ DO jkk = 1, jpkm1 ! when gdept_jkk < zl < gdept_jkk+1
IF( (zl-gdept_1d(jkk)) * (zl-gdept_1d(jkk+1)) <= 0._wp ) THEN
zi = ( zl - gdept_1d(jkk) ) / (gdept_1d(jkk+1)-gdept_1d(jkk))
ztp(jk) = ptsd(ji,jj,jkk,jp_tem) + ( ptsd(ji,jj,jkk+1,jp_tem) - ptsd(ji,jj,jkk,jp_tem) ) * zi
@@ -246,23 +247,6 @@ CONTAINS
ptsd(ji,jj,jk,jp_sal) = ptsd(ji,jj,jk,jp_sal) * tmask(ji,jj,jk)
END_3D
!
- IF( ln_zps ) THEN ! zps-coordinate (partial steps) interpolation at the last ocean level
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
- ik = mbkt(ji,jj)
- IF( ik > 1 ) THEN
- zl = ( gdept_1d(ik) - gdept_0(ji,jj,ik) ) / ( gdept_1d(ik) - gdept_1d(ik-1) )
- ptsd(ji,jj,ik,jp_tem) = (1.-zl) * ptsd(ji,jj,ik,jp_tem) + zl * ptsd(ji,jj,ik-1,jp_tem)
- ptsd(ji,jj,ik,jp_sal) = (1.-zl) * ptsd(ji,jj,ik,jp_sal) + zl * ptsd(ji,jj,ik-1,jp_sal)
- ENDIF
- ik = mikt(ji,jj)
- IF( ik > 1 ) THEN
- zl = ( gdept_0(ji,jj,ik) - gdept_1d(ik) ) / ( gdept_1d(ik+1) - gdept_1d(ik) )
- ptsd(ji,jj,ik,jp_tem) = (1.-zl) * ptsd(ji,jj,ik,jp_tem) + zl * ptsd(ji,jj,ik+1,jp_tem)
- ptsd(ji,jj,ik,jp_sal) = (1.-zl) * ptsd(ji,jj,ik,jp_sal) + zl * ptsd(ji,jj,ik+1,jp_sal)
- END IF
- END_2D
- ENDIF
- !
ENDIF
!
IF( .NOT.ln_tsd_dmp ) THEN !== deallocate T & S structure ==!
diff --git a/src/OCE/DOM/istate.F90 b/src/OCE/DOM/istate.F90
index a8ea487a05a3e0f8ddae46ca9a39ed1d9c9c270c..307de7bd0580034115dc090aab9e5cbcd4ff8f32 100644
--- a/src/OCE/DOM/istate.F90
+++ b/src/OCE/DOM/istate.F90
@@ -25,7 +25,6 @@ MODULE istate
USE daymod ! calendar
USE dtatsd ! data temperature and salinity (dta_tsd routine)
USE dtauvd ! data: U & V current (dta_uvd routine)
- USE domvvl ! varying vertical mesh
USE wet_dry ! wetting and drying (needed for wad_istate)
USE usrdef_istate ! User defined initial state
!
diff --git a/src/OCE/DYN/divhor.F90 b/src/OCE/DYN/divhor.F90
index 2cdf53d1848aa5af5c303cbafb3cbfd57777098d..3c2cabc25889046d3e490ed59a7c3add8ed5b2e9 100644
--- a/src/OCE/DYN/divhor.F90
+++ b/src/OCE/DYN/divhor.F90
@@ -78,17 +78,16 @@ CONTAINS
IF(lwp) WRITE(numout,*)
IF(lwp) WRITE(numout,*) 'div_hor_RK3 : thickness weighted horizontal divergence '
IF(lwp) WRITE(numout,*) '~~~~~~~~~~~'
- hdiv (:,:,:) = 0._wp ! initialize hdiv & pe3divUh for the halos and jpk level at the first time step
+ hdiv(:,:,:) = 0._wp ! initialize hdiv & pe3divUh for the halos and jpk level at the first time step
+ pe3divUh(:,:,jpk) = 0._wp
ENDIF
!
- pe3divUh(:,:,:) = 0._wp !!gm to be applied to the halos only
- !
- DO_3D_OVR( nn_hls-1, nn_hls, nn_hls-1, nn_hls, 1, jpkm1 )
- hdiv(ji,jj,jk) = ( e2u(ji ,jj) * e3u(ji ,jj,jk,Kmm) * puu(ji ,jj,jk) &
- & - e2u(ji-1,jj) * e3u(ji-1,jj,jk,Kmm) * puu(ji-1,jj,jk) &
- & + e1v(ji,jj ) * e3v(ji,jj ,jk,Kmm) * pvv(ji,jj ,jk) &
- & - e1v(ji,jj-1) * e3v(ji,jj-1,jk,Kmm) * pvv(ji,jj-1,jk) ) &
- & * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm)
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
+ hdiv(ji,jj,jk) = ( ( e2u(ji ,jj) * e3u(ji ,jj,jk,Kmm) * puu(ji ,jj,jk) & ! add () for NP repro
+ & - e2u(ji-1,jj) * e3u(ji-1,jj,jk,Kmm) * puu(ji-1,jj,jk) ) &
+ & + ( e1v(ji,jj ) * e3v(ji,jj ,jk,Kmm) * pvv(ji,jj ,jk) &
+ & - e1v(ji,jj-1) * e3v(ji,jj-1,jk,Kmm) * pvv(ji,jj-1,jk) ) &
+ & ) * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm)
END_3D
!
IF( ln_rnf ) CALL sbc_rnf_div( hdiv, Kmm ) !== + runoffs divergence ==!
@@ -100,7 +99,7 @@ CONTAINS
!
IF( ln_isf ) CALL isf_hdiv( kt, Kmm, hdiv ) !== + ice-shelf mass exchange ==!
!
- IF( nn_hls==1 ) CALL lbc_lnk( 'divhor', hdiv, 'T', 1._wp ) ! (no sign change)
+ CALL lbc_lnk( 'divhor', hdiv, 'T', 1._wp ) ! (no sign change)
!
!!gm Patch before suppression of hdiv from all modules that use it
! DO_3D( 0, 0, 0, 0, 1, jpkm1 ) !== e3t * Horizontal divergence ==!
@@ -143,22 +142,17 @@ CONTAINS
IF(lwp) WRITE(numout,*)
IF(lwp) WRITE(numout,*) 'div_hor : horizontal velocity divergence '
IF(lwp) WRITE(numout,*) '~~~~~~~ '
+
+ hdiv(:,:,:) = 0._wp ! initialize hdiv for the halos at the first time step
ENDIF
- DO_3D_OVR( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpk )
- hdiv(ji,jj,jk) = 0._wp ! initialize hdiv for the halos at the first time step
- END_3D
ENDIF
!
- DO_3D_OVR( nn_hls-1, nn_hls, nn_hls-1, nn_hls, 1, jpkm1 ) !== Horizontal divergence ==!
- ! round brackets added to fix the order of floating point operations
- ! needed to ensure halo 1 - halo 2 compatibility
- hdiv(ji,jj,jk) = ( ( e2u(ji ,jj) * e3u(ji ,jj,jk,Kmm) * uu(ji ,jj,jk,Kmm) &
- & - e2u(ji-1,jj) * e3u(ji-1,jj,jk,Kmm) * uu(ji-1,jj,jk,Kmm) &
- & ) & ! bracket for halo 1 - halo 2 compatibility
- & + ( e1v(ji,jj ) * e3v(ji,jj ,jk,Kmm) * vv(ji,jj ,jk,Kmm) &
- & - e1v(ji,jj-1) * e3v(ji,jj-1,jk,Kmm) * vv(ji,jj-1,jk,Kmm) &
- & ) & ! bracket for halo 1 - halo 2 compatibility
- & ) * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm)
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 ) !== Horizontal divergence ==!
+ hdiv(ji,jj,jk) = ( ( e2u(ji ,jj) * e3u(ji ,jj,jk,Kmm) * uu(ji ,jj,jk,Kmm) & ! add () for NP repro
+ & - e2u(ji-1,jj) * e3u(ji-1,jj,jk,Kmm) * uu(ji-1,jj,jk,Kmm) ) &
+ & + ( e1v(ji,jj ) * e3v(ji,jj ,jk,Kmm) * vv(ji,jj ,jk,Kmm) &
+ & - e1v(ji,jj-1) * e3v(ji,jj-1,jk,Kmm) * vv(ji,jj-1,jk,Kmm) ) &
+ & ) * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm)
END_3D
!
IF( ln_rnf ) CALL sbc_rnf_div( hdiv, Kmm ) !== runoffs ==! (update hdiv field)
@@ -167,10 +161,14 @@ CONTAINS
IF( ln_sshinc .AND. ln_asmiau ) CALL ssh_asm_div( kt, Kbb, Kmm, hdiv ) !== SSH assimilation ==! (update hdiv field)
!
#endif
- IF( ln_isf ) CALL isf_hdiv( kt, Kmm, hdiv ) !== ice shelf ==! (update hdiv field)
+ IF( ln_isf ) CALL isf_hdiv( kt, Kmm, hdiv ) !== ice shelf ==! (update hdiv field)
!
- IF( nn_hls==1 ) CALL lbc_lnk( 'divhor', hdiv, 'T', 1.0_wp ) ! (no sign change)
- ! ! needed for ww in sshwzv
+ ! hdiv is needed on haloes by wzv and ssh_nxt, but these are not called in the same tiling
+ ! loop as div_hor, so we can keep this lbc_lnk here and call it after all tiles are finished
+ IF( .NOT. l_istiled .OR. ntile == nijtile ) THEN ! Do only on the last tile
+ CALL lbc_lnk( 'divhor', hdiv, 'T', 1.0_wp ) ! needed for ww in sshwzv (no sign change)
+ ENDIF
+ !
IF( ln_timing ) CALL timing_stop('div_hor')
!
END SUBROUTINE div_hor_old
diff --git a/src/OCE/DYN/dynadv.F90 b/src/OCE/DYN/dynadv.F90
index bda2c3a4f806cd4fab1bcc5a6b3bc1ff89f77dd1..1c5afaa6810d2d7b1cce3f3881009935f9b4a0c2 100644
--- a/src/OCE/DYN/dynadv.F90
+++ b/src/OCE/DYN/dynadv.F90
@@ -7,6 +7,7 @@ MODULE dynadv
!! 3.3 ! 2010-10 (C. Ethe, G. Madec) reorganisation of initialisation phase
!! 3.6 ! 2015-05 (N. Ducousso, G. Madec) add Hollingsworth scheme as an option
!! 4.0 ! 2017-07 (G. Madec) add a linear dynamics option
+ !! 4.5 ! 2022-06 (S. Techene, G, Madec) refactorization to reduce local memory usage
!!----------------------------------------------------------------------
!!----------------------------------------------------------------------
@@ -50,7 +51,7 @@ MODULE dynadv
!!----------------------------------------------------------------------
CONTAINS
- SUBROUTINE dyn_adv( kt, Kbb, Kmm, puu, pvv, Krhs, pau, pav, paw, no_zad )
+ SUBROUTINE dyn_adv( kt, Kbb, Kmm, puu, pvv, Krhs, pau, pav, paw )
!!---------------------------------------------------------------------
!! *** ROUTINE dyn_adv ***
!!
@@ -64,7 +65,6 @@ CONTAINS
!! (see dynvor module).
!!----------------------------------------------------------------------
INTEGER , INTENT(in ) :: kt , Kbb, Kmm, Krhs ! ocean time step and level indices
- INTEGER , OPTIONAL , INTENT(in ) :: no_zad ! no vertical advection compotation
REAL(wp), DIMENSION(:,:,:), OPTIONAL, TARGET, INTENT(in ) :: pau, pav, paw ! advective velocity
REAL(wp), DIMENSION(jpi,jpj,jpk,jpt), TARGET, INTENT(inout) :: puu, pvv ! ocean velocities and RHS of momentum Eq.
!!----------------------------------------------------------------------
@@ -73,12 +73,15 @@ CONTAINS
!
SELECT CASE( n_dynadv ) !== compute advection trend and add it to general trend ==!
CASE( np_VEC_c2 ) != vector form =!
- CALL dyn_keg ( kt, nn_dynkeg , Kmm, puu, pvv, Krhs ) ! horizontal gradient of kinetic energy
- CALL dyn_zad ( kt , Kmm, puu, pvv, Krhs ) ! vertical advection
+ ! !* horizontal gradient of kinetic energy
+ CALL dyn_keg ( kt, nn_dynkeg , Kmm, puu, pvv, Krhs )
+ CALL dyn_zad ( kt , Kmm, puu, pvv, Krhs ) !* vertical advection
+ !
CASE( np_FLX_c2 ) != flux form =!
- CALL dyn_adv_cen2( kt , Kmm, puu, pvv, Krhs, pau, pav, paw, no_zad ) ! 2nd order centered scheme
- CASE( np_FLX_ubs )
- CALL dyn_adv_ubs ( kt , Kbb, Kmm, puu, pvv, Krhs, pau, pav, paw, no_zad ) ! 3rd order UBS scheme (UP3)
+ CALL dyn_adv_cen2( kt , Kmm, puu, pvv, Krhs, pau, pav, paw ) !* 2nd order centered scheme
+ !
+ CASE( np_FLX_ubs ) !* 3rd order UBS scheme (UP3)
+ CALL dyn_adv_ubs ( kt , Kbb, Kmm, puu, pvv, Krhs, pau, pav, paw )
END SELECT
!
IF( ln_timing ) CALL timing_stop( 'dyn_adv' )
diff --git a/src/OCE/DYN/dynadv_cen2.F90 b/src/OCE/DYN/dynadv_cen2.F90
index 7fd7f65f5c19ca959bd2437cb7352cf5bb1fd1b6..c318d6aedb7b5e06ea08403b981a89197ce968e9 100644
--- a/src/OCE/DYN/dynadv_cen2.F90
+++ b/src/OCE/DYN/dynadv_cen2.F90
@@ -6,6 +6,7 @@ MODULE dynadv_cen2
!!======================================================================
!! History : 2.0 ! 2006-08 (G. Madec, S. Theetten) Original code
!! 3.2 ! 2009-07 (R. Benshila) Suppression of rigid-lid option
+ !! 4.5 ! 2022-06 (S. Techene, G, Madec) refactorization to reduce local memory usage
!!----------------------------------------------------------------------
!!----------------------------------------------------------------------
@@ -35,7 +36,7 @@ MODULE dynadv_cen2
!!----------------------------------------------------------------------
CONTAINS
- SUBROUTINE dyn_adv_cen2( kt, Kmm, puu, pvv, Krhs, pau, pav, paw, no_zad )
+ SUBROUTINE dyn_adv_cen2( kt, Kmm, puu, pvv, Krhs, pau, pav, paw )
!!----------------------------------------------------------------------
!! *** ROUTINE dyn_adv_cen2 ***
!!
@@ -51,15 +52,17 @@ CONTAINS
!! ** Action : (puu,pvv)(:,:,:,Krhs) updated with the advective trend
!!----------------------------------------------------------------------
INTEGER , INTENT(in ) :: kt , Kmm, Krhs ! ocean time-step and level indices
- INTEGER , OPTIONAL , INTENT(in ) :: no_zad ! no vertical advection computation
REAL(wp), DIMENSION(jpi,jpj,jpk,jpt), TARGET, INTENT(inout) :: puu, pvv ! ocean velocities and RHS of momentum equation
REAL(wp), DIMENSION(:,:,:), OPTIONAL, TARGET, INTENT(in ) :: pau, pav, paw ! advective velocity
!
INTEGER :: ji, jj, jk ! dummy loop indices
- REAL(wp) :: zzu, zzv ! local scalars
- REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zfu_t, zfu_f, zfu_uw, zfu
- REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zfv_t, zfv_f, zfv_vw, zfv, zfw
+ REAL(wp) :: zzu, zzfu_kp1 ! local scalars
+ REAL(wp) :: zzv, zzfv_kp1 ! - -
+ REAL(wp), DIMENSION(T2D(1)) :: zfu_t, zfu_f, zfu
+ REAL(wp), DIMENSION(T2D(1)) :: zfv_t, zfv_f, zfv
+ REAL(wp), DIMENSION(T2D(1)) :: zfu_uw, zfv_vw, zfw
REAL(wp), DIMENSION(:,:,:) , POINTER :: zpt_u, zpt_v, zpt_w
+ REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE :: zu_trd, zv_trd
!!----------------------------------------------------------------------
!
IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile
@@ -71,8 +74,9 @@ CONTAINS
ENDIF
!
IF( l_trddyn ) THEN ! trends: store the input trends
- zfu_uw(:,:,:) = puu(:,:,:,Krhs)
- zfv_vw(:,:,:) = pvv(:,:,:,Krhs)
+ ALLOCATE( zu_trd(A2D(0),jpkm1), zv_trd(A2D(0),jpkm1) )
+ zu_trd(:,:,:) = puu(A2D(0),:,Krhs)
+ zv_trd(:,:,:) = pvv(A2D(0),:,Krhs)
ENDIF
!
IF( PRESENT( pau ) ) THEN ! RK3: advective velocity (pau,pav,paw) /= advected velocity (puu,pvv,ww)
@@ -89,85 +93,88 @@ CONTAINS
!
DO jk = 1, jpkm1 ! horizontal transport
DO_2D( 1, 1, 1, 1 )
- zfu(ji,jj,jk) = 0.25_wp * e2u(ji,jj) * e3u(ji,jj,jk,Kmm) * zpt_u(ji,jj,jk)
- zfv(ji,jj,jk) = 0.25_wp * e1v(ji,jj) * e3v(ji,jj,jk,Kmm) * zpt_v(ji,jj,jk)
+ zfu(ji,jj) = 0.25_wp * e2u(ji,jj) * e3u(ji,jj,jk,Kmm) * zpt_u(ji,jj,jk)
+ zfv(ji,jj) = 0.25_wp * e1v(ji,jj) * e3v(ji,jj,jk,Kmm) * zpt_v(ji,jj,jk)
END_2D
DO_2D( 1, 0, 1, 0 ) ! horizontal momentum fluxes (at T- and F-point)
- zfu_t(ji+1,jj ,jk) = ( zfu(ji,jj,jk) + zfu(ji+1,jj,jk) ) * ( puu(ji,jj,jk,Kmm) + puu(ji+1,jj ,jk,Kmm) )
- zfv_f(ji ,jj ,jk) = ( zfv(ji,jj,jk) + zfv(ji+1,jj,jk) ) * ( puu(ji,jj,jk,Kmm) + puu(ji ,jj+1,jk,Kmm) )
- zfu_f(ji ,jj ,jk) = ( zfu(ji,jj,jk) + zfu(ji,jj+1,jk) ) * ( pvv(ji,jj,jk,Kmm) + pvv(ji+1,jj ,jk,Kmm) )
- zfv_t(ji ,jj+1,jk) = ( zfv(ji,jj,jk) + zfv(ji,jj+1,jk) ) * ( pvv(ji,jj,jk,Kmm) + pvv(ji ,jj+1,jk,Kmm) )
+ zfu_t(ji+1,jj ) = ( zfu(ji,jj) + zfu(ji+1,jj) ) * ( puu(ji,jj,jk,Kmm) + puu(ji+1,jj ,jk,Kmm) )
+ zfv_f(ji ,jj ) = ( zfv(ji,jj) + zfv(ji+1,jj) ) * ( puu(ji,jj,jk,Kmm) + puu(ji ,jj+1,jk,Kmm) )
+ zfu_f(ji ,jj ) = ( zfu(ji,jj) + zfu(ji,jj+1) ) * ( pvv(ji,jj,jk,Kmm) + pvv(ji+1,jj ,jk,Kmm) )
+ zfv_t(ji ,jj+1) = ( zfv(ji,jj) + zfv(ji,jj+1) ) * ( pvv(ji,jj,jk,Kmm) + pvv(ji ,jj+1,jk,Kmm) )
END_2D
DO_2D( 0, 0, 0, 0 ) ! divergence of horizontal momentum fluxes
- puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) - ( zfu_t(ji+1,jj,jk) - zfu_t(ji,jj ,jk) &
- & + zfv_f(ji ,jj,jk) - zfv_f(ji,jj-1,jk) ) * r1_e1e2u(ji,jj) &
+ puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) - ( ( zfu_t(ji+1,jj) - zfu_t(ji,jj ) ) & ! add () for NP repro
+ & + ( zfv_f(ji ,jj) - zfv_f(ji,jj-1) ) ) * r1_e1e2u(ji,jj) &
& / e3u(ji,jj,jk,Kmm)
- pvv(ji,jj,jk,Krhs) = pvv(ji,jj,jk,Krhs) - ( zfu_f(ji,jj ,jk) - zfu_f(ji-1,jj,jk) &
- & + zfv_t(ji,jj+1,jk) - zfv_t(ji ,jj,jk) ) * r1_e1e2v(ji,jj) &
+ pvv(ji,jj,jk,Krhs) = pvv(ji,jj,jk,Krhs) - ( ( zfu_f(ji,jj ) - zfu_f(ji-1,jj) ) & ! add () for NP repro
+ & + ( zfv_t(ji,jj+1) - zfv_t(ji ,jj) ) ) * r1_e1e2v(ji,jj) &
& / e3v(ji,jj,jk,Kmm)
END_2D
END DO
!
IF( l_trddyn ) THEN ! trends: send trend to trddyn for diagnostic
- zfu_uw(:,:,:) = puu(:,:,:,Krhs) - zfu_uw(:,:,:)
- zfv_vw(:,:,:) = pvv(:,:,:,Krhs) - zfv_vw(:,:,:)
- CALL trd_dyn( zfu_uw, zfv_vw, jpdyn_keg, kt, Kmm )
- zfu_t(:,:,:) = puu(:,:,:,Krhs)
- zfv_t(:,:,:) = pvv(:,:,:,Krhs)
+ zu_trd(:,:,:) = puu(A2D(0),:,Krhs) - zu_trd(:,:,:)
+ zv_trd(:,:,:) = pvv(A2D(0),:,Krhs) - zv_trd(:,:,:)
+ CALL trd_dyn( zu_trd, zv_trd, jpdyn_keg, kt, Kmm )
+ zu_trd(:,:,:) = puu(A2D(0),:,Krhs)
+ zv_trd(:,:,:) = pvv(A2D(0),:,Krhs)
ENDIF
!
- IF( PRESENT( no_zad ) ) THEN !== No vertical advection ==! (except if linear free surface)
- ! ==
- IF( ln_linssh ) THEN ! linear free surface: advection through the surface z=0
- DO_2D( 0, 0, 0, 0 )
- zzu = 0.5_wp * ( e1e2t(ji,jj) * zpt_w(ji,jj,1) + e1e2t(ji+1,jj) * zpt_w(ji+1,jj,1) ) * puu(ji,jj,1,Kmm)
- zzv = 0.5_wp * ( e1e2t(ji,jj) * zpt_w(ji,jj,1) + e1e2t(ji,jj+1) * zpt_w(ji,jj+1,1) ) * pvv(ji,jj,1,Kmm)
- puu(ji,jj,1,Krhs) = puu(ji,jj,1,Krhs) - zzu * r1_e1e2u(ji,jj) &
- & / e3u(ji,jj,1,Kmm)
- pvv(ji,jj,1,Krhs) = pvv(ji,jj,1,Krhs) - zzv * r1_e1e2v(ji,jj) &
- & / e3v(ji,jj,1,Kmm)
- END_2D
- ENDIF
- !
- ELSE !== Vertical advection ==!
+ ! !== Vertical advection ==!
+ !
+ ! ! surface vertical fluxes
+ !
+ IF( ln_linssh ) THEN ! linear free surface: advection through the surface z=0
+ DO_2D( 0, 0, 0, 0 )
+ zfu_uw(ji,jj) = 0.5_wp * ( e1e2t(ji,jj) * zpt_w(ji,jj,1) + e1e2t(ji+1,jj) * zpt_w(ji+1,jj,1) ) * puu(ji,jj,1,Kmm)
+ zfv_vw(ji,jj) = 0.5_wp * ( e1e2t(ji,jj) * zpt_w(ji,jj,1) + e1e2t(ji,jj+1) * zpt_w(ji,jj+1,1) ) * pvv(ji,jj,1,Kmm)
+ END_2D
+ ELSE ! non linear free: surface advective fluxes set to zero
+ DO_2D( 0, 0, 0, 0 )
+ zfu_uw(ji,jj) = 0._wp
+ zfv_vw(ji,jj) = 0._wp
+ END_2D
+ ENDIF
+ !
+ DO jk = 1, jpk-2 ! divergence of advective fluxes
!
- DO_2D( 0, 0, 0, 0 ) ! surface/bottom advective fluxes set to zero
- zfu_uw(ji,jj,jpk) = 0._wp ; zfv_vw(ji,jj,jpk) = 0._wp
- zfu_uw(ji,jj, 1 ) = 0._wp ; zfv_vw(ji,jj, 1 ) = 0._wp
+ DO_2D( 0, 1, 0, 1 ) ! 1/4 * Vertical transport at level k+1
+ zfw(ji,jj) = 0.25_wp * e1e2t(ji,jj) * zpt_w(ji,jj,jk+1)
END_2D
- IF( ln_linssh ) THEN ! linear free surface: advection through the surface z=0
- DO_2D( 0, 0, 0, 0 )
- zfu_uw(ji,jj,1) = 0.5_wp * ( e1e2t(ji,jj) * zpt_w(ji,jj,1) + e1e2t(ji+1,jj) * zpt_w(ji+1,jj,1) ) * puu(ji,jj,1,Kmm)
- zfv_vw(ji,jj,1) = 0.5_wp * ( e1e2t(ji,jj) * zpt_w(ji,jj,1) + e1e2t(ji,jj+1) * zpt_w(ji,jj+1,1) ) * pvv(ji,jj,1,Kmm)
- END_2D
- ENDIF
- DO jk = 2, jpkm1 ! interior advective fluxes
- DO_2D( 0, 1, 0, 1 ) ! 1/4 * Vertical transport
- zfw(ji,jj,jk) = 0.25_wp * e1e2t(ji,jj) * zpt_w(ji,jj,jk)
- END_2D
- DO_2D( 0, 0, 0, 0 )
- zfu_uw(ji,jj,jk) = ( zfw(ji,jj,jk) + zfw(ji+1,jj ,jk) ) * ( puu(ji,jj,jk,Kmm) + puu(ji,jj,jk-1,Kmm) )
- zfv_vw(ji,jj,jk) = ( zfw(ji,jj,jk) + zfw(ji ,jj+1,jk) ) * ( pvv(ji,jj,jk,Kmm) + pvv(ji,jj,jk-1,Kmm) )
- END_2D
- END DO
- DO_3D( 0, 0, 0, 0, 1, jpkm1 ) ! divergence of vertical momentum flux divergence
- puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) - ( zfu_uw(ji,jj,jk) - zfu_uw(ji,jj,jk+1) ) * r1_e1e2u(ji,jj) &
+ DO_2D( 0, 0, 0, 0 )
+ ! ! vertical flux at level k+1
+ zzfu_kp1 = ( zfw(ji,jj) + zfw(ji+1,jj ) ) * ( puu(ji,jj,jk+1,Kmm) + puu(ji,jj,jk,Kmm) )
+ zzfv_kp1 = ( zfw(ji,jj) + zfw(ji ,jj+1) ) * ( pvv(ji,jj,jk+1,Kmm) + pvv(ji,jj,jk,Kmm) )
+ ! ! divergence of vertical momentum flux
+ puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) - ( zfu_uw(ji,jj) - zzfu_kp1 ) * r1_e1e2u(ji,jj) &
& / e3u(ji,jj,jk,Kmm)
- pvv(ji,jj,jk,Krhs) = pvv(ji,jj,jk,Krhs) - ( zfv_vw(ji,jj,jk) - zfv_vw(ji,jj,jk+1) ) * r1_e1e2v(ji,jj) &
+ pvv(ji,jj,jk,Krhs) = pvv(ji,jj,jk,Krhs) - ( zfv_vw(ji,jj) - zzfv_kp1 ) * r1_e1e2v(ji,jj) &
& / e3v(ji,jj,jk,Kmm)
- END_3D
- !
- IF( l_trddyn ) THEN ! trends: send trend to trddyn for diagnostic
- zfu_t(:,:,:) = puu(:,:,:,Krhs) - zfu_t(:,:,:)
- zfv_t(:,:,:) = pvv(:,:,:,Krhs) - zfv_t(:,:,:)
- CALL trd_dyn( zfu_t, zfv_t, jpdyn_zad, kt, Kmm )
- ENDIF
- ! ! Control print
- IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=puu(:,:,:,Krhs), clinfo1=' cen2 adv - Ua: ', mask1=umask, &
- & tab3d_2=pvv(:,:,:,Krhs), clinfo2= ' Va: ', mask2=vmask, clinfo3='dyn' )
- !
+ ! ! store vertical flux for next level calculation
+ zfu_uw(ji,jj) = zzfu_kp1
+ zfv_vw(ji,jj) = zzfv_kp1
+ END_2D
+ END DO
+ !
+ jk = jpkm1
+ DO_2D( 0, 0, 0, 0 )
+ puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) - zfu_uw(ji,jj) * r1_e1e2u(ji,jj) &
+ & / e3u(ji,jj,jk,Kmm)
+ pvv(ji,jj,jk,Krhs) = pvv(ji,jj,jk,Krhs) - zfv_vw(ji,jj) * r1_e1e2v(ji,jj) &
+ & / e3v(ji,jj,jk,Kmm)
+ END_2D
+ !
+ IF( l_trddyn ) THEN ! trends: send trend to trddyn for diagnostic
+ zu_trd(:,:,:) = puu(A2D(0),:,Krhs) - zu_trd(:,:,:)
+ zv_trd(:,:,:) = pvv(A2D(0),:,Krhs) - zv_trd(:,:,:)
+ CALL trd_dyn( zu_trd, zv_trd, jpdyn_zad, kt, Kmm )
+ DEALLOCATE( zu_trd, zv_trd )
ENDIF
+ ! ! Control print
+ IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=puu(:,:,:,Krhs), clinfo1=' cen2 adv - Ua: ', mask1=umask, &
+ & tab3d_2=pvv(:,:,:,Krhs), clinfo2= ' Va: ', mask2=vmask, clinfo3='dyn' )
!
+ !
END SUBROUTINE dyn_adv_cen2
!!==============================================================================
diff --git a/src/OCE/DYN/dynadv_ubs.F90 b/src/OCE/DYN/dynadv_ubs.F90
index 645f6fa800606d41375281e38c4bc077f1a848e8..23a88d51cdacfc3fcece7ec2aeeb24ad65a4d4eb 100644
--- a/src/OCE/DYN/dynadv_ubs.F90
+++ b/src/OCE/DYN/dynadv_ubs.F90
@@ -6,6 +6,7 @@ MODULE dynadv_ubs
!!======================================================================
!! History : 2.0 ! 2006-08 (R. Benshila, L. Debreu) Original code
!! 3.2 ! 2009-07 (R. Benshila) Suppression of rigid-lid option
+ !! 4.5 ! 2022-06 (S. Techene, G, Madec) refactorization to reduce local memory usage
!!----------------------------------------------------------------------
!!----------------------------------------------------------------------
@@ -29,7 +30,7 @@ MODULE dynadv_ubs
REAL(wp), PARAMETER :: gamma1 = 1._wp/3._wp ! =1/4 quick ; =1/3 3rd order UBS
REAL(wp), PARAMETER :: gamma2 = 1._wp/32._wp ! =0 2nd order ; =1/32 4th order centred
- PUBLIC dyn_adv_ubs ! routine called by step.F90
+ PUBLIC dyn_adv_ubs ! routine called by dynadv.F90
!! * Substitutions
# include "do_loop_substitute.h90"
@@ -41,7 +42,7 @@ MODULE dynadv_ubs
!!----------------------------------------------------------------------
CONTAINS
- SUBROUTINE dyn_adv_ubs( kt, Kbb, Kmm, puu, pvv, Krhs, pau, pav, paw, no_zad )
+ SUBROUTINE dyn_adv_ubs( kt, Kbb, Kmm, puu, pvv, Krhs, pau, pav, paw )
!!----------------------------------------------------------------------
!! *** ROUTINE dyn_adv_ubs ***
!!
@@ -73,17 +74,18 @@ CONTAINS
!! Reference : Shchepetkin & McWilliams, 2005, Ocean Modelling.
!!----------------------------------------------------------------------
INTEGER , INTENT(in ) :: kt , Kbb, Kmm, Krhs ! ocean time-step and level indices
- INTEGER , OPTIONAL , INTENT(in ) :: no_zad ! no vertical advection compotation
REAL(wp), DIMENSION(jpi,jpj,jpk,jpt), TARGET, INTENT(inout) :: puu, pvv ! ocean velocities and RHS of momentum equation
REAL(wp), DIMENSION(:,:,:), OPTIONAL, TARGET, INTENT(in ) :: pau, pav, paw ! advective velocity
!
INTEGER :: ji, jj, jk ! dummy loop indices
- REAL(wp) :: zui, zvj, zfuj, zfvi, zl_u, zl_v, zzu, zzv ! local scalars
- REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zfu_t, zfu_f, zfu_uw, zfu
- REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zfv_t, zfv_f, zfv_vw, zfv, zfw
- REAL(wp), DIMENSION(A2D(nn_hls),jpk,2) :: zlu_uu, zlu_uv
- REAL(wp), DIMENSION(A2D(nn_hls),jpk,2) :: zlv_vv, zlv_vu
- REAL(wp), DIMENSION(:,:,:), POINTER :: zpt_u, zpt_v, zpt_w
+ REAL(wp) :: zzu, zui, zfuj, zl_u, zzfu_kp1 ! local scalars
+ REAL(wp) :: zzv, zvj, zfvi, zl_v, zzfv_kp1 ! - -
+ REAL(wp), DIMENSION(T2D(2)) :: zfu_t, zfu_f, zfu
+ REAL(wp), DIMENSION(T2D(2)) :: zfv_t, zfv_f, zfv
+ REAL(wp), DIMENSION(T2D(2),2) :: zlu_uu, zlu_uv
+ REAL(wp), DIMENSION(T2D(2),2) :: zlv_vv, zlv_vu
+ REAL(wp), DIMENSION(:,:,:) , POINTER :: zpt_u, zpt_v, zpt_w
+ REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE :: zu_trd, zv_trd
!!----------------------------------------------------------------------
!
IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile
@@ -94,19 +96,10 @@ CONTAINS
ENDIF
ENDIF
!
- zfu_t(:,:,:) = 0._wp
- zfv_t(:,:,:) = 0._wp
- zfu_f(:,:,:) = 0._wp
- zfv_f(:,:,:) = 0._wp
- !
- zlu_uu(:,:,:,:) = 0._wp
- zlv_vv(:,:,:,:) = 0._wp
- zlu_uv(:,:,:,:) = 0._wp
- zlv_vu(:,:,:,:) = 0._wp
- !
- IF( l_trddyn ) THEN ! trends: store the input trends
- zfu_uw(:,:,:) = puu(:,:,:,Krhs)
- zfv_vw(:,:,:) = pvv(:,:,:,Krhs)
+ IF( l_trddyn ) THEN ! trends: send trend to trddyn for diagnostic
+ ALLOCATE( zu_trd(A2D(0),jpkm1), zv_trd(A2D(0),jpkm1) )
+ zu_trd(A2D(0),:) = puu(A2D(0),:,Krhs)
+ zv_trd(A2D(0),:) = pvv(A2D(0),:,Krhs)
ENDIF
!
IF( PRESENT( pau ) ) THEN ! RK3: advective velocity (pau,pav,paw) /= advected velocity (puu,pvv,ww)
@@ -123,169 +116,147 @@ CONTAINS
DO jk = 1, jpkm1 ! Laplacian of the velocity !
! ! =========================== !
! ! horizontal volume fluxes
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
- zfu(ji,jj,jk) = e2u(ji,jj) * e3u(ji,jj,jk,Kmm) * zpt_u(ji,jj,jk)
- zfv(ji,jj,jk) = e1v(ji,jj) * e3v(ji,jj,jk,Kmm) * zpt_v(ji,jj,jk)
+ DO_2D( 2, 2, 2, 2 )
+ zfu(ji,jj) = e2u(ji,jj) * e3u(ji,jj,jk,Kmm) * zpt_u(ji,jj,jk)
+ zfv(ji,jj) = e1v(ji,jj) * e3v(ji,jj,jk,Kmm) * zpt_v(ji,jj,jk)
END_2D
!
- DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) ! laplacian
- ! round brackets added to fix the order of floating point operations
- ! needed to ensure halo 1 - halo 2 compatibility
- zlu_uu(ji,jj,jk,1) = ( ( puu (ji+1,jj ,jk,Kbb) - puu (ji ,jj ,jk,Kbb) &
- & ) & ! bracket for halo 1 - halo 2 compatibility
- & + ( puu (ji-1,jj ,jk,Kbb) - puu (ji ,jj ,jk,Kbb) &
- & ) & ! bracket for halo 1 - halo 2 compatibility
- & ) * umask(ji ,jj ,jk)
- zlv_vv(ji,jj,jk,1) = ( ( pvv (ji ,jj+1,jk,Kbb) - pvv (ji ,jj ,jk,Kbb) &
- & ) & ! bracket for halo 1 - halo 2 compatibility
- & + ( pvv (ji ,jj-1,jk,Kbb) - pvv (ji ,jj ,jk,Kbb) &
- & ) & ! bracket for halo 1 - halo 2 compatibility
- & ) * vmask(ji ,jj ,jk)
- zlu_uv(ji,jj,jk,1) = ( puu (ji ,jj+1,jk,Kbb) - puu (ji ,jj ,jk,Kbb) ) * fmask(ji ,jj ,jk) &
- & - ( puu (ji ,jj ,jk,Kbb) - puu (ji ,jj-1,jk,Kbb) ) * fmask(ji ,jj-1,jk)
- zlv_vu(ji,jj,jk,1) = ( pvv (ji+1,jj ,jk,Kbb) - pvv (ji ,jj ,jk,Kbb) ) * fmask(ji ,jj ,jk) &
- & - ( pvv (ji ,jj ,jk,Kbb) - pvv (ji-1,jj ,jk,Kbb) ) * fmask(ji-1,jj ,jk)
+ DO_2D( 1, 1, 1, 1 ) ! laplacian
+ zlu_uu(ji,jj,1) = ( ( puu (ji+1,jj ,jk,Kbb) - puu (ji ,jj ,jk,Kbb) ) & ! add () for NP repro
+ & + ( puu (ji-1,jj ,jk,Kbb) - puu (ji ,jj ,jk,Kbb) ) ) * umask(ji ,jj ,jk)
+ zlv_vv(ji,jj,1) = ( ( pvv (ji ,jj+1,jk,Kbb) - pvv (ji ,jj ,jk,Kbb) ) & ! add () for NP repro
+ & + ( pvv (ji ,jj-1,jk,Kbb) - pvv (ji ,jj ,jk,Kbb) ) ) * vmask(ji ,jj ,jk)
+ zlu_uv(ji,jj,1) = ( puu(ji ,jj+1,jk,Kbb) - puu(ji ,jj ,jk,Kbb) ) * fmask(ji ,jj ,jk) &
+ & - ( puu(ji ,jj ,jk,Kbb) - puu(ji ,jj-1,jk,Kbb) ) * fmask(ji ,jj-1,jk)
+ zlv_vu(ji,jj,1) = ( pvv(ji+1,jj ,jk,Kbb) - pvv(ji ,jj ,jk,Kbb) ) * fmask(ji ,jj ,jk) &
+ & - ( pvv(ji ,jj ,jk,Kbb) - pvv(ji-1,jj ,jk,Kbb) ) * fmask(ji-1,jj ,jk)
!
- ! round brackets added to fix the order of floating point operations
- ! needed to ensure halo 1 - halo 2 compatibility
- zlu_uu(ji,jj,jk,2) = ( ( zfu(ji+1,jj ,jk) - zfu(ji ,jj ,jk) &
- & ) & ! bracket for halo 1 - halo 2 compatibility
- & + ( zfu(ji-1,jj ,jk) - zfu(ji ,jj ,jk) &
- & ) & ! bracket for halo 1 - halo 2 compatibility
- & ) * umask(ji ,jj ,jk)
- zlv_vv(ji,jj,jk,2) = ( ( zfv(ji ,jj+1,jk) - zfv(ji ,jj ,jk) &
- & ) & ! bracket for halo 1 - halo 2 compatibility
- & + ( zfv(ji ,jj-1,jk) - zfv(ji ,jj ,jk) &
- & ) & ! bracket for halo 1 - halo 2 compatibility
- & ) * vmask(ji ,jj ,jk)
- zlu_uv(ji,jj,jk,2) = ( zfu(ji ,jj+1,jk) - zfu(ji ,jj ,jk) ) * fmask(ji ,jj ,jk) &
- & - ( zfu(ji ,jj ,jk) - zfu(ji ,jj-1,jk) ) * fmask(ji ,jj-1,jk)
- zlv_vu(ji,jj,jk,2) = ( zfv(ji+1,jj ,jk) - zfv(ji ,jj ,jk) ) * fmask(ji ,jj ,jk) &
- & - ( zfv(ji ,jj ,jk) - zfv(ji-1,jj ,jk) ) * fmask(ji-1,jj ,jk)
+ zlu_uu(ji,jj,2) = ( ( zfu(ji+1,jj ) - zfu(ji ,jj ) ) & ! add () for NP repro
+ & + ( zfu(ji-1,jj ) - zfu(ji ,jj ) ) ) * umask(ji ,jj ,jk)
+ zlv_vv(ji,jj,2) = ( ( zfv(ji ,jj+1) - zfv(ji ,jj ) ) & ! add () for NP repro
+ & + ( zfv(ji ,jj-1) - zfv(ji ,jj ) ) ) * vmask(ji ,jj ,jk)
+ zlu_uv(ji,jj,2) = ( zfu(ji ,jj+1) - zfu(ji ,jj ) ) * fmask(ji ,jj ,jk) &
+ & - ( zfu(ji ,jj ) - zfu(ji ,jj-1) ) * fmask(ji ,jj-1,jk)
+ zlv_vu(ji,jj,2) = ( zfv(ji+1,jj ) - zfv(ji ,jj ) ) * fmask(ji ,jj ,jk) &
+ & - ( zfv(ji ,jj ) - zfv(ji-1,jj ) ) * fmask(ji-1,jj ,jk)
END_2D
- END DO
- IF( nn_hls == 1 ) CALL lbc_lnk( 'dynadv_ubs', zlu_uu(:,:,:,1), 'U', -1.0_wp , zlu_uv(:,:,:,1), 'U', -1.0_wp, &
- & zlu_uu(:,:,:,2), 'U', -1.0_wp , zlu_uv(:,:,:,2), 'U', -1.0_wp, &
- & zlv_vv(:,:,:,1), 'V', -1.0_wp , zlv_vu(:,:,:,1), 'V', -1.0_wp, &
- & zlv_vv(:,:,:,2), 'V', -1.0_wp , zlv_vu(:,:,:,2), 'V', -1.0_wp )
- !
- ! ! ====================== !
- ! ! Horizontal advection !
- DO jk = 1, jpkm1 ! ====================== !
+ !
+ ! ! ====================== !
+ ! ! Horizontal advection !
+ ! ! ====================== !
! ! horizontal volume fluxes
DO_2D( 1, 1, 1, 1 )
- zfu(ji,jj,jk) = 0.25_wp * e2u(ji,jj) * e3u(ji,jj,jk,Kmm) * zpt_u(ji,jj,jk)
- zfv(ji,jj,jk) = 0.25_wp * e1v(ji,jj) * e3v(ji,jj,jk,Kmm) * zpt_v(ji,jj,jk)
+ zfu(ji,jj) = 0.25_wp * zfu(ji,jj)
+ zfv(ji,jj) = 0.25_wp * zfv(ji,jj)
END_2D
!
DO_2D( 1, 0, 1, 0 ) ! horizontal momentum fluxes at T- and F-point
zui = ( puu(ji,jj,jk,Kmm) + puu(ji+1,jj ,jk,Kmm) )
zvj = ( pvv(ji,jj,jk,Kmm) + pvv(ji ,jj+1,jk,Kmm) )
!
- IF( zui > 0 ) THEN ; zl_u = zlu_uu(ji ,jj,jk,1)
- ELSE ; zl_u = zlu_uu(ji+1,jj,jk,1)
+ IF( zui > 0 ) THEN ; zl_u = zlu_uu(ji ,jj,1)
+ ELSE ; zl_u = zlu_uu(ji+1,jj,1)
ENDIF
- IF( zvj > 0 ) THEN ; zl_v = zlv_vv(ji,jj ,jk,1)
- ELSE ; zl_v = zlv_vv(ji,jj+1,jk,1)
+ IF( zvj > 0 ) THEN ; zl_v = zlv_vv(ji,jj ,1)
+ ELSE ; zl_v = zlv_vv(ji,jj+1,1)
ENDIF
!
- zfu_t(ji+1,jj ,jk) = ( zfu(ji,jj,jk) + zfu(ji+1,jj ,jk) &
- & - gamma2 * ( zlu_uu(ji,jj,jk,2) + zlu_uu(ji+1,jj ,jk,2) ) ) &
- & * ( zui - gamma1 * zl_u)
- zfv_t(ji ,jj+1,jk) = ( zfv(ji,jj,jk) + zfv(ji ,jj+1,jk) &
- & - gamma2 * ( zlv_vv(ji,jj,jk,2) + zlv_vv(ji ,jj+1,jk,2) ) ) &
- & * ( zvj - gamma1 * zl_v)
+ zfu_t(ji+1,jj ) = ( ( zfu(ji,jj ) + zfu(ji+1,jj ) ) & ! add () for NP repro
+ & - gamma2 * ( zlu_uu(ji,jj,2) + zlu_uu(ji+1,jj, 2) ) ) * ( zui - gamma1 * zl_u )
+ zfv_t(ji ,jj+1) = ( ( zfv(ji,jj ) + zfv(ji ,jj+1 ) ) & ! add () for NP repro
+ & - gamma2 * ( zlv_vv(ji,jj,2) + zlv_vv(ji ,jj+1,2) ) ) * ( zvj - gamma1 * zl_v )
!
- zfuj = ( zfu(ji,jj,jk) + zfu(ji ,jj+1,jk) )
- zfvi = ( zfv(ji,jj,jk) + zfv(ji+1,jj ,jk) )
- IF( zfuj > 0 ) THEN ; zl_v = zlv_vu( ji ,jj ,jk,1)
- ELSE ; zl_v = zlv_vu( ji+1,jj,jk,1)
+ zfuj = ( zfu(ji,jj) + zfu(ji ,jj+1) )
+ zfvi = ( zfv(ji,jj) + zfv(ji+1,jj ) )
+ IF( zfuj > 0 ) THEN ; zl_v = zlv_vu(ji ,jj,1)
+ ELSE ; zl_v = zlv_vu(ji+1,jj,1)
ENDIF
- IF( zfvi > 0 ) THEN ; zl_u = zlu_uv( ji,jj ,jk,1)
- ELSE ; zl_u = zlu_uv( ji,jj+1,jk,1)
+ IF( zfvi > 0 ) THEN ; zl_u = zlu_uv(ji,jj ,1)
+ ELSE ; zl_u = zlu_uv(ji,jj+1,1)
ENDIF
!
- zfv_f(ji ,jj ,jk) = ( zfvi - gamma2 * ( zlv_vu(ji,jj,jk,2) + zlv_vu(ji+1,jj ,jk,2) ) ) &
- & * ( puu(ji,jj,jk,Kmm) + puu(ji ,jj+1,jk,Kmm) - gamma1 * zl_u )
- zfu_f(ji ,jj ,jk) = ( zfuj - gamma2 * ( zlu_uv(ji,jj,jk,2) + zlu_uv(ji ,jj+1,jk,2) ) ) &
- & * ( pvv(ji,jj,jk,Kmm) + pvv(ji+1,jj ,jk,Kmm) - gamma1 * zl_v )
+ zfv_f(ji ,jj ) = ( zfvi - gamma2 * ( zlv_vu(ji,jj,2) + zlv_vu(ji+1,jj ,2) ) ) &
+ & * ( ( puu(ji,jj,jk,Kmm) + puu(ji ,jj+1,jk,Kmm) ) - gamma1 * zl_u ) ! add () for NP repro
+ zfu_f(ji ,jj ) = ( zfuj - gamma2 * ( zlu_uv(ji,jj,2) + zlu_uv(ji ,jj+1,2) ) ) &
+ & * ( ( pvv(ji,jj,jk,Kmm) + pvv(ji+1,jj ,jk,Kmm) ) - gamma1 * zl_v ) ! add () for NP repro
END_2D
DO_2D( 0, 0, 0, 0 ) ! divergence of horizontal momentum fluxes
- puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) - ( zfu_t(ji+1,jj,jk) - zfu_t(ji,jj ,jk) &
- & + zfv_f(ji ,jj,jk) - zfv_f(ji,jj-1,jk) ) * r1_e1e2u(ji,jj) &
- & / e3u(ji,jj,jk,Kmm)
- pvv(ji,jj,jk,Krhs) = pvv(ji,jj,jk,Krhs) - ( zfu_f(ji,jj ,jk) - zfu_f(ji-1,jj,jk) &
- & + zfv_t(ji,jj+1,jk) - zfv_t(ji ,jj,jk) ) * r1_e1e2v(ji,jj) &
- & / e3v(ji,jj,jk,Kmm)
+ puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) - ( ( zfu_t(ji+1,jj) - zfu_t(ji,jj ) ) & ! add () for NP repro
+ & + ( zfv_f(ji ,jj) - zfv_f(ji,jj-1) ) ) * r1_e1e2u(ji,jj) &
+ & / e3u(ji,jj,jk,Kmm)
+ pvv(ji,jj,jk,Krhs) = pvv(ji,jj,jk,Krhs) - ( ( zfu_f(ji,jj ) - zfu_f(ji-1,jj) ) & ! add () for NP repro
+ & + ( zfv_t(ji,jj+1) - zfv_t(ji ,jj) ) ) * r1_e1e2v(ji,jj) &
+ & / e3v(ji,jj,jk,Kmm)
END_2D
END DO
- IF( l_trddyn ) THEN ! trends: send trends to trddyn for diagnostic
- zfu_uw(:,:,:) = puu(:,:,:,Krhs) - zfu_uw(:,:,:)
- zfv_vw(:,:,:) = pvv(:,:,:,Krhs) - zfv_vw(:,:,:)
- CALL trd_dyn( zfu_uw, zfv_vw, jpdyn_keg, kt, Kmm )
- zfu_t(:,:,:) = puu(:,:,:,Krhs)
- zfv_t(:,:,:) = pvv(:,:,:,Krhs)
+ !
+ IF( l_trddyn ) THEN ! trends: send trend to trddyn for diagnostic
+ zu_trd(A2D(0),:) = puu(A2D(0),:,Krhs) - zu_trd(A2D(0),:)
+ zv_trd(A2D(0),:) = pvv(A2D(0),:,Krhs) - zv_trd(A2D(0),:)
+ CALL trd_dyn( zu_trd, zv_trd, jpdyn_keg, kt, Kmm )
+ zu_trd(A2D(0),:) = puu(A2D(0),:,Krhs)
+ zv_trd(A2D(0),:) = pvv(A2D(0),:,Krhs)
ENDIF
! ! ==================== !
! ! Vertical advection !
! ! ==================== !
!
- ! ! ======================== !
- IF( PRESENT( no_zad ) ) THEN ! No vertical advection ! (except if linear free surface)
- ! ! ======================== ! ------
- !
- IF( ln_linssh ) THEN ! linear free surface: advection through the surface z=0
- DO_2D( 0, 0, 0, 0 )
- zzu = 0.5_wp * ( e1e2t(ji,jj) * zpt_w(ji,jj,1) + e1e2t(ji+1,jj) * zpt_w(ji+1,jj,1) ) * puu(ji,jj,1,Kmm)
- zzv = 0.5_wp * ( e1e2t(ji,jj) * zpt_w(ji,jj,1) + e1e2t(ji,jj+1) * zpt_w(ji,jj+1,1) ) * pvv(ji,jj,1,Kmm)
- puu(ji,jj,1,Krhs) = puu(ji,jj,1,Krhs) - zzu * r1_e1e2u(ji,jj) &
- & / e3u(ji,jj,1,Kmm)
- pvv(ji,jj,1,Krhs) = pvv(ji,jj,1,Krhs) - zzv * r1_e1e2v(ji,jj) &
- & / e3v(ji,jj,1,Kmm)
- END_2D
- ENDIF
- ! ! =================== !
- ELSE ! Vertical advection !
- ! ! =================== !
- DO_2D( 0, 0, 0, 0 ) ! surface/bottom advective fluxes set to zero
- zfu_uw(ji,jj,jpk) = 0._wp
- zfv_vw(ji,jj,jpk) = 0._wp
- zfu_uw(ji,jj, 1 ) = 0._wp
- zfv_vw(ji,jj, 1 ) = 0._wp
+#define zfu_uw zfu_t
+#define zfv_vw zfv_t
+#define zfw zfu
+ !
+ ! ! surface vertical fluxes
+ !
+ IF( ln_linssh ) THEN ! linear free surface: advection through the surface z=0
+ DO_2D( 0, 0, 0, 0 )
+ zfu_uw(ji,jj) = 0.5_wp * ( e1e2t(ji,jj) * zpt_w(ji,jj,1) + e1e2t(ji+1,jj) * zpt_w(ji+1,jj,1) ) * puu(ji,jj,1,Kmm)
+ zfv_vw(ji,jj) = 0.5_wp * ( e1e2t(ji,jj) * zpt_w(ji,jj,1) + e1e2t(ji,jj+1) * zpt_w(ji,jj+1,1) ) * pvv(ji,jj,1,Kmm)
END_2D
- IF( ln_linssh ) THEN ! constant volume : advection through the surface
- DO_2D( 0, 0, 0, 0 )
- zfu_uw(ji,jj,1) = 0.5_wp * ( e1e2t(ji,jj) * zpt_w(ji,jj,1) + e1e2t(ji+1,jj) * zpt_w(ji+1,jj,1) ) * puu(ji,jj,1,Kmm)
- zfv_vw(ji,jj,1) = 0.5_wp * ( e1e2t(ji,jj) * zpt_w(ji,jj,1) + e1e2t(ji,jj+1) * zpt_w(ji,jj+1,1) ) * pvv(ji,jj,1,Kmm)
- END_2D
- ENDIF
- DO jk = 2, jpkm1 ! interior fluxes
- DO_2D( 0, 1, 0, 1 )
- zfw(ji,jj,jk) = 0.25_wp * e1e2t(ji,jj) * zpt_w(ji,jj,jk)
- END_2D
- DO_2D( 0, 0, 0, 0 )
- zfu_uw(ji,jj,jk) = ( zfw(ji,jj,jk)+ zfw(ji+1,jj,jk) ) * ( puu(ji,jj,jk,Kmm) + puu(ji,jj,jk-1,Kmm) )
- zfv_vw(ji,jj,jk) = ( zfw(ji,jj,jk)+ zfw(ji,jj+1,jk) ) * ( pvv(ji,jj,jk,Kmm) + pvv(ji,jj,jk-1,Kmm) )
- END_2D
- END DO
- DO_3D( 0, 0, 0, 0, 1, jpkm1 ) ! divergence of vertical momentum flux divergence
- puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) - ( zfu_uw(ji,jj,jk) - zfu_uw(ji,jj,jk+1) ) * r1_e1e2u(ji,jj) &
- & / e3u(ji,jj,jk,Kmm)
- pvv(ji,jj,jk,Krhs) = pvv(ji,jj,jk,Krhs) - ( zfv_vw(ji,jj,jk) - zfv_vw(ji,jj,jk+1) ) * r1_e1e2v(ji,jj) &
- & / e3v(ji,jj,jk,Kmm)
- END_3D
- !
- IF( l_trddyn ) THEN ! save the vertical advection trend for diagnostic
- zfu_t(:,:,:) = puu(:,:,:,Krhs) - zfu_t(:,:,:)
- zfv_t(:,:,:) = pvv(:,:,:,Krhs) - zfv_t(:,:,:)
- CALL trd_dyn( zfu_t, zfv_t, jpdyn_zad, kt, Kmm )
- ENDIF
- ! ! Control print
- IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=puu(:,:,:,Krhs), clinfo1=' ubs2 adv - Ua: ', mask1=umask, &
- & tab3d_2=pvv(:,:,:,Krhs), clinfo2= ' Va: ', mask2=vmask, clinfo3='dyn' )
+ ELSE ! non linear free: surface advective fluxes set to zero
+ DO_2D( 0, 0, 0, 0 )
+ zfu_uw(ji,jj) = 0._wp
+ zfv_vw(ji,jj) = 0._wp
+ END_2D
+ ENDIF
+ !
+ DO jk = 1, jpk-2 ! divergence of advective fluxes
!
+ DO_2D( 0, 1, 0, 1 ) ! 1/4 * Vertical transport at level k+1
+ zfw(ji,jj) = 0.25_wp * e1e2t(ji,jj) * zpt_w(ji,jj,jk+1)
+ END_2D
+ DO_2D( 0, 0, 0, 0 )
+ ! ! vertical flux at level k+1
+ zzfu_kp1 = ( zfw(ji,jj) + zfw(ji+1,jj ) ) * ( puu(ji,jj,jk+1,Kmm) + puu(ji,jj,jk,Kmm) )
+ zzfv_kp1 = ( zfw(ji,jj) + zfw(ji ,jj+1) ) * ( pvv(ji,jj,jk+1,Kmm) + pvv(ji,jj,jk,Kmm) )
+ ! ! divergence of vertical momentum flux
+ puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) - ( zfu_uw(ji,jj) - zzfu_kp1 ) * r1_e1e2u(ji,jj) / e3u(ji,jj,jk,Kmm)
+ pvv(ji,jj,jk,Krhs) = pvv(ji,jj,jk,Krhs) - ( zfv_vw(ji,jj) - zzfv_kp1 ) * r1_e1e2v(ji,jj) / e3v(ji,jj,jk,Kmm)
+ ! ! store vertical flux for next level calculation
+ zfu_uw(ji,jj) = zzfu_kp1
+ zfv_vw(ji,jj) = zzfv_kp1
+ END_2D
+ END DO
+ !
+ jk = jpkm1 ! compute last level (zzfu_kp1 = 0)
+ DO_2D( 0, 0, 0, 0 )
+ puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) - zfu_uw(ji,jj) * r1_e1e2u(ji,jj) / e3u(ji,jj,jk,Kmm)
+ pvv(ji,jj,jk,Krhs) = pvv(ji,jj,jk,Krhs) - zfv_vw(ji,jj) * r1_e1e2v(ji,jj) / e3v(ji,jj,jk,Kmm)
+ END_2D
+ !
+ IF( l_trddyn ) THEN ! trends: send trend to trddyn for diagnostic
+ zu_trd(A2D(0),:) = puu(A2D(0),:,Krhs) - zu_trd(A2D(0),:)
+ zv_trd(A2D(0),:) = pvv(A2D(0),:,Krhs) - zv_trd(A2D(0),:)
+ CALL trd_dyn( zu_trd, zv_trd, jpdyn_zad, kt, Kmm )
+ DEALLOCATE( zu_trd, zv_trd )
ENDIF
!
+#undef zfu_uw
+#undef zfv_vw
+#undef zfw
+ ! ! Control print
+ IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=puu(:,:,:,Krhs), clinfo1=' ubs2 adv - Ua: ', mask1=umask, &
+ & tab3d_2=pvv(:,:,:,Krhs), clinfo2= ' Va: ', mask2=vmask, clinfo3='dyn' )
+ !
END SUBROUTINE dyn_adv_ubs
!!==============================================================================
diff --git a/src/OCE/DYN/dynatf.F90 b/src/OCE/DYN/dynatf.F90
deleted file mode 100644
index 997692694ddf1bf7dd1fa04a5c50e96759b4e3c2..0000000000000000000000000000000000000000
--- a/src/OCE/DYN/dynatf.F90
+++ /dev/null
@@ -1,369 +0,0 @@
-MODULE dynatf
- !!=========================================================================
- !! *** MODULE dynatf ***
- !! Ocean dynamics: time filtering
- !!=========================================================================
- !! History : OPA ! 1987-02 (P. Andrich, D. L Hostis) Original code
- !! ! 1990-10 (C. Levy, G. Madec)
- !! 7.0 ! 1993-03 (M. Guyon) symetrical conditions
- !! 8.0 ! 1997-02 (G. Madec & M. Imbard) opa, release 8.0
- !! 8.2 ! 1997-04 (A. Weaver) Euler forward step
- !! - ! 1997-06 (G. Madec) lateral boudary cond., lbc routine
- !! NEMO 1.0 ! 2002-08 (G. Madec) F90: Free form and module
- !! - ! 2002-10 (C. Talandier, A-M. Treguier) Open boundary cond.
- !! 2.0 ! 2005-11 (V. Garnier) Surface pressure gradient organization
- !! 2.3 ! 2007-07 (D. Storkey) Calls to BDY routines.
- !! 3.2 ! 2009-06 (G. Madec, R.Benshila) re-introduce the vvl option
- !! 3.3 ! 2010-09 (D. Storkey, E.O'Dea) Bug fix for BDY module
- !! 3.3 ! 2011-03 (P. Oddo) Bug fix for time-splitting+(BDY-OBC) and not VVL
- !! 3.5 ! 2013-07 (J. Chanut) Compliant with time splitting changes
- !! 3.6 ! 2014-04 (G. Madec) add the diagnostic of the time filter trends
- !! 3.7 ! 2015-11 (J. Chanut) Free surface simplification
- !! 4.1 ! 2019-08 (A. Coward, D. Storkey) Rename dynnxt.F90 -> dynatf.F90. Now just does time filtering.
- !!-------------------------------------------------------------------------
-
- !!----------------------------------------------------------------------------------------------
- !! dyn_atf : apply Asselin time filtering to "now" velocities and vertical scale factors
- !!----------------------------------------------------------------------------------------------
- USE oce ! ocean dynamics and tracers
- USE dom_oce ! ocean space and time domain
- USE sbc_oce ! Surface boundary condition: ocean fields
- USE sbcrnf ! river runoffs
- USE phycst ! physical constants
- USE dynadv ! dynamics: vector invariant versus flux form
- USE dynspg_ts ! surface pressure gradient: split-explicit scheme
- USE domvvl ! variable volume
- USE bdy_oce , ONLY : ln_bdy
- USE bdydta ! ocean open boundary conditions
- USE bdydyn ! ocean open boundary conditions
- USE bdyvol ! ocean open boundary condition (bdy_vol routines)
- USE trd_oce ! trends: ocean variables
- USE trddyn ! trend manager: dynamics
- USE trdken ! trend manager: kinetic energy
- USE isf_oce , ONLY: ln_isf ! ice shelf
- USE isfdynatf , ONLY: isf_dynatf ! ice shelf volume filter correction subroutine
- !
- USE in_out_manager ! I/O manager
- USE iom ! I/O manager library
- USE lbclnk ! lateral boundary condition (or mpp link)
- USE lib_mpp ! MPP library
- USE prtctl ! Print control
- USE timing ! Timing
- USE zdfdrg , ONLY : ln_drgice_imp, rCdU_top
-#if defined key_agrif
- USE agrif_oce_interp
-#endif
-
- IMPLICIT NONE
- PRIVATE
-
- PUBLIC dyn_atf ! routine called by step.F90
-
-#if defined key_qco || defined key_linssh
- !!----------------------------------------------------------------------
- !! 'key_qco' Quasi-Eulerian vertical coordinate
- !! OR EMPTY MODULE
- !! 'key_linssh' Fix in time vertical coordinate
- !!----------------------------------------------------------------------
-CONTAINS
-
- SUBROUTINE dyn_atf( kt, Kbb, Kmm, Kaa, puu, pvv, pe3t, pe3u, pe3v )
- INTEGER , INTENT(in ) :: kt ! ocean time-step index
- INTEGER , INTENT(in ) :: Kbb, Kmm, Kaa ! before and after time level indices
- REAL(wp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) :: puu, pvv ! velocities to be time filtered
- REAL(wp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) :: pe3t, pe3u, pe3v ! scale factors to be time filtered
-
- WRITE(*,*) 'dyn_atf: You should not have seen this print! error?', kt
- END SUBROUTINE dyn_atf
-
-#else
-
- !! * Substitutions
-# include "do_loop_substitute.h90"
- !!----------------------------------------------------------------------
- !! NEMO/OCE 4.0 , NEMO Consortium (2018)
- !! $Id: dynatf.F90 14834 2021-05-11 09:24:44Z hadcv $
- !! Software governed by the CeCILL license (see ./LICENSE)
- !!----------------------------------------------------------------------
-CONTAINS
-
- SUBROUTINE dyn_atf ( kt, Kbb, Kmm, Kaa, puu, pvv, pe3t, pe3u, pe3v )
- !!----------------------------------------------------------------------
- !! *** ROUTINE dyn_atf ***
- !!
- !! ** Purpose : Finalize after horizontal velocity. Apply the boundary
- !! condition on the after velocity and apply the Asselin time
- !! filter to the now fields.
- !!
- !! ** Method : * Ensure after velocities transport matches time splitting
- !! estimate (ln_dynspg_ts=T)
- !!
- !! * Apply lateral boundary conditions on after velocity
- !! at the local domain boundaries through lbc_lnk call,
- !! at the one-way open boundaries (ln_bdy=T),
- !! at the AGRIF zoom boundaries (lk_agrif=T)
- !!
- !! * Apply the Asselin time filter to the now fields
- !! arrays to start the next time step:
- !! (puu(Kmm),pvv(Kmm)) = (puu(Kmm),pvv(Kmm))
- !! + rn_atfp [ (puu(Kbb),pvv(Kbb)) + (puu(Kaa),pvv(Kaa)) - 2 (puu(Kmm),pvv(Kmm)) ]
- !! Note that with flux form advection and non linear free surface,
- !! the time filter is applied on thickness weighted velocity.
- !! As a result, dyn_atf MUST be called after tra_atf.
- !!
- !! ** Action : puu(Kmm),pvv(Kmm) filtered now horizontal velocity
- !!----------------------------------------------------------------------
- INTEGER , INTENT(in ) :: kt ! ocean time-step index
- INTEGER , INTENT(in ) :: Kbb, Kmm, Kaa ! before and after time level indices
- REAL(wp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) :: puu, pvv ! velocities to be time filtered
- REAL(wp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) :: pe3t, pe3u, pe3v ! scale factors to be time filtered
- !
- INTEGER :: ji, jj, jk ! dummy loop indices
- REAL(wp) :: zue3a, zue3n, zue3b, zcoef ! local scalars
- REAL(wp) :: zve3a, zve3n, zve3b ! - -
- REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zue, zve, zwfld
- REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zutau, zvtau
- REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: ze3t_f, ze3u_f, ze3v_f, zua, zva
- !!----------------------------------------------------------------------
- !
- IF( ln_timing ) CALL timing_start('dyn_atf')
- IF( ln_dynspg_ts ) ALLOCATE( zue(jpi,jpj) , zve(jpi,jpj) )
- IF( l_trddyn ) ALLOCATE( zua(jpi,jpj,jpk) , zva(jpi,jpj,jpk) )
- !
- IF( kt == nit000 ) THEN
- IF(lwp) WRITE(numout,*)
- IF(lwp) WRITE(numout,*) 'dyn_atf : Asselin time filtering'
- IF(lwp) WRITE(numout,*) '~~~~~~~'
- ENDIF
-
- IF ( ln_dynspg_ts ) THEN
- ! Ensure below that barotropic velocities match time splitting estimate
- ! Compute actual transport and replace it with ts estimate at "after" time step
- zue(:,:) = pe3u(:,:,1,Kaa) * puu(:,:,1,Kaa) * umask(:,:,1)
- zve(:,:) = pe3v(:,:,1,Kaa) * pvv(:,:,1,Kaa) * vmask(:,:,1)
- DO jk = 2, jpkm1
- zue(:,:) = zue(:,:) + pe3u(:,:,jk,Kaa) * puu(:,:,jk,Kaa) * umask(:,:,jk)
- zve(:,:) = zve(:,:) + pe3v(:,:,jk,Kaa) * pvv(:,:,jk,Kaa) * vmask(:,:,jk)
- END DO
- DO jk = 1, jpkm1
- puu(:,:,jk,Kaa) = ( puu(:,:,jk,Kaa) - zue(:,:) * r1_hu(:,:,Kaa) + uu_b(:,:,Kaa) ) * umask(:,:,jk)
- pvv(:,:,jk,Kaa) = ( pvv(:,:,jk,Kaa) - zve(:,:) * r1_hv(:,:,Kaa) + vv_b(:,:,Kaa) ) * vmask(:,:,jk)
- END DO
- !
- IF( .NOT.ln_bt_fw ) THEN
- ! Remove advective velocity from "now velocities"
- ! prior to asselin filtering
- ! In the forward case, this is done below after asselin filtering
- ! so that asselin contribution is removed at the same time
- DO jk = 1, jpkm1
- puu(:,:,jk,Kmm) = ( puu(:,:,jk,Kmm) - un_adv(:,:)*r1_hu(:,:,Kmm) + uu_b(:,:,Kmm) )*umask(:,:,jk)
- pvv(:,:,jk,Kmm) = ( pvv(:,:,jk,Kmm) - vn_adv(:,:)*r1_hv(:,:,Kmm) + vv_b(:,:,Kmm) )*vmask(:,:,jk)
- END DO
- ENDIF
- ENDIF
-
- ! Update after velocity on domain lateral boundaries
- ! --------------------------------------------------
-# if defined key_agrif
- CALL Agrif_dyn( kt ) !* AGRIF zoom boundaries
-# endif
- !
- CALL lbc_lnk( 'dynatf', puu(:,:,:,Kaa), 'U', -1.0_wp, pvv(:,:,:,Kaa), 'V', -1.0_wp ) !* local domain boundaries
- !
- ! !* BDY open boundaries
- IF( ln_bdy .AND. ln_dynspg_exp ) CALL bdy_dyn( kt, Kbb, puu, pvv, Kaa )
- IF( ln_bdy .AND. ln_dynspg_ts ) CALL bdy_dyn( kt, Kbb, puu, pvv, Kaa, dyn3d_only=.true. )
-
-!!$ Do we need a call to bdy_vol here??
- !
- IF( l_trddyn ) THEN ! prepare the atf trend computation + some diagnostics
- !
- ! ! Kinetic energy and Conversion
- IF( ln_KE_trd ) CALL trd_dyn( puu(:,:,:,Kaa), pvv(:,:,:,Kaa), jpdyn_ken, kt, Kmm )
- !
- IF( ln_dyn_trd ) THEN ! 3D output: total momentum trends
- zua(:,:,:) = ( puu(:,:,:,Kaa) - puu(:,:,:,Kbb) ) * r1_Dt
- zva(:,:,:) = ( pvv(:,:,:,Kaa) - pvv(:,:,:,Kbb) ) * r1_Dt
- CALL iom_put( "utrd_tot", zua ) ! total momentum trends, except the asselin time filter
- CALL iom_put( "vtrd_tot", zva )
- ENDIF
- !
- zua(:,:,:) = puu(:,:,:,Kmm) ! save the now velocity before the asselin filter
- zva(:,:,:) = pvv(:,:,:,Kmm) ! (caution: there will be a shift by 1 timestep in the
- ! ! computation of the asselin filter trends)
- ENDIF
-
- ! Time filter and swap of dynamics arrays
- ! ------------------------------------------
-
- IF( .NOT. l_1st_euler ) THEN !* Leap-Frog : Asselin time filter
- ! ! =============!
- IF( ln_linssh ) THEN ! Fixed volume !
- ! ! =============!
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 )
- puu(ji,jj,jk,Kmm) = puu(ji,jj,jk,Kmm) + rn_atfp * ( puu(ji,jj,jk,Kbb) - 2._wp * puu(ji,jj,jk,Kmm) + puu(ji,jj,jk,Kaa) )
- pvv(ji,jj,jk,Kmm) = pvv(ji,jj,jk,Kmm) + rn_atfp * ( pvv(ji,jj,jk,Kbb) - 2._wp * pvv(ji,jj,jk,Kmm) + pvv(ji,jj,jk,Kaa) )
- END_3D
- ! ! ================!
- ELSE ! Variable volume !
- ! ! ================!
- ! Time-filtered scale factor at t-points
- ! ----------------------------------------------------
- ALLOCATE( ze3t_f(jpi,jpj,jpk), zwfld(jpi,jpj) )
- DO jk = 1, jpkm1
- ze3t_f(:,:,jk) = pe3t(:,:,jk,Kmm) + rn_atfp * ( pe3t(:,:,jk,Kbb) - 2._wp * pe3t(:,:,jk,Kmm) + pe3t(:,:,jk,Kaa) )
- END DO
- ! Add volume filter correction: compatibility with tracer advection scheme
- ! => time filter + conservation correction
- zcoef = rn_atfp * rn_Dt * r1_rho0
- zwfld(:,:) = emp_b(:,:) - emp(:,:)
- IF ( ln_rnf ) zwfld(:,:) = zwfld(:,:) - ( rnf_b(:,:) - rnf(:,:) )
-
- DO jk = 1, jpkm1
- ze3t_f(:,:,jk) = ze3t_f(:,:,jk) - zcoef * zwfld(:,:) * tmask(:,:,jk) &
- & * pe3t(:,:,jk,Kmm) / ( ht(:,:) + 1._wp - ssmask(:,:) )
- END DO
- !
- ! ice shelf melting (deal separately as it can be in depth)
- ! PM: we could probably define a generic subroutine to do the in depth correction
- ! to manage rnf, isf and possibly in the futur icb, tide water glacier (...)
- ! ...(kt, coef, ktop, kbot, hz, fwf_b, fwf)
- IF ( ln_isf ) CALL isf_dynatf( kt, Kmm, ze3t_f, rn_atfp * rn_Dt )
- !
- pe3t(:,:,1:jpkm1,Kmm) = ze3t_f(:,:,1:jpkm1) ! filtered scale factor at T-points
- !
- IF( ln_dynadv_vec ) THEN ! Asselin filter applied on velocity
- ! Before filtered scale factor at (u/v)-points
- CALL dom_vvl_interpol( pe3t(:,:,:,Kmm), pe3u(:,:,:,Kmm), 'U' )
- CALL dom_vvl_interpol( pe3t(:,:,:,Kmm), pe3v(:,:,:,Kmm), 'V' )
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 )
- puu(ji,jj,jk,Kmm) = puu(ji,jj,jk,Kmm) + rn_atfp * ( puu(ji,jj,jk,Kbb) - 2._wp * puu(ji,jj,jk,Kmm) + puu(ji,jj,jk,Kaa) )
- pvv(ji,jj,jk,Kmm) = pvv(ji,jj,jk,Kmm) + rn_atfp * ( pvv(ji,jj,jk,Kbb) - 2._wp * pvv(ji,jj,jk,Kmm) + pvv(ji,jj,jk,Kaa) )
- END_3D
- !
- ELSE ! Asselin filter applied on thickness weighted velocity
- !
- ALLOCATE( ze3u_f(jpi,jpj,jpk) , ze3v_f(jpi,jpj,jpk) )
- ! Now filtered scale factor at (u/v)-points stored in ze3u_f, ze3v_f
- CALL dom_vvl_interpol( pe3t(:,:,:,Kmm), ze3u_f, 'U' )
- CALL dom_vvl_interpol( pe3t(:,:,:,Kmm), ze3v_f, 'V' )
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 )
- zue3a = pe3u(ji,jj,jk,Kaa) * puu(ji,jj,jk,Kaa)
- zve3a = pe3v(ji,jj,jk,Kaa) * pvv(ji,jj,jk,Kaa)
- zue3n = pe3u(ji,jj,jk,Kmm) * puu(ji,jj,jk,Kmm)
- zve3n = pe3v(ji,jj,jk,Kmm) * pvv(ji,jj,jk,Kmm)
- zue3b = pe3u(ji,jj,jk,Kbb) * puu(ji,jj,jk,Kbb)
- zve3b = pe3v(ji,jj,jk,Kbb) * pvv(ji,jj,jk,Kbb)
- !
- puu(ji,jj,jk,Kmm) = ( zue3n + rn_atfp * ( zue3b - 2._wp * zue3n + zue3a ) ) / ze3u_f(ji,jj,jk)
- pvv(ji,jj,jk,Kmm) = ( zve3n + rn_atfp * ( zve3b - 2._wp * zve3n + zve3a ) ) / ze3v_f(ji,jj,jk)
- END_3D
- pe3u(:,:,1:jpkm1,Kmm) = ze3u_f(:,:,1:jpkm1)
- pe3v(:,:,1:jpkm1,Kmm) = ze3v_f(:,:,1:jpkm1)
- !
- DEALLOCATE( ze3u_f , ze3v_f )
- ENDIF
- !
- DEALLOCATE( ze3t_f, zwfld )
- ENDIF
- !
- IF( ln_dynspg_ts .AND. ln_bt_fw ) THEN
- ! Revert filtered "now" velocities to time split estimate
- ! Doing it here also means that asselin filter contribution is removed
- zue(:,:) = pe3u(:,:,1,Kmm) * puu(:,:,1,Kmm) * umask(:,:,1)
- zve(:,:) = pe3v(:,:,1,Kmm) * pvv(:,:,1,Kmm) * vmask(:,:,1)
- DO jk = 2, jpkm1
- zue(:,:) = zue(:,:) + pe3u(:,:,jk,Kmm) * puu(:,:,jk,Kmm) * umask(:,:,jk)
- zve(:,:) = zve(:,:) + pe3v(:,:,jk,Kmm) * pvv(:,:,jk,Kmm) * vmask(:,:,jk)
- END DO
- DO jk = 1, jpkm1
- puu(:,:,jk,Kmm) = puu(:,:,jk,Kmm) - (zue(:,:) * r1_hu(:,:,Kmm) - uu_b(:,:,Kmm)) * umask(:,:,jk)
- pvv(:,:,jk,Kmm) = pvv(:,:,jk,Kmm) - (zve(:,:) * r1_hv(:,:,Kmm) - vv_b(:,:,Kmm)) * vmask(:,:,jk)
- END DO
- ENDIF
- !
- ENDIF ! .NOT. l_1st_euler
- !
- ! This is needed for dyn_ldf_blp to be restartable
- IF( nn_hls == 2 ) CALL lbc_lnk( 'dynatf', puu(:,:,:,Kmm), 'U', -1.0_wp, pvv(:,:,:,Kmm), 'V', -1.0_wp )
- ! Set "now" and "before" barotropic velocities for next time step:
- ! JC: Would be more clever to swap variables than to make a full vertical
- ! integration
- !
- IF(.NOT.ln_linssh ) THEN
- hu(:,:,Kmm) = pe3u(:,:,1,Kmm ) * umask(:,:,1)
- hv(:,:,Kmm) = pe3v(:,:,1,Kmm ) * vmask(:,:,1)
- DO jk = 2, jpkm1
- hu(:,:,Kmm) = hu(:,:,Kmm) + pe3u(:,:,jk,Kmm ) * umask(:,:,jk)
- hv(:,:,Kmm) = hv(:,:,Kmm) + pe3v(:,:,jk,Kmm ) * vmask(:,:,jk)
- END DO
- r1_hu(:,:,Kmm) = ssumask(:,:) / ( hu(:,:,Kmm) + 1._wp - ssumask(:,:) )
- r1_hv(:,:,Kmm) = ssvmask(:,:) / ( hv(:,:,Kmm) + 1._wp - ssvmask(:,:) )
- ENDIF
- !
- uu_b(:,:,Kaa) = pe3u(:,:,1,Kaa) * puu(:,:,1,Kaa) * umask(:,:,1)
- uu_b(:,:,Kmm) = pe3u(:,:,1,Kmm) * puu(:,:,1,Kmm) * umask(:,:,1)
- vv_b(:,:,Kaa) = pe3v(:,:,1,Kaa) * pvv(:,:,1,Kaa) * vmask(:,:,1)
- vv_b(:,:,Kmm) = pe3v(:,:,1,Kmm) * pvv(:,:,1,Kmm) * vmask(:,:,1)
- DO jk = 2, jpkm1
- uu_b(:,:,Kaa) = uu_b(:,:,Kaa) + pe3u(:,:,jk,Kaa) * puu(:,:,jk,Kaa) * umask(:,:,jk)
- uu_b(:,:,Kmm) = uu_b(:,:,Kmm) + pe3u(:,:,jk,Kmm) * puu(:,:,jk,Kmm) * umask(:,:,jk)
- vv_b(:,:,Kaa) = vv_b(:,:,Kaa) + pe3v(:,:,jk,Kaa) * pvv(:,:,jk,Kaa) * vmask(:,:,jk)
- vv_b(:,:,Kmm) = vv_b(:,:,Kmm) + pe3v(:,:,jk,Kmm) * pvv(:,:,jk,Kmm) * vmask(:,:,jk)
- END DO
- uu_b(:,:,Kaa) = uu_b(:,:,Kaa) * r1_hu(:,:,Kaa)
- vv_b(:,:,Kaa) = vv_b(:,:,Kaa) * r1_hv(:,:,Kaa)
- uu_b(:,:,Kmm) = uu_b(:,:,Kmm) * r1_hu(:,:,Kmm)
- vv_b(:,:,Kmm) = vv_b(:,:,Kmm) * r1_hv(:,:,Kmm)
- !
- IF( .NOT.ln_dynspg_ts ) THEN ! output the barotropic currents
- CALL iom_put( "ubar", uu_b(:,:,Kmm) )
- CALL iom_put( "vbar", vv_b(:,:,Kmm) )
- ENDIF
- IF( l_trddyn ) THEN ! 3D output: asselin filter trends on momentum
- zua(:,:,:) = ( puu(:,:,:,Kmm) - zua(:,:,:) ) * r1_Dt
- zva(:,:,:) = ( pvv(:,:,:,Kmm) - zva(:,:,:) ) * r1_Dt
- CALL trd_dyn( zua, zva, jpdyn_atf, kt, Kmm )
- ENDIF
- !
- IF ( iom_use("utau") ) THEN
- IF ( ln_drgice_imp.OR.ln_isfcav ) THEN
- ALLOCATE(zutau(jpi,jpj))
- DO_2D( 0, 0, 0, 0 )
- jk = miku(ji,jj)
- zutau(ji,jj) = utau(ji,jj) + 0.5_wp * rho0 * ( rCdU_top(ji+1,jj)+rCdU_top(ji,jj) ) * puu(ji,jj,jk,Kaa)
- END_2D
- CALL iom_put( "utau", zutau(:,:) )
- DEALLOCATE(zutau)
- ELSE
- CALL iom_put( "utau", utau(:,:) )
- ENDIF
- ENDIF
- !
- IF ( iom_use("vtau") ) THEN
- IF ( ln_drgice_imp.OR.ln_isfcav ) THEN
- ALLOCATE(zvtau(jpi,jpj))
- DO_2D( 0, 0, 0, 0 )
- jk = mikv(ji,jj)
- zvtau(ji,jj) = vtau(ji,jj) + 0.5_wp * rho0 * ( rCdU_top(ji,jj+1)+rCdU_top(ji,jj) ) * pvv(ji,jj,jk,Kaa)
- END_2D
- CALL iom_put( "vtau", zvtau(:,:) )
- DEALLOCATE(zvtau)
- ELSE
- CALL iom_put( "vtau", vtau(:,:) )
- ENDIF
- ENDIF
- !
- IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=puu(:,:,:,Kaa), clinfo1=' nxt - puu(:,:,:,Kaa): ', mask1=umask, &
- & tab3d_2=pvv(:,:,:,Kaa), clinfo2=' pvv(:,:,:,Kaa): ' , mask2=vmask )
- !
- IF( ln_dynspg_ts ) DEALLOCATE( zue, zve )
- IF( l_trddyn ) DEALLOCATE( zua, zva )
- IF( ln_timing ) CALL timing_stop('dyn_atf')
- !
- END SUBROUTINE dyn_atf
-
-#endif
-
- !!=========================================================================
-END MODULE dynatf
diff --git a/src/OCE/DYN/dynatf_qco.F90 b/src/OCE/DYN/dynatf_qco.F90
index f9ed9f4644d525d233b884f53ad0e7f37760253c..f8a64ee9713786f743047b3392cb04eaa1ec8324 100644
--- a/src/OCE/DYN/dynatf_qco.F90
+++ b/src/OCE/DYN/dynatf_qco.F90
@@ -32,11 +32,6 @@ MODULE dynatf_qco
USE phycst ! physical constants
USE dynadv ! dynamics: vector invariant versus flux form
USE dynspg_ts ! surface pressure gradient: split-explicit scheme
- USE domvvl ! variable volume
- USE bdy_oce , ONLY: ln_bdy
- USE bdydta ! ocean open boundary conditions
- USE bdydyn ! ocean open boundary conditions
- USE bdyvol ! ocean open boundary condition (bdy_vol routines)
USE trd_oce ! trends: ocean variables
USE trddyn ! trend manager: dynamics
USE trdken ! trend manager: kinetic energy
@@ -78,9 +73,7 @@ CONTAINS
!! estimate (ln_dynspg_ts=T)
!!
!! * Apply lateral boundary conditions on after velocity
- !! at the local domain boundaries through lbc_lnk call,
- !! at the one-way open boundaries (ln_bdy=T),
- !! at the AGRIF zoom boundaries (lk_agrif=T)
+ !! at the local domain boundaries through lbc_lnk call
!!
!! * Apply the Asselin time filter to the now fields
!! arrays to start the next time step:
@@ -245,10 +238,11 @@ CONTAINS
!
IF ( iom_use("utau") ) THEN
IF ( ln_drgice_imp.OR.ln_isfcav ) THEN
- ALLOCATE(zutau(jpi,jpj))
+ ! TEMP: Declared with halo points so there is a consistent shape for XIOS
+ ALLOCATE(zutau(A2D(nn_hls)))
DO_2D( 0, 0, 0, 0 )
jk = miku(ji,jj)
- zutau(ji,jj) = utau(ji,jj) + 0.5_wp * rho0 * ( rCdU_top(ji+1,jj)+rCdU_top(ji,jj) ) * puu(ji,jj,jk,Kaa)
+ zutau(ji,jj) = utau(ji,jj) + 0.5_wp * rho0 * rCdU_top(ji,jj) * ( puu(ji-1,jj,jk,Kaa) + puu(ji,jj,jk,Kaa) )
END_2D
CALL iom_put( "utau", zutau(:,:) )
DEALLOCATE(zutau)
@@ -259,10 +253,11 @@ CONTAINS
!
IF ( iom_use("vtau") ) THEN
IF ( ln_drgice_imp.OR.ln_isfcav ) THEN
- ALLOCATE(zvtau(jpi,jpj))
+ ! TEMP: Declared with halo points so there is a consistent shape for XIOS
+ ALLOCATE(zvtau(A2D(nn_hls)))
DO_2D( 0, 0, 0, 0 )
jk = mikv(ji,jj)
- zvtau(ji,jj) = vtau(ji,jj) + 0.5_wp * rho0 * ( rCdU_top(ji,jj+1)+rCdU_top(ji,jj) ) * pvv(ji,jj,jk,Kaa)
+ zvtau(ji,jj) = vtau(ji,jj) + 0.5_wp * rho0 * rCdU_top(ji,jj) * ( pvv(ji,jj-1,jk,Kaa) + pvv(ji,jj,jk,Kaa) )
END_2D
CALL iom_put( "vtau", zvtau(:,:) )
DEALLOCATE(zvtau)
diff --git a/src/OCE/DYN/dynhpg.F90 b/src/OCE/DYN/dynhpg.F90
index 145c7f9e17407167fc54774c8fe282f407e31f8b..ffc642b7722a6ccd25ac41393d37ea52e639c823 100644
--- a/src/OCE/DYN/dynhpg.F90
+++ b/src/OCE/DYN/dynhpg.F90
@@ -24,7 +24,6 @@ MODULE dynhpg
!! gradient of the hydrostatic pressure
!! dyn_hpg_init : initialisation and control of options
!! hpg_zco : z-coordinate scheme
- !! hpg_zps : z-coordinate plus partial steps (interpolation)
!! hpg_sco : s-coordinate (standard jacobian formulation)
!! hpg_isf : s-coordinate (sco formulation) adapted to ice shelf
!! hpg_djc : s-coordinate (Density Jacobian with Cubic polynomial)
@@ -39,7 +38,6 @@ MODULE dynhpg
USE phycst ! physical constants
USE trd_oce ! trends: ocean variables
USE trddyn ! trend manager: dynamics
- USE zpshde ! partial step: hor. derivative (zps_hde routine)
!
USE in_out_manager ! I/O manager
USE prtctl ! Print control
@@ -115,7 +113,6 @@ CONTAINS
!
SELECT CASE ( nhpg ) ! Hydrostatic pressure gradient computation
CASE ( np_zco ) ; CALL hpg_zco ( kt, Kmm, puu, pvv, Krhs ) ! z-coordinate
- CASE ( np_zps ) ; CALL hpg_zps ( kt, Kmm, puu, pvv, Krhs ) ! z-coordinate plus partial steps (interpolation)
CASE ( np_sco ) ; CALL hpg_sco ( kt, Kmm, puu, pvv, Krhs ) ! s-coordinate (standard jacobian formulation)
CASE ( np_djc ) ; CALL hpg_djc ( kt, Kmm, puu, pvv, Krhs ) ! s-coordinate (Density Jacobian with Cubic polynomial)
CASE ( np_prj ) ; CALL hpg_prj ( kt, Kmm, puu, pvv, Krhs ) ! s-coordinate (Pressure Jacobian scheme)
@@ -260,7 +257,7 @@ CONTAINS
!
INTEGER :: ji, jj, jk ! dummy loop indices
REAL(wp) :: zcoef0, zcoef1 ! temporary scalars
- REAL(wp), DIMENSION(A2D(nn_hls)) :: zhpi, zhpj
+ REAL(wp), DIMENSION(T2D(nn_hls)) :: zhpi, zhpj
!!----------------------------------------------------------------------
!
IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile
@@ -299,90 +296,6 @@ CONTAINS
END SUBROUTINE hpg_zco
- SUBROUTINE hpg_zps( kt, Kmm, puu, pvv, Krhs )
- !!---------------------------------------------------------------------
- !! *** ROUTINE hpg_zps ***
- !!
- !! ** Method : z-coordinate plus partial steps case. blahblah...
- !!
- !! ** Action : - Update (puu(:,:,:,Krhs),pvv(:,:,:,Krhs)) with the now hydrastatic pressure trend
- !!----------------------------------------------------------------------
- INTEGER , INTENT( in ) :: kt ! ocean time-step index
- INTEGER , INTENT( in ) :: Kmm, Krhs ! ocean time level indices
- REAL(wp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) :: puu, pvv ! ocean velocities and RHS of momentum equation
- !!
- INTEGER :: ji, jj, jk ! dummy loop indices
- INTEGER :: iku, ikv ! temporary integers
- REAL(wp) :: zcoef0, zcoef1, zcoef2, zcoef3 ! temporary scalars
- REAL(wp), DIMENSION(A2D(nn_hls),jpk ) :: zhpi, zhpj
- REAL(wp), DIMENSION(A2D(nn_hls),jpts) :: zgtsu, zgtsv
- REAL(wp), DIMENSION(A2D(nn_hls) ) :: zgru, zgrv
- !!----------------------------------------------------------------------
- !
- IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile
- IF( kt == nit000 ) THEN
- IF(lwp) WRITE(numout,*)
- IF(lwp) WRITE(numout,*) 'dyn:hpg_zps : hydrostatic pressure gradient trend'
- IF(lwp) WRITE(numout,*) '~~~~~~~~~~~ z-coordinate with partial steps - vector optimization'
- ENDIF
- ENDIF
-
- ! Partial steps: Compute NOW horizontal gradient of t, s, rd at the last ocean level
- CALL zps_hde( kt, jpts, ts(:,:,:,:,Kmm), zgtsu, zgtsv, rhd, zgru , zgrv )
-
- ! Local constant initialization
- zcoef0 = - grav * 0.5_wp
-
- ! Surface value (also valid in partial step case)
- DO_2D( 0, 0, 0, 0 )
- zcoef1 = zcoef0 * e3w(ji,jj,1,Kmm)
- ! hydrostatic pressure gradient
- zhpi(ji,jj,1) = zcoef1 * ( rhd(ji+1,jj ,1) - rhd(ji,jj,1) ) * r1_e1u(ji,jj)
- zhpj(ji,jj,1) = zcoef1 * ( rhd(ji ,jj+1,1) - rhd(ji,jj,1) ) * r1_e2v(ji,jj)
- ! add to the general momentum trend
- puu(ji,jj,1,Krhs) = puu(ji,jj,1,Krhs) + zhpi(ji,jj,1)
- pvv(ji,jj,1,Krhs) = pvv(ji,jj,1,Krhs) + zhpj(ji,jj,1)
- END_2D
-
- ! interior value (2=<jk=<jpkm1)
- DO_3D( 0, 0, 0, 0, 2, jpkm1 )
- zcoef1 = zcoef0 * e3w(ji,jj,jk,Kmm)
- ! hydrostatic pressure gradient
- zhpi(ji,jj,jk) = zhpi(ji,jj,jk-1) &
- & + zcoef1 * ( ( rhd(ji+1,jj,jk) + rhd(ji+1,jj,jk-1) ) &
- & - ( rhd(ji ,jj,jk) + rhd(ji ,jj,jk-1) ) ) * r1_e1u(ji,jj)
-
- zhpj(ji,jj,jk) = zhpj(ji,jj,jk-1) &
- & + zcoef1 * ( ( rhd(ji,jj+1,jk) + rhd(ji,jj+1,jk-1) ) &
- & - ( rhd(ji,jj, jk) + rhd(ji,jj ,jk-1) ) ) * r1_e2v(ji,jj)
- ! add to the general momentum trend
- puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) + zhpi(ji,jj,jk)
- pvv(ji,jj,jk,Krhs) = pvv(ji,jj,jk,Krhs) + zhpj(ji,jj,jk)
- END_3D
-
- ! partial steps correction at the last level (use zgru & zgrv computed in zpshde.F90)
- DO_2D( 0, 0, 0, 0 )
- iku = mbku(ji,jj)
- ikv = mbkv(ji,jj)
- zcoef2 = zcoef0 * MIN( e3w(ji,jj,iku,Kmm), e3w(ji+1,jj ,iku,Kmm) )
- zcoef3 = zcoef0 * MIN( e3w(ji,jj,ikv,Kmm), e3w(ji ,jj+1,ikv,Kmm) )
- IF( iku > 1 ) THEN ! on i-direction (level 2 or more)
- puu (ji,jj,iku,Krhs) = puu(ji,jj,iku,Krhs) - zhpi(ji,jj,iku) ! subtract old value
- zhpi(ji,jj,iku) = zhpi(ji,jj,iku-1) & ! compute the new one
- & + zcoef2 * ( rhd(ji+1,jj,iku-1) - rhd(ji,jj,iku-1) + zgru(ji,jj) ) * r1_e1u(ji,jj)
- puu (ji,jj,iku,Krhs) = puu(ji,jj,iku,Krhs) + zhpi(ji,jj,iku) ! add the new one to the general momentum trend
- ENDIF
- IF( ikv > 1 ) THEN ! on j-direction (level 2 or more)
- pvv (ji,jj,ikv,Krhs) = pvv(ji,jj,ikv,Krhs) - zhpj(ji,jj,ikv) ! subtract old value
- zhpj(ji,jj,ikv) = zhpj(ji,jj,ikv-1) & ! compute the new one
- & + zcoef3 * ( rhd(ji,jj+1,ikv-1) - rhd(ji,jj,ikv-1) + zgrv(ji,jj) ) * r1_e2v(ji,jj)
- pvv (ji,jj,ikv,Krhs) = pvv(ji,jj,ikv,Krhs) + zhpj(ji,jj,ikv) ! add the new one to the general momentum trend
- ENDIF
- END_2D
- !
- END SUBROUTINE hpg_zps
-
-
SUBROUTINE hpg_sco( kt, Kmm, puu, pvv, Krhs )
!!---------------------------------------------------------------------
!! *** ROUTINE hpg_sco ***
@@ -391,7 +304,7 @@ CONTAINS
!! The now hydrostatic pressure gradient at a given level, jk,
!! is computed by taking the vertical integral of the in-situ
!! density gradient along the model level from the suface to that
- !! level. s-coordinates (ln_sco): a corrective term is added
+ !! level. s-coordinates (l_sco): a corrective term is added
!! to the horizontal pressure gradient :
!! zhpi = grav ..... + 1/e1u mi(rhd) di[ grav dep3w ]
!! zhpj = grav ..... + 1/e2v mj(rhd) dj[ grav dep3w ]
@@ -401,18 +314,18 @@ CONTAINS
!!
!! ** Action : - Update (puu(:,:,:,Krhs),pvv(:,:,:,Krhs)) with the now hydrastatic pressure trend
!!----------------------------------------------------------------------
- INTEGER , INTENT( in ) :: kt ! ocean time-step index
- INTEGER , INTENT( in ) :: Kmm, Krhs ! ocean time level indices
+ INTEGER , INTENT(in ) :: kt ! ocean time-step index
+ INTEGER , INTENT(in ) :: Kmm, Krhs ! ocean time level indices
REAL(wp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) :: puu, pvv ! ocean velocities and RHS of momentum equation
!!
INTEGER :: ji, jj, jk, jii, jjj ! dummy loop indices
REAL(wp) :: zcoef0, zuap, zvap, ztmp ! local scalars
LOGICAL :: ll_tmp1, ll_tmp2 ! local logical variables
- REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zhpi, zhpj
+ REAL(wp), DIMENSION(T2D(0)) :: zhpi, zhpj
REAL(wp), DIMENSION(:,:), ALLOCATABLE :: zcpx, zcpy !W/D pressure filter
!!----------------------------------------------------------------------
!
- IF( ln_wd_il ) ALLOCATE(zcpx(A2D(nn_hls)), zcpy(A2D(nn_hls)))
+ IF( ln_wd_il ) ALLOCATE(zcpx(T2D(0)), zcpy(T2D(0)))
!
IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile
IF( kt == nit000 ) THEN
@@ -456,8 +369,8 @@ CONTAINS
zcpy(ji,jj) = 1.0_wp
ELSE IF(ll_tmp2) THEN
! no worries about ssh(ji,jj+1,Kmm) - ssh(ji,jj ,Kmm) = 0, it won't happen ! here
- zcpy(ji,jj) = ABS( (ssh(ji,jj+1,Kmm) + ht_0(ji,jj+1) - ssh(ji,jj,Kmm) - ht_0(ji,jj)) &
- & / (ssh(ji,jj+1,Kmm) - ssh(ji,jj ,Kmm)) )
+ zcpy(ji,jj) = ABS( ( ( ssh(ji,jj+1,Kmm) + ht_0(ji,jj+1) ) - ( ssh(ji,jj,Kmm) + ht_0(ji,jj) ) ) & ! add () for NP repro
+ & / ( ssh(ji,jj+1,Kmm) - ssh(ji,jj,Kmm) ) )
ELSE
zcpy(ji,jj) = 0._wp
END IF
@@ -466,54 +379,56 @@ CONTAINS
!
DO_2D( 0, 0, 0, 0 ) ! Surface value
! ! hydrostatic pressure gradient along s-surfaces
- zhpi(ji,jj,1) = zcoef0 * r1_e1u(ji,jj) &
- & * ( e3w(ji+1,jj ,1,Kmm) * rhd(ji+1,jj ,1) &
- & - e3w(ji ,jj ,1,Kmm) * rhd(ji ,jj ,1) )
- zhpj(ji,jj,1) = zcoef0 * r1_e2v(ji,jj) &
- & * ( e3w(ji ,jj+1,1,Kmm) * rhd(ji ,jj+1,1) &
- & - e3w(ji ,jj ,1,Kmm) * rhd(ji ,jj ,1) )
+ zhpi(ji,jj) = zcoef0 * r1_e1u(ji,jj) &
+ & * ( e3w(ji+1,jj ,1,Kmm) * rhd(ji+1,jj ,1) &
+ & - e3w(ji ,jj ,1,Kmm) * rhd(ji ,jj ,1) )
+ zhpj(ji,jj) = zcoef0 * r1_e2v(ji,jj) &
+ & * ( e3w(ji ,jj+1,1,Kmm) * rhd(ji ,jj+1,1) &
+ & - e3w(ji ,jj ,1,Kmm) * rhd(ji ,jj ,1) )
! ! s-coordinate pressure gradient correction
- zuap = -zcoef0 * ( rhd (ji+1,jj,1) + rhd (ji,jj,1) ) &
- & * ( gde3w(ji+1,jj,1) - gde3w(ji,jj,1) ) * r1_e1u(ji,jj)
- zvap = -zcoef0 * ( rhd (ji,jj+1,1) + rhd (ji,jj,1) ) &
- & * ( gde3w(ji,jj+1,1) - gde3w(ji,jj,1) ) * r1_e2v(ji,jj)
+ zuap = -zcoef0 * ( rhd (ji+1,jj,1) + rhd (ji,jj,1) ) &
+ & * ( gdept_z0(ji+1,jj,1,Kmm) - gdept_z0(ji,jj,1,Kmm) ) * r1_e1u(ji,jj)
+ zvap = -zcoef0 * ( rhd (ji,jj+1,1) + rhd (ji,jj,1) ) &
+ & * ( gdept_z0(ji,jj+1,1,Kmm) - gdept_z0(ji,jj,1,Kmm) ) * r1_e2v(ji,jj)
!
IF( ln_wd_il ) THEN
- zhpi(ji,jj,1) = zhpi(ji,jj,1) * zcpx(ji,jj)
- zhpj(ji,jj,1) = zhpj(ji,jj,1) * zcpy(ji,jj)
+ zhpi(ji,jj) = zhpi(ji,jj) * zcpx(ji,jj)
+ zhpj(ji,jj) = zhpj(ji,jj) * zcpy(ji,jj)
zuap = zuap * zcpx(ji,jj)
zvap = zvap * zcpy(ji,jj)
ENDIF
! ! add to the general momentum trend
- puu(ji,jj,1,Krhs) = puu(ji,jj,1,Krhs) + zhpi(ji,jj,1) + zuap
- pvv(ji,jj,1,Krhs) = pvv(ji,jj,1,Krhs) + zhpj(ji,jj,1) + zvap
+ puu(ji,jj,1,Krhs) = puu(ji,jj,1,Krhs) + zhpi(ji,jj) + zuap
+ pvv(ji,jj,1,Krhs) = pvv(ji,jj,1,Krhs) + zhpj(ji,jj) + zvap
END_2D
!
- DO_3D( 0, 0, 0, 0, 2, jpkm1 ) ! interior value (2=<jk=<jpkm1)
- ! ! hydrostatic pressure gradient along s-surfaces
- zhpi(ji,jj,jk) = zhpi(ji,jj,jk-1) + zcoef0 * r1_e1u(ji,jj) &
- & * ( e3w(ji+1,jj,jk,Kmm) * ( rhd(ji+1,jj,jk) + rhd(ji+1,jj,jk-1) ) &
- & - e3w(ji ,jj,jk,Kmm) * ( rhd(ji ,jj,jk) + rhd(ji ,jj,jk-1) ) )
- zhpj(ji,jj,jk) = zhpj(ji,jj,jk-1) + zcoef0 * r1_e2v(ji,jj) &
- & * ( e3w(ji,jj+1,jk,Kmm) * ( rhd(ji,jj+1,jk) + rhd(ji,jj+1,jk-1) ) &
- & - e3w(ji,jj ,jk,Kmm) * ( rhd(ji,jj, jk) + rhd(ji,jj ,jk-1) ) )
- ! ! s-coordinate pressure gradient correction
- zuap = -zcoef0 * ( rhd (ji+1,jj ,jk) + rhd (ji,jj,jk) ) &
- & * ( gde3w(ji+1,jj ,jk) - gde3w(ji,jj,jk) ) * r1_e1u(ji,jj)
- zvap = -zcoef0 * ( rhd (ji ,jj+1,jk) + rhd (ji,jj,jk) ) &
- & * ( gde3w(ji ,jj+1,jk) - gde3w(ji,jj,jk) ) * r1_e2v(ji,jj)
- !
- IF( ln_wd_il ) THEN
- zhpi(ji,jj,jk) = zhpi(ji,jj,jk) * zcpx(ji,jj)
- zhpj(ji,jj,jk) = zhpj(ji,jj,jk) * zcpy(ji,jj)
- zuap = zuap * zcpx(ji,jj)
- zvap = zvap * zcpy(ji,jj)
- ENDIF
- !
- ! add to the general momentum trend
- puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) + zhpi(ji,jj,jk) + zuap
- pvv(ji,jj,jk,Krhs) = pvv(ji,jj,jk,Krhs) + zhpj(ji,jj,jk) + zvap
- END_3D
+ DO jk= 2, jpkm1
+ DO_2D( 0, 0, 0, 0 ) ! interior value (2=<jk=<jpkm1)
+ ! ! hydrostatic pressure gradient along s-surfaces
+ zhpi(ji,jj) = zhpi(ji,jj) + zcoef0 * r1_e1u(ji,jj) &
+ & * ( e3w(ji+1,jj,jk,Kmm) * ( rhd(ji+1,jj,jk) + rhd(ji+1,jj,jk-1) ) &
+ & - e3w(ji ,jj,jk,Kmm) * ( rhd(ji ,jj,jk) + rhd(ji ,jj,jk-1) ) )
+ zhpj(ji,jj) = zhpj(ji,jj) + zcoef0 * r1_e2v(ji,jj) &
+ & * ( e3w(ji,jj+1,jk,Kmm) * ( rhd(ji,jj+1,jk) + rhd(ji,jj+1,jk-1) ) &
+ & - e3w(ji,jj ,jk,Kmm) * ( rhd(ji,jj, jk) + rhd(ji,jj ,jk-1) ) )
+ ! ! s-coordinate pressure gradient correction
+ zuap = -zcoef0 * ( rhd (ji+1,jj ,jk) + rhd (ji,jj,jk) ) &
+ & * ( gdept_z0(ji+1,jj ,jk,Kmm) - gdept_z0(ji,jj,jk,Kmm) ) * r1_e1u(ji,jj)
+ zvap = -zcoef0 * ( rhd (ji ,jj+1,jk) + rhd (ji,jj,jk) ) &
+ & * ( gdept_z0(ji ,jj+1,jk,Kmm) - gdept_z0(ji,jj,jk,Kmm) ) * r1_e2v(ji,jj)
+ !
+ IF( ln_wd_il ) THEN
+ zhpi(ji,jj) = zhpi(ji,jj) * zcpx(ji,jj)
+ zhpj(ji,jj) = zhpj(ji,jj) * zcpy(ji,jj)
+ zuap = zuap * zcpx(ji,jj)
+ zvap = zvap * zcpy(ji,jj)
+ ENDIF
+ !
+ ! add to the general momentum trend
+ puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) + zhpi(ji,jj) + zuap
+ pvv(ji,jj,jk,Krhs) = pvv(ji,jj,jk,Krhs) + zhpj(ji,jj) + zvap
+ END_2D
+ END DO
!
IF( ln_wd_il ) DEALLOCATE( zcpx , zcpy )
!
@@ -528,7 +443,7 @@ CONTAINS
!! The now hydrostatic pressure gradient at a given level, jk,
!! is computed by taking the vertical integral of the in-situ
!! density gradient along the model level from the suface to that
- !! level. s-coordinates (ln_sco): a corrective term is added
+ !! level. s-coordinates (l_sco): a corrective term is added
!! to the horizontal pressure gradient :
!! zhpi = grav ..... + 1/e1u mi(rhd) di[ grav dep3w ]
!! zhpj = grav ..... + 1/e2v mj(rhd) dj[ grav dep3w ]
@@ -539,34 +454,35 @@ CONTAINS
!!
!! ** Action : - Update (puu(:,:,:,Krhs),pvv(:,:,:,Krhs)) with the now hydrastatic pressure trend
!!----------------------------------------------------------------------
- INTEGER , INTENT( in ) :: kt ! ocean time-step index
- INTEGER , INTENT( in ) :: Kmm, Krhs ! ocean time level indices
+ INTEGER , INTENT(in ) :: kt ! ocean time-step index
+ INTEGER , INTENT(in ) :: Kmm, Krhs ! ocean time level indices
REAL(wp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) :: puu, pvv ! ocean velocities and RHS of momentum equation
!!
INTEGER :: ji, jj, jk ! dummy loop indices
INTEGER :: ikt , ikti1, iktj1 ! local integer
REAL(wp) :: ze3w, ze3wi1, ze3wj1 ! local scalars
REAL(wp) :: zcoef0, zuap, zvap ! - -
- REAL(wp), DIMENSION(A2D(nn_hls),jpk ) :: zhpi, zhpj
- REAL(wp), DIMENSION(A2D(nn_hls),jpts) :: zts_top
- REAL(wp), DIMENSION(A2D(nn_hls)) :: zrhd_top, zdep_top
+ REAL(wp), DIMENSION(T2D(1),jpts) :: zts_top
+ REAL(wp), DIMENSION(T2D(1)) :: zrhd_top, zdep_top
+ REAL(wp), DIMENSION(T2D(0)) :: zhpi, zhpj
!!----------------------------------------------------------------------
!
zcoef0 = - grav * 0.5_wp ! Local constant initialization
!
- ! ! iniitialised to 0. zhpi zhpi
- zhpi(:,:,:) = 0._wp ; zhpj(:,:,:) = 0._wp
+ ! ! iniitialised to 0. zhpi zhpi !!st is it necessary ???
+ zhpi(:,:) = 0._wp ; zhpj(:,:) = 0._wp
! compute rhd at the ice/oce interface (ocean side)
! usefull to reduce residual current in the test case ISOMIP with no melting
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 1, 1, 1, 1 )
ikt = mikt(ji,jj)
zts_top(ji,jj,1) = ts(ji,jj,ikt,1,Kmm)
zts_top(ji,jj,2) = ts(ji,jj,ikt,2,Kmm)
zdep_top(ji,jj) = MAX( risfdep(ji,jj) , gdept(ji,jj,1,Kmm) )
END_2D
- CALL eos( zts_top, zdep_top, zrhd_top )
-
+ ! eos 2D interface
+ CALL eos( zts_top, zdep_top, zrhd_top, kbnd=1 )
+ !
! !===========================!
! !===== surface value =====!
! !===========================!
@@ -576,45 +492,47 @@ CONTAINS
iktj1 = mikt(ji ,jj+1) ; ze3wj1 = e3w(ji ,jj+1,iktj1,Kmm)
! ! hydrostatic pressure gradient along s-surfaces and ice shelf pressure
! ! we assume ISF is in isostatic equilibrium
- zhpi(ji,jj,1) = zcoef0 * r1_e1u(ji,jj) * ( risfload(ji+1,jj) - risfload(ji,jj) &
- & + 0.5_wp * ( ze3wi1 * ( rhd(ji+1,jj,ikti1) + zrhd_top(ji+1,jj) ) &
- & - ze3w * ( rhd(ji ,jj,ikt ) + zrhd_top(ji ,jj) ) ) )
- zhpj(ji,jj,1) = zcoef0 * r1_e2v(ji,jj) * ( risfload(ji,jj+1) - risfload(ji,jj) &
- & + 0.5_wp * ( ze3wj1 * ( rhd(ji,jj+1,iktj1) + zrhd_top(ji,jj+1) ) &
- & - ze3w * ( rhd(ji,jj ,ikt ) + zrhd_top(ji,jj ) ) ) )
+ zhpi(ji,jj) = zcoef0 * r1_e1u(ji,jj) * ( risfload(ji+1,jj) - risfload(ji,jj) &
+ & + 0.5_wp * ( ze3wi1 * ( rhd(ji+1,jj,ikti1) + zrhd_top(ji+1,jj) ) &
+ & - ze3w * ( rhd(ji ,jj,ikt ) + zrhd_top(ji ,jj) ) ) )
+ zhpj(ji,jj) = zcoef0 * r1_e2v(ji,jj) * ( risfload(ji,jj+1) - risfload(ji,jj) &
+ & + 0.5_wp * ( ze3wj1 * ( rhd(ji,jj+1,iktj1) + zrhd_top(ji,jj+1) ) &
+ & - ze3w * ( rhd(ji,jj ,ikt ) + zrhd_top(ji,jj ) ) ) )
! ! s-coordinate pressure gradient correction (=0 if z coordinate)
- zuap = -zcoef0 * ( rhd (ji+1,jj,1) + rhd (ji,jj,1) ) &
- & * ( gde3w(ji+1,jj,1) - gde3w(ji,jj,1) ) * r1_e1u(ji,jj)
- zvap = -zcoef0 * ( rhd (ji,jj+1,1) + rhd (ji,jj,1) ) &
- & * ( gde3w(ji,jj+1,1) - gde3w(ji,jj,1) ) * r1_e2v(ji,jj)
+ zuap = -zcoef0 * ( rhd (ji+1,jj,1) + rhd (ji,jj,1) ) &
+ & * ( gdept_z0(ji+1,jj,1,Kmm) - gdept_z0(ji,jj,1,Kmm) ) * r1_e1u(ji,jj)
+ zvap = -zcoef0 * ( rhd (ji,jj+1,1) + rhd (ji,jj,1) ) &
+ & * ( gdept_z0(ji,jj+1,1,Kmm) - gdept_z0(ji,jj,1,Kmm) ) * r1_e2v(ji,jj)
! ! add to the general momentum trend
- puu(ji,jj,1,Krhs) = puu(ji,jj,1,Krhs) + (zhpi(ji,jj,1) + zuap) * umask(ji,jj,1)
- pvv(ji,jj,1,Krhs) = pvv(ji,jj,1,Krhs) + (zhpj(ji,jj,1) + zvap) * vmask(ji,jj,1)
+ puu(ji,jj,1,Krhs) = puu(ji,jj,1,Krhs) + (zhpi(ji,jj) + zuap) * umask(ji,jj,1)
+ pvv(ji,jj,1,Krhs) = pvv(ji,jj,1,Krhs) + (zhpj(ji,jj) + zvap) * vmask(ji,jj,1)
END_2D
!
! !=============================!
! !===== interior values =====!
! !=============================!
- DO_3D( 0, 0, 0, 0, 2, jpkm1 )
- ze3w = e3w(ji ,jj ,jk,Kmm)
- ze3wi1 = e3w(ji+1,jj ,jk,Kmm)
- ze3wj1 = e3w(ji ,jj+1,jk,Kmm)
- ! ! hydrostatic pressure gradient along s-surfaces
- zhpi(ji,jj,jk) = zhpi(ji,jj,jk-1) + zcoef0 / e1u(ji,jj) &
- & * ( ze3wi1 * ( rhd(ji+1,jj,jk) + rhd(ji+1,jj,jk-1) ) * wmask(ji+1,jj,jk) &
- & - ze3w * ( rhd(ji ,jj,jk) + rhd(ji ,jj,jk-1) ) * wmask(ji ,jj,jk) )
- zhpj(ji,jj,jk) = zhpj(ji,jj,jk-1) + zcoef0 / e2v(ji,jj) &
- & * ( ze3wj1 * ( rhd(ji,jj+1,jk) + rhd(ji,jj+1,jk-1) ) * wmask(ji,jj+1,jk) &
- & - ze3w * ( rhd(ji,jj, jk) + rhd(ji,jj ,jk-1) ) * wmask(ji,jj ,jk) )
- ! ! s-coordinate pressure gradient correction
- zuap = -zcoef0 * ( rhd (ji+1,jj ,jk) + rhd (ji,jj,jk) ) &
- & * ( gde3w(ji+1,jj ,jk) - gde3w(ji,jj,jk) ) / e1u(ji,jj)
- zvap = -zcoef0 * ( rhd (ji ,jj+1,jk) + rhd (ji,jj,jk) ) &
- & * ( gde3w(ji ,jj+1,jk) - gde3w(ji,jj,jk) ) / e2v(ji,jj)
- ! ! add to the general momentum trend
- puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) + (zhpi(ji,jj,jk) + zuap) * umask(ji,jj,jk)
- pvv(ji,jj,jk,Krhs) = pvv(ji,jj,jk,Krhs) + (zhpj(ji,jj,jk) + zvap) * vmask(ji,jj,jk)
- END_3D
+ DO jk=2, jpkm1
+ DO_2D( 0, 0, 0, 0 )
+ ze3w = e3w(ji ,jj ,jk,Kmm)
+ ze3wi1 = e3w(ji+1,jj ,jk,Kmm)
+ ze3wj1 = e3w(ji ,jj+1,jk,Kmm)
+ ! ! hydrostatic pressure gradient along s-surfaces
+ zhpi(ji,jj) = zhpi(ji,jj) + zcoef0 / e1u(ji,jj) &
+ & * ( ze3wi1 * ( rhd(ji+1,jj,jk) + rhd(ji+1,jj,jk-1) ) * wmask(ji+1,jj,jk) &
+ & - ze3w * ( rhd(ji ,jj,jk) + rhd(ji ,jj,jk-1) ) * wmask(ji ,jj,jk) )
+ zhpj(ji,jj) = zhpj(ji,jj) + zcoef0 / e2v(ji,jj) &
+ & * ( ze3wj1 * ( rhd(ji,jj+1,jk) + rhd(ji,jj+1,jk-1) ) * wmask(ji,jj+1,jk) &
+ & - ze3w * ( rhd(ji,jj, jk) + rhd(ji,jj ,jk-1) ) * wmask(ji,jj ,jk) )
+ ! ! s-coordinate pressure gradient correction
+ zuap = -zcoef0 * ( rhd (ji+1,jj ,jk) + rhd (ji,jj,jk) ) &
+ & * ( gdept_z0(ji+1,jj ,jk,Kmm) - gdept_z0(ji,jj,jk,Kmm) ) / e1u(ji,jj)
+ zvap = -zcoef0 * ( rhd (ji ,jj+1,jk) + rhd (ji,jj,jk) ) &
+ & * ( gdept_z0(ji ,jj+1,jk,Kmm) - gdept_z0(ji,jj,jk,Kmm) ) / e2v(ji,jj)
+ ! ! add to the general momentum trend
+ puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) + (zhpi(ji,jj) + zuap) * umask(ji,jj,jk)
+ pvv(ji,jj,jk,Krhs) = pvv(ji,jj,jk,Krhs) + (zhpj(ji,jj) + zvap) * vmask(ji,jj,jk)
+ END_2D
+ END DO
!
END SUBROUTINE hpg_isf
@@ -638,19 +556,19 @@ CONTAINS
REAL(wp) :: cffu, cffx ! " "
REAL(wp) :: cffv, cffy ! " "
LOGICAL :: ll_tmp1, ll_tmp2 ! local logical variables
- REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zhpi, zhpj
-
- REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zdzx, zdzy, zdzz ! Primitive grid differences ('delta_xyz')
- REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zdz_i, zdz_j, zdz_k ! Harmonic average of primitive grid differences ('d_xyz')
- REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zdrhox, zdrhoy, zdrhoz ! Primitive rho differences ('delta_rho')
- REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zdrho_i, zdrho_j, zdrho_k ! Harmonic average of primitive rho differences ('d_rho')
- REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: z_rho_i, z_rho_j, z_rho_k ! Face intergrals
- REAL(wp), DIMENSION(A2D(nn_hls)) :: zz_dz_i, zz_dz_j, zz_drho_i, zz_drho_j ! temporary arrays
+ REAL(wp), DIMENSION(T2D(nn_hls),jpk) :: zhpi, zhpj
+
+ REAL(wp), DIMENSION(T2D(nn_hls),jpk) :: zdzx, zdzy, zdzz ! Primitive grid differences ('delta_xyz')
+ REAL(wp), DIMENSION(T2D(nn_hls),jpk) :: zdz_i, zdz_j, zdz_k ! Harmonic average of primitive grid differences ('d_xyz')
+ REAL(wp), DIMENSION(T2D(nn_hls),jpk) :: zdrhox, zdrhoy, zdrhoz ! Primitive rho differences ('delta_rho')
+ REAL(wp), DIMENSION(T2D(nn_hls),jpk) :: zdrho_i, zdrho_j, zdrho_k ! Harmonic average of primitive rho differences ('d_rho')
+ REAL(wp), DIMENSION(T2D(nn_hls),jpk) :: z_rho_i, z_rho_j, z_rho_k ! Face intergrals
+ REAL(wp), DIMENSION(T2D(nn_hls)) :: zz_dz_i, zz_dz_j, zz_drho_i, zz_drho_j ! temporary arrays
REAL(wp), DIMENSION(:,:), ALLOCATABLE :: zcpx, zcpy !W/D pressure filter
!!----------------------------------------------------------------------
!
IF( ln_wd_il ) THEN
- ALLOCATE( zcpx(A2D(nn_hls)) , zcpy(A2D(nn_hls)) )
+ ALLOCATE( zcpx(T2D(nn_hls)) , zcpy(T2D(nn_hls)) )
DO_2D( 0, 0, 0, 0 )
ll_tmp1 = MIN( ssh(ji,jj,Kmm) , ssh(ji+1,jj,Kmm) ) > &
& MAX( -ht_0(ji,jj) , -ht_0(ji+1,jj) ) .AND. &
@@ -663,8 +581,8 @@ CONTAINS
zcpx(ji,jj) = 1.0_wp
ELSE IF(ll_tmp2) THEN
! no worries about ssh(ji+1,jj,Kmm) - ssh(ji ,jj,Kmm) = 0, it won't happen ! here
- zcpx(ji,jj) = ABS( (ssh(ji+1,jj,Kmm) + ht_0(ji+1,jj) - ssh(ji,jj,Kmm) - ht_0(ji,jj)) &
- & / (ssh(ji+1,jj,Kmm) - ssh(ji ,jj,Kmm)) )
+ zcpx(ji,jj) = ABS( ( ( ssh(ji+1,jj,Kmm) + ht_0(ji+1,jj) ) - ( ssh(ji,jj,Kmm) + ht_0(ji,jj) ) ) & ! add () for NP repro
+ & / ( ssh(ji+1,jj,Kmm) - ssh(ji,jj,Kmm) ) )
ELSE
zcpx(ji,jj) = 0._wp
END IF
@@ -681,8 +599,8 @@ CONTAINS
zcpy(ji,jj) = 1.0_wp
ELSE IF(ll_tmp2) THEN
! no worries about ssh(ji,jj+1,Kmm) - ssh(ji,jj ,Kmm) = 0, it won't happen ! here
- zcpy(ji,jj) = ABS( (ssh(ji,jj+1,Kmm) + ht_0(ji,jj+1) - ssh(ji,jj,Kmm) - ht_0(ji,jj)) &
- & / (ssh(ji,jj+1,Kmm) - ssh(ji,jj ,Kmm)) )
+ zcpy(ji,jj) = ABS( ( ( ssh(ji,jj+1,Kmm) + ht_0(ji,jj+1) ) - ( ssh(ji,jj,Kmm) + ht_0(ji,jj) ) ) & ! add () for NP repro
+ & / ( ssh(ji,jj+1,Kmm) - ssh(ji,jj,Kmm) ) )
ELSE
zcpy(ji,jj) = 0._wp
END IF
@@ -709,8 +627,8 @@ CONTAINS
!!bug gm Not a true bug, but... zdzz=e3w for zdzx, zdzy verify what it is really
DO_3D( 1, 1, 1, 1, 2, jpkm1 )
- zdrhoz(ji,jj,jk) = rhd (ji ,jj ,jk) - rhd (ji,jj,jk-1)
- zdzz (ji,jj,jk) = - gde3w(ji ,jj ,jk) + gde3w(ji,jj,jk-1)
+ zdrhoz(ji,jj,jk) = rhd (ji,jj,jk ) - rhd (ji,jj,jk-1 )
+ zdzz (ji,jj,jk) = - gdept_z0(ji,jj,jk,Kmm) + gdept_z0(ji,jj,jk-1,Kmm)
END_3D
!-------------------------------------------------------------------------
@@ -727,7 +645,7 @@ CONTAINS
z1_cff = zdrhoz(ji,jj,jk) + zdrhoz(ji,jj,jk+1)
zdrho_k(ji,jj,jk) = cffw / SIGN( MAX( ABS(z1_cff), zep ), z1_cff )
zdz_k(ji,jj,jk) = 2._wp * zdzz(ji,jj,jk) * zdzz(ji,jj,jk+1) &
- & / ( zdzz(ji,jj,jk) + zdzz(ji,jj,jk+1) )
+ & / ( zdzz(ji,jj,jk) + zdzz(ji,jj,jk+1) )
END_3D
!----------------------------------------------------------------------------------
@@ -736,15 +654,15 @@ CONTAINS
! mb for sea-ice shelves we will need to re-write this upper boundary condition in the same form as the lower boundary condition
DO_2D( 1, 1, 1, 1 )
- zdrho_k(ji,jj,1) = aco_bc_vrt * ( rhd (ji,jj,2) - rhd (ji,jj,1) ) - bco_bc_vrt * zdrho_k(ji,jj,2)
- zdz_k (ji,jj,1) = aco_bc_vrt * (-gde3w(ji,jj,2) + gde3w(ji,jj,1) ) - bco_bc_vrt * zdz_k (ji,jj,2)
+ zdrho_k(ji,jj,1) = aco_bc_vrt * ( rhd (ji,jj,2 ) - rhd (ji,jj,1 ) ) - bco_bc_vrt * zdrho_k(ji,jj,2)
+ zdz_k (ji,jj,1) = aco_bc_vrt * (-gdept_z0(ji,jj,2,Kmm) + gdept_z0(ji,jj,1,Kmm) ) - bco_bc_vrt * zdz_k (ji,jj,2)
END_2D
DO_2D( 1, 1, 1, 1 )
IF ( mbkt(ji,jj)>1 ) THEN
iktb = mbkt(ji,jj)
- zdrho_k(ji,jj,iktb) = aco_bc_vrt * ( rhd(ji,jj,iktb) - rhd(ji,jj,iktb-1) ) - bco_bc_vrt * zdrho_k(ji,jj,iktb-1)
- zdz_k (ji,jj,iktb) = aco_bc_vrt * (-gde3w(ji,jj,iktb) + gde3w(ji,jj,iktb-1) ) - bco_bc_vrt * zdz_k (ji,jj,iktb-1)
+ zdrho_k(ji,jj,iktb) = aco_bc_vrt * ( rhd(ji,jj,iktb ) - rhd(ji,jj,iktb-1 ) ) - bco_bc_vrt * zdrho_k(ji,jj,iktb-1)
+ zdz_k (ji,jj,iktb) = aco_bc_vrt * (-gdept_z0(ji,jj,iktb,Kmm) + gdept_z0(ji,jj,iktb-1,Kmm) ) - bco_bc_vrt * zdz_k (ji,jj,iktb-1)
END IF
END_2D
@@ -772,14 +690,14 @@ CONTAINS
!-------------------------------------------------------------
DO_3D( 0, 1, 0, 1, 2, jpkm1 )
- z_rho_k(ji,jj,jk) = zcoef0 * ( rhd (ji,jj,jk) + rhd (ji,jj,jk-1) ) &
- & * ( - gde3w(ji,jj,jk) + gde3w(ji,jj,jk-1) ) &
+ z_rho_k(ji,jj,jk) = zcoef0 * ( rhd (ji,jj,jk ) + rhd (ji,jj,jk-1 ) ) &
+ & * ( - gdept_z0(ji,jj,jk,Kmm) + gdept_z0(ji,jj,jk-1,Kmm) ) &
& + z_grav_10 * ( &
- & ( zdrho_k (ji,jj,jk) - zdrho_k (ji,jj,jk-1) ) &
- & * ( - gde3w(ji,jj,jk) + gde3w(ji,jj,jk-1) - z1_12 * ( zdz_k (ji,jj,jk) + zdz_k (ji,jj,jk-1) ) ) &
- & - ( zdz_k (ji,jj,jk) - zdz_k (ji,jj,jk-1) ) &
- & * ( rhd (ji,jj,jk) - rhd (ji,jj,jk-1) - z1_12 * ( zdrho_k(ji,jj,jk) + zdrho_k(ji,jj,jk-1) ) ) &
- & )
+ & ( zdrho_k (ji,jj,jk ) - zdrho_k (ji,jj,jk-1 ) ) &
+ & * ( - ( gdept_z0(ji,jj,jk,Kmm) - gdept_z0(ji,jj,jk-1,Kmm) ) - z1_12 * ( zdz_k (ji,jj,jk) + zdz_k (ji,jj,jk-1) ) ) &
+ & - ( zdz_k (ji,jj,jk) - zdz_k (ji,jj,jk-1) ) &
+ & * ( ( rhd (ji,jj,jk) - rhd (ji,jj,jk-1) ) - z1_12 * ( zdrho_k(ji,jj,jk) + zdrho_k(ji,jj,jk-1) ) ) &
+ & )
END_3D
!----------------------------------------------------------------------------------------
@@ -791,10 +709,10 @@ CONTAINS
zdzy (:,:,:) = 0._wp
DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpkm1 )
- zdrhox(ji,jj,jk) = rhd (ji+1,jj ,jk) - rhd (ji ,jj ,jk)
- zdzx (ji,jj,jk) = gde3w(ji ,jj ,jk) - gde3w(ji+1,jj ,jk)
- zdrhoy(ji,jj,jk) = rhd (ji ,jj+1,jk) - rhd (ji ,jj ,jk)
- zdzy (ji,jj,jk) = gde3w(ji ,jj ,jk) - gde3w(ji ,jj+1,jk)
+ zdrhox(ji,jj,jk) = rhd (ji+1,jj ,jk ) - rhd (ji ,jj ,jk)
+ zdzx (ji,jj,jk) = gdept_z0(ji ,jj ,jk,Kmm) - gdept_z0(ji+1,jj ,jk,Kmm)
+ zdrhoy(ji,jj,jk) = rhd (ji ,jj+1,jk ) - rhd (ji ,jj ,jk)
+ zdzy (ji,jj,jk) = gdept_z0(ji ,jj ,jk,Kmm) - gdept_z0(ji ,jj+1,jk,Kmm)
END_3D
IF( nn_hls == 1 ) CALL lbc_lnk( 'dynhpg', zdrhox, 'U', -1._wp, zdzx, 'U', -1._wp, zdrhoy, 'V', -1._wp, zdzy, 'V', -1._wp )
@@ -836,28 +754,28 @@ CONTAINS
DO_2D( 0, 0, 0, 1 )
IF ( umask(ji,jj,jk) > 0.5_wp .AND. umask(ji-1,jj,jk) < 0.5_wp .AND. umask(ji+1,jj,jk) > 0.5_wp) THEN
zz_drho_i(ji,jj) = aco_bc_hor * ( rhd (ji+1,jj,jk) - rhd (ji,jj,jk) ) - bco_bc_hor * zdrho_i(ji+1,jj,jk)
- zz_dz_i (ji,jj) = aco_bc_hor * (-gde3w(ji+1,jj,jk) + gde3w(ji,jj,jk) ) - bco_bc_hor * zdz_i (ji+1,jj,jk)
+ zz_dz_i (ji,jj) = aco_bc_hor * (-gdept_z0(ji+1,jj,jk,Kmm) + gdept_z0(ji,jj,jk,Kmm) ) - bco_bc_hor * zdz_i (ji+1,jj,jk)
END IF
END_2D
! Walls coming from right: should check from 3 to jpi (and jpj=2-jpj)
DO_2D( -1, 1, 0, 1 )
IF ( umask(ji,jj,jk) < 0.5_wp .AND. umask(ji-1,jj,jk) > 0.5_wp .AND. umask(ji-2,jj,jk) > 0.5_wp) THEN
- zz_drho_i(ji,jj) = aco_bc_hor * ( rhd (ji,jj,jk) - rhd (ji-1,jj,jk) ) - bco_bc_hor * zdrho_i(ji-1,jj,jk)
- zz_dz_i (ji,jj) = aco_bc_hor * (-gde3w(ji,jj,jk) + gde3w(ji-1,jj,jk) ) - bco_bc_hor * zdz_i (ji-1,jj,jk)
+ zz_drho_i(ji,jj) = aco_bc_hor * ( rhd (ji,jj,jk ) - rhd (ji-1,jj,jk ) ) - bco_bc_hor * zdrho_i(ji-1,jj,jk)
+ zz_dz_i (ji,jj) = aco_bc_hor * (-gdept_z0(ji,jj,jk,Kmm) + gdept_z0(ji-1,jj,jk,Kmm) ) - bco_bc_hor * zdz_i (ji-1,jj,jk)
END IF
END_2D
! Walls coming from left: should check from 2 to jpj-1 (and jpi=2-jpi)
DO_2D( 0, 1, 0, 0 )
IF ( vmask(ji,jj,jk) > 0.5_wp .AND. vmask(ji,jj-1,jk) < 0.5_wp .AND. vmask(ji,jj+1,jk) > 0.5_wp) THEN
- zz_drho_j(ji,jj) = aco_bc_hor * ( rhd (ji,jj+1,jk) - rhd (ji,jj,jk) ) - bco_bc_hor * zdrho_j(ji,jj+1,jk)
- zz_dz_j (ji,jj) = aco_bc_hor * (-gde3w(ji,jj+1,jk) + gde3w(ji,jj,jk) ) - bco_bc_hor * zdz_j (ji,jj+1,jk)
+ zz_drho_j(ji,jj) = aco_bc_hor * ( rhd (ji,jj+1,jk ) - rhd (ji,jj,jk ) ) - bco_bc_hor * zdrho_j(ji,jj+1,jk)
+ zz_dz_j (ji,jj) = aco_bc_hor * (-gdept_z0(ji,jj+1,jk,Kmm) + gdept_z0(ji,jj,jk,Kmm) ) - bco_bc_hor * zdz_j (ji,jj+1,jk)
END IF
END_2D
! Walls coming from right: should check from 3 to jpj (and jpi=2-jpi)
DO_2D( 0, 1, -1, 1 )
IF ( vmask(ji,jj,jk) < 0.5_wp .AND. vmask(ji,jj-1,jk) > 0.5_wp .AND. vmask(ji,jj-2,jk) > 0.5_wp) THEN
- zz_drho_j(ji,jj) = aco_bc_hor * ( rhd (ji,jj,jk) - rhd (ji,jj-1,jk) ) - bco_bc_hor * zdrho_j(ji,jj-1,jk)
- zz_dz_j (ji,jj) = aco_bc_hor * (-gde3w(ji,jj,jk) + gde3w(ji,jj-1,jk) ) - bco_bc_hor * zdz_j (ji,jj-1,jk)
+ zz_drho_j(ji,jj) = aco_bc_hor * ( rhd (ji,jj,jk ) - rhd (ji,jj-1,jk ) ) - bco_bc_hor * zdrho_j(ji,jj-1,jk)
+ zz_dz_j (ji,jj) = aco_bc_hor * (-gdept_z0(ji,jj,jk,Kmm) + gdept_z0(ji,jj-1,jk,Kmm) ) - bco_bc_hor * zdz_j (ji,jj-1,jk)
END IF
END_2D
zdrho_i(:,:,jk) = zz_drho_i(:,:)
@@ -872,26 +790,26 @@ CONTAINS
DO_3D( 0, 0, 0, 0, 1, jpkm1 )
! two -ve signs cancel in next two lines (within zcoef0 and because gde3w is a depth not a height)
- z_rho_i(ji,jj,jk) = zcoef0 * ( rhd (ji+1,jj,jk) + rhd (ji,jj,jk) ) &
- & * ( gde3w(ji+1,jj,jk) - gde3w(ji,jj,jk) )
+ z_rho_i(ji,jj,jk) = zcoef0 * ( rhd (ji+1,jj,jk ) + rhd (ji,jj,jk ) ) &
+ & * ( gdept_z0(ji+1,jj,jk,Kmm) - gdept_z0(ji,jj,jk,Kmm) )
IF ( umask(ji-1, jj, jk) > 0.5 .OR. umask(ji+1, jj, jk) > 0.5 ) THEN
z_rho_i(ji,jj,jk) = z_rho_i(ji,jj,jk) - z_grav_10 * ( &
- & ( zdrho_i (ji+1,jj,jk) - zdrho_i (ji,jj,jk) ) &
- & * ( - gde3w(ji+1,jj,jk) + gde3w(ji,jj,jk) - z1_12 * ( zdz_i (ji+1,jj,jk) + zdz_i (ji,jj,jk) ) ) &
- & - ( zdz_i (ji+1,jj,jk) - zdz_i (ji,jj,jk) ) &
- & * ( rhd (ji+1,jj,jk) - rhd (ji,jj,jk) - z1_12 * ( zdrho_i(ji+1,jj,jk) + zdrho_i(ji,jj,jk) ) ) &
- & )
+ & ( zdrho_i (ji+1,jj,jk) - zdrho_i (ji,jj,jk) ) &
+ & * ( - ( gdept_z0(ji+1,jj,jk,Kmm) - gdept_z0(ji,jj,jk,Kmm) ) - z1_12 * ( zdz_i (ji+1,jj,jk) + zdz_i (ji,jj,jk) ) ) &
+ & - ( zdz_i (ji+1,jj,jk) - zdz_i (ji,jj,jk) ) &
+ & * ( ( rhd (ji+1,jj,jk) - rhd (ji,jj,jk) ) - z1_12 * ( zdrho_i(ji+1,jj,jk) + zdrho_i(ji,jj,jk) ) ) &
+ & )
END IF
- z_rho_j(ji,jj,jk) = zcoef0 * ( rhd (ji,jj+1,jk) + rhd (ji,jj,jk) ) &
- & * ( gde3w(ji,jj+1,jk) - gde3w(ji,jj,jk) )
+ z_rho_j(ji,jj,jk) = zcoef0 * ( rhd (ji,jj+1,jk ) + rhd (ji,jj,jk ) ) &
+ & * ( gdept_z0(ji,jj+1,jk,Kmm) - gdept_z0(ji,jj,jk,Kmm) )
IF ( vmask(ji, jj-1, jk) > 0.5 .OR. vmask(ji, jj+1, jk) > 0.5 ) THEN
z_rho_j(ji,jj,jk) = z_rho_j(ji,jj,jk) - z_grav_10 * ( &
- & ( zdrho_j (ji,jj+1,jk) - zdrho_j (ji,jj,jk) ) &
- & * ( - gde3w(ji,jj+1,jk) + gde3w(ji,jj,jk) - z1_12 * ( zdz_j (ji,jj+1,jk) + zdz_j (ji,jj,jk) ) ) &
- & - ( zdz_j (ji,jj+1,jk) - zdz_j (ji,jj,jk) ) &
- & * ( rhd (ji,jj+1,jk) - rhd (ji,jj,jk) - z1_12 * ( zdrho_j(ji,jj+1,jk) + zdrho_j(ji,jj,jk) ) ) &
- & )
+ & ( zdrho_j (ji,jj+1,jk) - zdrho_j (ji,jj,jk) ) &
+ & * ( - ( gdept_z0(ji,jj+1,jk,Kmm) - gdept_z0(ji,jj,jk,Kmm) ) - z1_12 * ( zdz_j (ji,jj+1,jk) + zdz_j (ji,jj,jk) ) ) &
+ & - ( zdz_j(ji,jj+1,jk) - zdz_j(ji,jj,jk) ) &
+ & * ( ( rhd(ji,jj+1,jk) - rhd(ji,jj,jk) ) - z1_12 * ( zdrho_j(ji,jj+1,jk) + zdrho_j(ji,jj,jk) ) ) &
+ & )
END IF
END_3D
@@ -903,8 +821,8 @@ CONTAINS
! Surface value
! ---------------
DO_2D( 0, 0, 0, 0 )
- zhpi(ji,jj,1) = ( z_rho_k(ji,jj,1) - z_rho_k(ji+1,jj ,1) - z_rho_i(ji,jj,1) ) * r1_e1u(ji,jj)
- zhpj(ji,jj,1) = ( z_rho_k(ji,jj,1) - z_rho_k(ji ,jj+1,1) - z_rho_j(ji,jj,1) ) * r1_e2v(ji,jj)
+ zhpi(ji,jj,1) = ( ( z_rho_k(ji,jj,1) - z_rho_k(ji+1,jj ,1) ) - z_rho_i(ji,jj,1) ) * r1_e1u(ji,jj) ! add () for NP repro
+ zhpj(ji,jj,1) = ( ( z_rho_k(ji,jj,1) - z_rho_k(ji ,jj+1,1) ) - z_rho_j(ji,jj,1) ) * r1_e2v(ji,jj)
IF( ln_wd_il ) THEN
zhpi(ji,jj,1) = zhpi(ji,jj,1) * zcpx(ji,jj)
zhpj(ji,jj,1) = zhpj(ji,jj,1) * zcpy(ji,jj)
@@ -964,10 +882,10 @@ CONTAINS
REAL(wp) :: zuijk, zvijk, zpwes, zpwed, zpnss, zpnsd, zdeps
REAL(wp) :: zrhdt1
REAL(wp) :: zdpdx1, zdpdx2, zdpdy1, zdpdy2
- REAL(wp), DIMENSION(A2D(nn_hls)) :: zpgu, zpgv ! 2D workspace
- REAL(wp), DIMENSION(A2D(nn_hls)) :: zsshu_n, zsshv_n
- REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zdept, zrhh
- REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zhpi, zu, zv, fsp, xsp, asp, bsp, csp, dsp
+ REAL(wp), DIMENSION(T2D(nn_hls)) :: zpgu, zpgv ! 2D workspace
+ REAL(wp), DIMENSION(T2D(nn_hls)) :: zsshu_n, zsshv_n
+ REAL(wp), DIMENSION(T2D(nn_hls),jpk) :: zdept, zrhh
+ REAL(wp), DIMENSION(T2D(nn_hls),jpk) :: zhpi, zu, zv, fsp, xsp, asp, bsp, csp, dsp
REAL(wp), DIMENSION(:,:), ALLOCATABLE :: zcpx, zcpy !W/D pressure filter
!!----------------------------------------------------------------------
!
@@ -993,7 +911,7 @@ CONTAINS
END_2D
!
IF( ln_wd_il ) THEN
- ALLOCATE( zcpx(A2D(nn_hls)) , zcpy(A2D(nn_hls)) )
+ ALLOCATE( zcpx(T2D(nn_hls)) , zcpy(T2D(nn_hls)) )
DO_2D( 0, 0, 0, 0 )
ll_tmp1 = MIN( ssh(ji,jj,Kmm) , ssh(ji+1,jj,Kmm) ) > &
& MAX( -ht_0(ji,jj) , -ht_0(ji+1,jj) ) .AND. &
@@ -1007,8 +925,8 @@ CONTAINS
zcpx(ji,jj) = 1.0_wp
ELSE IF(ll_tmp2) THEN
! no worries about ssh(ji+1,jj,Kmm) - ssh(ji ,jj,Kmm) = 0, it won't happen ! here
- zcpx(ji,jj) = ABS( (ssh(ji+1,jj,Kmm) + ht_0(ji+1,jj) - ssh(ji,jj,Kmm) - ht_0(ji,jj)) &
- & / (ssh(ji+1,jj,Kmm) - ssh(ji ,jj,Kmm)) )
+ zcpx(ji,jj) = ABS( ( ( ssh(ji+1,jj,Kmm) + ht_0(ji+1,jj) ) - ( ssh(ji,jj,Kmm) + ht_0(ji,jj) ) ) &
+ & / ( ssh(ji+1,jj,Kmm) - ssh(ji,jj,Kmm) ) )
zcpx(ji,jj) = MAX(MIN( zcpx(ji,jj) , 1.0_wp),0.0_wp)
ELSE
zcpx(ji,jj) = 0._wp
@@ -1026,8 +944,8 @@ CONTAINS
zcpy(ji,jj) = 1.0_wp
ELSE IF(ll_tmp2) THEN
! no worries about ssh(ji,jj+1,Kmm) - ssh(ji,jj ,Kmm) = 0, it won't happen ! here
- zcpy(ji,jj) = ABS( (ssh(ji,jj+1,Kmm) + ht_0(ji,jj+1) - ssh(ji,jj,Kmm) - ht_0(ji,jj)) &
- & / (ssh(ji,jj+1,Kmm) - ssh(ji,jj ,Kmm)) )
+ zcpy(ji,jj) = ABS( ( ( ssh(ji,jj+1,Kmm) + ht_0(ji,jj+1) ) - ( ssh(ji,jj,Kmm) + ht_0(ji,jj) ) ) &
+ & / ( ssh(ji,jj+1,Kmm) - ssh(ji,jj,Kmm) ) )
zcpy(ji,jj) = MAX(MIN( zcpy(ji,jj) , 1.0_wp),0.0_wp)
ELSE
zcpy(ji,jj) = 0._wp
@@ -1037,7 +955,7 @@ CONTAINS
! Clean 3-D work arrays
zhpi(:,:,:) = 0._wp
- zrhh(:,:,:) = rhd(A2D(nn_hls),:)
+ zrhh(:,:,:) = rhd(T2D(nn_hls),:)
! Preparing vertical density profile "zrhh(:,:,:)" for hybrid-sco coordinate
DO_2D( 1, 1, 1, 1 )
@@ -1046,8 +964,8 @@ CONTAINS
ELSEIF( jk == 2 ) THEN ; zrhh(ji,jj,jk+1:jpk) = rhd(ji,jj,jk)
ELSEIF( jk < jpkm1 ) THEN
DO jkk = jk+1, jpk
- zrhh(ji,jj,jkk) = interp1(gde3w(ji,jj,jkk ), gde3w(ji,jj,jkk-1), &
- & gde3w(ji,jj,jkk-2), zrhh (ji,jj,jkk-1), zrhh(ji,jj,jkk-2))
+ zrhh(ji,jj,jkk) = interp1(gdept_z0(ji,jj,jkk ,Kmm), gdept_z0(ji,jj,jkk-1,Kmm), &
+ & gdept_z0(ji,jj,jkk-2,Kmm), zrhh (ji,jj,jkk-1), zrhh(ji,jj,jkk-2))
END DO
ENDIF
END_2D
@@ -1263,8 +1181,8 @@ CONTAINS
!!
!! Reference: CJC Kruger, Constrained Cubic Spline Interpoltation
!!----------------------------------------------------------------------
- REAL(wp), DIMENSION(A2D(nn_hls),jpk), INTENT(in ) :: fsp, xsp ! value and coordinate
- REAL(wp), DIMENSION(A2D(nn_hls),jpk), INTENT( out) :: asp, bsp, csp, dsp ! coefficients of the interpoated function
+ REAL(wp), DIMENSION(T2D(nn_hls),jpk), INTENT(in ) :: fsp, xsp ! value and coordinate
+ REAL(wp), DIMENSION(T2D(nn_hls),jpk), INTENT( out) :: asp, bsp, csp, dsp ! coefficients of the interpoated function
INTEGER , INTENT(in ) :: polynomial_type ! 1: cubic spline ; 2: Linear
!
INTEGER :: ji, jj, jk ! dummy loop indices
diff --git a/src/OCE/DYN/dynkeg.F90 b/src/OCE/DYN/dynkeg.F90
index d751899d0de9266477ed7f9ecc26941906cba84d..cb8697b995c685fb39e6779ee081766a55d345d6 100644
--- a/src/OCE/DYN/dynkeg.F90
+++ b/src/OCE/DYN/dynkeg.F90
@@ -6,7 +6,8 @@ MODULE dynkeg
!! History : 1.0 ! 1987-09 (P. Andrich, M.-A. Foujols) Original code
!! 7.0 ! 1997-05 (G. Madec) Split dynber into dynkeg and dynhpg
!! NEMO 1.0 ! 2002-07 (G. Madec) F90: Free form and module
- !! 3.6 ! 2015-05 (N. Ducousso, G. Madec) add Hollingsworth scheme as an option
+ !! 3.6 ! 2015-05 (N. Ducousso, G. Madec) add Hollingsworth scheme as an option
+ !! 4.5 ! 2022-06 (S. Techene, G, Madec) refactorization to reduce local memory usage
!!----------------------------------------------------------------------
!!----------------------------------------------------------------------
@@ -27,7 +28,7 @@ MODULE dynkeg
IMPLICIT NONE
PRIVATE
- PUBLIC dyn_keg ! routine called by step module
+ PUBLIC dyn_keg ! routine called by step module
INTEGER, PARAMETER, PUBLIC :: nkeg_C2 = 0 !: 2nd order centered scheme (standard scheme)
INTEGER, PARAMETER, PUBLIC :: nkeg_HW = 1 !: Hollingsworth et al., QJRMS, 1983
@@ -70,15 +71,15 @@ CONTAINS
!! ** References : Arakawa, A., International Geophysics 2001.
!! Hollingsworth et al., Quart. J. Roy. Meteor. Soc., 1983.
!!----------------------------------------------------------------------
- INTEGER , INTENT( in ) :: kt ! ocean time-step index
- INTEGER , INTENT( in ) :: kscheme ! =0/1 type of KEG scheme
- INTEGER , INTENT( in ) :: Kmm, Krhs ! ocean time level indices
- REAL(wp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) :: puu, pvv ! ocean velocities and RHS of momentum equation
+ INTEGER , INTENT(in ) :: kt ! ocean time-step index
+ INTEGER , INTENT(in ) :: kscheme ! =0/1 type of KEG scheme
+ INTEGER , INTENT(in ) :: Kmm, Krhs ! ocean time level indices
+ REAL(wp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) :: puu, pvv ! ocean velocities and RHS of momentum equation
!
- INTEGER :: ji, jj, jk ! dummy loop indices
- REAL(wp) :: zu, zv ! local scalars
- REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zhke
- REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: ztrdu, ztrdv
+ INTEGER :: ji, jj, jk ! dummy loop indices
+ REAL(wp) :: zu, zv ! local scalars
+ REAL(wp), DIMENSION(:,: ) , ALLOCATABLE :: zhke
+ REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE :: zu_trd, zv_trd
!!----------------------------------------------------------------------
!
IF( ln_timing ) CALL timing_start('dyn_keg')
@@ -90,56 +91,66 @@ CONTAINS
IF(lwp) WRITE(numout,*) '~~~~~~~'
ENDIF
ENDIF
-
- IF( l_trddyn ) THEN ! Save the input trends
- ALLOCATE( ztrdu(jpi,jpj,jpk) , ztrdv(jpi,jpj,jpk) )
- ztrdu(:,:,:) = puu(:,:,:,Krhs)
- ztrdv(:,:,:) = pvv(:,:,:,Krhs)
+ !
+ IF( l_trddyn ) THEN ! Save the input trends
+ ALLOCATE( zu_trd(A2D(0),jpk), zv_trd(A2D(0),jpk) )
+ zu_trd(A2D(0),:) = puu(A2D(0),:,Krhs)
+ zv_trd(A2D(0),:) = pvv(A2D(0),:,Krhs)
ENDIF
-
- zhke(:,:,jpk) = 0._wp
-
- SELECT CASE ( kscheme ) !== Horizontal kinetic energy at T-point ==!
!
- CASE ( nkeg_C2 ) !-- Standard scheme --!
- DO_3D( 0, 1, 0, 1, 1, jpkm1 )
- zu = puu(ji-1,jj ,jk,Kmm) * puu(ji-1,jj ,jk,Kmm) &
- & + puu(ji ,jj ,jk,Kmm) * puu(ji ,jj ,jk,Kmm)
- zv = pvv(ji ,jj-1,jk,Kmm) * pvv(ji ,jj-1,jk,Kmm) &
- & + pvv(ji ,jj ,jk,Kmm) * pvv(ji ,jj ,jk,Kmm)
- zhke(ji,jj,jk) = 0.25_wp * ( zv + zu )
- END_3D
- CASE ( nkeg_HW ) !-- Hollingsworth scheme --!
- DO_3D( 0, nn_hls-1, 0, nn_hls-1, 1, jpkm1 )
- ! round brackets added to fix the order of floating point operations
- ! needed to ensure halo 1 - halo 2 compatibility
- zu = 8._wp * ( puu(ji-1,jj ,jk,Kmm) * puu(ji-1,jj ,jk,Kmm) &
- & + puu(ji ,jj ,jk,Kmm) * puu(ji ,jj ,jk,Kmm) ) &
- & + ( ( puu(ji-1,jj-1,jk,Kmm) + puu(ji-1,jj+1,jk,Kmm) ) * ( puu(ji-1,jj-1,jk,Kmm) + puu(ji-1,jj+1,jk,Kmm) ) &
- & + ( puu(ji ,jj-1,jk,Kmm) + puu(ji ,jj+1,jk,Kmm) ) * ( puu(ji ,jj-1,jk,Kmm) + puu(ji ,jj+1,jk,Kmm) ) &
- & ) ! bracket for halo 1 - halo 2 compatibility
- !
- zv = 8._wp * ( pvv(ji ,jj-1,jk,Kmm) * pvv(ji ,jj-1,jk,Kmm) &
- & + pvv(ji ,jj ,jk,Kmm) * pvv(ji ,jj ,jk,Kmm) ) &
- & + ( ( pvv(ji-1,jj-1,jk,Kmm) + pvv(ji+1,jj-1,jk,Kmm) ) * ( pvv(ji-1,jj-1,jk,Kmm) + pvv(ji+1,jj-1,jk,Kmm) ) &
- & + ( pvv(ji-1,jj ,jk,Kmm) + pvv(ji+1,jj ,jk,Kmm) ) * ( pvv(ji-1,jj ,jk,Kmm) + pvv(ji+1,jj ,jk,Kmm) ) &
- & ) ! bracket for halo 1 - halo 2 compatibility
- zhke(ji,jj,jk) = r1_48 * ( zv + zu )
- END_3D
- IF (nn_hls==1) CALL lbc_lnk( 'dynkeg', zhke, 'T', 1.0_wp )
- !
- END SELECT
+ SELECT CASE ( kscheme )
!
- DO_3D( 0, 0, 0, 0, 1, jpkm1 ) !== grad( KE ) added to the general momentum trends ==!
- puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) - ( zhke(ji+1,jj ,jk) - zhke(ji,jj,jk) ) / e1u(ji,jj)
- pvv(ji,jj,jk,Krhs) = pvv(ji,jj,jk,Krhs) - ( zhke(ji ,jj+1,jk) - zhke(ji,jj,jk) ) / e2v(ji,jj)
- END_3D
+ CASE ( nkeg_C2 ) !== Standard scheme ==!
+ ALLOCATE( zhke(T2D(1)) )
+ DO jk = 1, jpkm1
+ DO_2D( 0, 1, 0, 1 ) !* Horizontal kinetic energy at T-point
+ zu = puu(ji-1,jj ,jk,Kmm) * puu(ji-1,jj ,jk,Kmm) &
+ & + puu(ji ,jj ,jk,Kmm) * puu(ji ,jj ,jk,Kmm)
+ zv = pvv(ji ,jj-1,jk,Kmm) * pvv(ji ,jj-1,jk,Kmm) &
+ & + pvv(ji ,jj ,jk,Kmm) * pvv(ji ,jj ,jk,Kmm)
+ zhke(ji,jj) = 0.25_wp * ( zv + zu )
+ END_2D
+ !
+ DO_2D( 0, 0, 0, 0 ) !* grad( KE ) added to the general momentum trends
+ puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) - ( zhke(ji+1,jj ) - zhke(ji,jj) ) * r1_e1u(ji,jj)
+ pvv(ji,jj,jk,Krhs) = pvv(ji,jj,jk,Krhs) - ( zhke(ji ,jj+1) - zhke(ji,jj) ) * r1_e2v(ji,jj)
+ END_2D
+ END DO
+ DEALLOCATE( zhke )
+ !
+ CASE ( nkeg_HW ) !* Hollingsworth scheme
+ ALLOCATE( zhke(T2D(1)) )
+ DO jk = 1, jpkm1
+ DO_2D( 0, 1, 0, 1 )
+ ! round brackets added to fix the order of floating point operations
+ ! needed to ensure halo 1 - halo 2 compatibility
+ zu = ( puu(ji-1,jj ,jk,Kmm) * puu(ji-1,jj ,jk,Kmm) &
+ & + puu(ji ,jj ,jk,Kmm) * puu(ji ,jj ,jk,Kmm) ) * 8._wp &
+ & + ( ( puu(ji-1,jj-1,jk,Kmm) + puu(ji-1,jj+1,jk,Kmm) ) * ( puu(ji-1,jj-1,jk,Kmm) + puu(ji-1,jj+1,jk,Kmm) ) &
+ & + ( puu(ji ,jj-1,jk,Kmm) + puu(ji ,jj+1,jk,Kmm) ) * ( puu(ji ,jj-1,jk,Kmm) + puu(ji ,jj+1,jk,Kmm) ) &
+ & ) ! bracket for halo 1 - halo 2 compatibility
+ zv = ( pvv(ji ,jj-1,jk,Kmm) * pvv(ji ,jj-1,jk,Kmm) &
+ & + pvv(ji ,jj ,jk,Kmm) * pvv(ji ,jj ,jk,Kmm) ) * 8._wp &
+ & + ( ( pvv(ji-1,jj-1,jk,Kmm) + pvv(ji+1,jj-1,jk,Kmm) ) * ( pvv(ji-1,jj-1,jk,Kmm) + pvv(ji+1,jj-1,jk,Kmm) ) &
+ & + ( pvv(ji-1,jj ,jk,Kmm) + pvv(ji+1,jj ,jk,Kmm) ) * ( pvv(ji-1,jj ,jk,Kmm) + pvv(ji+1,jj ,jk,Kmm) ) &
+ & ) ! bracket for halo 1 - halo 2 compatibility
+ zhke(ji,jj) = r1_48 * ( zv + zu )
+ END_2D
+ !
+ DO_2D( 0, 0, 0, 0 ) !* grad( KE ) added to the general momentum trends
+ puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) - ( zhke(ji+1,jj ) - zhke(ji,jj) ) * r1_e1u(ji,jj)
+ pvv(ji,jj,jk,Krhs) = pvv(ji,jj,jk,Krhs) - ( zhke(ji ,jj+1) - zhke(ji,jj) ) * r1_e2v(ji,jj)
+ END_2D
+ END DO
+ DEALLOCATE( zhke )
+ !
+ END SELECT
!
- IF( l_trddyn ) THEN ! save the Kinetic Energy trends for diagnostic
- ztrdu(:,:,:) = puu(:,:,:,Krhs) - ztrdu(:,:,:)
- ztrdv(:,:,:) = pvv(:,:,:,Krhs) - ztrdv(:,:,:)
- CALL trd_dyn( ztrdu, ztrdv, jpdyn_keg, kt, Kmm )
- DEALLOCATE( ztrdu , ztrdv )
+ IF( l_trddyn ) THEN ! save the Kinetic Energy trends for diagnostic
+ zu_trd(A2D(0),:) = puu(A2D(0),:,Krhs) - zu_trd(A2D(0),:)
+ zv_trd(A2D(0),:) = pvv(A2D(0),:,Krhs) - zv_trd(A2D(0),:)
+ CALL trd_dyn( zu_trd, zv_trd, jpdyn_keg, kt, Kmm )
+ DEALLOCATE( zu_trd, zv_trd )
ENDIF
!
IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=puu(:,:,:,Krhs), clinfo1=' keg - Ua: ', mask1=umask, &
diff --git a/src/OCE/DYN/dynldf.F90 b/src/OCE/DYN/dynldf.F90
index da8705afa39587639c9f56495ccfbe9956300fb1..6649da6174537d7103dedc203b93439d9594098d 100644
--- a/src/OCE/DYN/dynldf.F90
+++ b/src/OCE/DYN/dynldf.F90
@@ -16,7 +16,8 @@ MODULE dynldf
USE dom_oce ! ocean space and time domain
USE phycst ! physical constants
USE ldfdyn ! lateral diffusion: eddy viscosity coef.
- USE dynldf_lap_blp ! lateral mixing (dyn_ldf_lap & dyn_ldf_blp routines)
+ USE dynldf_lev ! lateral mixing (dynldf_lev_lap & dynldf_lev_blp routines)
+!!st USE dynldf_lap_blp ! lateral mixing (dyn_ldf_lap & dyn_ldf_blp routines)
USE dynldf_iso ! lateral mixing (dyn_ldf_iso routine )
USE trd_oce ! trends: ocean variables
USE trddyn ! trend manager: dynamics (trd_dyn routine)
@@ -64,11 +65,13 @@ CONTAINS
SELECT CASE ( nldf_dyn ) ! compute lateral mixing trend and add it to the general trend
!
CASE ( np_lap )
- CALL dyn_ldf_lap( kt, Kbb, Kmm, puu(:,:,:,Kbb), pvv(:,:,:,Kbb), puu(:,:,:,Krhs), pvv(:,:,:,Krhs), 1 ) ! iso-level laplacian
+!!st CALL dyn_ldf_lap( kt, Kbb, Kmm, puu(:,:,:,Kbb), pvv(:,:,:,Kbb), puu(:,:,:,Krhs), pvv(:,:,:,Krhs), 1 ) ! iso-level laplacian
+ CALL dynldf_lev_lap( kt, Kbb, Kmm, puu, pvv, Krhs )
CASE ( np_lap_i )
CALL dyn_ldf_iso( kt, Kbb, Kmm, puu, pvv, Krhs ) ! rotated laplacian
CASE ( np_blp )
- CALL dyn_ldf_blp( kt, Kbb, Kmm, puu(:,:,:,Kbb), pvv(:,:,:,Kbb), puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! iso-level bi-laplacian
+!!st CALL dyn_ldf_blp( kt, Kbb, Kmm, puu(:,:,:,Kbb), pvv(:,:,:,Kbb), puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! iso-level bi-laplacian
+ CALL dynldf_lev_blp( kt, Kbb, Kmm, puu, pvv, Krhs )
!
END SELECT
diff --git a/src/OCE/DYN/dynldf_iso.F90 b/src/OCE/DYN/dynldf_iso.F90
index 891d8842cc5955dd9f3ea41c56aaf819a160d321..9c8d84f11e35956a86c6f4004bb2ccbc4ab11979 100644
--- a/src/OCE/DYN/dynldf_iso.F90
+++ b/src/OCE/DYN/dynldf_iso.F90
@@ -27,9 +27,6 @@ MODULE dynldf_iso
USE lib_mpp ! MPP library
USE lbclnk ! ocean lateral boundary conditions (or mpp link)
USE prtctl ! Print control
-#if defined key_loop_fusion
- USE dynldf_iso_lf, ONLY: dyn_ldf_iso_lf ! lateral mixing - loop fusion version (dyn_ldf_iso routine )
-#endif
IMPLICIT NONE
PRIVATE
@@ -113,16 +110,12 @@ CONTAINS
REAL(wp) :: zabe1, zmskt, zmkt, zuav, zuwslpi, zuwslpj ! local scalars
REAL(wp) :: zabe2, zmskf, zmkf, zvav, zvwslpi, zvwslpj ! - -
REAL(wp) :: zcof0, zcof1, zcof2, zcof3, zcof4, zaht_0 ! - -
- REAL(wp), DIMENSION(A2D(nn_hls)) :: ziut, zivf, zdku, zdk1u ! 2D workspace
- REAL(wp), DIMENSION(A2D(nn_hls)) :: zjuf, zjvt, zdkv, zdk1v ! - -
- REAL(wp), DIMENSION(A1Di(nn_hls),jpk) :: zfuw, zdiu, zdju, zdj1u ! - -
- REAL(wp), DIMENSION(A1Di(nn_hls),jpk) :: zfvw, zdiv, zdjv, zdj1v ! - -
+ REAL(wp), DIMENSION(T2D(nn_hls)) :: ziut, zivf, zdku, zdk1u ! 2D workspace
+ REAL(wp), DIMENSION(T2D(nn_hls)) :: zjuf, zjvt, zdkv, zdk1v ! - -
+ REAL(wp), DIMENSION(T1Di(nn_hls),jpk) :: zfuw, zdiu, zdju, zdj1u ! - -
+ REAL(wp), DIMENSION(T1Di(nn_hls),jpk) :: zfvw, zdiv, zdjv, zdj1v ! - -
!!----------------------------------------------------------------------
!
-#if defined key_loop_fusion
- CALL dyn_ldf_iso_lf( kt, Kbb, Kmm, puu, pvv, Krhs )
-#else
-
IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile
IF( kt == nit000 ) THEN
IF(lwp) WRITE(numout,*)
@@ -131,7 +124,7 @@ CONTAINS
! ! allocate dyn_ldf_iso arrays
IF( dyn_ldf_iso_alloc() /= 0 ) CALL ctl_stop('STOP', 'dyn_ldf_iso: failed to allocate arrays')
!
- DO_2D_OVR( 0, 0, 0, 0 )
+ DO_2D( 0, 0, 0, 0 )
akzu(ji,jj,1) = 0._wp
akzu(ji,jj,jpk) = 0._wp
akzv(ji,jj,1) = 0._wp
@@ -188,7 +181,7 @@ CONTAINS
! |
! i-flux at t-point -----f-----
- IF( ln_zps ) THEN ! z-coordinate - partial steps : min(e3u)
+ IF( l_zps ) THEN ! z-coordinate - partial steps : min(e3u)
DO_2D( 0, 1, 0, 0 )
zabe1 = ( ahmt(ji,jj,jk)+rn_ahm_b ) * e2t(ji,jj) &
& * MIN( e3u(ji ,jj,jk,Kmm), &
@@ -200,8 +193,8 @@ CONTAINS
zcof1 = - zaht_0 * e2t(ji,jj) * zmskt * 0.5 * ( uslp(ji-1,jj,jk) + uslp(ji,jj,jk) )
ziut(ji,jj) = ( zabe1 * ( puu(ji,jj,jk,Kbb) - puu(ji-1,jj,jk,Kbb) ) &
- & + zcof1 * ( zdku (ji,jj) + zdk1u(ji-1,jj) &
- & +zdk1u(ji,jj) + zdku (ji-1,jj) ) ) * tmask(ji,jj,jk)
+ & + zcof1 * ( ( zdku (ji,jj) + zdk1u(ji-1,jj) ) & ! add () for NP repro
+ & +( zdk1u(ji,jj) + zdku (ji-1,jj) ) ) ) * tmask(ji,jj,jk)
END_2D
ELSE ! other coordinate system (zco or sco) : e3t
DO_2D( 0, 1, 0, 0 )
@@ -214,8 +207,8 @@ CONTAINS
zcof1 = - zaht_0 * e2t(ji,jj) * zmskt * 0.5 * ( uslp(ji-1,jj,jk) + uslp(ji,jj,jk) )
ziut(ji,jj) = ( zabe1 * ( puu(ji,jj,jk,Kbb) - puu(ji-1,jj,jk,Kbb) ) &
- & + zcof1 * ( zdku (ji,jj) + zdk1u(ji-1,jj) &
- & +zdk1u(ji,jj) + zdku (ji-1,jj) ) ) * tmask(ji,jj,jk)
+ & + zcof1 * ( ( zdku (ji,jj) + zdk1u(ji-1,jj) ) & ! add () for NP repro
+ & +( zdk1u(ji,jj) + zdku (ji-1,jj) ) ) ) * tmask(ji,jj,jk)
END_2D
ENDIF
@@ -230,8 +223,8 @@ CONTAINS
zcof2 = - zaht_0 * e1f(ji,jj) * zmskf * 0.5 * ( vslp(ji+1,jj,jk) + vslp(ji,jj,jk) )
zjuf(ji,jj) = ( zabe2 * ( puu(ji,jj+1,jk,Kbb) - puu(ji,jj,jk,Kbb) ) &
- & + zcof2 * ( zdku (ji,jj+1) + zdk1u(ji,jj) &
- & +zdk1u(ji,jj+1) + zdku (ji,jj) ) ) * fmask(ji,jj,jk)
+ & + zcof2 * ( ( zdku (ji,jj+1) + zdk1u(ji,jj) ) & ! add () for NP repro
+ & +( zdk1u(ji,jj+1) + zdku (ji,jj) ) ) ) * fmask(ji,jj,jk)
END_2D
! | t |
@@ -250,12 +243,12 @@ CONTAINS
zcof1 = - zaht_0 * e2f(ji,jj) * zmskf * 0.5 * ( uslp(ji,jj+1,jk) + uslp(ji,jj,jk) )
zivf(ji,jj) = ( zabe1 * ( pvv(ji+1,jj,jk,Kbb) - pvv(ji,jj,jk,Kbb) ) &
- & + zcof1 * ( zdkv (ji,jj) + zdk1v(ji+1,jj) &
- & + zdk1v(ji,jj) + zdkv (ji+1,jj) ) ) * fmask(ji,jj,jk)
+ & + zcof1 * ( ( zdkv (ji,jj) + zdk1v(ji+1,jj) ) & ! add () for NP repro
+ & + ( zdk1v(ji,jj) + zdkv (ji+1,jj) ) ) ) * fmask(ji,jj,jk)
END_2D
! j-flux at t-point
- IF( ln_zps ) THEN ! z-coordinate - partial steps : min(e3u)
+ IF( l_zps ) THEN ! z-coordinate - partial steps : min(e3u)
DO_2D( 1, 0, 0, 1 )
zabe2 = ( ahmt(ji,jj,jk)+rn_ahm_b ) * e1t(ji,jj) &
& * MIN( e3v(ji,jj ,jk,Kmm), &
@@ -267,8 +260,8 @@ CONTAINS
zcof2 = - zaht_0 * e1t(ji,jj) * zmskt * 0.5 * ( vslp(ji,jj-1,jk) + vslp(ji,jj,jk) )
zjvt(ji,jj) = ( zabe2 * ( pvv(ji,jj,jk,Kbb) - pvv(ji,jj-1,jk,Kbb) ) &
- & + zcof2 * ( zdkv (ji,jj-1) + zdk1v(ji,jj) &
- & +zdk1v(ji,jj-1) + zdkv (ji,jj) ) ) * tmask(ji,jj,jk)
+ & + zcof2 * ( ( zdkv (ji,jj-1) + zdk1v(ji,jj) ) & ! add () for NP repro
+ & +( zdk1v(ji,jj-1) + zdkv (ji,jj) ) ) ) * tmask(ji,jj,jk)
END_2D
ELSE ! other coordinate system (zco or sco) : e3t
DO_2D( 1, 0, 0, 1 )
@@ -281,8 +274,8 @@ CONTAINS
zcof2 = - zaht_0 * e1t(ji,jj) * zmskt * 0.5 * ( vslp(ji,jj-1,jk) + vslp(ji,jj,jk) )
zjvt(ji,jj) = ( zabe2 * ( pvv(ji,jj,jk,Kbb) - pvv(ji,jj-1,jk,Kbb) ) &
- & + zcof2 * ( zdkv (ji,jj-1) + zdk1v(ji,jj) &
- & +zdk1v(ji,jj-1) + zdkv (ji,jj) ) ) * tmask(ji,jj,jk)
+ & + zcof2 * ( ( zdkv (ji,jj-1) + zdk1v(ji,jj) ) & ! add () for NP repro
+ & +( zdk1v(ji,jj-1) + zdkv (ji,jj) ) ) ) * tmask(ji,jj,jk)
END_2D
ENDIF
@@ -290,12 +283,10 @@ CONTAINS
! Second derivative (divergence) and add to the general trend
! -----------------------------------------------------------
DO_2D( 0, 0, 0, 0 ) !!gm Question vectop possible??? !!bug
- puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) + ( ziut(ji+1,jj) - ziut(ji,jj ) &
- & + zjuf(ji ,jj) - zjuf(ji,jj-1) ) * r1_e1e2u(ji,jj) &
- & / e3u(ji,jj,jk,Kmm)
- pvv(ji,jj,jk,Krhs) = pvv(ji,jj,jk,Krhs) + ( zivf(ji,jj ) - zivf(ji-1,jj) &
- & + zjvt(ji,jj+1) - zjvt(ji,jj ) ) * r1_e1e2v(ji,jj) &
- & / e3v(ji,jj,jk,Kmm)
+ puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) + ( ( ziut(ji+1,jj) - ziut(ji,jj ) ) & ! add () for NP repro
+ & + ( zjuf(ji ,jj) - zjuf(ji,jj-1) ) ) * r1_e1e2u(ji,jj) / e3u(ji,jj,jk,Kmm)
+ pvv(ji,jj,jk,Krhs) = pvv(ji,jj,jk,Krhs) + ( ( zivf(ji,jj ) - zivf(ji-1,jj) ) & ! add () for NP repro
+ & + ( zjvt(ji,jj+1) - zjvt(ji,jj ) ) ) * r1_e1e2v(ji,jj) / e3v(ji,jj,jk,Kmm)
END_2D
! ! ===============
END DO ! End of slab
@@ -366,10 +357,10 @@ CONTAINS
zcof3 = - e2u(ji,jj) * zmkt * zuwslpi
zcof4 = - e1u(ji,jj) * zmkf * zuwslpj
! vertical flux on u field
- zfuw(ji,jk) = zcof3 * ( zdiu (ji,jk-1) + zdiu (ji+1,jk-1) &
- & + zdiu (ji,jk ) + zdiu (ji+1,jk ) ) &
- & + zcof4 * ( zdj1u(ji,jk-1) + zdju (ji ,jk-1) &
- & + zdj1u(ji,jk ) + zdju (ji ,jk ) )
+ zfuw(ji,jk) = zcof3 * ( ( zdiu (ji,jk-1) + zdiu (ji+1,jk-1) ) & ! add () for NP repro
+ & + ( zdiu (ji,jk ) + zdiu (ji+1,jk ) ) ) &
+ & + zcof4 * ( ( zdj1u(ji,jk-1) + zdju (ji ,jk-1) ) & ! add () for NP repro
+ & + ( zdj1u(ji,jk ) + zdju (ji ,jk ) ) )
! vertical mixing coefficient (akzu)
! Note: zcof0 include zaht_0, so divided by zaht_0 to obtain slp^2 * zaht_0
akzu(ji,jj,jk) = ( zuwslpi * zuwslpi + zuwslpj * zuwslpj ) / zaht_0
@@ -392,10 +383,10 @@ CONTAINS
zcof3 = - e2v(ji,jj) * zmkf * zvwslpi
zcof4 = - e1v(ji,jj) * zmkt * zvwslpj
! vertical flux on v field
- zfvw(ji,jk) = zcof3 * ( zdiv (ji,jk-1) + zdiv (ji-1,jk-1) &
- & + zdiv (ji,jk ) + zdiv (ji-1,jk ) ) &
- & + zcof4 * ( zdjv (ji,jk-1) + zdj1v(ji ,jk-1) &
- & + zdjv (ji,jk ) + zdj1v(ji ,jk ) )
+ zfvw(ji,jk) = zcof3 * ( ( zdiv (ji,jk-1) + zdiv (ji-1,jk-1) ) & ! add () for NP repro
+ & + ( zdiv (ji,jk ) + zdiv (ji-1,jk ) ) ) &
+ & + zcof4 * ( ( zdjv (ji,jk-1) + zdj1v(ji ,jk-1) ) & ! add () for NP repro
+ & + ( zdjv (ji,jk ) + zdj1v(ji ,jk ) ) )
! vertical mixing coefficient (akzv)
! Note: zcof0 include zaht_0, so divided by zaht_0 to obtain slp^2 * zaht_0
akzv(ji,jj,jk) = ( zvwslpi * zvwslpi + zvwslpj * zvwslpj ) / zaht_0
@@ -407,16 +398,13 @@ CONTAINS
! -------------------------------------------------------------------
DO jk = 1, jpkm1
DO ji = ntsi, ntei
- puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) + ( zfuw(ji,jk) - zfuw(ji,jk+1) ) * r1_e1e2u(ji,jj) &
- & / e3u(ji,jj,jk,Kmm)
- pvv(ji,jj,jk,Krhs) = pvv(ji,jj,jk,Krhs) + ( zfvw(ji,jk) - zfvw(ji,jk+1) ) * r1_e1e2v(ji,jj) &
- & / e3v(ji,jj,jk,Kmm)
+ puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) + ( zfuw(ji,jk) - zfuw(ji,jk+1) ) * r1_e1e2u(ji,jj) / e3u(ji,jj,jk,Kmm)
+ pvv(ji,jj,jk,Krhs) = pvv(ji,jj,jk,Krhs) + ( zfvw(ji,jk) - zfvw(ji,jk+1) ) * r1_e1e2v(ji,jj) / e3v(ji,jj,jk,Kmm)
END DO
END DO
! ! ===============
END DO ! End of slab
! ! ===============
-#endif
END SUBROUTINE dyn_ldf_iso
!!======================================================================
diff --git a/src/OCE/DYN/dynldf_iso_lf.F90 b/src/OCE/DYN/dynldf_iso_lf.F90
deleted file mode 100644
index 07b38792080db5a019c312c40b9fbf989a43b710..0000000000000000000000000000000000000000
--- a/src/OCE/DYN/dynldf_iso_lf.F90
+++ /dev/null
@@ -1,401 +0,0 @@
-MODULE dynldf_iso_lf
- !!======================================================================
- !! *** MODULE dynldf_iso ***
- !! Ocean dynamics: lateral viscosity trend (rotated laplacian operator)
- !!======================================================================
- !! History : OPA ! 97-07 (G. Madec) Original code
- !! NEMO 1.0 ! 2002-08 (G. Madec) F90: Free form and module
- !! - ! 2004-08 (C. Talandier) New trends organization
- !! 2.0 ! 2005-11 (G. Madec) s-coordinate: horizontal diffusion
- !! 3.7 ! 2014-01 (F. Lemarie, G. Madec) restructuration/simplification of ahm specification,
- !! ! add velocity dependent coefficient and optional read in file
- !!----------------------------------------------------------------------
-
- !!----------------------------------------------------------------------
- !! dyn_ldf_iso : update the momentum trend with the horizontal part
- !! of the lateral diffusion using isopycnal or horizon-
- !! tal s-coordinate laplacian operator.
- !!----------------------------------------------------------------------
- USE oce ! ocean dynamics and tracers
- USE dom_oce ! ocean space and time domain
- USE ldfdyn ! lateral diffusion: eddy viscosity coef.
- USE ldftra ! lateral physics: eddy diffusivity
- USE zdf_oce ! ocean vertical physics
- USE ldfslp ! iso-neutral slopes
- !
- USE in_out_manager ! I/O manager
- USE lib_mpp ! MPP library
- USE lbclnk ! ocean lateral boundary conditions (or mpp link)
- USE prtctl ! Print control
-
- IMPLICIT NONE
- PRIVATE
-
- PUBLIC dyn_ldf_iso_lf ! called by step.F90
- PUBLIC dyn_ldf_iso_alloc_lf ! called by nemogcm.F90
-
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: akzu, akzv !: vertical component of rotated lateral viscosity
-
- !! * Substitutions
-# include "do_loop_substitute.h90"
-# include "domzgr_substitute.h90"
- !!----------------------------------------------------------------------
- !! NEMO/OCE 4.0 , NEMO Consortium (2018)
- !! $Id: dynldf_iso.F90 14757 2021-04-27 15:33:44Z francesca $
- !! Software governed by the CeCILL license (see ./LICENSE)
- !!----------------------------------------------------------------------
-CONTAINS
-
- INTEGER FUNCTION dyn_ldf_iso_alloc_lf()
- !!----------------------------------------------------------------------
- !! *** ROUTINE dyn_ldf_iso_alloc ***
- !!----------------------------------------------------------------------
- dyn_ldf_iso_alloc_lf = 0
- IF( .NOT. ALLOCATED( akzu ) ) THEN
- ALLOCATE( akzu(jpi,jpj,jpk), akzv(jpi,jpj,jpk), STAT=dyn_ldf_iso_alloc_lf )
- !
- IF( dyn_ldf_iso_alloc_lf /= 0 ) CALL ctl_warn('dyn_ldf_iso_alloc: array allocate failed.')
- ENDIF
- END FUNCTION dyn_ldf_iso_alloc_lf
-
-
- SUBROUTINE dyn_ldf_iso_lf( kt, Kbb, Kmm, puu, pvv, Krhs )
- !!----------------------------------------------------------------------
- !! *** ROUTINE dyn_ldf_iso ***
- !!
- !! ** Purpose : Compute the before trend of the rotated laplacian
- !! operator of lateral momentum diffusion except the diagonal
- !! vertical term that will be computed in dynzdf module. Add it
- !! to the general trend of momentum equation.
- !!
- !! ** Method :
- !! The momentum lateral diffusive trend is provided by a 2nd
- !! order operator rotated along neutral or geopotential surfaces
- !! (in s-coordinates).
- !! It is computed using before fields (forward in time) and isopyc-
- !! nal or geopotential slopes computed in routine ldfslp.
- !! Here, u and v components are considered as 2 independent scalar
- !! fields. Therefore, the property of splitting divergent and rota-
- !! tional part of the flow of the standard, z-coordinate laplacian
- !! momentum diffusion is lost.
- !! horizontal fluxes associated with the rotated lateral mixing:
- !! u-component:
- !! ziut = ( ahmt + rn_ahm_b ) e2t * e3t / e1t di[ uu ]
- !! - ahmt e2t * mi-1(uslp) dk[ mi(mk(uu)) ]
- !! zjuf = ( ahmf + rn_ahm_b ) e1f * e3f / e2f dj[ uu ]
- !! - ahmf e1f * mi(vslp) dk[ mj(mk(uu)) ]
- !! v-component:
- !! zivf = ( ahmf + rn_ahm_b ) e2t * e3t / e1t di[ vv ]
- !! - ahmf e2t * mj(uslp) dk[ mi(mk(vv)) ]
- !! zjvt = ( ahmt + rn_ahm_b ) e1f * e3f / e2f dj[ vv ]
- !! - ahmt e1f * mj-1(vslp) dk[ mj(mk(vv)) ]
- !! take the horizontal divergence of the fluxes:
- !! diffu = 1/(e1u*e2u*e3u) { di [ ziut ] + dj-1[ zjuf ] }
- !! diffv = 1/(e1v*e2v*e3v) { di-1[ zivf ] + dj [ zjvt ] }
- !! Add this trend to the general trend (uu(rhs),vv(rhs)):
- !! uu(rhs) = uu(rhs) + diffu
- !! CAUTION: here the isopycnal part is with a coeff. of aht. This
- !! should be modified for applications others than orca_r2 (!!bug)
- !!
- !! ** Action :
- !! -(puu(:,:,:,Krhs),pvv(:,:,:,Krhs)) updated with the before geopotential harmonic mixing trend
- !! -(akzu,akzv) to accompt for the diagonal vertical component
- !! of the rotated operator in dynzdf module
- !!----------------------------------------------------------------------
- INTEGER , INTENT( in ) :: kt ! ocean time-step index
- INTEGER , INTENT( in ) :: Kbb, Kmm, Krhs ! ocean time level indices
- REAL(wp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) :: puu, pvv ! ocean velocities and RHS of momentum equation
- !
- INTEGER :: ji, jj, jk ! dummy loop indices
- REAL(wp) :: zabe1, zmskt, zmkt, zuav, zuwslpi, zuwslpj ! local scalars
- REAL(wp) :: zabe2, zmskf, zmkf, zvav, zvwslpi, zvwslpj ! - -
- REAL(wp) :: zcof0, zcof1, zcof2, zcof3, zcof4, zaht_0 ! - -
- REAL(wp) :: zdiu, zdiu_km1, zdiu_ip1, zdiu_ip1_km1 ! - -
- REAL(wp) :: zdju, zdju_km1, zdj1u, zdj1u_km1
- REAL(wp) :: zdjv, zdjv_km1, zdj1v, zdj1v_km1
- REAL(wp) :: zdiv_im1_km1, zdiv, zdiv_im1, zdiv_km1 ! - -
- REAL(wp), DIMENSION(A2D(nn_hls)) :: ziut, zivf, zdku, zdk1u ! 2D workspace
- REAL(wp), DIMENSION(A2D(nn_hls)) :: zjuf, zjvt, zdkv, zdk1v ! - -
- REAL(wp), DIMENSION(A1Di(nn_hls),jpk) :: zfuw, zfvw
- !!----------------------------------------------------------------------
- !
- IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile
- IF( kt == nit000 ) THEN
- IF(lwp) WRITE(numout,*)
- IF(lwp) WRITE(numout,*) 'dyn_ldf_iso_lf : iso-neutral laplacian diffusive operator or '
- IF(lwp) WRITE(numout,*) '~~~~~~~~~~~ s-coordinate horizontal diffusive operator'
- ! ! allocate dyn_ldf_bilap arrays
- IF( dyn_ldf_iso_alloc_lf() /= 0 ) CALL ctl_stop('STOP', 'dyn_ldf_iso: failed to allocate arrays')
- ENDIF
- ENDIF
-
-!!gm bug is dyn_ldf_iso called before tra_ldf_iso .... <<<<<===== TO BE CHECKED
- ! s-coordinate: Iso-level diffusion on momentum but not on tracer
- IF( ln_dynldf_hor .AND. ln_traldf_iso ) THEN
- !
- DO_3D_OVR( 1, 1, 1, 1, 1, jpk ) ! set the slopes of iso-level
- uslp (ji,jj,jk) = - ( gdept(ji+1,jj,jk,Kbb) - gdept(ji ,jj ,jk,Kbb) ) * r1_e1u(ji,jj) * umask(ji,jj,jk)
- vslp (ji,jj,jk) = - ( gdept(ji,jj+1,jk,Kbb) - gdept(ji ,jj ,jk,Kbb) ) * r1_e2v(ji,jj) * vmask(ji,jj,jk)
- wslpi(ji,jj,jk) = - ( gdepw(ji+1,jj,jk,Kbb) - gdepw(ji-1,jj,jk,Kbb) ) * r1_e1t(ji,jj) * tmask(ji,jj,jk) * 0.5
- wslpj(ji,jj,jk) = - ( gdepw(ji,jj+1,jk,Kbb) - gdepw(ji,jj-1,jk,Kbb) ) * r1_e2t(ji,jj) * tmask(ji,jj,jk) * 0.5
- END_3D
- !
- ENDIF
-
- zaht_0 = 0.5_wp * rn_Ud * rn_Ld ! aht_0 from namtra_ldf = zaht_max
-
- ! ! ===============
- DO jk = 1, jpkm1 ! Horizontal slab
- ! ! ===============
-
- ! Vertical u- and v-shears at level jk and jk+1
- ! ---------------------------------------------
- ! surface boundary condition: zdku(jk=1)=zdku(jk=2)
- ! zdkv(jk=1)=zdkv(jk=2)
-
- DO_2D( 1, 1, 1, 1 )
- zdk1u(ji,jj) = ( puu(ji,jj,jk,Kbb) -puu(ji,jj,jk+1,Kbb) ) * umask(ji,jj,jk+1)
- zdk1v(ji,jj) = ( pvv(ji,jj,jk,Kbb) -pvv(ji,jj,jk+1,Kbb) ) * vmask(ji,jj,jk+1)
- END_2D
-
- IF( jk == 1 ) THEN
- zdku(:,:) = zdk1u(:,:)
- zdkv(:,:) = zdk1v(:,:)
- ELSE
- DO_2D( 1, 1, 1, 1 )
- zdku(ji,jj) = ( puu(ji,jj,jk-1,Kbb) - puu(ji,jj,jk,Kbb) ) * umask(ji,jj,jk)
- zdkv(ji,jj) = ( pvv(ji,jj,jk-1,Kbb) - pvv(ji,jj,jk,Kbb) ) * vmask(ji,jj,jk)
- END_2D
- ENDIF
-
- ! -----f-----
- ! Horizontal fluxes on U |
- ! --------------------=== t u t
- ! |
- ! i-flux at t-point -----f-----
-
- IF( ln_zps ) THEN ! z-coordinate - partial steps : min(e3u)
- DO_2D( 0, 1, 0, 0 )
- zabe1 = ( ahmt(ji,jj,jk)+rn_ahm_b ) * e2t(ji,jj) &
- & * MIN( e3u(ji ,jj,jk,Kmm), &
- & e3u(ji-1,jj,jk,Kmm) ) * r1_e1t(ji,jj)
-
- zmskt = 1._wp / MAX( umask(ji-1,jj,jk )+umask(ji,jj,jk+1) &
- & + umask(ji-1,jj,jk+1)+umask(ji,jj,jk ) , 1._wp )
-
- zcof1 = - zaht_0 * e2t(ji,jj) * zmskt * 0.5 * ( uslp(ji-1,jj,jk) + uslp(ji,jj,jk) )
-
- ziut(ji,jj) = ( zabe1 * ( puu(ji,jj,jk,Kbb) - puu(ji-1,jj,jk,Kbb) ) &
- & + zcof1 * ( zdku (ji,jj) + zdk1u(ji-1,jj) &
- & +zdk1u(ji,jj) + zdku (ji-1,jj) ) ) * tmask(ji,jj,jk)
- END_2D
- ELSE ! other coordinate system (zco or sco) : e3t
- DO_2D( 0, 1, 0, 0 )
- zabe1 = ( ahmt(ji,jj,jk)+rn_ahm_b ) &
- & * e2t(ji,jj) * e3t(ji,jj,jk,Kmm) * r1_e1t(ji,jj)
-
- zmskt = 1._wp / MAX( umask(ji-1,jj,jk ) + umask(ji,jj,jk+1) &
- & + umask(ji-1,jj,jk+1) + umask(ji,jj,jk ) , 1._wp )
-
- zcof1 = - zaht_0 * e2t(ji,jj) * zmskt * 0.5 * ( uslp(ji-1,jj,jk) + uslp(ji,jj,jk) )
-
- ziut(ji,jj) = ( zabe1 * ( puu(ji,jj,jk,Kbb) - puu(ji-1,jj,jk,Kbb) ) &
- & + zcof1 * ( zdku (ji,jj) + zdk1u(ji-1,jj) &
- & +zdk1u(ji,jj) + zdku (ji-1,jj) ) ) * tmask(ji,jj,jk)
- END_2D
- ENDIF
-
- ! j-flux at f-point
- DO_2D( 1, 0, 1, 0 )
- zabe2 = ( ahmf(ji,jj,jk) + rn_ahm_b ) &
- & * e1f(ji,jj) * e3f(ji,jj,jk) * r1_e2f(ji,jj)
-
- zmskf = 1._wp / MAX( umask(ji,jj+1,jk )+umask(ji,jj,jk+1) &
- & + umask(ji,jj+1,jk+1)+umask(ji,jj,jk ) , 1._wp )
-
- zcof2 = - zaht_0 * e1f(ji,jj) * zmskf * 0.5 * ( vslp(ji+1,jj,jk) + vslp(ji,jj,jk) )
-
- zjuf(ji,jj) = ( zabe2 * ( puu(ji,jj+1,jk,Kbb) - puu(ji,jj,jk,Kbb) ) &
- & + zcof2 * ( zdku (ji,jj+1) + zdk1u(ji,jj) &
- & +zdk1u(ji,jj+1) + zdku (ji,jj) ) ) * fmask(ji,jj,jk)
-
- ! | t |
- ! Horizontal fluxes on V | |
- ! --------------------=== f---v---f
- ! | |
- ! i-flux at f-point | t |
-
- zabe1 = ( ahmf(ji,jj,jk) + rn_ahm_b ) &
- & * e2f(ji,jj) * e3f(ji,jj,jk) * r1_e1f(ji,jj)
-
- zmskf = 1._wp / MAX( vmask(ji+1,jj,jk )+vmask(ji,jj,jk+1) &
- & + vmask(ji+1,jj,jk+1)+vmask(ji,jj,jk ) , 1._wp )
-
- zcof1 = - zaht_0 * e2f(ji,jj) * zmskf * 0.5 * ( uslp(ji,jj+1,jk) + uslp(ji,jj,jk) )
-
- zivf(ji,jj) = ( zabe1 * ( pvv(ji+1,jj,jk,Kbb) - pvv(ji,jj,jk,Kbb) ) &
- & + zcof1 * ( zdkv (ji,jj) + zdk1v(ji+1,jj) &
- & + zdk1v(ji,jj) + zdkv (ji+1,jj) ) ) * fmask(ji,jj,jk)
- END_2D
-
- ! j-flux at t-point
- IF( ln_zps ) THEN ! z-coordinate - partial steps : min(e3u)
- DO_2D( 1, 0, 0, 1 )
- zabe2 = ( ahmt(ji,jj,jk)+rn_ahm_b ) * e1t(ji,jj) &
- & * MIN( e3v(ji,jj ,jk,Kmm), &
- & e3v(ji,jj-1,jk,Kmm) ) * r1_e2t(ji,jj)
-
- zmskt = 1._wp / MAX( vmask(ji,jj-1,jk )+vmask(ji,jj,jk+1) &
- & + vmask(ji,jj-1,jk+1)+vmask(ji,jj,jk ) , 1._wp )
-
- zcof2 = - zaht_0 * e1t(ji,jj) * zmskt * 0.5 * ( vslp(ji,jj-1,jk) + vslp(ji,jj,jk) )
-
- zjvt(ji,jj) = ( zabe2 * ( pvv(ji,jj,jk,Kbb) - pvv(ji,jj-1,jk,Kbb) ) &
- & + zcof2 * ( zdkv (ji,jj-1) + zdk1v(ji,jj) &
- & +zdk1v(ji,jj-1) + zdkv (ji,jj) ) ) * tmask(ji,jj,jk)
- END_2D
- ELSE ! other coordinate system (zco or sco) : e3t
- DO_2D( 1, 0, 0, 1 )
- zabe2 = ( ahmt(ji,jj,jk)+rn_ahm_b ) &
- & * e1t(ji,jj) * e3t(ji,jj,jk,Kmm) * r1_e2t(ji,jj)
-
- zmskt = 1./MAX( vmask(ji,jj-1,jk )+vmask(ji,jj,jk+1) &
- & + vmask(ji,jj-1,jk+1)+vmask(ji,jj,jk ), 1. )
-
- zcof2 = - zaht_0 * e1t(ji,jj) * zmskt * 0.5 * ( vslp(ji,jj-1,jk) + vslp(ji,jj,jk) )
-
- zjvt(ji,jj) = ( zabe2 * ( pvv(ji,jj,jk,Kbb) - pvv(ji,jj-1,jk,Kbb) ) &
- & + zcof2 * ( zdkv (ji,jj-1) + zdk1v(ji,jj) &
- & +zdk1v(ji,jj-1) + zdkv (ji,jj) ) ) * tmask(ji,jj,jk)
- END_2D
- ENDIF
-
-
- ! Second derivative (divergence) and add to the general trend
- ! -----------------------------------------------------------
- DO_2D( 0, 0, 0, 0 ) !!gm Question vectop possible??? !!bug
- puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) + ( ziut(ji+1,jj) - ziut(ji,jj ) &
- & + zjuf(ji ,jj) - zjuf(ji,jj-1) ) * r1_e1e2u(ji,jj) &
- & / e3u(ji,jj,jk,Kmm)
- pvv(ji,jj,jk,Krhs) = pvv(ji,jj,jk,Krhs) + ( zivf(ji,jj ) - zivf(ji-1,jj) &
- & + zjvt(ji,jj+1) - zjvt(ji,jj ) ) * r1_e1e2v(ji,jj) &
- & / e3v(ji,jj,jk,Kmm)
- END_2D
- ! ! ===============
- END DO ! End of slab
- ! ! ===============
-
- ! print sum trends (used for debugging)
- IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=puu(:,:,:,Krhs), clinfo1=' ldfh - Ua: ', mask1=umask, &
- & tab3d_2=pvv(:,:,:,Krhs), clinfo2= ' Va: ', mask2=vmask, clinfo3='dyn' )
-
-
- ! ! ===============
- DO jj = ntsj, ntej ! Vertical slab
- ! ! ===============
-
-
- ! I. vertical trends associated with the lateral mixing
- ! =====================================================
- ! (excluding the vertical flux proportional to dk[t]
-
- ! I.2 Vertical fluxes
- ! -------------------
-
- ! Surface and bottom vertical fluxes set to zero
- DO ji = ntsi - nn_hls, ntei + nn_hls
- zfuw(ji, 1 ) = 0.e0
- zfvw(ji, 1 ) = 0.e0
- zfuw(ji,jpk) = 0.e0
- zfvw(ji,jpk) = 0.e0
- END DO
-
- ! interior (2=<jk=<jpk-1) on U and V fields
- DO jk = 2, jpkm1
- DO ji = ntsi, ntei
- ! I.1 horizontal momentum gradient
- ! --------------------------------
- ! i-gradient of u at jj
- zdiu = tmask(ji,jj,jk) * ( puu(ji,jj ,jk,Kbb) - puu(ji-1,jj ,jk,Kbb) )
- zdiu_km1 = tmask(ji,jj,jk-1) * ( puu(ji,jj,jk-1,Kbb) - puu(ji-1,jj,jk-1,Kbb) )
- zdiu_ip1 = tmask(ji+1,jj,jk) * ( puu(ji+1,jj,jk,Kbb) - puu(ji,jj,jk,Kbb) )
- zdiu_ip1_km1 = tmask(ji+1,jj,jk-1) * ( puu(ji+1,jj,jk-1,Kbb) - puu(ji,jj,jk-1,Kbb) )
- ! j-gradient of u and v at jj
- zdju = fmask(ji,jj,jk) * ( puu(ji,jj+1,jk,Kbb) - puu(ji,jj,jk,Kbb) )
- zdju_km1 = fmask(ji,jj,jk-1) * ( puu(ji,jj+1,jk-1,Kbb) - puu(ji,jj,jk-1,Kbb) )
- ! j-gradient of u and v at jj+1
- zdj1u = fmask(ji,jj-1,jk) * ( puu(ji,jj,jk,Kbb) - puu(ji,jj-1,jk,Kbb) )
- zdj1u_km1 = fmask(ji,jj-1,jk-1) * ( puu(ji,jj,jk-1,Kbb) - puu(ji,jj-1,jk-1,Kbb) )
- !
- zcof0 = 0.5_wp * zaht_0 * umask(ji,jj,jk)
- !
- zuwslpi = zcof0 * ( wslpi(ji+1,jj,jk) + wslpi(ji,jj,jk) )
- zuwslpj = zcof0 * ( wslpj(ji+1,jj,jk) + wslpj(ji,jj,jk) )
- !
- zmkt = 1./MAX( tmask(ji,jj,jk-1)+tmask(ji+1,jj,jk-1) &
- + tmask(ji,jj,jk )+tmask(ji+1,jj,jk ) , 1. )
- zmkf = 1./MAX( fmask(ji,jj-1,jk-1) + fmask(ji,jj,jk-1) &
- + fmask(ji,jj-1,jk ) + fmask(ji,jj,jk ) , 1. )
-
- zcof3 = - e2u(ji,jj) * zmkt * zuwslpi
- zcof4 = - e1u(ji,jj) * zmkf * zuwslpj
- ! vertical flux on u field
- zfuw(ji,jk) = zcof3 * ( zdiu_km1 + zdiu_ip1_km1 + zdiu + zdiu_ip1 ) &
- & + zcof4 * ( zdj1u_km1 + zdju_km1 + zdj1u + zdju )
- ! vertical mixing coefficient (akzu)
- ! Note: zcof0 include zaht_0, so divided by zaht_0 to obtain slp^2 * zaht_0
- akzu(ji,jj,jk) = ( zuwslpi * zuwslpi + zuwslpj * zuwslpj ) / zaht_0
-
- ! I.1 horizontal momentum gradient
- ! --------------------------------
- ! j-gradient of u and v at jj
- zdjv = tmask(ji,jj ,jk) * ( pvv(ji,jj ,jk,Kbb) - pvv(ji ,jj-1,jk,Kbb) )
- zdjv_km1 = tmask(ji,jj,jk-1) * ( pvv(ji,jj,jk-1,Kbb) - pvv(ji,jj-1,jk-1,Kbb) )
- ! i-gradient of v at jj
- zdiv = fmask(ji,jj,jk) * ( pvv(ji+1,jj,jk,Kbb) - pvv(ji,jj,jk,Kbb) )
- zdiv_im1 = fmask(ji-1,jj,jk) * ( pvv(ji,jj,jk,Kbb) - pvv(ji-1,jj,jk,Kbb) )
- zdiv_km1 = fmask(ji,jj,jk-1) * ( pvv(ji+1,jj,jk-1,Kbb) - pvv(ji,jj,jk-1,Kbb) )
- zdiv_im1_km1 = fmask(ji-1,jj,jk-1) * ( pvv(ji,jj,jk-1,Kbb) - pvv(ji-1,jj,jk-1,Kbb) )
- ! j-gradient of u and v at jj+1
- zdj1v = tmask(ji,jj+1,jk) * ( pvv(ji,jj+1,jk,Kbb) - pvv(ji,jj,jk,Kbb) )
- zdj1v_km1 = tmask(ji,jj+1,jk-1) * ( pvv(ji,jj+1,jk-1,Kbb) - pvv(ji,jj,jk-1,Kbb) )
- !
- zcof0 = 0.5_wp * zaht_0 * vmask(ji,jj,jk)
- !
- zvwslpi = zcof0 * ( wslpi(ji,jj+1,jk) + wslpi(ji,jj,jk) )
- zvwslpj = zcof0 * ( wslpj(ji,jj+1,jk) + wslpj(ji,jj,jk) )
- !
- zmkf = 1./MAX( fmask(ji-1,jj,jk-1)+fmask(ji,jj,jk-1) &
- & + fmask(ji-1,jj,jk )+fmask(ji,jj,jk ) , 1. )
- zmkt = 1./MAX( tmask(ji,jj,jk-1)+tmask(ji,jj+1,jk-1) &
- & + tmask(ji,jj,jk )+tmask(ji,jj+1,jk ) , 1. )
-
- zcof3 = - e2v(ji,jj) * zmkf * zvwslpi
- zcof4 = - e1v(ji,jj) * zmkt * zvwslpj
- ! vertical flux on v field
- zfvw(ji,jk) = zcof3 * ( zdiv_km1 + zdiv_im1_km1 + zdiv + zdiv_im1 ) &
- & + zcof4 * ( zdjv_km1 + zdj1v_km1 + zdjv + zdj1v )
- ! vertical mixing coefficient (akzv)
- ! Note: zcof0 include zaht_0, so divided by zaht_0 to obtain slp^2 * zaht_0
- akzv(ji,jj,jk) = ( zvwslpi * zvwslpi + zvwslpj * zvwslpj ) / zaht_0
- END DO
- END DO
-
-
- ! I.3 Divergence of vertical fluxes added to the general tracer trend
- ! -------------------------------------------------------------------
- DO jk = 1, jpkm1
- DO ji = ntsi, ntei
- puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) + ( zfuw(ji,jk) - zfuw(ji,jk+1) ) * r1_e1e2u(ji,jj) &
- & / e3u(ji,jj,jk,Kmm)
- pvv(ji,jj,jk,Krhs) = pvv(ji,jj,jk,Krhs) + ( zfvw(ji,jk) - zfvw(ji,jk+1) ) * r1_e1e2v(ji,jj) &
- & / e3v(ji,jj,jk,Kmm)
- END DO
- END DO
- ! ! ===============
- END DO ! End of slab
- ! ! ===============
- END SUBROUTINE dyn_ldf_iso_lf
-
- !!======================================================================
-END MODULE dynldf_iso_lf
diff --git a/src/OCE/DYN/dynldf_lap_blp.F90 b/src/OCE/DYN/dynldf_lap_blp.F90
deleted file mode 100644
index 09ae6fe78b107e89def6af8016a01409dffc6dea..0000000000000000000000000000000000000000
--- a/src/OCE/DYN/dynldf_lap_blp.F90
+++ /dev/null
@@ -1,230 +0,0 @@
-MODULE dynldf_lap_blp
- !!======================================================================
- !! *** MODULE dynldf_lap_blp ***
- !! Ocean dynamics: lateral viscosity trend (laplacian and bilaplacian)
- !!======================================================================
- !! History : 3.7 ! 2014-01 (G. Madec, S. Masson) Original code, re-entrant laplacian
- !! 4.0 ! 2020-04 (A. Nasser, G. Madec) Add symmetric mixing tensor
- !!----------------------------------------------------------------------
-
- !!----------------------------------------------------------------------
- !! dyn_ldf_lap : update the momentum trend with the lateral viscosity using an iso-level laplacian operator
- !! dyn_ldf_blp : update the momentum trend with the lateral viscosity using an iso-level bilaplacian operator
- !!----------------------------------------------------------------------
- USE oce ! ocean dynamics and tracers
- USE dom_oce ! ocean space and time domain
- USE domutl, ONLY : is_tile
- USE ldfdyn ! lateral diffusion: eddy viscosity coef.
- USE ldfslp ! iso-neutral slopes
- USE zdf_oce ! ocean vertical physics
- !
- USE in_out_manager ! I/O manager
- USE lbclnk ! ocean lateral boundary conditions (or mpp link)
- USE lib_mpp
-#if defined key_loop_fusion
- USE dynldf_lap_blp_lf
-#endif
-
- IMPLICIT NONE
- PRIVATE
-
- PUBLIC dyn_ldf_lap ! called by dynldf.F90
- PUBLIC dyn_ldf_blp ! called by dynldf.F90
-
- !! * Substitutions
-# include "do_loop_substitute.h90"
-# include "domzgr_substitute.h90"
- !!----------------------------------------------------------------------
- !! NEMO/OCE 4.0 , NEMO Consortium (2018)
- !! $Id: dynldf_lap_blp.F90 15033 2021-06-21 10:24:45Z smasson $
- !! Software governed by the CeCILL license (see ./LICENSE)
- !!----------------------------------------------------------------------
-CONTAINS
-
- SUBROUTINE dyn_ldf_lap( kt, Kbb, Kmm, pu, pv, pu_rhs, pv_rhs, kpass )
- !!
- INTEGER , INTENT(in ) :: kt ! ocean time-step index
- INTEGER , INTENT(in ) :: Kbb, Kmm ! ocean time level indices
- INTEGER , INTENT(in ) :: kpass ! =1/2 first or second passage
- REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: pu, pv ! before velocity [m/s]
- REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: pu_rhs, pv_rhs ! velocity trend [m/s2]
- !!
-#if defined key_loop_fusion
- CALL dyn_ldf_lap_lf( kt, Kbb, Kmm, pu, pv, pu_rhs, pv_rhs, kpass )
-#else
- CALL dyn_ldf_lap_t( kt, Kbb, Kmm, pu, pv, is_tile(pu), pu_rhs, pv_rhs, is_tile(pu_rhs), kpass )
-#endif
-
- END SUBROUTINE dyn_ldf_lap
-
-
- SUBROUTINE dyn_ldf_lap_t( kt, Kbb, Kmm, pu, pv, ktuv, pu_rhs, pv_rhs, ktuv_rhs, kpass )
- !!----------------------------------------------------------------------
- !! *** ROUTINE dyn_ldf_lap ***
- !!
- !! ** Purpose : Compute the before horizontal momentum diffusive
- !! trend and add it to the general trend of momentum equation.
- !!
- !! ** Method : The Laplacian operator apply on horizontal velocity is
- !! writen as : grad_h( ahmt div_h(U )) - curl_h( ahmf curl_z(U) )
- !!
- !! ** Action : - pu_rhs, pv_rhs increased by the harmonic operator applied on pu, pv.
- !!
- !! Reference : S.Griffies, R.Hallberg 2000 Mon.Wea.Rev., DOI:/
- !!----------------------------------------------------------------------
- INTEGER , INTENT(in ) :: kt ! ocean time-step index
- INTEGER , INTENT(in ) :: Kbb, Kmm ! ocean time level indices
- INTEGER , INTENT(in ) :: kpass ! =1/2 first or second passage
- INTEGER , INTENT(in ) :: ktuv, ktuv_rhs
- REAL(wp), DIMENSION(A2D_T(ktuv) ,JPK), INTENT(in ) :: pu, pv ! before velocity [m/s]
- REAL(wp), DIMENSION(A2D_T(ktuv_rhs),JPK), INTENT(inout) :: pu_rhs, pv_rhs ! velocity trend [m/s2]
- !
- INTEGER :: ji, jj, jk ! dummy loop indices
- INTEGER :: iij
- REAL(wp) :: zsign ! local scalars
- REAL(wp) :: zua, zva ! local scalars
- REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zcur, zdiv
- REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zten, zshe ! tension (diagonal) and shearing (anti-diagonal) terms
- !!----------------------------------------------------------------------
- !
- IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile
- IF( kt == nit000 .AND. lwp ) THEN
- WRITE(numout,*)
- WRITE(numout,*) 'dyn_ldf : iso-level harmonic (laplacian) operator, pass=', kpass
- WRITE(numout,*) '~~~~~~~ '
- ENDIF
- ENDIF
- !
- ! Define pu_rhs/pv_rhs halo points for multi-point haloes in bilaplacian case
- IF( nldf_dyn == np_blp .AND. kpass == 1 ) THEN ; iij = nn_hls
- ELSE ; iij = 1
- ENDIF
- !
- IF( kpass == 1 ) THEN ; zsign = 1._wp ! bilaplacian operator require a minus sign
- ELSE ; zsign = -1._wp ! (eddy viscosity coef. >0)
- ENDIF
- !
- SELECT CASE( nn_dynldf_typ )
- !
- CASE ( np_typ_rot ) !== Vorticity-Divergence operator ==!
- !
- ALLOCATE( zcur(A2D(nn_hls)) , zdiv(A2D(nn_hls)) )
- !
- DO jk = 1, jpkm1 ! Horizontal slab
- !
- DO_2D( iij-1, iij, iij-1, iij )
- ! ! ahm * e3 * curl (warning: computed for ji-1,jj-1)
- zcur(ji-1,jj-1) = ahmf(ji-1,jj-1,jk) * e3f(ji-1,jj-1,jk) * r1_e1e2f(ji-1,jj-1) & ! ahmf already * by fmask
- & * ( e2v(ji ,jj-1) * pv(ji ,jj-1,jk) - e2v(ji-1,jj-1) * pv(ji-1,jj-1,jk) &
- & - e1u(ji-1,jj ) * pu(ji-1,jj ,jk) + e1u(ji-1,jj-1) * pu(ji-1,jj-1,jk) )
- ! ! ahm * div (warning: computed for ji,jj)
- zdiv(ji,jj) = ahmt(ji,jj,jk) * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kbb) & ! ahmt already * by tmask
- & * ( e2u(ji,jj)*e3u(ji,jj,jk,Kbb) * pu(ji,jj,jk) - e2u(ji-1,jj)*e3u(ji-1,jj,jk,Kbb) * pu(ji-1,jj,jk) &
- & + e1v(ji,jj)*e3v(ji,jj,jk,Kbb) * pv(ji,jj,jk) - e1v(ji,jj-1)*e3v(ji,jj-1,jk,Kbb) * pv(ji,jj-1,jk) )
- END_2D
- !
- DO_2D( iij-1, iij-1, iij-1, iij-1 ) ! - curl( curl) + grad( div )
- pu_rhs(ji,jj,jk) = pu_rhs(ji,jj,jk) + zsign * umask(ji,jj,jk) * ( & ! * by umask is mandatory for dyn_ldf_blp use
- & - ( zcur(ji ,jj) - zcur(ji,jj-1) ) * r1_e2u(ji,jj) / e3u(ji,jj,jk,Kmm) &
- & + ( zdiv(ji+1,jj) - zdiv(ji,jj ) ) * r1_e1u(ji,jj) )
- !
- pv_rhs(ji,jj,jk) = pv_rhs(ji,jj,jk) + zsign * vmask(ji,jj,jk) * ( & ! * by vmask is mandatory for dyn_ldf_blp use
- & ( zcur(ji,jj ) - zcur(ji-1,jj) ) * r1_e1v(ji,jj) / e3v(ji,jj,jk,Kmm) &
- & + ( zdiv(ji,jj+1) - zdiv(ji ,jj) ) * r1_e2v(ji,jj) )
- END_2D
- !
- END DO ! End of slab
- !
- DEALLOCATE( zcur , zdiv )
- !
- CASE ( np_typ_sym ) !== Symmetric operator ==!
- !
- ALLOCATE( zten(A2D(nn_hls)) , zshe(A2D(nn_hls)) )
- !
- DO jk = 1, jpkm1 ! Horizontal slab
- !
- DO_2D( iij-1, iij, iij-1, iij )
- ! ! shearing stress component (F-point) NB : ahmf has already been multiplied by fmask
- zshe(ji-1,jj-1) = ahmf(ji-1,jj-1,jk) &
- & * ( e1f(ji-1,jj-1) * r1_e2f(ji-1,jj-1) &
- & * ( pu(ji-1,jj ,jk) * r1_e1u(ji-1,jj ) - pu(ji-1,jj-1,jk) * r1_e1u(ji-1,jj-1) ) &
- & + e2f(ji-1,jj-1) * r1_e1f(ji-1,jj-1) &
- & * ( pv(ji ,jj-1,jk) * r1_e2v(ji ,jj-1) - pv(ji-1,jj-1,jk) * r1_e2v(ji-1,jj-1) ) )
- ! ! tension stress component (T-point) NB : ahmt has already been multiplied by tmask
- zten(ji,jj) = ahmt(ji,jj,jk) &
- & * ( e2t(ji,jj) * r1_e1t(ji,jj) &
- & * ( pu(ji,jj,jk) * r1_e2u(ji,jj) - pu(ji-1,jj,jk) * r1_e2u(ji-1,jj) ) &
- & - e1t(ji,jj) * r1_e2t(ji,jj) &
- & * ( pv(ji,jj,jk) * r1_e1v(ji,jj) - pv(ji,jj-1,jk) * r1_e1v(ji,jj-1) ) )
- END_2D
- !
- DO_2D( iij-1, iij-1, iij-1, iij-1 )
- pu_rhs(ji,jj,jk) = pu_rhs(ji,jj,jk) + zsign * r1_e1e2u(ji,jj) / e3u(ji,jj,jk,Kmm) &
- & * ( ( zten(ji+1,jj ) * e2t(ji+1,jj )*e2t(ji+1,jj ) * e3t(ji+1,jj ,jk,Kmm) &
- & - zten(ji ,jj ) * e2t(ji ,jj )*e2t(ji ,jj ) * e3t(ji ,jj ,jk,Kmm) ) * r1_e2u(ji,jj) &
- & + ( zshe(ji ,jj ) * e1f(ji ,jj )*e1f(ji ,jj ) * e3f(ji ,jj ,jk) &
- & - zshe(ji ,jj-1) * e1f(ji ,jj-1)*e1f(ji ,jj-1) * e3f(ji ,jj-1,jk) ) * r1_e1u(ji,jj) )
- !
- pv_rhs(ji,jj,jk) = pv_rhs(ji,jj,jk) + zsign * r1_e1e2v(ji,jj) / e3v(ji,jj,jk,Kmm) &
- & * ( ( zshe(ji ,jj ) * e2f(ji ,jj )*e2f(ji ,jj ) * e3f(ji ,jj ,jk) &
- & - zshe(ji-1,jj ) * e2f(ji-1,jj )*e2f(ji-1,jj ) * e3f(ji-1,jj ,jk) ) * r1_e2v(ji,jj) &
- & - ( zten(ji ,jj+1) * e1t(ji ,jj+1)*e1t(ji ,jj+1) * e3t(ji ,jj+1,jk,Kmm) &
- & - zten(ji ,jj ) * e1t(ji ,jj )*e1t(ji ,jj ) * e3t(ji ,jj ,jk,Kmm) ) * r1_e1v(ji,jj) )
- !
- END_2D
- !
- END DO
- !
- DEALLOCATE( zten , zshe )
- !
- END SELECT
- !
- END SUBROUTINE dyn_ldf_lap_t
-
-
- SUBROUTINE dyn_ldf_blp( kt, Kbb, Kmm, pu, pv, pu_rhs, pv_rhs )
- !!----------------------------------------------------------------------
- !! *** ROUTINE dyn_ldf_blp ***
- !!
- !! ** Purpose : Compute the before lateral momentum viscous trend
- !! and add it to the general trend of momentum equation.
- !!
- !! ** Method : The lateral viscous trends is provided by a bilaplacian
- !! operator applied to before field (forward in time).
- !! It is computed by two successive calls to dyn_ldf_lap routine
- !!
- !! ** Action : pt(:,:,:,:,Krhs) updated with the before rotated bilaplacian diffusion
- !!----------------------------------------------------------------------
- INTEGER , INTENT(in ) :: kt ! ocean time-step index
- INTEGER , INTENT(in ) :: Kbb, Kmm ! ocean time level indices
- REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in ) :: pu, pv ! before velocity fields
- REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pu_rhs, pv_rhs ! momentum trend
- !
- REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zulap, zvlap ! laplacian at u- and v-point
- !!----------------------------------------------------------------------
- !
-#if defined key_loop_fusion
- CALL dyn_ldf_blp_lf( kt, Kbb, Kmm, pu, pv, pu_rhs, pv_rhs )
-#else
- IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile
- IF( kt == nit000 ) THEN
- IF(lwp) WRITE(numout,*)
- IF(lwp) WRITE(numout,*) 'dyn_ldf_blp : bilaplacian operator momentum '
- IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~'
- ENDIF
- ENDIF
- !
- zulap(:,:,:) = 0._wp
- zvlap(:,:,:) = 0._wp
- !
- CALL dyn_ldf_lap( kt, Kbb, Kmm, pu, pv, zulap, zvlap, 1 ) ! rotated laplacian applied to pt (output in zlap,Kbb)
- !
- IF (nn_hls==1) CALL lbc_lnk( 'dynldf_lap_blp', zulap, 'U', -1.0_wp, zvlap, 'V', -1.0_wp ) ! Lateral boundary conditions
- !
- CALL dyn_ldf_lap( kt, Kbb, Kmm, zulap, zvlap, pu_rhs, pv_rhs, 2 ) ! rotated laplacian applied to zlap (output in pt(:,:,:,:,Krhs))
- !
-#endif
- END SUBROUTINE dyn_ldf_blp
-
- !!======================================================================
-END MODULE dynldf_lap_blp
diff --git a/src/OCE/DYN/dynldf_lap_blp_lf.F90 b/src/OCE/DYN/dynldf_lap_blp_lf.F90
index 75d66fdb0e7fa69ab14d1c05a227a663252c4794..0e169ea003d4d11fab749501a3154f38db6f39a7 100644
--- a/src/OCE/DYN/dynldf_lap_blp_lf.F90
+++ b/src/OCE/DYN/dynldf_lap_blp_lf.F90
@@ -13,7 +13,7 @@ MODULE dynldf_lap_blp_lf
!!----------------------------------------------------------------------
USE oce ! ocean dynamics and tracers
USE dom_oce ! ocean space and time domain
- USE domutl, ONLY : is_tile
+ USE domutl, ONLY : lbnd_ij
USE ldfdyn ! lateral diffusion: eddy viscosity coef.
USE ldfslp ! iso-neutral slopes
USE zdf_oce ! ocean vertical physics
@@ -45,7 +45,7 @@ CONTAINS
REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: pu, pv ! before velocity [m/s]
REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: pu_rhs, pv_rhs ! velocity trend [m/s2]
!!
- CALL dyn_ldf_lap_lf_t( kt, Kbb, Kmm, pu, pv, is_tile(pu), pu_rhs, pv_rhs, is_tile(pu_rhs), kpass )
+ CALL dyn_ldf_lap_lf_t( kt, Kbb, Kmm, pu, pv, lbnd_ij(pu), pu_rhs, pv_rhs, lbnd_ij(pu_rhs), kpass )
END SUBROUTINE dyn_ldf_lap_lf
@@ -63,12 +63,12 @@ CONTAINS
!!
!! Reference : S.Griffies, R.Hallberg 2000 Mon.Wea.Rev., DOI:/
!!----------------------------------------------------------------------
- INTEGER , INTENT(in ) :: kt ! ocean time-step index
- INTEGER , INTENT(in ) :: Kbb, Kmm ! ocean time level indices
- INTEGER , INTENT(in ) :: kpass ! =1/2 first or second passage
- INTEGER , INTENT(in ) :: ktuv, ktuv_rhs
- REAL(wp), DIMENSION(A2D_T(ktuv) ,JPK), INTENT(in ) :: pu, pv ! before velocity [m/s]
- REAL(wp), DIMENSION(A2D_T(ktuv_rhs),JPK), INTENT(inout) :: pu_rhs, pv_rhs ! velocity trend [m/s2]
+ INTEGER , INTENT(in ) :: kt ! ocean time-step index
+ INTEGER , INTENT(in ) :: Kbb, Kmm ! ocean time level indices
+ INTEGER , INTENT(in ) :: kpass ! =1/2 first or second passage
+ INTEGER, DIMENSION(2) , INTENT(in ) :: ktuv, ktuv_rhs
+ REAL(wp), DIMENSION(AB2D(ktuv) ,JPK), INTENT(in ) :: pu, pv ! before velocity [m/s]
+ REAL(wp), DIMENSION(AB2D(ktuv_rhs),JPK), INTENT(inout) :: pu_rhs, pv_rhs ! velocity trend [m/s2]
!
INTEGER :: ji, jj, jk ! dummy loop indices
INTEGER :: iij
@@ -203,7 +203,7 @@ CONTAINS
REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in ) :: pu, pv ! before velocity fields
REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pu_rhs, pv_rhs ! momentum trend
!
- REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zulap, zvlap ! laplacian at u- and v-point
+ REAL(wp), DIMENSION(T2D(nn_hls),jpk) :: zulap, zvlap ! laplacian at u- and v-point
!!----------------------------------------------------------------------
!
IF( kt == nit000 ) THEN
diff --git a/src/OCE/DYN/dynldf_lev.F90 b/src/OCE/DYN/dynldf_lev.F90
new file mode 100644
index 0000000000000000000000000000000000000000..863151cb23bb00827f76474e111bbaeda0e2f9bc
--- /dev/null
+++ b/src/OCE/DYN/dynldf_lev.F90
@@ -0,0 +1,222 @@
+MODULE dynldf_lev
+ !!======================================================================
+ !! *** MODULE dynldf_lev ***
+ !! Ocean dynamics: lateral viscosity trend (laplacian and bilaplacian)
+ !!======================================================================
+ !! History : 3.7 ! 2014-01 (G. Madec, S. Masson) Original code, re-entrant laplacian
+ !! 4.0 ! 2020-04 (A. Nasser, G. Madec) Add symmetric mixing tensor
+ !! 4.5 ! 2022-10 (S. Techene, G, Madec) refactorization to reduce local memory usage
+ !! ! + removal of old partial-step treatment
+ !!----------------------------------------------------------------------
+
+ !!----------------------------------------------------------------------
+ !! dynldf_lev_lap : update the momentum trend with the lateral viscosity using an iso-level laplacian operator
+ !! dynldf_lev_blp : update the momentum trend with the lateral viscosity using an iso-level bilaplacian operator
+ !!----------------------------------------------------------------------
+ USE oce ! ocean dynamics and tracers
+ USE dom_oce ! ocean space and time domain
+ USE domutl, ONLY : is_tile
+ USE ldfdyn ! lateral diffusion: eddy viscosity coef.
+ USE ldfslp ! iso-neutral slopes
+ USE zdf_oce ! ocean vertical physics
+ !
+ USE in_out_manager ! I/O manager
+ USE lbclnk ! ocean lateral boundary conditions (or mpp link)
+ USE lib_mpp
+
+ IMPLICIT NONE
+ PRIVATE
+
+ PUBLIC dynldf_lev_lap ! called by dynldf.F90
+ PUBLIC dynldf_lev_blp ! called by dynldf.F90
+
+ !! * Substitutions
+# include "do_loop_substitute.h90"
+# include "domzgr_substitute.h90"
+ !!----------------------------------------------------------------------
+ !! NEMO/OCE 4.0 , NEMO Consortium (2018)
+ !! $Id: dynldf_lap_blp.F90 15033 2021-06-21 10:24:45Z smasson $
+ !! Software governed by the CeCILL license (see ./LICENSE)
+ !!----------------------------------------------------------------------
+CONTAINS
+
+ SUBROUTINE dynldf_lev_lap( kt, Kbb, Kmm, pu, pv, Krhs )
+ !!----------------------------------------------------------------------
+ !! *** ROUTINE dynldf_lev_lap ***
+ !!
+ !! ** Purpose : Compute the before horizontal momentum diffusive
+ !! trend and add it to the general trend of momentum equation.
+ !!
+ !! ** Method : The Laplacian operator apply on horizontal velocity is
+ !! writen as : grad_h( ahmt div_h(U )) - curl_h( ahmf curl_z(U) )
+ !!
+ !! ** Action : - pu(Krhs), pv(Krhs) increased by the harmonic operator applied on pu(Kbb), pv(Kbb).
+ !!
+ !! Reference : S.Griffies, R.Hallberg 2000 Mon.Wea.Rev., DOI:/
+ !!----------------------------------------------------------------------
+ INTEGER , INTENT(in ) :: kt, Kbb, Kmm, Krhs ! ocean time-step index and time-level indices
+ REAL(wp), DIMENSION(:,:,:,:), INTENT(inout) :: pu, pv ! velocity [m/s2]
+ !
+ INTEGER :: ji, jj, jk ! dummy loop indices
+ REAL(wp), DIMENSION(T2D(1)) :: zwf, zwt
+ !!----------------------------------------------------------------------
+ !
+ IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile
+ IF( kt == nit000 ) THEN
+ IF(lwp) WRITE(numout,*)
+ IF(lwp) WRITE(numout,*) 'dynldf_lev_lap : laplacian operator momentum '
+ IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~~'
+ ENDIF
+ ENDIF
+ !
+# define lap
+# define INN 0
+# define pu_in(i,j,k,t) pu(i,j,k,t)
+# define pv_in(i,j,k,t) pv(i,j,k,t)
+ !
+ SELECT CASE( nn_dynldf_typ )
+ !
+ CASE ( np_typ_rot ) !== Vorticity-Divergence operator ==!
+ !
+# define zcur zwf
+# define zdiv zwt
+ !
+ DO jk = 1, jpkm1 ! Horizontal slab
+# include "dynldf_lev_rot_scheme.h90"
+ END DO
+ !
+# undef zcur
+# undef zdiv
+ !
+ CASE ( np_typ_sym ) !== Symmetric operator ==!
+ !
+# define zshe zwf
+# define zten zwt
+ !
+ DO jk = 1, jpkm1 ! Horizontal slab
+# include "dynldf_lev_sym_scheme.h90"
+ END DO
+ !
+# undef zshe
+# undef zten
+ !
+ END SELECT
+ !
+# undef lap
+# undef INN
+# undef pu_in
+# undef pv_in
+ !
+ END SUBROUTINE dynldf_lev_lap
+
+
+ SUBROUTINE dynldf_lev_blp( kt, Kbb, Kmm, pu, pv, Krhs )
+ !!----------------------------------------------------------------------
+ !! *** ROUTINE dynldf_lev_blp ***
+ !!
+ !! ** Purpose : Compute the before lateral momentum viscous trend
+ !! and add it to the general trend of momentum equation.
+ !!
+ !! ** Method : The lateral viscous trends is provided by a bilaplacian
+ !! operator applied to before field (forward in time).
+ !! It is computed by two successive calls to dyn_ldf_lap routine
+ !!
+ !! ** Action : pt(:,:,:,:,Krhs) updated with the before rotated bilaplacian diffusion
+ !!----------------------------------------------------------------------
+ !!
+ INTEGER , INTENT(in ) :: kt, Kbb, Kmm, Krhs ! ocean time-step index and time-level indices
+ REAL(wp), DIMENSION(:,:,:,:) , INTENT(inout) :: pu, pv ! velocity [m/s2]
+ !
+ INTEGER :: ji, jj, jk ! dummy loop indices
+ REAL(wp), DIMENSION(T2D(2)) :: zulap ! laplacian at u-point
+ REAL(wp), DIMENSION(T2D(2)) :: zvlap ! laplacian at v-point
+ REAL(wp), DIMENSION(T2D(2)) :: zwf, zwt
+ !!----------------------------------------------------------------------
+ !
+ IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile
+ IF( kt == nit000 ) THEN
+ IF(lwp) WRITE(numout,*)
+ IF(lwp) WRITE(numout,*) 'dynldf_lev_blp : bilaplacian operator momentum '
+ IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~'
+ ENDIF
+ ENDIF
+ !
+ SELECT CASE( nn_dynldf_typ )
+ !
+ CASE ( np_typ_rot ) !== Vorticity-Divergence operator ==!
+ !
+# define zcur zwf
+# define zdiv zwt
+ !
+ DO jk = 1, jpkm1 ! Horizontal slab
+ ! !- 1st pass
+# define blp_p1
+# define INN 1
+# define pu_in(i,j,k,t) pu(i,j,k,t)
+# define pv_in(i,j,k,t) pv(i,j,k,t)
+!
+# include "dynldf_lev_rot_scheme.h90"
+!
+# undef blp_p1
+# undef INN
+# undef pu_in
+# undef pv_in
+
+ ! !- 2nd pass
+# define blp_p2
+# define INN 0
+# define pu_in(i,j,k,t) zulap(i,j)
+# define pv_in(i,j,k,t) zvlap(i,j)
+!
+# include "dynldf_lev_rot_scheme.h90"
+!
+# undef blp_p2
+# undef INN
+# undef pu_in
+# undef pv_in
+ END DO
+ !
+# undef zcur
+# undef zdiv
+ !
+ CASE ( np_typ_sym ) !== Symmetric operator ==!
+ !
+# define zshe zwf
+# define zten zwt
+ !
+ DO jk = 1, jpkm1 ! Horizontal slab
+ ! !- 1st pass
+# define blp_p1
+# define INN 1
+# define pu_in(i,j,k,t) pu(i,j,k,t)
+# define pv_in(i,j,k,t) pv(i,j,k,t)
+!
+# include "dynldf_lev_sym_scheme.h90"
+!
+# undef blp_p1
+# undef INN
+# undef pu_in
+# undef pv_in
+
+ ! !- 2nd pass
+# define blp_p2
+# define INN 0
+# define pu_in(i,j,k,t) zulap(i,j)
+# define pv_in(i,j,k,t) zvlap(i,j)
+!
+# include "dynldf_lev_sym_scheme.h90"
+!
+# undef blp_p2
+# undef INN
+# undef pu_in
+# undef pv_in
+ END DO
+ !
+# undef zshe
+# undef zten
+ END SELECT
+ !
+ END SUBROUTINE dynldf_lev_blp
+
+ !!======================================================================
+END MODULE dynldf_lev
diff --git a/src/OCE/DYN/dynldf_lev_rot_scheme.h90 b/src/OCE/DYN/dynldf_lev_rot_scheme.h90
new file mode 100644
index 0000000000000000000000000000000000000000..81a3841e61d5e44b99adfd276edb480787e04c06
--- /dev/null
+++ b/src/OCE/DYN/dynldf_lev_rot_scheme.h90
@@ -0,0 +1,53 @@
+ !!======================================================================
+ !! *** dynldf_lev_rot_scheme.h90 ***
+ !! dynldf_lev: divergence the lateral iso-neutral fluxes
+#if defined lap
+ !! laplacian
+#elif defined blp_p1
+ !! bilaplacian: 1st pass
+#elif defined blp_p2
+ !! bilaplacian: 2nd pass
+#endif
+ !!======================================================================
+ !! History : 4.5 ! 2022-10 (S. Techene, G, Madec) refactorization to reduce local memory usage
+ !! + no more re-entering lap with dynldf_lev_blp creation
+ !!----------------------------------------------------------------------
+
+
+ !!======================================================================
+ !! masked tracer gradient : (zdit, zdjt, zdkt) at both jk and jk+1
+ !!======================================================================
+ !
+ DO_2D( INN, INN+1, INN, INN+1 )
+ ! ! ahm * e3 * curl (warning: computed for ji-1,jj-1)
+ zcur(ji-1,jj-1) = ahmf(ji-1,jj-1,jk) * e3f(ji-1,jj-1,jk) * r1_e1e2f(ji-1,jj-1) & ! ahmf already * by fmask
+ & * ( ( e2v(ji ,jj-1) * pv_in(ji ,jj-1,jk,Kbb) - e2v(ji-1,jj-1) * pv_in(ji-1,jj-1,jk,Kbb) ) &
+ & - ( e1u(ji-1,jj ) * pu_in(ji-1,jj ,jk,Kbb) - e1u(ji-1,jj-1) * pu_in(ji-1,jj-1,jk,Kbb) ) )
+ ! ! ahm * div (warning: computed for ji,jj)
+ zdiv(ji,jj) = ahmt(ji,jj,jk) * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kbb) & ! ahmt already * by tmask
+ & * ( ( e2u(ji,jj)*e3u(ji,jj,jk,Kbb) * pu_in(ji,jj,jk,Kbb) - e2u(ji-1,jj)*e3u(ji-1,jj ,jk,Kbb) * pu_in(ji-1,jj ,jk,Kbb) ) &
+ & + ( e1v(ji,jj)*e3v(ji,jj,jk,Kbb) * pv_in(ji,jj,jk,Kbb) - e1v(ji,jj-1)*e3v(ji ,jj-1,jk,Kbb) * pv_in(ji ,jj-1,jk,Kbb) ) )
+ END_2D
+ !
+ DO_2D( INN, INN, INN, INN ) ! - curl( curl) + grad( div )
+#if defined lap
+ pu(ji,jj,jk,Krhs) = pu(ji,jj,jk,Krhs) + & ! added to RHS with PLUS sign (lap)
+#elif defined blp_p1
+ zulap(ji,jj) = & ! store in zulap
+#elif defined blp_p2
+ pu(ji,jj,jk,Krhs) = pu(ji,jj,jk,Krhs) - & ! added to RHS with MINUS sign (blp)
+#endif
+ & umask(ji,jj,jk) * ( & ! * by umask is mandatory for dyn_ldf_blp use
+ & - ( zcur(ji ,jj) - zcur(ji,jj-1) ) * r1_e2u(ji,jj) / e3u(ji,jj,jk,Kmm) &
+ & + ( zdiv(ji+1,jj) - zdiv(ji,jj ) ) * r1_e1u(ji,jj) )
+#if defined lap
+ pv(ji,jj,jk,Krhs) = pv(ji,jj,jk,Krhs) + & ! added to RHS with PLUS sign (lap)
+#elif defined blp_p1
+ zvlap(ji,jj) = & ! store in zulap
+#elif defined blp_p2
+ pv(ji,jj,jk,Krhs) = pv(ji,jj,jk,Krhs) - & ! added to RHS with MINUS sign (blp)
+#endif
+ & vmask(ji,jj,jk) * ( & ! * by vmask is mandatory for dyn_ldf_blp use
+ & ( zcur(ji,jj ) - zcur(ji-1,jj) ) * r1_e1v(ji,jj) / e3v(ji,jj,jk,Kmm) &
+ & + ( zdiv(ji,jj+1) - zdiv(ji ,jj) ) * r1_e2v(ji,jj) )
+ END_2D
diff --git a/src/OCE/DYN/dynldf_lev_sym_scheme.h90 b/src/OCE/DYN/dynldf_lev_sym_scheme.h90
new file mode 100644
index 0000000000000000000000000000000000000000..26d0d4c0e9245d0796340e5858680bf0db6dfe5a
--- /dev/null
+++ b/src/OCE/DYN/dynldf_lev_sym_scheme.h90
@@ -0,0 +1,58 @@
+ !!======================================================================
+ !! *** dynldf_lev_sym_scheme.h90 ***
+ !! dynldf_lev: divergence the lateral fluxes
+#if defined lap
+ !! laplacian
+#elif defined blp_p1
+ !! bilaplacian: 1st pass
+#elif defined blp_p2
+ !! bilaplacian: 2nd pass
+#endif
+ !!======================================================================
+ !! History : 4.5 ! 2022-10 (S. Techene, G, Madec) refactorization to reduce local memory usage
+ !! + no more re-entering lap with dynldf_lev_rot_blp creation
+ !!----------------------------------------------------------------------
+
+ !
+ DO_2D( INN, INN+1, INN, INN+1 )
+ ! ! shearing stress component (F-point) NB : ahmf has already been multiplied by fmask
+ zshe(ji-1,jj-1) = ahmf(ji-1,jj-1,jk) &
+ & * ( e1f(ji-1,jj-1)*r1_e2f(ji-1,jj-1) * ( pu_in(ji-1,jj ,jk,Kbb) * r1_e1u(ji-1,jj ) &
+ & - pu_in(ji-1,jj-1,jk,Kbb) * r1_e1u(ji-1,jj-1) ) &
+ & + e2f(ji-1,jj-1)*r1_e1f(ji-1,jj-1) * ( pv_in(ji ,jj-1,jk,Kbb) * r1_e2v(ji ,jj-1) &
+ & - pv_in(ji-1,jj-1,jk,Kbb) * r1_e2v(ji-1,jj-1) ) )
+ ! ! tension stress component (T-point) NB : ahmt has already been multiplied by tmask
+ zten(ji,jj) = ahmt(ji,jj,jk) &
+ & * ( e2t(ji,jj) * r1_e1t(ji,jj) &
+ & * ( pu_in(ji,jj,jk,Kbb) * r1_e2u(ji,jj) - pu_in(ji-1,jj,jk,Kbb) * r1_e2u(ji-1,jj) ) &
+ & - e1t(ji,jj) * r1_e2t(ji,jj) &
+ & * ( pv_in(ji,jj,jk,Kbb) * r1_e1v(ji,jj) - pv_in(ji,jj-1,jk,Kbb) * r1_e1v(ji,jj-1) ) )
+ END_2D
+ !
+ DO_2D( INN, INN, INN, INN )
+#if defined lap
+ pu(ji,jj,jk,Krhs) = pu(ji,jj,jk,Krhs) + & ! added to RHS with PLUS sign (lap)
+#elif defined blp_p1
+ zulap(ji,jj) = & ! store in zulap
+#elif defined blp_p2
+ pu(ji,jj,jk,Krhs) = pu(ji,jj,jk,Krhs) - & ! added to RHS with MINUS sign (blp)
+#endif
+ & r1_e1e2u(ji,jj) / e3u(ji,jj,jk,Kmm) &
+ & * ( ( zten(ji+1,jj) * e2t(ji+1,jj)*e2t(ji+1,jj)*e3t(ji+1,jj,jk,Kmm) &
+ & - zten(ji ,jj) * e2t(ji ,jj)*e2t(ji ,jj)*e3t(ji ,jj,jk,Kmm) ) * r1_e2u(ji,jj) &
+ & + ( zshe(ji,jj ) * e1f(ji,jj )*e1f(ji,jj )*e3f(ji,jj ,jk) &
+ & - zshe(ji,jj-1) * e1f(ji,jj-1)*e1f(ji,jj-1)*e3f(ji,jj-1,jk) ) * r1_e1u(ji,jj) )
+#if defined lap
+ pv(ji,jj,jk,Krhs) = pv(ji,jj,jk,Krhs) + & ! added to RHS with PLUS sign (lap)
+#elif defined blp_p1
+ zvlap(ji,jj) = & ! store in zulap
+#elif defined blp_p2
+ pv(ji,jj,jk,Krhs) = pv(ji,jj,jk,Krhs) - & ! added to RHS with MINUS sign (blp)
+#endif
+ & r1_e1e2v(ji,jj) / e3v(ji,jj,jk,Kmm) &
+ & * ( ( zshe(ji ,jj) * e2f(ji ,jj)*e2f(ji ,jj)*e3f(ji ,jj,jk) &
+ & - zshe(ji-1,jj) * e2f(ji-1,jj)*e2f(ji-1,jj)*e3f(ji-1,jj,jk) ) * r1_e2v(ji,jj) &
+ & - ( zten(ji,jj+1) * e1t(ji,jj+1)*e1t(ji,jj+1)*e3t(ji,jj+1,jk,Kmm) &
+ & - zten(ji,jj ) * e1t(ji,jj )*e1t(ji,jj )*e3t(ji,jj ,jk,Kmm) ) * r1_e1v(ji,jj) )
+ !
+ END_2D
diff --git a/src/OCE/DYN/dynspg.F90 b/src/OCE/DYN/dynspg.F90
index ffd2219a2eff482503a8e24da3f039df87c80e55..3d635744ad477d9b9bdcca0f2a609693692b64ed 100644
--- a/src/OCE/DYN/dynspg.F90
+++ b/src/OCE/DYN/dynspg.F90
@@ -107,10 +107,10 @@ CONTAINS
IF( ln_apr_dyn .AND. .NOT.ln_dynspg_ts ) THEN !== Atmospheric pressure gradient (added later in time-split case) ==!
zg_2 = grav * 0.5
DO_2D( 0, 0, 0, 0 ) ! gradient of Patm using inverse barometer ssh
- zpgu(ji,jj) = zpgu(ji,jj) + zg_2 * ( ssh_ib (ji+1,jj) - ssh_ib (ji,jj) &
- & + ssh_ibb(ji+1,jj) - ssh_ibb(ji,jj) ) * r1_e1u(ji,jj)
- zpgv(ji,jj) = zpgv(ji,jj) + zg_2 * ( ssh_ib (ji,jj+1) - ssh_ib (ji,jj) &
- & + ssh_ibb(ji,jj+1) - ssh_ibb(ji,jj) ) * r1_e2v(ji,jj)
+ zpgu(ji,jj) = zpgu(ji,jj) + zg_2 * ( ( ssh_ib (ji+1,jj) - ssh_ib (ji,jj) ) & ! add () for NP repro
+ & + ( ssh_ibb(ji+1,jj) - ssh_ibb(ji,jj) ) ) * r1_e1u(ji,jj)
+ zpgv(ji,jj) = zpgv(ji,jj) + zg_2 * ( ( ssh_ib (ji,jj+1) - ssh_ib (ji,jj) ) & ! add () for NP repro
+ & + ( ssh_ibb(ji,jj+1) - ssh_ibb(ji,jj) ) ) * r1_e2v(ji,jj)
END_2D
ENDIF
!
diff --git a/src/OCE/DYN/dynspg_exp.F90 b/src/OCE/DYN/dynspg_exp.F90
index 8d59e3f977cf444b6fd504813b296c0aa2d1f547..29dfa58961149b09ffbe866cac47d36c141a12d1 100644
--- a/src/OCE/DYN/dynspg_exp.F90
+++ b/src/OCE/DYN/dynspg_exp.F90
@@ -54,12 +54,12 @@ CONTAINS
!! ** Action : (puu(:,:,:,Krhs),pvv(:,:,:,Krhs)) trend of horizontal velocity increased by
!! the surf. pressure gradient trend
!!---------------------------------------------------------------------
- INTEGER , INTENT( in ) :: kt ! ocean time-step index
- INTEGER , INTENT( in ) :: Kmm, Krhs ! ocean time level indices
+ INTEGER , INTENT(in ) :: kt ! ocean time-step index
+ INTEGER , INTENT(in ) :: Kmm, Krhs ! ocean time level indices
REAL(wp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) :: puu, pvv ! ocean velocities and RHS of momentum equation
!!
INTEGER :: ji, jj, jk ! dummy loop indices
- REAL(wp), DIMENSION(jpi,jpj) :: zpgu, zpgv ! 2D workspace
+ REAL(wp), DIMENSION(A2D(0)) :: zpgu, zpgv ! 2D workspace
!!----------------------------------------------------------------------
!
IF( kt == nit000 ) THEN
diff --git a/src/OCE/DYN/dynspg_ts.F90 b/src/OCE/DYN/dynspg_ts.F90
index 6e51d97c41e5a1784fb383ea2fce397daaa02e9c..85d15a9c1f7013c704bdbb41d5acd34111630f5d 100644
--- a/src/OCE/DYN/dynspg_ts.F90
+++ b/src/OCE/DYN/dynspg_ts.F90
@@ -254,8 +254,8 @@ CONTAINS
zhU(:,:) = puu_b(:,:,Kmm) * hu(:,:,Kmm) * e2u(:,:) ! now fluxes
zhV(:,:) = pvv_b(:,:,Kmm) * hv(:,:,Kmm) * e1v(:,:) ! NB: FULL domain : put a value in last row and column
!
- CALL dyn_cor_2D( ht(:,:), hu(:,:,Kmm), hv(:,:,Kmm), puu_b(:,:,Kmm), pvv_b(:,:,Kmm), zhU, zhV, & ! <<== in
- & zu_trd, zv_trd ) ! ==>> out
+ CALL dyn_cor_2D( ht(:,:,Kmm), hu(:,:,Kmm), hv(:,:,Kmm), puu_b(:,:,Kmm), pvv_b(:,:,Kmm), zhU, zhV, & ! <<== in
+ & zu_trd, zv_trd ) ! ==>> out
!
DO_2D( 0, 0, 0, 0 ) ! Remove coriolis term (and possibly spg) from barotropic trend
zu_frc(ji,jj) = zu_frc(ji,jj) - zu_trd(ji,jj) * ssumask(ji,jj)
@@ -271,9 +271,17 @@ CONTAINS
!
! != zu_frc = 1/H e3*d/dt(Ua) =! (Vertical mean of Ua, the 3D trends)
! ! --------------------------- !
-# if defined key_qco
+# if defined key_qco || defined key_linssh
+# if defined key_vco_1d
+ ! e3. are substitute by 1D arrays and can't be used in SUM operand
+ DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ zu_frc(ji,jj) = SUM( e3u_0(ji,jj,:) * puu(ji,jj,:,Krhs) * umask(ji,jj,:) ) * r1_hu_0(ji,jj)
+ zv_frc(ji,jj) = SUM( e3v_0(ji,jj,:) * pvv(ji,jj,:,Krhs) * vmask(ji,jj,:) ) * r1_hv_0(ji,jj)
+ END_2D
+# else
zu_frc(:,:) = SUM( e3u_0(:,:,: ) * puu(:,:,:,Krhs) * umask(:,:,:), DIM=3 ) * r1_hu_0(:,:)
zv_frc(:,:) = SUM( e3v_0(:,:,: ) * pvv(:,:,:,Krhs) * vmask(:,:,:), DIM=3 ) * r1_hv_0(:,:)
+# endif
# else
zu_frc(:,:) = SUM( e3u(:,:,:,Kmm) * puu(:,:,:,Krhs) * umask(:,:,:), DIM=3 ) * r1_hu(:,:,Kmm)
zv_frc(:,:) = SUM( e3v(:,:,:,Kmm) * pvv(:,:,:,Krhs) * vmask(:,:,:), DIM=3 ) * r1_hv(:,:,Kmm)
@@ -298,8 +306,8 @@ CONTAINS
zhU(:,:) = puu_b(:,:,Kmm) * hu(:,:,Kmm) * e2u(:,:) ! now fluxes
zhV(:,:) = pvv_b(:,:,Kmm) * hv(:,:,Kmm) * e1v(:,:) ! NB: FULL domain : put a value in last row and column
!
- CALL dyn_cor_2D( ht(:,:), hu(:,:,Kmm), hv(:,:,Kmm), puu_b(:,:,Kmm), pvv_b(:,:,Kmm), zhU, zhV, & ! <<== in
- & zu_trd, zv_trd ) ! ==>> out
+ CALL dyn_cor_2D( ht(:,:,Kmm), hu(:,:,Kmm), hv(:,:,Kmm), puu_b(:,:,Kmm), pvv_b(:,:,Kmm), zhU, zhV, & ! <<== in
+ & zu_trd, zv_trd ) ! ==>> out
!
DO_2D( 0, 0, 0, 0 ) ! Remove coriolis term (and possibly spg) from barotropic trend
zu_frc(ji,jj) = zu_frc(ji,jj) - zu_trd(ji,jj) * ssumask(ji,jj)
@@ -322,10 +330,10 @@ CONTAINS
ELSE ! CENTRED integration: use kt-1/2 + kt+1/2 pressure (NOW)
zztmp = grav * r1_2
DO_2D( 0, 0, 0, 0 )
- zu_frc(ji,jj) = zu_frc(ji,jj) + zztmp * ( ssh_ib (ji+1,jj ) - ssh_ib (ji,jj) &
- & + ssh_ibb(ji+1,jj ) - ssh_ibb(ji,jj) ) * r1_e1u(ji,jj)
- zv_frc(ji,jj) = zv_frc(ji,jj) + zztmp * ( ssh_ib (ji ,jj+1) - ssh_ib (ji,jj) &
- & + ssh_ibb(ji ,jj+1) - ssh_ibb(ji,jj) ) * r1_e2v(ji,jj)
+ zu_frc(ji,jj) = zu_frc(ji,jj) + zztmp * ( ( ssh_ib (ji+1,jj ) - ssh_ib (ji,jj) ) &
+ & + ( ssh_ibb(ji+1,jj ) - ssh_ibb(ji,jj) ) ) * r1_e1u(ji,jj)
+ zv_frc(ji,jj) = zv_frc(ji,jj) + zztmp * ( ( ssh_ib (ji ,jj+1) - ssh_ib (ji,jj) ) &
+ & + ( ssh_ibb(ji ,jj+1) - ssh_ibb(ji,jj) ) ) * r1_e2v(ji,jj)
END_2D
ENDIF
ENDIF
@@ -334,14 +342,14 @@ CONTAINS
! ! ------------------ !
IF( ln_bt_fw ) THEN
DO_2D( 0, 0, 0, 0 )
- zu_frc(ji,jj) = zu_frc(ji,jj) + r1_rho0 * utau(ji,jj) * r1_hu(ji,jj,Kmm)
- zv_frc(ji,jj) = zv_frc(ji,jj) + r1_rho0 * vtau(ji,jj) * r1_hv(ji,jj,Kmm)
+ zu_frc(ji,jj) = zu_frc(ji,jj) + r1_rho0 * utauU(ji,jj) * r1_hu(ji,jj,Kmm)
+ zv_frc(ji,jj) = zv_frc(ji,jj) + r1_rho0 * vtauV(ji,jj) * r1_hv(ji,jj,Kmm)
END_2D
ELSE
zztmp = r1_rho0 * r1_2
DO_2D( 0, 0, 0, 0 )
- zu_frc(ji,jj) = zu_frc(ji,jj) + zztmp * ( utau_b(ji,jj) + utau(ji,jj) ) * r1_hu(ji,jj,Kmm)
- zv_frc(ji,jj) = zv_frc(ji,jj) + zztmp * ( vtau_b(ji,jj) + vtau(ji,jj) ) * r1_hv(ji,jj,Kmm)
+ zu_frc(ji,jj) = zu_frc(ji,jj) + zztmp * ( utau_b(ji,jj) + utauU(ji,jj) ) * r1_hu(ji,jj,Kmm)
+ zv_frc(ji,jj) = zv_frc(ji,jj) + zztmp * ( vtau_b(ji,jj) + vtauV(ji,jj) ) * r1_hv(ji,jj,Kmm)
END_2D
ENDIF
!
@@ -459,8 +467,6 @@ CONTAINS
DO jn = 1, icycle ! sub-time-step loop !
! ! ==================== !
!
- l_full_nf_update = jn == icycle ! false: disable full North fold update (performances) for jn = 1 to icycle-1
- !
! !== Update the forcing ==! (BDY and tides)
!
IF( ln_bdy .AND. ln_tide ) CALL bdy_dta_tides( kt, kit=jn, pt_offset= REAL(noffset+1,wp) )
@@ -561,7 +567,7 @@ CONTAINS
!-- ssh = ssh - delta_t' * [ frc + div( flux ) ] --!
!-------------------------------------------------------------------------!
DO_2D( 0, 0, 0, 0 )
- zhdiv = ( zhU(ji,jj) - zhU(ji-1,jj) + zhV(ji,jj) - zhV(ji,jj-1) ) * r1_e1e2t(ji,jj)
+ zhdiv = ( ( zhU(ji,jj) - zhU(ji-1,jj) ) + ( zhV(ji,jj) - zhV(ji,jj-1) ) ) * r1_e1e2t(ji,jj)
ssha_e(ji,jj) = ( sshn_e(ji,jj) - rDt_e * ( ssh_frc(ji,jj) + zhdiv ) ) * ssmask(ji,jj)
END_2D
!
@@ -1255,16 +1261,16 @@ CONTAINS
SELECT CASE( nn_e3f_typ ) !* ff_f/e3 at F-point
CASE ( 0 ) ! original formulation (masked averaging of e3t divided by 4)
DO_2D( 0, 0, 0, 0 )
- zwz(ji,jj) = ( ht(ji,jj+1) + ht(ji+1,jj+1) &
- & + ht(ji,jj ) + ht(ji+1,jj ) ) * 0.25_wp
+ zwz(ji,jj) = ( ( ht(ji,jj+1,Kmm) + ht(ji+1,jj+1,Kmm) ) & ! need additional () for reproducibility around NP
+ & + ( ht(ji,jj ,Kmm) + ht(ji+1,jj ,Kmm) ) ) * 0.25_wp
IF( zwz(ji,jj) /= 0._wp ) zwz(ji,jj) = ff_f(ji,jj) / zwz(ji,jj)
END_2D
CASE ( 1 ) ! new formulation (masked averaging of e3t divided by the sum of mask)
DO_2D( 0, 0, 0, 0 )
- zwz(ji,jj) = ( ht(ji,jj+1) + ht(ji+1,jj+1) &
- & + ht(ji,jj ) + ht(ji+1,jj ) ) &
- & / ( MAX(ssmask(ji,jj+1) + ssmask(ji+1,jj+1) &
- & + ssmask(ji,jj ) + ssmask(ji+1,jj ) , 1._wp ) )
+ zwz(ji,jj) = ( ( ht(ji,jj+1,Kmm) + ht(ji+1,jj+1,Kmm) ) & ! need additional () for
+ & + ( ht(ji,jj ,Kmm) + ht(ji+1,jj ,Kmm) ) ) & ! reproducibility around NP
+ & / ( MAX( ( ssmask(ji,jj+1) + ssmask(ji+1,jj+1) ) &
+ & + ( ssmask(ji,jj ) + ssmask(ji+1,jj ) ), 1._wp ) )
IF( zwz(ji,jj) /= 0._wp ) zwz(ji,jj) = ff_f(ji,jj) / zwz(ji,jj)
END_2D
END SELECT
@@ -1285,7 +1291,7 @@ CONTAINS
CASE( np_EET ) != EEN scheme using e3t energy conserving scheme
ftne(1,:) = 0._wp ; ftnw(1,:) = 0._wp ; ftse(1,:) = 0._wp ; ftsw(1,:) = 0._wp
DO_2D( 0, 1, 0, 1 )
- z1_ht = ssmask(ji,jj) / ( ht(ji,jj) + 1._wp - ssmask(ji,jj) )
+ z1_ht = ssmask(ji,jj) / ( ht(ji,jj,Kmm) + 1._wp - ssmask(ji,jj) )
ftne(ji,jj) = ( ff_f(ji-1,jj ) + ff_f(ji ,jj ) + ff_f(ji ,jj-1) ) * z1_ht
ftnw(ji,jj) = ( ff_f(ji-1,jj-1) + ff_f(ji-1,jj ) + ff_f(ji ,jj ) ) * z1_ht
ftse(ji,jj) = ( ff_f(ji ,jj ) + ff_f(ji ,jj-1) + ff_f(ji-1,jj-1) ) * z1_ht
@@ -1335,24 +1341,24 @@ CONTAINS
!
CASE( np_ENS ) ! enstrophy conserving scheme (f-point)
DO_2D( 0, 0, 0, 0 )
- zy1 = r1_8 * ( zhV(ji ,jj-1) + zhV(ji+1,jj-1) &
- & + zhV(ji ,jj ) + zhV(ji+1,jj ) ) * r1_e1u(ji,jj)
- zx1 = - r1_8 * ( zhU(ji-1,jj ) + zhU(ji-1,jj+1) &
- & + zhU(ji ,jj ) + zhU(ji ,jj+1) ) * r1_e2v(ji,jj)
+ zy1 = r1_8 * ( ( zhV(ji ,jj-1) + zhV(ji+1,jj-1) ) & ! need additional () for
+ & + ( zhV(ji ,jj ) + zhV(ji+1,jj ) ) ) * r1_e1u(ji,jj) ! reproducibility around NP
+ zx1 = - r1_8 * ( ( zhU(ji-1,jj ) + zhU(ji-1,jj+1) ) & ! need additional () for
+ & + ( zhU(ji ,jj ) + zhU(ji ,jj+1) ) ) * r1_e2v(ji,jj) ! reproducibility around NP
zu_trd(ji,jj) = zy1 * ( zwz(ji ,jj-1) + zwz(ji,jj) )
zv_trd(ji,jj) = zx1 * ( zwz(ji-1,jj ) + zwz(ji,jj) )
END_2D
!
CASE( np_EET , np_EEN ) ! energy & enstrophy scheme (using e3t or e3f)
DO_2D( 0, 0, 0, 0 )
- zu_trd(ji,jj) = + r1_12 * r1_e1u(ji,jj) * ( ftne(ji,jj ) * zhV(ji ,jj ) &
- & + ftnw(ji+1,jj) * zhV(ji+1,jj ) &
- & + ftse(ji,jj ) * zhV(ji ,jj-1) &
- & + ftsw(ji+1,jj) * zhV(ji+1,jj-1) )
- zv_trd(ji,jj) = - r1_12 * r1_e2v(ji,jj) * ( ftsw(ji,jj+1) * zhU(ji-1,jj+1) &
- & + ftse(ji,jj+1) * zhU(ji ,jj+1) &
- & + ftnw(ji,jj ) * zhU(ji-1,jj ) &
- & + ftne(ji,jj ) * zhU(ji ,jj ) )
+ zu_trd(ji,jj) = + r1_12 * r1_e1u(ji,jj) * ( ( ftne(ji,jj ) * zhV(ji ,jj ) & ! need additional () for
+ & + ftnw(ji+1,jj) * zhV(ji+1,jj ) ) & ! reproducibility around NP
+ & + ( ftse(ji,jj ) * zhV(ji ,jj-1) &
+ & + ftsw(ji+1,jj) * zhV(ji+1,jj-1) ) )
+ zv_trd(ji,jj) = - r1_12 * r1_e2v(ji,jj) * ( ( ftsw(ji,jj+1) * zhU(ji-1,jj+1) &
+ & + ftse(ji,jj+1) * zhU(ji ,jj+1) ) &
+ & + ( ftnw(ji,jj ) * zhU(ji-1,jj ) &
+ & + ftne(ji,jj ) * zhU(ji ,jj ) ) )
END_2D
!
END SELECT
@@ -1518,13 +1524,13 @@ CONTAINS
IF( ln_isfcav.OR.ln_drgice_imp ) THEN ! top+bottom friction (ocean cavities)
DO_2D( 0, 0, 0, 0 )
- pCdU_u(ji,jj) = r1_2*( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) + rCdU_top(ji+1,jj)+rCdU_top(ji,jj) )
- pCdU_v(ji,jj) = r1_2*( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) + rCdU_top(ji,jj+1)+rCdU_top(ji,jj) )
+ pCdU_u(ji,jj) = r1_2*( ( rCdU_bot(ji+1,jj) + rCdU_bot(ji,jj) ) + ( rCdU_top(ji+1,jj) + rCdU_top(ji,jj) ) )
+ pCdU_v(ji,jj) = r1_2*( ( rCdU_bot(ji,jj+1) + rCdU_bot(ji,jj) ) + ( rCdU_top(ji,jj+1) + rCdU_top(ji,jj) ) )
END_2D
ELSE ! bottom friction only
DO_2D( 0, 0, 0, 0 )
- pCdU_u(ji,jj) = r1_2*( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) )
- pCdU_v(ji,jj) = r1_2*( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) )
+ pCdU_u(ji,jj) = r1_2*( rCdU_bot(ji+1,jj) + rCdU_bot(ji,jj) )
+ pCdU_v(ji,jj) = r1_2*( rCdU_bot(ji,jj+1) + rCdU_bot(ji,jj) )
END_2D
ENDIF
!
diff --git a/src/OCE/DYN/dynvor.F90 b/src/OCE/DYN/dynvor.F90
index 03dda78ceb4f6ce993419062208a9240e3ae7d75..55fe50cbcff424981af9afdb5226a069f4465b45 100644
--- a/src/OCE/DYN/dynvor.F90
+++ b/src/OCE/DYN/dynvor.F90
@@ -22,6 +22,7 @@ MODULE dynvor
!! - ! 2018-04 (G. Madec) add pre-computed gradient for metric term calculation
!! 4.x ! 2020-03 (G. Madec, A. Nasser) make ln_dynvor_msk truly efficient on relative vorticity
!! 4.2 ! 2020-12 (G. Madec, E. Clementi) add vortex force trends (ln_vortex_force=T)
+ !! 4.5 ! 2022-06 (S. Techene, G, Madec) refactorization to reduce local memory usage
!!----------------------------------------------------------------------
!!----------------------------------------------------------------------
@@ -173,11 +174,11 @@ CONTAINS
ENDIF
CASE( np_EET ) !* energy conserving scheme (een scheme using e3t)
CALL vor_eeT( kt, Kmm, ntot, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! total vorticity trend
- IF( ln_stcor .AND. .NOT. ln_vortex_force ) THEN
+ IF( ln_stcor .AND. .NOT. ln_vortex_force ) THEN
CALL vor_eeT( kt, Kmm, ncor, usd, vsd, puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! add the Stokes-Coriolis trend
- ELSE IF( ln_stcor .AND. ln_vortex_force ) THEN
+ ELSE IF( ln_stcor .AND. ln_vortex_force ) THEN
CALL vor_eeT( kt, Kmm, ntot, usd, vsd, puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! add the Stokes-Coriolis trend and vortex force
- ENDIF
+ ENDIF
CASE( np_ENE ) !* energy conserving scheme
CALL vor_ene( kt, Kmm, ntot, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! total vorticity trend
IF( ln_stcor .AND. .NOT. ln_vortex_force ) THEN
@@ -200,11 +201,11 @@ CONTAINS
IF( ln_vortex_force ) CALL vor_ens( kt, Kmm, nrvm, usd, vsd, puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! add vortex force
CASE( np_EEN ) !* energy and enstrophy conserving scheme
CALL vor_een( kt, Kmm, ntot, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! total vorticity trend
- IF( ln_stcor .AND. .NOT. ln_vortex_force ) THEN
+ IF( ln_stcor .AND. .NOT. ln_vortex_force ) THEN
CALL vor_een( kt, Kmm, ncor, usd, vsd, puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! add the Stokes-Coriolis trend
- ELSE IF( ln_stcor .AND. ln_vortex_force ) THEN
+ ELSE IF( ln_stcor .AND. ln_vortex_force ) THEN
CALL vor_een( kt, Kmm, ntot, usd, vsd, puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! add the Stokes-Coriolis trend and vortex force
- ENDIF
+ ENDIF
END SELECT
!
ENDIF
@@ -320,8 +321,8 @@ CONTAINS
!
INTEGER :: ji, jj, jk ! dummy loop indices
REAL(wp) :: zx1, zy1, zx2, zy2 ! local scalars
- REAL(wp), DIMENSION(A2D(nn_hls)) :: zwx, zwy, zwt ! 2D workspace
- REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zwz ! 3D workspace, jpkm1 -> avoid lbc_lnk on jpk that is not defined
+ REAL(wp), DIMENSION(T2D(1)) :: zwt ! 2D workspace
+ REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zwz ! 3D workspace, jpkm1 -> avoid lbc_lnk on jpk that is not defined
!!----------------------------------------------------------------------
!
IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile
@@ -333,28 +334,25 @@ CONTAINS
ENDIF
!
!
- SELECT CASE( kvor ) !== relative vorticity considered ==!
- !
- CASE ( np_RVO , np_CRV ) !* relative vorticity at f-point is used
- ALLOCATE( zwz(A2D(nn_hls),jpk) )
- DO jk = 1, jpkm1 ! Horizontal slab
- DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 )
- zwz(ji,jj,jk) = ( e2v(ji+1,jj) * pv(ji+1,jj,jk) - e2v(ji,jj) * pv(ji,jj,jk) &
- & - e1u(ji,jj+1) * pu(ji,jj+1,jk) + e1u(ji,jj) * pu(ji,jj,jk) ) * r1_e1e2f(ji,jj)
+ ! ! ===============
+ DO jk = 1, jpkm1 ! Horizontal slab
+ ! ! ===============
+ !
+ SELECT CASE( kvor ) !== relative vorticity considered ==!
+ !
+ CASE ( np_RVO , np_CRV ) !* relative vorticity at f-point is used
+ ALLOCATE( zwz(T2D(1)) )
+ DO_2D( 1, 1, 1, 1 )
+ zwz(ji,jj) = ( ( e2v(ji+1,jj) * pv(ji+1,jj,jk) - e2v(ji,jj) * pv(ji,jj,jk) ) & ! add () for
+ & - ( e1u(ji,jj+1) * pu(ji,jj+1,jk) - e1u(ji,jj) * pu(ji,jj,jk) ) ) * r1_e1e2f(ji,jj) ! NP repro
END_2D
IF( ln_dynvor_msk ) THEN ! mask relative vorticity
- DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 )
- zwz(ji,jj,jk) = zwz(ji,jj,jk) * fmask(ji,jj,jk)
+ DO_2D( 1, 1, 1, 1 )
+ zwz(ji,jj) = zwz(ji,jj) * fmask(ji,jj,jk)
END_2D
ENDIF
- END DO
- IF (nn_hls==1) CALL lbc_lnk( 'dynvor', zwz, 'F', 1.0_wp )
- !
- END SELECT
-
- ! ! ===============
- DO jk = 1, jpkm1 ! Horizontal slab
- ! ! ===============
+ !
+ END SELECT
!
SELECT CASE( kvor ) !== volume weighted vorticity considered ==!
!
@@ -364,8 +362,8 @@ CONTAINS
END_2D
CASE ( np_RVO ) !* relative vorticity
DO_2D( 0, 1, 0, 1 )
- zwt(ji,jj) = r1_4 * ( zwz(ji-1,jj ,jk) + zwz(ji,jj ,jk) &
- & + zwz(ji-1,jj-1,jk) + zwz(ji,jj-1,jk) ) &
+ zwt(ji,jj) = r1_4 * ( ( zwz(ji-1,jj ) + zwz(ji,jj ) ) & ! need additional () for
+ & + ( zwz(ji-1,jj-1) + zwz(ji,jj-1) ) ) & ! reproducibility around NP
& * e1e2t(ji,jj)*e3t(ji,jj,jk,Kmm)
END_2D
CASE ( np_MET ) !* metric term
@@ -376,8 +374,8 @@ CONTAINS
END_2D
CASE ( np_CRV ) !* Coriolis + relative vorticity
DO_2D( 0, 1, 0, 1 )
- zwt(ji,jj) = ( ff_t(ji,jj) + r1_4 * ( zwz(ji-1,jj ,jk) + zwz(ji,jj ,jk) &
- & + zwz(ji-1,jj-1,jk) + zwz(ji,jj-1,jk) ) ) &
+ zwt(ji,jj) = ( ff_t(ji,jj) + r1_4 * ( ( zwz(ji-1,jj ) + zwz(ji,jj ) ) & ! need additional () for
+ & + ( zwz(ji-1,jj-1) + zwz(ji,jj-1) ) ) ) & ! reproducibility around NP
& * e1e2t(ji,jj)*e3t(ji,jj,jk,Kmm)
END_2D
CASE ( np_CME ) !* Coriolis + metric
@@ -440,7 +438,7 @@ CONTAINS
!
INTEGER :: ji, jj, jk ! dummy loop indices
REAL(wp) :: zx1, zy1, zx2, zy2, ze3f, zmsk ! local scalars
- REAL(wp), DIMENSION(A2D(nn_hls)) :: zwx, zwy, zwz ! 2D workspace
+ REAL(wp), DIMENSION(T2D(1)) :: zwx, zwy, zwz ! 2D workspace
!!----------------------------------------------------------------------
!
IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile
@@ -462,8 +460,8 @@ CONTAINS
END_2D
CASE ( np_RVO ) !* relative vorticity
DO_2D( 1, 0, 1, 0 )
- zwz(ji,jj) = ( e2v(ji+1,jj ) * pv(ji+1,jj ,jk) - e2v(ji,jj) * pv(ji,jj,jk) &
- & - e1u(ji ,jj+1) * pu(ji ,jj+1,jk) + e1u(ji,jj) * pu(ji,jj,jk) ) * r1_e1e2f(ji,jj)
+ zwz(ji,jj) = ( ( e2v(ji+1,jj ) * pv(ji+1,jj ,jk) - e2v(ji,jj) * pv(ji,jj,jk) ) & ! add () for
+ & - ( e1u(ji ,jj+1) * pu(ji ,jj+1,jk) - e1u(ji,jj) * pu(ji,jj,jk) ) ) * r1_e1e2f(ji,jj) ! NP repro
END_2D
IF( ln_dynvor_msk ) THEN ! mask the relative vorticity
DO_2D( 1, 0, 1, 0 )
@@ -477,8 +475,8 @@ CONTAINS
END_2D
CASE ( np_CRV ) !* Coriolis + relative vorticity
DO_2D( 1, 0, 1, 0 )
- zwz(ji,jj) = ff_f(ji,jj) + ( e2v(ji+1,jj) * pv(ji+1,jj,jk) - e2v(ji,jj) * pv(ji,jj,jk) &
- & - e1u(ji,jj+1) * pu(ji,jj+1,jk) + e1u(ji,jj) * pu(ji,jj,jk) ) * r1_e1e2f(ji,jj)
+ zwz(ji,jj) = ff_f(ji,jj) + ( ( e2v(ji+1,jj) * pv(ji+1,jj,jk) - e2v(ji,jj) * pv(ji,jj,jk) ) & ! add () for NP repro
+ & - ( e1u(ji,jj+1) * pu(ji,jj+1,jk) - e1u(ji,jj) * pu(ji,jj,jk) ) ) * r1_e1e2f(ji,jj)
END_2D
IF( ln_dynvor_msk ) THEN ! mask the relative vorticity (NOT the Coriolis term)
DO_2D( 1, 0, 1, 0 )
@@ -502,22 +500,22 @@ CONTAINS
SELECT CASE( nn_e3f_typ ) !== potential vorticity ==!
CASE ( 0 ) ! original formulation (masked averaging of e3t divided by 4)
DO_2D( 1, 0, 1, 0 )
- ze3f = ( e3t(ji ,jj+1,jk,Kmm)*tmask(ji ,jj+1,jk) &
- & + e3t(ji+1,jj+1,jk,Kmm)*tmask(ji+1,jj+1,jk) &
- & + e3t(ji ,jj ,jk,Kmm)*tmask(ji ,jj ,jk) &
- & + e3t(ji+1,jj ,jk,Kmm)*tmask(ji+1,jj ,jk) )
+ ze3f = ( ( e3t(ji ,jj+1,jk,Kmm)*tmask(ji ,jj+1,jk) & ! need additional () for
+ & + e3t(ji+1,jj+1,jk,Kmm)*tmask(ji+1,jj+1,jk) ) & ! reproducibility around NP
+ & + ( e3t(ji ,jj ,jk,Kmm)*tmask(ji ,jj ,jk) &
+ & + e3t(ji+1,jj ,jk,Kmm)*tmask(ji+1,jj ,jk) ) )
IF( ze3f /= 0._wp ) THEN ; zwz(ji,jj) = zwz(ji,jj) * 4._wp / ze3f
ELSE ; zwz(ji,jj) = 0._wp
ENDIF
END_2D
CASE ( 1 ) ! new formulation (masked averaging of e3t divided by the sum of mask)
DO_2D( 1, 0, 1, 0 )
- ze3f = ( e3t(ji ,jj+1,jk,Kmm)*tmask(ji ,jj+1,jk) &
- & + e3t(ji+1,jj+1,jk,Kmm)*tmask(ji+1,jj+1,jk) &
- & + e3t(ji ,jj ,jk,Kmm)*tmask(ji ,jj ,jk) &
- & + e3t(ji+1,jj ,jk,Kmm)*tmask(ji+1,jj ,jk) )
- zmsk = ( tmask(ji,jj+1,jk) + tmask(ji+1,jj+1,jk) &
- & + tmask(ji,jj ,jk) + tmask(ji+1,jj ,jk) )
+ ze3f = ( ( e3t(ji ,jj+1,jk,Kmm)*tmask(ji ,jj+1,jk) & ! need additional () for
+ & + e3t(ji+1,jj+1,jk,Kmm)*tmask(ji+1,jj+1,jk) ) & ! reproducibility around NP
+ & + ( e3t(ji ,jj ,jk,Kmm)*tmask(ji ,jj ,jk) &
+ & + e3t(ji+1,jj ,jk,Kmm)*tmask(ji+1,jj ,jk) ) )
+ zmsk = ( tmask(ji,jj+1,jk) + tmask(ji+1,jj+1,jk) &
+ & + tmask(ji,jj ,jk) + tmask(ji+1,jj ,jk) )
IF( ze3f /= 0._wp ) THEN ; zwz(ji,jj) = zwz(ji,jj) * zmsk / ze3f
ELSE ; zwz(ji,jj) = 0._wp
ENDIF
@@ -573,7 +571,7 @@ CONTAINS
!
INTEGER :: ji, jj, jk ! dummy loop indices
REAL(wp) :: zuav, zvau, ze3f, zmsk ! local scalars
- REAL(wp), DIMENSION(A2D(nn_hls)) :: zwx, zwy, zwz ! 2D workspace
+ REAL(wp), DIMENSION(T2D(1)) :: zwx, zwy, zwz ! 2D workspace
!!----------------------------------------------------------------------
!
IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile
@@ -594,8 +592,8 @@ CONTAINS
END_2D
CASE ( np_RVO ) !* relative vorticity
DO_2D( 1, 0, 1, 0 )
- zwz(ji,jj) = ( e2v(ji+1,jj ) * pv(ji+1,jj ,jk) - e2v(ji,jj) * pv(ji,jj,jk) &
- & - e1u(ji ,jj+1) * pu(ji ,jj+1,jk) + e1u(ji,jj) * pu(ji,jj,jk) ) * r1_e1e2f(ji,jj)
+ zwz(ji,jj) = ( ( e2v(ji+1,jj ) * pv(ji+1,jj ,jk) - e2v(ji,jj) * pv(ji,jj,jk) ) & ! add () for NP repro
+ & - ( e1u(ji ,jj+1) * pu(ji ,jj+1,jk) - e1u(ji,jj) * pu(ji,jj,jk) ) ) * r1_e1e2f(ji,jj)
END_2D
IF( ln_dynvor_msk ) THEN ! mask the relative vorticity
DO_2D( 1, 0, 1, 0 )
@@ -609,8 +607,8 @@ CONTAINS
END_2D
CASE ( np_CRV ) !* Coriolis + relative vorticity
DO_2D( 1, 0, 1, 0 )
- zwz(ji,jj) = ff_f(ji,jj) + ( e2v(ji+1,jj ) * pv(ji+1,jj ,jk) - e2v(ji,jj) * pv(ji,jj,jk) &
- & - e1u(ji ,jj+1) * pu(ji ,jj+1,jk) + e1u(ji,jj) * pu(ji,jj,jk) ) * r1_e1e2f(ji,jj)
+ zwz(ji,jj) = ff_f(ji,jj) + ( ( e2v(ji+1,jj ) * pv(ji+1,jj ,jk) - e2v(ji,jj) * pv(ji,jj,jk) ) &! add () for NP repro
+ & -( e1u(ji ,jj+1) * pu(ji ,jj+1,jk) - e1u(ji,jj) * pu(ji,jj,jk) ) ) * r1_e1e2f(ji,jj)
END_2D
IF( ln_dynvor_msk ) THEN ! mask the relative vorticity (NOT the Coriolis term)
DO_2D( 1, 0, 1, 0 )
@@ -635,22 +633,22 @@ CONTAINS
SELECT CASE( nn_e3f_typ ) !== potential vorticity ==!
CASE ( 0 ) ! original formulation (masked averaging of e3t divided by 4)
DO_2D( 1, 0, 1, 0 )
- ze3f = ( e3t(ji ,jj+1,jk,Kmm)*tmask(ji ,jj+1,jk) &
- & + e3t(ji+1,jj+1,jk,Kmm)*tmask(ji+1,jj+1,jk) &
- & + e3t(ji ,jj ,jk,Kmm)*tmask(ji ,jj ,jk) &
- & + e3t(ji+1,jj ,jk,Kmm)*tmask(ji+1,jj ,jk) )
+ ze3f = ( ( e3t(ji ,jj+1,jk,Kmm)*tmask(ji ,jj+1,jk) & ! need additional () for
+ & + e3t(ji+1,jj+1,jk,Kmm)*tmask(ji+1,jj+1,jk) ) & ! reproducibility around NP
+ & + ( e3t(ji ,jj ,jk,Kmm)*tmask(ji ,jj ,jk) &
+ & + e3t(ji+1,jj ,jk,Kmm)*tmask(ji+1,jj ,jk) ) )
IF( ze3f /= 0._wp ) THEN ; zwz(ji,jj) = zwz(ji,jj) * 4._wp / ze3f
ELSE ; zwz(ji,jj) = 0._wp
ENDIF
END_2D
CASE ( 1 ) ! new formulation (masked averaging of e3t divided by the sum of mask)
DO_2D( 1, 0, 1, 0 )
- ze3f = ( e3t(ji ,jj+1,jk,Kmm)*tmask(ji ,jj+1,jk) &
- & + e3t(ji+1,jj+1,jk,Kmm)*tmask(ji+1,jj+1,jk) &
- & + e3t(ji ,jj ,jk,Kmm)*tmask(ji ,jj ,jk) &
- & + e3t(ji+1,jj ,jk,Kmm)*tmask(ji+1,jj ,jk) )
- zmsk = ( tmask(ji,jj+1,jk) + tmask(ji+1,jj+1,jk) &
- & + tmask(ji,jj ,jk) + tmask(ji+1,jj ,jk) )
+ ze3f = ( ( e3t(ji ,jj+1,jk,Kmm)*tmask(ji ,jj+1,jk) & ! need additional () for
+ & + e3t(ji+1,jj+1,jk,Kmm)*tmask(ji+1,jj+1,jk) ) & ! reproducibility around NP
+ & + ( e3t(ji ,jj ,jk,Kmm)*tmask(ji ,jj ,jk) &
+ & + e3t(ji+1,jj ,jk,Kmm)*tmask(ji+1,jj ,jk) ) )
+ zmsk = ( tmask(ji,jj+1,jk) + tmask(ji+1,jj+1,jk) &
+ & + tmask(ji,jj ,jk) + tmask(ji+1,jj ,jk) )
IF( ze3f /= 0._wp ) THEN ; zwz(ji,jj) = zwz(ji,jj) * zmsk / ze3f
ELSE ; zwz(ji,jj) = 0._wp
ENDIF
@@ -665,10 +663,10 @@ CONTAINS
!
! !== compute and add the vorticity term trend =!
DO_2D( 0, 0, 0, 0 )
- zuav = r1_8 * r1_e1u(ji,jj) * ( zwy(ji ,jj-1) + zwy(ji+1,jj-1) &
- & + zwy(ji ,jj ) + zwy(ji+1,jj ) )
- zvau =-r1_8 * r1_e2v(ji,jj) * ( zwx(ji-1,jj ) + zwx(ji-1,jj+1) &
- & + zwx(ji ,jj ) + zwx(ji ,jj+1) )
+ zuav = r1_8 * r1_e1u(ji,jj) * ( ( zwy(ji ,jj-1) + zwy(ji+1,jj-1) ) & ! need additional () for
+ & + ( zwy(ji ,jj ) + zwy(ji+1,jj ) ) ) ! reproducibility around NP
+ zvau =-r1_8 * r1_e2v(ji,jj) * ( ( zwx(ji-1,jj ) + zwx(ji-1,jj+1) ) &
+ & + ( zwx(ji ,jj ) + zwx(ji ,jj+1) ) )
pu_rhs(ji,jj,jk) = pu_rhs(ji,jj,jk) + zuav * ( zwz(ji ,jj-1) + zwz(ji,jj) )
pv_rhs(ji,jj,jk) = pv_rhs(ji,jj,jk) + zvau * ( zwz(ji-1,jj ) + zwz(ji,jj) )
END_2D
@@ -705,16 +703,10 @@ CONTAINS
INTEGER :: ierr ! local integer
REAL(wp) :: zua, zva ! local scalars
REAL(wp) :: zmsk, ze3f ! local scalars
- REAL(wp), DIMENSION(A2D(nn_hls)) :: z1_e3f
-#if defined key_loop_fusion
- REAL(wp) :: ztne, ztnw, ztnw_ip1, ztse, ztse_jp1, ztsw_jp1, ztsw_ip1
- REAL(wp) :: zwx, zwx_im1, zwx_jp1, zwx_im1_jp1
- REAL(wp) :: zwy, zwy_ip1, zwy_jm1, zwy_ip1_jm1
-#else
- REAL(wp), DIMENSION(A2D(nn_hls)) :: zwx , zwy
- REAL(wp), DIMENSION(A2D(nn_hls)) :: ztnw, ztne, ztsw, ztse
-#endif
- REAL(wp), DIMENSION(A2D(nn_hls),jpkm1) :: zwz ! 3D workspace, jpkm1 -> jpkm1 -> avoid lbc_lnk on jpk that is not defined
+ REAL(wp), DIMENSION(T2D(1)) :: z1_e3f
+ REAL(wp), DIMENSION(T2D(1)) :: zwx , zwy
+ REAL(wp), DIMENSION(T2D(1)) :: ztnw, ztne, ztsw, ztse
+ REAL(wp), DIMENSION(T2D(1)) :: zwz ! 3D workspace, jpkm1 -> jpkm1 -> avoid lbc_lnk on jpk that is not defined
!!----------------------------------------------------------------------
!
IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile
@@ -730,33 +722,29 @@ CONTAINS
! ! ===============
!
#if defined key_qco || defined key_linssh
- DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) ! == reciprocal of e3 at F-point (key_qco)
+ DO_2D( 1, 1, 1, 1 ) ! == reciprocal of e3 at F-point (key_qco)
z1_e3f(ji,jj) = 1._wp / e3f_vor(ji,jj,jk)
END_2D
#else
SELECT CASE( nn_e3f_typ ) ! == reciprocal of e3 at F-point
CASE ( 0 ) ! original formulation (masked averaging of e3t divided by 4)
- DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 )
- ! round brackets added to fix the order of floating point operations
- ! needed to ensure halo 1 - halo 2 compatibility
- ze3f = ( (e3t(ji ,jj+1,jk,Kmm)*tmask(ji ,jj+1,jk) &
- & + e3t(ji+1,jj+1,jk,Kmm)*tmask(ji+1,jj+1,jk)) &
- & + (e3t(ji ,jj ,jk,Kmm)*tmask(ji ,jj ,jk) &
- & + e3t(ji+1,jj ,jk,Kmm)*tmask(ji+1,jj ,jk)) )
+ DO_2D( 1, 1, 1, 1 )
+ ze3f = ( ( e3t(ji ,jj+1,jk,Kmm)*tmask(ji ,jj+1,jk) & ! need additional () for
+ & + e3t(ji+1,jj+1,jk,Kmm)*tmask(ji+1,jj+1,jk) ) & ! reproducibility around NP
+ & + ( e3t(ji ,jj ,jk,Kmm)*tmask(ji ,jj ,jk) &
+ & + e3t(ji+1,jj ,jk,Kmm)*tmask(ji+1,jj ,jk) ) )
IF( ze3f /= 0._wp ) THEN ; z1_e3f(ji,jj) = 4._wp / ze3f
ELSE ; z1_e3f(ji,jj) = 0._wp
ENDIF
END_2D
CASE ( 1 ) ! new formulation (masked averaging of e3t divided by the sum of mask)
- DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 )
- ! round brackets added to fix the order of floating point operations
- ! needed to ensure halo 1 - halo 2 compatibility
- ze3f = ( (e3t(ji ,jj+1,jk,Kmm)*tmask(ji ,jj+1,jk) &
- & + e3t(ji+1,jj+1,jk,Kmm)*tmask(ji+1,jj+1,jk)) &
- & + (e3t(ji ,jj ,jk,Kmm)*tmask(ji ,jj ,jk) &
- & + e3t(ji+1,jj ,jk,Kmm)*tmask(ji+1,jj ,jk)) )
- zmsk = ( tmask(ji,jj+1,jk) + tmask(ji+1,jj+1,jk) &
- & + tmask(ji,jj ,jk) + tmask(ji+1,jj ,jk) )
+ DO_2D( 1, 1, 1, 1 )
+ ze3f = ( ( e3t(ji ,jj+1,jk,Kmm)*tmask(ji ,jj+1,jk) & ! need additional () for
+ & + e3t(ji+1,jj+1,jk,Kmm)*tmask(ji+1,jj+1,jk) ) & ! reproducibility around NP
+ & + ( e3t(ji ,jj ,jk,Kmm)*tmask(ji ,jj ,jk) &
+ & + e3t(ji+1,jj ,jk,Kmm)*tmask(ji+1,jj ,jk) ) )
+ zmsk = (tmask(ji,jj+1,jk) + tmask(ji+1,jj+1,jk) &
+ & + tmask(ji,jj ,jk) + tmask(ji+1,jj ,jk) )
IF( ze3f /= 0._wp ) THEN ; z1_e3f(ji,jj) = zmsk / ze3f
ELSE ; z1_e3f(ji,jj) = 0._wp
ENDIF
@@ -767,86 +755,72 @@ CONTAINS
SELECT CASE( kvor ) !== vorticity considered ==!
!
CASE ( np_COR ) !* Coriolis (planetary vorticity)
- DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 )
- zwz(ji,jj,jk) = ff_f(ji,jj) * z1_e3f(ji,jj)
+ DO_2D( 1, 1, 1, 1 )
+ zwz(ji,jj) = ff_f(ji,jj) * z1_e3f(ji,jj)
END_2D
CASE ( np_RVO ) !* relative vorticity
- DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 )
- zwz(ji,jj,jk) = ( e2v(ji+1,jj ) * pv(ji+1,jj,jk) - e2v(ji,jj) * pv(ji,jj,jk) &
- & - e1u(ji ,jj+1) * pu(ji,jj+1,jk) + e1u(ji,jj) * pu(ji,jj,jk) ) * r1_e1e2f(ji,jj)*z1_e3f(ji,jj)
+ DO_2D( 1, 1, 1, 1 )
+ zwz(ji,jj) = ( ( e2v(ji+1,jj ) * pv(ji+1,jj,jk) - e2v(ji,jj) * pv(ji,jj,jk) ) & ! add () for NP repro
+ & - ( e1u(ji ,jj+1) * pu(ji,jj+1,jk) - e1u(ji,jj) * pu(ji,jj,jk) ) ) * r1_e1e2f(ji,jj)*z1_e3f(ji,jj)
END_2D
IF( ln_dynvor_msk ) THEN ! mask the relative vorticity
- DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 )
- zwz(ji,jj,jk) = zwz(ji,jj,jk) * fmask(ji,jj,jk)
+ DO_2D( 1, 1, 1, 1 )
+ zwz(ji,jj) = zwz(ji,jj) * fmask(ji,jj,jk)
END_2D
ENDIF
CASE ( np_MET ) !* metric term
- DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 )
- zwz(ji,jj,jk) = ( ( pv(ji+1,jj,jk) + pv(ji,jj,jk) ) * di_e2v_2e1e2f(ji,jj) &
- & - ( pu(ji,jj+1,jk) + pu(ji,jj,jk) ) * dj_e1u_2e1e2f(ji,jj) ) * z1_e3f(ji,jj)
+ DO_2D( 1, 1, 1, 1 )
+ zwz(ji,jj) = ( ( pv(ji+1,jj,jk) + pv(ji,jj,jk) ) * di_e2v_2e1e2f(ji,jj) &
+ & - ( pu(ji,jj+1,jk) + pu(ji,jj,jk) ) * dj_e1u_2e1e2f(ji,jj) ) * z1_e3f(ji,jj)
END_2D
CASE ( np_CRV ) !* Coriolis + relative vorticity
- DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 )
- ! round brackets added to fix the order of floating point operations
- ! needed to ensure halo 1 - halo 2 compatibility
- zwz(ji,jj,jk) = ( ff_f(ji,jj) + ( ( e2v(ji+1,jj ) * pv(ji+1,jj,jk) - e2v(ji,jj) * pv(ji,jj,jk) &
- & ) & ! bracket for halo 1 - halo 2 compatibility
- & - ( e1u(ji ,jj+1) * pu(ji,jj+1,jk) - e1u(ji,jj) * pu(ji,jj,jk) &
- & ) & ! bracket for halo 1 - halo 2 compatibility
- & ) * r1_e1e2f(ji,jj) ) * z1_e3f(ji,jj)
+ DO_2D( 1, 1, 1, 1 )
+ zwz(ji,jj) = ( ff_f(ji,jj) + ( ( e2v(ji+1,jj ) * pv(ji+1,jj,jk) - e2v(ji,jj) * pv(ji,jj,jk) ) & ! add () for
+ & - ( e1u(ji ,jj+1) * pu(ji,jj+1,jk) - e1u(ji,jj) * pu(ji,jj,jk) ) & ! NP repro
+ & ) * r1_e1e2f(ji,jj) ) * z1_e3f(ji,jj)
END_2D
IF( ln_dynvor_msk ) THEN ! mask the relative vorticity
- DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 )
- zwz(ji,jj,jk) = ( zwz(ji,jj,jk) - ff_f(ji,jj) ) * fmask(ji,jj,jk) + ff_f(ji,jj)
+ DO_2D( 1, 1, 1, 1 )
+ zwz(ji,jj) = ( zwz(ji,jj) - ff_f(ji,jj) ) * fmask(ji,jj,jk) + ff_f(ji,jj)
END_2D
ENDIF
CASE ( np_CME ) !* Coriolis + metric
- DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 )
- zwz(ji,jj,jk) = ( ff_f(ji,jj) + ( pv(ji+1,jj ,jk) + pv(ji,jj,jk) ) * di_e2v_2e1e2f(ji,jj) &
- & - ( pu(ji ,jj+1,jk) + pu(ji,jj,jk) ) * dj_e1u_2e1e2f(ji,jj) ) * z1_e3f(ji,jj)
+ DO_2D( 1, 1, 1, 1 )
+ zwz(ji,jj) = ( ff_f(ji,jj) + ( pv(ji+1,jj ,jk) + pv(ji,jj,jk) ) * di_e2v_2e1e2f(ji,jj) &
+ & - ( pu(ji ,jj+1,jk) + pu(ji,jj,jk) ) * dj_e1u_2e1e2f(ji,jj) ) * z1_e3f(ji,jj)
END_2D
CASE DEFAULT ! error
CALL ctl_stop('STOP','dyn_vor: wrong value for kvor' )
END SELECT
- ! ! ===============
- END DO ! End of slab
- ! ! ===============
- !
- IF (nn_hls==1) CALL lbc_lnk( 'dynvor', zwz, 'F', 1.0_wp )
- !
- ! ! ===============
- ! ! Horizontal slab
- ! ! ===============
-#if defined key_loop_fusion
- DO_3D( 0, 0, 0, 0, 1, jpkm1 )
- ! !== horizontal fluxes ==!
- zwx = e2u(ji ,jj ) * e3u(ji ,jj ,jk,Kmm) * pu(ji ,jj ,jk)
- zwx_im1 = e2u(ji-1,jj ) * e3u(ji-1,jj ,jk,Kmm) * pu(ji-1,jj ,jk)
- zwx_jp1 = e2u(ji ,jj+1) * e3u(ji ,jj+1,jk,Kmm) * pu(ji ,jj+1,jk)
- zwx_im1_jp1 = e2u(ji-1,jj+1) * e3u(ji-1,jj+1,jk,Kmm) * pu(ji-1,jj+1,jk)
- zwy = e1v(ji ,jj ) * e3v(ji ,jj ,jk,Kmm) * pv(ji ,jj ,jk)
- zwy_ip1 = e1v(ji+1,jj ) * e3v(ji+1,jj ,jk,Kmm) * pv(ji+1,jj ,jk)
- zwy_jm1 = e1v(ji ,jj-1) * e3v(ji ,jj-1,jk,Kmm) * pv(ji ,jj-1,jk)
- zwy_ip1_jm1 = e1v(ji+1,jj-1) * e3v(ji+1,jj-1,jk,Kmm) * pv(ji+1,jj-1,jk)
- ! !== compute and add the vorticity term trend =!
- ztne = zwz(ji-1,jj ,jk) + zwz(ji ,jj ,jk) + zwz(ji ,jj-1,jk)
- ztnw = zwz(ji-1,jj-1,jk) + zwz(ji-1,jj ,jk) + zwz(ji ,jj ,jk)
- ztnw_ip1 = zwz(ji ,jj-1,jk) + zwz(ji ,jj ,jk) + zwz(ji+1,jj ,jk)
- ztse = zwz(ji ,jj ,jk) + zwz(ji ,jj-1,jk) + zwz(ji-1,jj-1,jk)
- ztse_jp1 = zwz(ji ,jj+1,jk) + zwz(ji ,jj ,jk) + zwz(ji-1,jj ,jk)
- ztsw_jp1 = zwz(ji ,jj ,jk) + zwz(ji-1,jj ,jk) + zwz(ji-1,jj+1,jk)
- ztsw_ip1 = zwz(ji+1,jj-1,jk) + zwz(ji ,jj-1,jk) + zwz(ji ,jj ,jk)
!
- zua = + r1_12 * r1_e1u(ji,jj) * ( ztne * zwy + ztnw_ip1 * zwy_ip1 &
- & + ztse * zwy_jm1 + ztsw_ip1 * zwy_ip1_jm1 )
- zva = - r1_12 * r1_e2v(ji,jj) * ( ztsw_jp1 * zwx_im1_jp1 + ztse_jp1 * zwx_jp1 &
- & + ztnw * zwx_im1 + ztne * zwx )
- pu_rhs(ji,jj,jk) = pu_rhs(ji,jj,jk) + zua
- pv_rhs(ji,jj,jk) = pv_rhs(ji,jj,jk) + zva
- END_3D
+#if defined key_loop_fusion
+ DO_2D( 0, 0, 0, 0 )
+ ! !== horizontal fluxes ==!
+ zwx = e2u(ji ,jj ) * e3u(ji ,jj ,jk,Kmm) * pu(ji ,jj ,jk)
+ zwx_im1 = e2u(ji-1,jj ) * e3u(ji-1,jj ,jk,Kmm) * pu(ji-1,jj ,jk)
+ zwx_jp1 = e2u(ji ,jj+1) * e3u(ji ,jj+1,jk,Kmm) * pu(ji ,jj+1,jk)
+ zwx_im1_jp1 = e2u(ji-1,jj+1) * e3u(ji-1,jj+1,jk,Kmm) * pu(ji-1,jj+1,jk)
+ zwy = e1v(ji ,jj ) * e3v(ji ,jj ,jk,Kmm) * pv(ji ,jj ,jk)
+ zwy_ip1 = e1v(ji+1,jj ) * e3v(ji+1,jj ,jk,Kmm) * pv(ji+1,jj ,jk)
+ zwy_jm1 = e1v(ji ,jj-1) * e3v(ji ,jj-1,jk,Kmm) * pv(ji ,jj-1,jk)
+ zwy_ip1_jm1 = e1v(ji+1,jj-1) * e3v(ji+1,jj-1,jk,Kmm) * pv(ji+1,jj-1,jk)
+ ! !== compute and add the vorticity term trend =!
+ ztne = zwz(ji-1,jj ) + zwz(ji ,jj ) + zwz(ji ,jj-1)
+ ztnw = zwz(ji-1,jj-1) + zwz(ji-1,jj ) + zwz(ji ,jj )
+ ztnw_ip1 = zwz(ji ,jj-1) + zwz(ji ,jj ) + zwz(ji+1,jj )
+ ztse = zwz(ji ,jj ) + zwz(ji ,jj-1) + zwz(ji-1,jj-1)
+ ztse_jp1 = zwz(ji ,jj+1) + zwz(ji ,jj ) + zwz(ji-1,jj )
+ ztsw_jp1 = zwz(ji ,jj ) + zwz(ji-1,jj ) + zwz(ji-1,jj+1)
+ ztsw_ip1 = zwz(ji+1,jj-1) + zwz(ji ,jj-1) + zwz(ji ,jj )
+ !
+ zua = + r1_12 * r1_e1u(ji,jj) * ( ( ztne * zwy + ztnw_ip1 * zwy_ip1 ) & ! add () for
+ & + ( ztse * zwy_jm1 + ztsw_ip1 * zwy_ip1_jm1 ) ) ! NP repro
+ zva = - r1_12 * r1_e2v(ji,jj) * ( ( ztsw_jp1 * zwx_im1_jp1 + ztse_jp1 * zwx_jp1 ) &
+ & + ( ztnw * zwx_im1 + ztne * zwx ) )
+ pu_rhs(ji,jj,jk) = pu_rhs(ji,jj,jk) + zua
+ pv_rhs(ji,jj,jk) = pv_rhs(ji,jj,jk) + zva
+ END_2D
#else
- DO jk = 1, jpkm1
- !
! !== horizontal fluxes ==!
DO_2D( 1, 1, 1, 1 )
zwx(ji,jj) = e2u(ji,jj) * e3u(ji,jj,jk,Kmm) * pu(ji,jj,jk)
@@ -855,24 +829,24 @@ CONTAINS
!
! !== compute and add the vorticity term trend =!
DO_2D( 0, 1, 0, 1 )
- ztne(ji,jj) = zwz(ji-1,jj ,jk) + zwz(ji ,jj ,jk) + zwz(ji ,jj-1,jk)
- ztnw(ji,jj) = zwz(ji-1,jj-1,jk) + zwz(ji-1,jj ,jk) + zwz(ji ,jj ,jk)
- ztse(ji,jj) = zwz(ji ,jj ,jk) + zwz(ji ,jj-1,jk) + zwz(ji-1,jj-1,jk)
- ztsw(ji,jj) = zwz(ji ,jj-1,jk) + zwz(ji-1,jj-1,jk) + zwz(ji-1,jj ,jk)
+ ztne(ji,jj) = zwz(ji-1,jj ) + zwz(ji ,jj ) + zwz(ji ,jj-1)
+ ztnw(ji,jj) = zwz(ji-1,jj-1) + zwz(ji-1,jj ) + zwz(ji ,jj )
+ ztse(ji,jj) = zwz(ji ,jj ) + zwz(ji ,jj-1) + zwz(ji-1,jj-1)
+ ztsw(ji,jj) = zwz(ji ,jj-1) + zwz(ji-1,jj-1) + zwz(ji-1,jj )
END_2D
!
- DO_2D( 0, 0, 0, 0 )
- zua = + r1_12 * r1_e1u(ji,jj) * ( ztne(ji,jj ) * zwy(ji ,jj ) + ztnw(ji+1,jj) * zwy(ji+1,jj ) &
- & + ztse(ji,jj ) * zwy(ji ,jj-1) + ztsw(ji+1,jj) * zwy(ji+1,jj-1) )
- zva = - r1_12 * r1_e2v(ji,jj) * ( ztsw(ji,jj+1) * zwx(ji-1,jj+1) + ztse(ji,jj+1) * zwx(ji ,jj+1) &
- & + ztnw(ji,jj ) * zwx(ji-1,jj ) + ztne(ji,jj ) * zwx(ji ,jj ) )
+ DO_2D( 0, 0, 0, 0 ) ! add () for NP repro
+ zua = + r1_12 * r1_e1u(ji,jj) * ( ( ztne(ji,jj ) * zwy(ji ,jj ) + ztnw(ji+1,jj) * zwy(ji+1,jj ) ) & ! add () for
+ & + ( ztse(ji,jj ) * zwy(ji ,jj-1) + ztsw(ji+1,jj) * zwy(ji+1,jj-1) ) ) ! NP repro
+ zva = - r1_12 * r1_e2v(ji,jj) * ( ( ztsw(ji,jj+1) * zwx(ji-1,jj+1) + ztse(ji,jj+1) * zwx(ji ,jj+1) ) &
+ & + ( ztnw(ji,jj ) * zwx(ji-1,jj ) + ztne(ji,jj ) * zwx(ji ,jj ) ) )
pu_rhs(ji,jj,jk) = pu_rhs(ji,jj,jk) + zua
pv_rhs(ji,jj,jk) = pv_rhs(ji,jj,jk) + zva
END_2D
- END DO
#endif
- ! ! ===============
- ! ! End of slab
+ END DO
+ ! ! ===============
+ ! ! End of slab
! ! ===============
END SUBROUTINE vor_een
@@ -904,9 +878,9 @@ CONTAINS
INTEGER :: ierr ! local integer
REAL(wp) :: zua, zva ! local scalars
REAL(wp) :: zmsk, z1_e3t ! local scalars
- REAL(wp), DIMENSION(A2D(nn_hls)) :: zwx , zwy
- REAL(wp), DIMENSION(A2D(nn_hls)) :: ztnw, ztne, ztsw, ztse
- REAL(wp), DIMENSION(A2D(nn_hls),jpkm1) :: zwz ! 3D workspace, avoid lbc_lnk on jpk that is not defined
+ REAL(wp), DIMENSION(T2D(1)) :: zwx , zwy
+ REAL(wp), DIMENSION(T2D(1)) :: ztnw, ztne, ztsw, ztse
+ REAL(wp), DIMENSION(T2D(1)) :: zwz ! 3D workspace, avoid lbc_lnk on jpk that is not defined
!!----------------------------------------------------------------------
!
IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile
@@ -924,58 +898,45 @@ CONTAINS
!
SELECT CASE( kvor ) !== vorticity considered ==!
CASE ( np_COR ) !* Coriolis (planetary vorticity)
- DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 )
- zwz(ji,jj,jk) = ff_f(ji,jj)
+ DO_2D( 1, 1, 1, 1 )
+ zwz(ji,jj) = ff_f(ji,jj)
END_2D
CASE ( np_RVO ) !* relative vorticity
- DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 )
- ! round brackets added to fix the order of floating point operations
- ! needed to ensure halo 1 - halo 2 compatibility
- zwz(ji,jj,jk) = ( (e2v(ji+1,jj ) * pv(ji+1,jj ,jk) - e2v(ji,jj) * pv(ji,jj,jk)) &
- & - (e1u(ji ,jj+1) * pu(ji ,jj+1,jk) - e1u(ji,jj) * pu(ji,jj,jk)) ) &
- & * r1_e1e2f(ji,jj)
+ DO_2D( 1, 1, 1, 1 )
+ zwz(ji,jj) = ( ( e2v(ji+1,jj ) * pv(ji+1,jj ,jk) - e2v(ji,jj) * pv(ji,jj,jk) ) & ! add () for
+ & - ( e1u(ji ,jj+1) * pu(ji ,jj+1,jk) - e1u(ji,jj) * pu(ji,jj,jk) ) ) & ! NP reproducibility
+ & * r1_e1e2f(ji,jj)
END_2D
IF( ln_dynvor_msk ) THEN ! mask the relative vorticity
- DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 )
- zwz(ji,jj,jk) = zwz(ji,jj,jk) * fmask(ji,jj,jk)
+ DO_2D( 1, 1, 1, 1 )
+ zwz(ji,jj) = zwz(ji,jj) * fmask(ji,jj,jk)
END_2D
ENDIF
CASE ( np_MET ) !* metric term
- DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 )
- zwz(ji,jj,jk) = ( pv(ji+1,jj ,jk) + pv(ji,jj,jk) ) * di_e2v_2e1e2f(ji,jj) &
- & - ( pu(ji ,jj+1,jk) + pu(ji,jj,jk) ) * dj_e1u_2e1e2f(ji,jj)
+ DO_2D( 1, 1, 1, 1 )
+ zwz(ji,jj) = ( pv(ji+1,jj ,jk) + pv(ji,jj,jk) ) * di_e2v_2e1e2f(ji,jj) &
+ & - ( pu(ji ,jj+1,jk) + pu(ji,jj,jk) ) * dj_e1u_2e1e2f(ji,jj)
END_2D
CASE ( np_CRV ) !* Coriolis + relative vorticity
- DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 )
- ! round brackets added to fix the order of floating point operations
- ! needed to ensure halo 1 - halo 2 compatibility
- zwz(ji,jj,jk) = ( ff_f(ji,jj) + ( (e2v(ji+1,jj ) * pv(ji+1,jj ,jk) - e2v(ji,jj) * pv(ji,jj,jk)) &
- & - (e1u(ji ,jj+1) * pu(ji ,jj+1,jk) - e1u(ji,jj) * pu(ji,jj,jk)) ) &
- & * r1_e1e2f(ji,jj) )
+ DO_2D( 1, 1, 1, 1 )
+ zwz(ji,jj) = ( ff_f(ji,jj) + ( ( e2v(ji+1,jj ) * pv(ji+1,jj ,jk) - e2v(ji,jj) * pv(ji,jj,jk) ) & ! add () for
+ & - ( e1u(ji ,jj+1) * pu(ji ,jj+1,jk) - e1u(ji,jj) * pu(ji,jj,jk) ) ) & ! NP repro
+ & * r1_e1e2f(ji,jj) )
END_2D
IF( ln_dynvor_msk ) THEN ! mask the relative vorticity
- DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 )
- zwz(ji,jj,jk) = ( zwz(ji,jj,jk) - ff_f(ji,jj) ) * fmask(ji,jj,jk) + ff_f(ji,jj)
+ DO_2D( 1, 1, 1, 1 )
+ zwz(ji,jj) = ( zwz(ji,jj) - ff_f(ji,jj) ) * fmask(ji,jj,jk) + ff_f(ji,jj)
END_2D
ENDIF
CASE ( np_CME ) !* Coriolis + metric
- DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 )
- zwz(ji,jj,jk) = ff_f(ji,jj) + ( pv(ji+1,jj ,jk) + pv(ji,jj,jk) ) * di_e2v_2e1e2f(ji,jj) &
- & - ( pu(ji ,jj+1,jk) + pu(ji,jj,jk) ) * dj_e1u_2e1e2f(ji,jj)
+ DO_2D( 1, 1, 1, 1 )
+ zwz(ji,jj) = ff_f(ji,jj) + ( pv(ji+1,jj ,jk) + pv(ji,jj,jk) ) * di_e2v_2e1e2f(ji,jj) &
+ & - ( pu(ji ,jj+1,jk) + pu(ji,jj,jk) ) * dj_e1u_2e1e2f(ji,jj)
END_2D
CASE DEFAULT ! error
CALL ctl_stop('STOP','dyn_vor: wrong value for kvor' )
END SELECT
!
- ! ! ===============
- END DO ! End of slab
- ! ! ===============
- !
- IF (nn_hls==1) CALL lbc_lnk( 'dynvor', zwz, 'F', 1.0_wp )
- !
- ! ! ===============
- DO jk = 1, jpkm1 ! Horizontal slab
- ! ! ===============
!
! !== horizontal fluxes ==!
DO_2D( 1, 1, 1, 1 )
@@ -986,17 +947,17 @@ CONTAINS
! !== compute and add the vorticity term trend =!
DO_2D( 0, 1, 0, 1 )
z1_e3t = 1._wp / e3t(ji,jj,jk,Kmm)
- ztne(ji,jj) = ( zwz(ji-1,jj ,jk) + zwz(ji ,jj ,jk) + zwz(ji ,jj-1,jk) ) * z1_e3t
- ztnw(ji,jj) = ( zwz(ji-1,jj-1,jk) + zwz(ji-1,jj ,jk) + zwz(ji ,jj ,jk) ) * z1_e3t
- ztse(ji,jj) = ( zwz(ji ,jj ,jk) + zwz(ji ,jj-1,jk) + zwz(ji-1,jj-1,jk) ) * z1_e3t
- ztsw(ji,jj) = ( zwz(ji ,jj-1,jk) + zwz(ji-1,jj-1,jk) + zwz(ji-1,jj ,jk) ) * z1_e3t
+ ztne(ji,jj) = ( zwz(ji-1,jj ) + zwz(ji ,jj ) + zwz(ji ,jj-1) ) * z1_e3t
+ ztnw(ji,jj) = ( zwz(ji-1,jj-1) + zwz(ji-1,jj ) + zwz(ji ,jj ) ) * z1_e3t
+ ztse(ji,jj) = ( zwz(ji ,jj ) + zwz(ji ,jj-1) + zwz(ji-1,jj-1) ) * z1_e3t
+ ztsw(ji,jj) = ( zwz(ji ,jj-1) + zwz(ji-1,jj-1) + zwz(ji-1,jj ) ) * z1_e3t
END_2D
!
DO_2D( 0, 0, 0, 0 )
- zua = + r1_12 * r1_e1u(ji,jj) * ( ztne(ji,jj ) * zwy(ji ,jj ) + ztnw(ji+1,jj) * zwy(ji+1,jj ) &
- & + ztse(ji,jj ) * zwy(ji ,jj-1) + ztsw(ji+1,jj) * zwy(ji+1,jj-1) )
- zva = - r1_12 * r1_e2v(ji,jj) * ( ztsw(ji,jj+1) * zwx(ji-1,jj+1) + ztse(ji,jj+1) * zwx(ji ,jj+1) &
- & + ztnw(ji,jj ) * zwx(ji-1,jj ) + ztne(ji,jj ) * zwx(ji ,jj ) )
+ zua = + r1_12 * r1_e1u(ji,jj) * ( ( ztne(ji,jj ) * zwy(ji ,jj ) + ztnw(ji+1,jj) * zwy(ji+1,jj ) ) & ! add () for
+ & + ( ztse(ji,jj ) * zwy(ji ,jj-1) + ztsw(ji+1,jj) * zwy(ji+1,jj-1) ) ) ! NP repro
+ zva = - r1_12 * r1_e2v(ji,jj) * ( ( ztsw(ji,jj+1) * zwx(ji-1,jj+1) + ztse(ji,jj+1) * zwx(ji ,jj+1) ) &
+ & + ( ztnw(ji,jj ) * zwx(ji-1,jj ) + ztne(ji,jj ) * zwx(ji ,jj ) ) )
pu_rhs(ji,jj,jk) = pu_rhs(ji,jj,jk) + zua
pv_rhs(ji,jj,jk) = pv_rhs(ji,jj,jk) + zva
END_2D
@@ -1115,10 +1076,10 @@ CONTAINS
SELECT CASE( nn_e3f_typ )
CASE ( 0 ) ! original formulation (masked averaging of e3t divided by 4)
DO_3D( 0, 0, 0, 0, 1, jpk )
- e3f_0vor(ji,jj,jk) = ( e3t_0(ji ,jj+1,jk)*tmask(ji ,jj+1,jk) &
- & + e3t_0(ji+1,jj+1,jk)*tmask(ji+1,jj+1,jk) &
- & + e3t_0(ji ,jj ,jk)*tmask(ji ,jj ,jk) &
- & + e3t_0(ji+1,jj ,jk)*tmask(ji+1,jj ,jk) ) * 0.25_wp
+ e3f_0vor(ji,jj,jk) = ( ( e3t_0(ji ,jj+1,jk)*tmask(ji ,jj+1,jk) & ! need additional () for
+ & + e3t_0(ji+1,jj+1,jk)*tmask(ji+1,jj+1,jk) ) & ! reproducibility around NP
+ & + ( e3t_0(ji ,jj ,jk)*tmask(ji ,jj ,jk) &
+ & + e3t_0(ji+1,jj ,jk)*tmask(ji+1,jj ,jk) ) ) * 0.25_wp
END_3D
CASE ( 1 ) ! new formulation (masked averaging of e3t divided by the sum of mask)
DO_3D( 0, 0, 0, 0, 1, jpk )
@@ -1126,10 +1087,10 @@ CONTAINS
& + tmask(ji,jj ,jk) +tmask(ji+1,jj ,jk) )
!
IF( zmsk /= 0._wp ) THEN
- e3f_0vor(ji,jj,jk) = ( e3t_0(ji ,jj+1,jk)*tmask(ji ,jj+1,jk) &
- & + e3t_0(ji+1,jj+1,jk)*tmask(ji+1,jj+1,jk) &
- & + e3t_0(ji ,jj ,jk)*tmask(ji ,jj ,jk) &
- & + e3t_0(ji+1,jj ,jk)*tmask(ji+1,jj ,jk) ) / zmsk
+ e3f_0vor(ji,jj,jk) = ( ( e3t_0(ji ,jj+1,jk)*tmask(ji ,jj+1,jk) & ! need additional () for
+ & + e3t_0(ji+1,jj+1,jk)*tmask(ji+1,jj+1,jk) ) & ! reproducibility around NP
+ & + ( e3t_0(ji ,jj ,jk)*tmask(ji ,jj ,jk) &
+ & + e3t_0(ji+1,jj ,jk)*tmask(ji+1,jj ,jk) ) ) / zmsk
ELSE ; e3f_0vor(ji,jj,jk) = 0._wp
ENDIF
END_3D
@@ -1137,7 +1098,13 @@ CONTAINS
!
CALL lbc_lnk( 'dynvor', e3f_0vor, 'F', 1._wp )
! ! insure e3f_0vor /= 0
+# if defined key_vco_1d
+ DO jk = 1, jpk
+ WHERE( e3f_0vor(:,:,jk) == 0._wp ) e3f_0vor(:,:,jk) = e3f_0(:,:,jk)
+ END DO
+# else
WHERE( e3f_0vor(:,:,:) == 0._wp ) e3f_0vor(:,:,:) = e3f_0(:,:,:)
+# endif
!
END SELECT
!
diff --git a/src/OCE/DYN/dynzad.F90 b/src/OCE/DYN/dynzad.F90
index 5433b956f84b03e19cc2ffa356f1a23b3938858a..7871f4bb6dba7bfbc59bba7e115f6720383b042b 100644
--- a/src/OCE/DYN/dynzad.F90
+++ b/src/OCE/DYN/dynzad.F90
@@ -60,7 +60,7 @@ CONTAINS
INTEGER :: ji, jj, jk ! dummy loop indices
REAL(wp) :: zWf, zWfi, zzWfu, zzWdzU ! local scalars
REAL(wp) :: zWfj, zzWfv, zzWdzV ! - -
- REAL(wp), DIMENSION(A2D(0)) :: zWdzU, zWdzV ! 2D inner workspace
+ REAL(wp), DIMENSION(T2D(0)) :: zWdzU, zWdzV ! 2D inner workspace
REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: ztrdu, ztrdv ! 3D workspace
!!----------------------------------------------------------------------
!
@@ -81,8 +81,8 @@ CONTAINS
!
! !== vertical momentum advection ==! at u- and v-points
!
- zWdzU(A2D(0)) = 0._wp ! set surface (jk=1) vertical advection to zero
- zWdzV(A2D(0)) = 0._wp
+ zWdzU(T2D(0)) = 0._wp ! set surface (jk=1) vertical advection to zero
+ zWdzV(T2D(0)) = 0._wp
!
DO_3D( 0, 0, 0, 0 , 1, jpk-2 ) != surface to jpk-2 vertical advection
! ! vertical transport at jk+1 uw/vw-level (x2): 2*mi/j[e1e2t*(We)]
diff --git a/src/OCE/DYN/dynzdf.F90 b/src/OCE/DYN/dynzdf.F90
index 1e026021941c8a5891459385a52d899c8c88123e..5f6f706d4afe1e4ff4ea38d8ee771be1ac7e616c 100644
--- a/src/OCE/DYN/dynzdf.F90
+++ b/src/OCE/DYN/dynzdf.F90
@@ -6,6 +6,7 @@ MODULE dynzdf
!! History : 1.0 ! 2005-11 (G. Madec) Original code
!! 3.3 ! 2010-10 (C. Ethe, G. Madec) reorganisation of initialisation phase
!! 4.0 ! 2017-06 (G. Madec) remove the explicit time-stepping option + avm at t-point
+ !! 4.5 ! 2022-06 (S. Techene, G, Madec) refactorization to reduce local memory usage
!!----------------------------------------------------------------------
!!----------------------------------------------------------------------
@@ -18,11 +19,7 @@ MODULE dynzdf
USE zdf_oce ! ocean vertical physics variables
USE zdfdrg ! vertical physics: top/bottom drag coef.
USE dynadv ,ONLY: ln_dynadv_vec ! dynamics: advection form
-#if defined key_loop_fusion
- USE dynldf_iso_lf,ONLY: akzu, akzv ! dynamics: vertical component of rotated lateral mixing
-#else
USE dynldf_iso,ONLY: akzu, akzv ! dynamics: vertical component of rotated lateral mixing
-#endif
USE ldfdyn ! lateral diffusion: eddy viscosity coef. and type of operator
USE trd_oce ! trends: ocean variables
USE trddyn ! trend manager: dynamics
@@ -79,7 +76,7 @@ CONTAINS
REAL(wp) :: zWu , zWv ! - -
REAL(wp) :: zWui, zWvi ! - -
REAL(wp) :: zWus, zWvs ! - -
- REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zwi, zwd, zws ! 3D workspace
+ REAL(wp), DIMENSION(T1Di(0),jpk) :: zwi, zwd, zws ! 2D workspace
REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: ztrdu, ztrdv ! - -
!!---------------------------------------------------------------------
!
@@ -105,315 +102,327 @@ CONTAINS
ztrdv(:,:,:) = pvv(:,:,:,Krhs)
ENDIF
!
- ! !== RHS: Leap-Frog time stepping on all trends but the vertical mixing ==! (put in puu(:,:,:,Kaa),pvv(:,:,:,Kaa))
- !
- ! ! time stepping except vertical diffusion
- IF( ln_dynadv_vec .OR. ln_linssh ) THEN ! applied on velocity
- DO_3D( 0, 0, 0, 0, 1, jpkm1 )
- puu(ji,jj,jk,Kaa) = ( puu(ji,jj,jk,Kbb) + rDt * puu(ji,jj,jk,Krhs) ) * umask(ji,jj,jk)
- pvv(ji,jj,jk,Kaa) = ( pvv(ji,jj,jk,Kbb) + rDt * pvv(ji,jj,jk,Krhs) ) * vmask(ji,jj,jk)
- END_3D
- ELSE ! applied on thickness weighted velocity
- DO_3D( 0, 0, 0, 0, 1, jpkm1 )
- puu(ji,jj,jk,Kaa) = ( e3u(ji,jj,jk,Kbb) * puu(ji,jj,jk,Kbb ) &
- & + rDt * e3u(ji,jj,jk,Kmm) * puu(ji,jj,jk,Krhs) ) &
- & / e3u(ji,jj,jk,Kaa) * umask(ji,jj,jk)
- pvv(ji,jj,jk,Kaa) = ( e3v(ji,jj,jk,Kbb) * pvv(ji,jj,jk,Kbb ) &
- & + rDt * e3v(ji,jj,jk,Kmm) * pvv(ji,jj,jk,Krhs) ) &
- & / e3v(ji,jj,jk,Kaa) * vmask(ji,jj,jk)
- END_3D
- ENDIF
- ! ! add top/bottom friction
- ! With split-explicit free surface, barotropic stress is treated explicitly Update velocities at the bottom.
- ! J. Chanut: The bottom stress is computed considering after barotropic velocities, which does
- ! not lead to the effective stress seen over the whole barotropic loop.
- ! G. Madec : in linear free surface, e3u(:,:,:,Kaa) = e3u(:,:,:,Kmm) = e3u_0, so systematic use of e3u(:,:,:,Kaa)
- IF( ln_drgimp .AND. ln_dynspg_ts ) THEN
- DO_3D( 0, 0, 0, 0, 1, jpkm1 ) ! remove barotropic velocities
- puu(ji,jj,jk,Kaa) = ( puu(ji,jj,jk,Kaa) - uu_b(ji,jj,Kaa) ) * umask(ji,jj,jk)
- pvv(ji,jj,jk,Kaa) = ( pvv(ji,jj,jk,Kaa) - vv_b(ji,jj,Kaa) ) * vmask(ji,jj,jk)
- END_3D
- DO_2D( 0, 0, 0, 0 ) ! Add bottom/top stress due to barotropic component only
- iku = mbku(ji,jj) ! ocean bottom level at u- and v-points
- ikv = mbkv(ji,jj) ! (deepest ocean u- and v-points)
- puu(ji,jj,iku,Kaa) = puu(ji,jj,iku,Kaa) + zDt_2 *( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) ) * uu_b(ji,jj,Kaa) &
- & / e3u(ji,jj,iku,Kaa)
- pvv(ji,jj,ikv,Kaa) = pvv(ji,jj,ikv,Kaa) + zDt_2 *( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) ) * vv_b(ji,jj,Kaa) &
- & / e3v(ji,jj,ikv,Kaa)
- END_2D
- IF( ln_isfcav.OR.ln_drgice_imp ) THEN ! Ocean cavities (ISF)
- DO_2D( 0, 0, 0, 0 )
- iku = miku(ji,jj) ! top ocean level at u- and v-points
- ikv = mikv(ji,jj) ! (first wet ocean u- and v-points)
- puu(ji,jj,iku,Kaa) = puu(ji,jj,iku,Kaa) + zDt_2 *( rCdU_top(ji+1,jj)+rCdU_top(ji,jj) ) * uu_b(ji,jj,Kaa) &
+ ! ! ================= !
+ DO_1Dj( 0, 0 ) ! i-k slices loop !
+ ! ! ================= !
+ !
+ ! !== RHS: Leap-Frog time stepping on all trends but the vertical mixing ==! (put in puu(:,:,:,Kaa),pvv(:,:,:,Kaa))
+ !
+ ! ! time stepping except vertical diffusion
+ IF( ln_dynadv_vec .OR. ln_linssh ) THEN ! applied on velocity
+ DO_2Dik( 0, 0, 1, jpkm1, 1 )
+ puu(ji,jj,jk,Kaa) = ( puu(ji,jj,jk,Kbb) + rDt * puu(ji,jj,jk,Krhs) ) * umask(ji,jj,jk)
+ pvv(ji,jj,jk,Kaa) = ( pvv(ji,jj,jk,Kbb) + rDt * pvv(ji,jj,jk,Krhs) ) * vmask(ji,jj,jk)
+ END_2D
+ ELSE ! applied on thickness weighted velocity
+ DO_2Dik( 0, 0, 1, jpkm1, 1 )
+ puu(ji,jj,jk,Kaa) = ( e3u(ji,jj,jk,Kbb) * puu(ji,jj,jk,Kbb ) &
+ & + rDt * e3u(ji,jj,jk,Kmm) * puu(ji,jj,jk,Krhs) ) &
+ & / e3u(ji,jj,jk,Kaa) * umask(ji,jj,jk)
+ pvv(ji,jj,jk,Kaa) = ( e3v(ji,jj,jk,Kbb) * pvv(ji,jj,jk,Kbb ) &
+ & + rDt * e3v(ji,jj,jk,Kmm) * pvv(ji,jj,jk,Krhs) ) &
+ & / e3v(ji,jj,jk,Kaa) * vmask(ji,jj,jk)
+ END_2D
+ ENDIF
+ ! ! add top/bottom friction
+ ! With split-explicit free surface, barotropic stress is treated explicitly Update velocities at the bottom.
+ ! J. Chanut: The bottom stress is computed considering after barotropic velocities, which does
+ ! not lead to the effective stress seen over the whole barotropic loop.
+ ! G. Madec : in linear free surface, e3u(:,:,:,Kaa) = e3u(:,:,:,Kmm) = e3u_0, so systematic use of e3u(:,:,:,Kaa)
+ IF( ln_drgimp .AND. ln_dynspg_ts ) THEN
+ DO_2Dik( 0, 0, 1, jpkm1, 1 ) ! remove barotropic velocities
+ puu(ji,jj,jk,Kaa) = ( puu(ji,jj,jk,Kaa) - uu_b(ji,jj,Kaa) ) * umask(ji,jj,jk)
+ pvv(ji,jj,jk,Kaa) = ( pvv(ji,jj,jk,Kaa) - vv_b(ji,jj,Kaa) ) * vmask(ji,jj,jk)
+ END_2D
+ DO_1Di( 0, 0 ) ! Add bottom/top stress due to barotropic component only
+ iku = mbku(ji,jj) ! ocean bottom level at u- and v-points
+ ikv = mbkv(ji,jj) ! (deepest ocean u- and v-points)
+ puu(ji,jj,iku,Kaa) = puu(ji,jj,iku,Kaa) + zDt_2 * ( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) ) * uu_b(ji,jj,Kaa) &
& / e3u(ji,jj,iku,Kaa)
- pvv(ji,jj,ikv,Kaa) = pvv(ji,jj,ikv,Kaa) + zDt_2 *( rCdU_top(ji,jj+1)+rCdU_top(ji,jj) ) * vv_b(ji,jj,Kaa) &
+ pvv(ji,jj,ikv,Kaa) = pvv(ji,jj,ikv,Kaa) + zDt_2 * ( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) ) * vv_b(ji,jj,Kaa) &
& / e3v(ji,jj,ikv,Kaa)
- END_2D
- END IF
- ENDIF
- !
- ! !== Vertical diffusion on u ==!
- !
- ! !* Matrix construction
- IF( ln_zad_Aimp ) THEN !!
- SELECT CASE( nldf_dyn )
- CASE( np_lap_i ) ! rotated lateral mixing: add its vertical mixing (akzu)
- DO_3D( 0, 0, 0, 0, 1, jpkm1 )
- z1_e3ua = 1._wp / e3u(ji,jj,jk,Kaa) ! after scale factor at U-point
- zzwi = - zDt_2 * ( avm(ji+1,jj,jk ) + avm(ji,jj,jk ) + akzu(ji,jj,jk ) ) &
- & / e3uw(ji,jj,jk ,Kmm) * z1_e3ua * wumask(ji,jj,jk )
- zzws = - zDt_2 * ( avm(ji+1,jj,jk+1) + avm(ji,jj,jk+1) + akzu(ji,jj,jk+1) ) &
- & / e3uw(ji,jj,jk+1,Kmm) * z1_e3ua * wumask(ji,jj,jk+1)
- zWui = ( wi(ji,jj,jk ) + wi(ji+1,jj,jk ) ) * z1_e3ua
- zWus = ( wi(ji,jj,jk+1) + wi(ji+1,jj,jk+1) ) * z1_e3ua
- zwi(ji,jj,jk) = zzwi + zDt_2 * MIN( zWui, 0._wp )
- zws(ji,jj,jk) = zzws - zDt_2 * MAX( zWus, 0._wp )
- zwd(ji,jj,jk) = 1._wp - zzwi - zzws + zDt_2 * ( MAX( zWui, 0._wp ) - MIN( zWus, 0._wp ) )
- END_3D
- CASE DEFAULT ! iso-level lateral mixing
- DO_3D( 0, 0, 0, 0, 1, jpkm1 )
- z1_e3ua = 1._wp / e3u(ji,jj,jk,Kaa) ! after scale factor at U-point
- zzwi = - zDt_2 * ( avm(ji+1,jj,jk ) + avm(ji,jj,jk ) ) &
- & / e3uw(ji,jj,jk ,Kmm) * z1_e3ua * wumask(ji,jj,jk )
- zzws = - zDt_2 * ( avm(ji+1,jj,jk+1) + avm(ji,jj,jk+1) ) &
- & / e3uw(ji,jj,jk+1,Kmm) * z1_e3ua * wumask(ji,jj,jk+1)
- zWui = ( wi(ji,jj,jk ) + wi(ji+1,jj,jk ) ) * z1_e3ua
- zWus = ( wi(ji,jj,jk+1) + wi(ji+1,jj,jk+1) ) * z1_e3ua
- zwi(ji,jj,jk) = zzwi + zDt_2 * MIN( zWui, 0._wp )
- zws(ji,jj,jk) = zzws - zDt_2 * MAX( zWus, 0._wp )
- zwd(ji,jj,jk) = 1._wp - zzwi - zzws + zDt_2 * ( MAX( zWui, 0._wp ) - MIN( zWus, 0._wp ) )
- END_3D
- END SELECT
- DO_2D( 0, 0, 0, 0 ) !* Surface boundary conditions
- zwi(ji,jj,1) = 0._wp
- zzws = - zDt_2 * ( avm(ji+1,jj,2) + avm(ji ,jj,2) ) &
- & / ( e3u(ji,jj,1,Kaa) * e3uw(ji,jj,2,Kmm) ) * wumask(ji,jj,2)
- zWus = ( wi(ji ,jj,2) + wi(ji+1,jj,2) ) / e3u(ji,jj,1,Kaa)
- zws(ji,jj,1 ) = zzws - zDt_2 * MAX( zWus, 0._wp )
- zwd(ji,jj,1 ) = 1._wp - zzws - zDt_2 * ( MIN( zWus, 0._wp ) )
- END_2D
- ELSE
- SELECT CASE( nldf_dyn )
- CASE( np_lap_i ) ! rotated lateral mixing: add its vertical mixing (akzu)
- DO_3D( 0, 0, 0, 0, 1, jpkm1 )
- zzwi = - zDt_2 * ( avm(ji+1,jj,jk ) + avm(ji,jj,jk ) + akzu(ji,jj,jk ) ) &
- & / ( e3u(ji,jj,jk,Kaa) * e3uw(ji,jj,jk ,Kmm) ) * wumask(ji,jj,jk )
- zzws = - zDt_2 * ( avm(ji+1,jj,jk+1) + avm(ji,jj,jk+1) + akzu(ji,jj,jk+1) ) &
- & / ( e3u(ji,jj,jk,Kaa) * e3uw(ji,jj,jk+1,Kmm) ) * wumask(ji,jj,jk+1)
- zwi(ji,jj,jk) = zzwi
- zws(ji,jj,jk) = zzws
- zwd(ji,jj,jk) = 1._wp - zzwi - zzws
- END_3D
- CASE DEFAULT ! iso-level lateral mixing
- DO_3D( 0, 0, 0, 0, 1, jpkm1 )
- zzwi = - zDt_2 * ( avm(ji+1,jj,jk ) + avm(ji,jj,jk ) ) &
- & / ( e3u(ji,jj,jk,Kaa) * e3uw(ji,jj,jk ,Kmm) ) * wumask(ji,jj,jk )
- zzws = - zDt_2 * ( avm(ji+1,jj,jk+1) + avm(ji,jj,jk+1) ) &
- & / ( e3u(ji,jj,jk,Kaa) * e3uw(ji,jj,jk+1,Kmm) ) * wumask(ji,jj,jk+1)
- zwi(ji,jj,jk) = zzwi
- zws(ji,jj,jk) = zzws
- zwd(ji,jj,jk) = 1._wp - zzwi - zzws
- END_3D
- END SELECT
- DO_2D( 0, 0, 0, 0 ) !* Surface boundary conditions
- zwi(ji,jj,1) = 0._wp
- zwd(ji,jj,1) = 1._wp - zws(ji,jj,1)
- END_2D
- ENDIF
- !
- !
- ! !== Apply semi-implicit bottom friction ==!
- !
- ! Only needed for semi-implicit bottom friction setup. The explicit
- ! bottom friction has been included in "u(v)a" which act as the R.H.S
- ! column vector of the tri-diagonal matrix equation
- !
- IF ( ln_drgimp ) THEN ! implicit bottom friction
- DO_2D( 0, 0, 0, 0 )
- iku = mbku(ji,jj) ! ocean bottom level at u- and v-points
- zwd(ji,jj,iku) = zwd(ji,jj,iku) - zDt_2 *( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) ) &
- & / e3u(ji,jj,iku,Kaa)
- END_2D
- IF ( ln_isfcav.OR.ln_drgice_imp ) THEN ! top friction (always implicit)
- DO_2D( 0, 0, 0, 0 )
+ END_1D
+ IF( ln_isfcav.OR.ln_drgice_imp ) THEN ! Ocean cavities (ISF)
+ DO_1Di( 0, 0 )
+ iku = miku(ji,jj) ! top ocean level at u- and v-points
+ ikv = mikv(ji,jj) ! (first wet ocean u- and v-points)
+ puu(ji,jj,iku,Kaa) = puu(ji,jj,iku,Kaa) + zDt_2 * ( rCdU_top(ji+1,jj)+rCdU_top(ji,jj) ) * uu_b(ji,jj,Kaa) &
+ & / e3u(ji,jj,iku,Kaa)
+ pvv(ji,jj,ikv,Kaa) = pvv(ji,jj,ikv,Kaa) + zDt_2 * ( rCdU_top(ji,jj+1)+rCdU_top(ji,jj) ) * vv_b(ji,jj,Kaa) &
+ & / e3v(ji,jj,ikv,Kaa)
+ END_1D
+ END IF
+ ENDIF
+ !
+ ! !== Vertical diffusion on u ==!
+ !
+ !
+ ! !* Matrix construction
+ IF( ln_zad_Aimp ) THEN !- including terms associated with partly implicit vertical advection
+ SELECT CASE( nldf_dyn )
+ CASE( np_lap_i ) ! rotated lateral mixing: add its vertical mixing (akzu)
+ DO_2Dik( 0, 0, 1, jpkm1, 1 )
+ z1_e3ua = 1._wp / e3u(ji,jj,jk,Kaa) ! after scale factor at U-point
+ zzwi = - zDt_2 * ( ( avm(ji+1,jj,jk ) + avm(ji,jj,jk ) ) + akzu(ji,jj,jk ) ) & ! add () for NP repro
+ & / e3uw(ji,jj,jk ,Kmm) * z1_e3ua * wumask(ji,jj,jk )
+ zzws = - zDt_2 * ( ( avm(ji+1,jj,jk+1) + avm(ji,jj,jk+1) ) + akzu(ji,jj,jk+1) ) & ! add () for NP repro
+ & / e3uw(ji,jj,jk+1,Kmm) * z1_e3ua * wumask(ji,jj,jk+1)
+ zWui = ( wi(ji,jj,jk ) + wi(ji+1,jj,jk ) ) * z1_e3ua
+ zWus = ( wi(ji,jj,jk+1) + wi(ji+1,jj,jk+1) ) * z1_e3ua
+ zwi(ji,jk) = zzwi + zDt_2 * MIN( zWui, 0._wp )
+ zws(ji,jk) = zzws - zDt_2 * MAX( zWus, 0._wp )
+ zwd(ji,jk) = 1._wp - zzwi - zzws + zDt_2 * ( MAX( zWui, 0._wp ) - MIN( zWus, 0._wp ) )
+ END_2D
+ CASE DEFAULT ! iso-level lateral mixing
+ DO_2Dik( 0, 0, 1, jpkm1, 1 )
+ z1_e3ua = 1._wp / e3u(ji,jj,jk,Kaa) ! after scale factor at U-point
+ zzwi = - zDt_2 * ( avm(ji+1,jj,jk ) + avm(ji,jj,jk ) ) &
+ & / e3uw(ji,jj,jk ,Kmm) * z1_e3ua * wumask(ji,jj,jk )
+ zzws = - zDt_2 * ( avm(ji+1,jj,jk+1) + avm(ji,jj,jk+1) ) &
+ & / e3uw(ji,jj,jk+1,Kmm) * z1_e3ua * wumask(ji,jj,jk+1)
+ zWui = ( wi(ji,jj,jk ) + wi(ji+1,jj,jk ) ) * z1_e3ua
+ zWus = ( wi(ji,jj,jk+1) + wi(ji+1,jj,jk+1) ) * z1_e3ua
+ zwi(ji,jk) = zzwi + zDt_2 * MIN( zWui, 0._wp )
+ zws(ji,jk) = zzws - zDt_2 * MAX( zWus, 0._wp )
+ zwd(ji,jk) = 1._wp - zzwi - zzws + zDt_2 * ( MAX( zWui, 0._wp ) - MIN( zWus, 0._wp ) )
+ END_2D
+ END SELECT
+ !
+ zwi(:,1) = 0._wp
+ DO_1Di( 0, 0 ) !* Surface boundary conditions
+ zwi(ji,1) = 0._wp
+ zzws = - zDt_2 * ( avm(ji+1,jj,2) + avm(ji ,jj,2) ) &
+ & / ( e3u(ji,jj,1,Kaa) * e3uw(ji,jj,2,Kmm) ) * wumask(ji,jj,2)
+ zWus = ( wi(ji ,jj,2) + wi(ji+1,jj,2) ) / e3u(ji,jj,1,Kaa)
+ zws(ji,1) = zzws - zDt_2 * MAX( zWus, 0._wp )
+ zwd(ji,1) = 1._wp - zzws - zDt_2 * ( MIN( zWus, 0._wp ) )
+ END_1D
+ ELSE !- only vertical diffusive terms
+ SELECT CASE( nldf_dyn )
+ CASE( np_lap_i ) ! rotated lateral mixing: add its vertical mixing (akzu)
+ DO_2Dik( 0, 0, 1, jpkm1, 1 )
+ zzwi = - zDt_2 * ( ( avm(ji+1,jj,jk ) + avm(ji,jj,jk ) ) + akzu(ji,jj,jk ) ) & ! add () for NP repro
+ & / ( e3u(ji,jj,jk,Kaa) * e3uw(ji,jj,jk ,Kmm) ) * wumask(ji,jj,jk )
+ zzws = - zDt_2 * ( ( avm(ji+1,jj,jk+1) + avm(ji,jj,jk+1) ) + akzu(ji,jj,jk+1) ) & ! add () for NP repro
+ & / ( e3u(ji,jj,jk,Kaa) * e3uw(ji,jj,jk+1,Kmm) ) * wumask(ji,jj,jk+1)
+ zwi(ji,jk) = zzwi
+ zws(ji,jk) = zzws
+ zwd(ji,jk) = 1._wp - zzwi - zzws
+ END_2D
+ CASE DEFAULT ! iso-level lateral mixing
+ DO_2Dik( 0, 0, 1, jpkm1, 1 )
+ zzwi = - zDt_2 * ( avm(ji+1,jj,jk ) + avm(ji,jj,jk ) ) &
+ & / ( e3u(ji,jj,jk,Kaa) * e3uw(ji,jj,jk ,Kmm) ) * wumask(ji,jj,jk )
+ zzws = - zDt_2 * ( avm(ji+1,jj,jk+1) + avm(ji,jj,jk+1) ) &
+ & / ( e3u(ji,jj,jk,Kaa) * e3uw(ji,jj,jk+1,Kmm) ) * wumask(ji,jj,jk+1)
+ zwi(ji,jk) = zzwi
+ zws(ji,jk) = zzws
+ zwd(ji,jk) = 1._wp - zzwi - zzws
+ END_2D
+ END SELECT
+ !
+ zwi(:,1) = 0._wp
+ DO_1Di( 0, 0 ) !* Surface boundary conditions
+ zwd(ji,1) = 1._wp - zws(ji,1)
+ END_1D
+ ENDIF
+ !
+ !
+ ! !== Apply semi-implicit bottom friction ==!
+ !
+ ! Only needed for semi-implicit bottom friction setup. The explicit
+ ! bottom friction has been included in "u(v)a" which act as the R.H.S
+ ! column vector of the tri-diagonal matrix equation
+ !
+ IF ( ln_drgimp ) THEN ! implicit bottom friction
+ DO_1Di( 0, 0 )
+ iku = mbku(ji,jj) ! ocean bottom level at u- and v-points
+ zwd(ji,iku) = zwd(ji,iku) - zDt_2 *( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) ) / e3u(ji,jj,iku,Kaa)
+ END_1D
+ IF ( ln_isfcav.OR.ln_drgice_imp ) THEN ! top friction (always implicit)
+ DO_1Di( 0, 0 )
!!gm top Cd is masked (=0 outside cavities) no need of test on mik>=2 ==>> it has been suppressed
- iku = miku(ji,jj) ! ocean top level at u- and v-points
- zwd(ji,jj,iku) = zwd(ji,jj,iku) - zDt_2 *( rCdU_top(ji+1,jj)+rCdU_top(ji,jj) ) &
- & / e3u(ji,jj,iku,Kaa)
- END_2D
- END IF
- ENDIF
- !
- ! Matrix inversion starting from the first level
- !-----------------------------------------------------------------------
- ! solve m.x = y where m is a tri diagonal matrix ( jpk*jpk )
- !
- ! ( zwd1 zws1 0 0 0 )( zwx1 ) ( zwy1 )
- ! ( zwi2 zwd2 zws2 0 0 )( zwx2 ) ( zwy2 )
- ! ( 0 zwi3 zwd3 zws3 0 )( zwx3 )=( zwy3 )
- ! ( ... )( ... ) ( ... )
- ! ( 0 0 0 zwik zwdk )( zwxk ) ( zwyk )
- !
- ! m is decomposed in the product of an upper and a lower triangular matrix
- ! The 3 diagonal terms are in 2d arrays: zwd, zws, zwi
- ! The solution (the after velocity) is in puu(:,:,:,Kaa)
- !-----------------------------------------------------------------------
- !
- DO_3D( 0, 0, 0, 0, 2, jpkm1 ) !== First recurrence : Dk = Dk - Lk * Uk-1 / Dk-1 (increasing k) ==
- zwd(ji,jj,jk) = zwd(ji,jj,jk) - zwi(ji,jj,jk) * zws(ji,jj,jk-1) / zwd(ji,jj,jk-1)
- END_3D
- !
- DO_2D( 0, 0, 0, 0 ) !== second recurrence: SOLk = RHSk - Lk / Dk-1 Lk-1 ==!
+ iku = miku(ji,jj) ! ocean top level at u- and v-points
+ zwd(ji,iku) = zwd(ji,iku) - zDt_2 *( rCdU_top(ji+1,jj)+rCdU_top(ji,jj) ) / e3u(ji,jj,iku,Kaa)
+ END_1D
+ ENDIF
+ ENDIF
+ !
+ ! Matrix inversion starting from the first level
+ !-----------------------------------------------------------------------
+ ! solve m.x = y where m is a tri diagonal matrix ( jpk*jpk )
+ !
+ ! ( zwd1 zws1 0 0 0 )( zwx1 ) ( zwy1 )
+ ! ( zwi2 zwd2 zws2 0 0 )( zwx2 ) ( zwy2 )
+ ! ( 0 zwi3 zwd3 zws3 0 )( zwx3 )=( zwy3 )
+ ! ( ... )( ... ) ( ... )
+ ! ( 0 0 0 zwik zwdk )( zwxk ) ( zwyk )
+ !
+ ! m is decomposed in the product of an upper and a lower triangular matrix
+ ! The 3 diagonal terms are in 2d arrays: zwd, zws, zwi
+ ! The solution (the after velocity) is in puu(:,:,:,Kaa)
+ !-----------------------------------------------------------------------
+ !
+ DO_2Dik( 0, 0, 2, jpkm1, 1 ) !== First recurrence : Dk = Dk - Lk * Uk-1 / Dk-1 (increasing k) ==
+ zwd(ji,jk) = zwd(ji,jk) - zwi(ji,jk) * zws(ji,jk-1) / zwd(ji,jk-1)
+ END_2D
+ !
+ DO_1Di( 0, 0 ) !== second recurrence: SOLk = RHSk - Lk / Dk-1 Lk-1 ==!
#if defined key_RK3
- ! ! RK3: use only utau (not utau_b)
- puu(ji,jj,1,Kaa) = puu(ji,jj,1,Kaa) + rDt * utau(ji,jj) &
- & / ( e3u(ji,jj,1,Kaa) * rho0 ) * umask(ji,jj,1)
+ ! ! RK3: use only utau (not utau_b)
+ puu(ji,jj,1,Kaa) = puu(ji,jj,1,Kaa) + rDt * utauU(ji,jj) &
+ & / ( e3u(ji,jj,1,Kaa) * rho0 ) * umask(ji,jj,1)
#else
- puu(ji,jj,1,Kaa) = puu(ji,jj,1,Kaa) + zDt_2 * ( utau_b(ji,jj) + utau(ji,jj) ) &
- & / ( e3u(ji,jj,1,Kaa) * rho0 ) * umask(ji,jj,1)
+ ! ! MLF: average of utau and utau_b
+ puu(ji,jj,1,Kaa) = puu(ji,jj,1,Kaa) + zDt_2 * ( utau_b(ji,jj) + utauU(ji,jj) ) &
+ & / ( e3u(ji,jj,1,Kaa) * rho0 ) * umask(ji,jj,1)
#endif
- END_2D
- DO_3D( 0, 0, 0, 0, 2, jpkm1 )
- puu(ji,jj,jk,Kaa) = puu(ji,jj,jk,Kaa) - zwi(ji,jj,jk) / zwd(ji,jj,jk-1) * puu(ji,jj,jk-1,Kaa)
- END_3D
- !
- DO_2D( 0, 0, 0, 0 ) !== thrid recurrence : SOLk = ( Lk - Uk * Ek+1 ) / Dk ==!
- puu(ji,jj,jpkm1,Kaa) = puu(ji,jj,jpkm1,Kaa) / zwd(ji,jj,jpkm1)
- END_2D
- DO_3DS( 0, 0, 0, 0, jpk-2, 1, -1 )
- puu(ji,jj,jk,Kaa) = ( puu(ji,jj,jk,Kaa) - zws(ji,jj,jk) * puu(ji,jj,jk+1,Kaa) ) / zwd(ji,jj,jk)
- END_3D
- !
- ! !== Vertical diffusion on v ==!
- !
- ! !* Matrix construction
- IF( ln_zad_Aimp ) THEN !!
- SELECT CASE( nldf_dyn )
- CASE( np_lap_i ) ! rotated lateral mixing: add its vertical mixing (akzv)
- DO_3D( 0, 0, 0, 0, 1, jpkm1 )
- z1_e3va = 1._wp / e3v(ji,jj,jk,Kaa) ! after scale factor at V-point
- zzwi = - zDt_2 * ( avm(ji,jj+1,jk ) + avm(ji,jj,jk ) + akzv(ji,jj,jk ) ) &
- & / e3vw(ji,jj,jk ,Kmm) * z1_e3va * wvmask(ji,jj,jk )
- zzws = - zDt_2 * ( avm(ji,jj+1,jk+1) + avm(ji,jj,jk+1) + akzv(ji,jj,jk+1) ) &
- & / e3vw(ji,jj,jk+1,Kmm) * z1_e3va * wvmask(ji,jj,jk+1)
- zWvi = ( wi(ji,jj,jk ) + wi(ji,jj+1,jk ) ) * z1_e3va
- zWvs = ( wi(ji,jj,jk+1) + wi(ji,jj+1,jk+1) ) * z1_e3va
- zwi(ji,jj,jk) = zzwi + zDt_2 * MIN( zWvi, 0._wp )
- zws(ji,jj,jk) = zzws - zDt_2 * MAX( zWvs, 0._wp )
- zwd(ji,jj,jk) = 1._wp - zzwi - zzws - zDt_2 * ( - MAX( zWvi, 0._wp ) + MIN( zWvs, 0._wp ) )
- END_3D
- CASE DEFAULT ! iso-level lateral mixing
- DO_3D( 0, 0, 0, 0, 1, jpkm1 )
- z1_e3va = 1._wp / e3v(ji,jj,jk,Kaa) ! after scale factor at V-point
- zzwi = - zDt_2 * ( avm(ji,jj+1,jk ) + avm(ji,jj,jk ) ) &
- & / e3vw(ji,jj,jk ,Kmm) * z1_e3va * wvmask(ji,jj,jk )
- zzws = - zDt_2 * ( avm(ji,jj+1,jk+1) + avm(ji,jj,jk+1) ) &
- & / e3vw(ji,jj,jk+1,Kmm) * z1_e3va * wvmask(ji,jj,jk+1)
- zWvi = ( wi(ji,jj,jk ) + wi(ji,jj+1,jk ) ) * z1_e3va
- zWvs = ( wi(ji,jj,jk+1) + wi(ji,jj+1,jk+1) ) * z1_e3va
- zwi(ji,jj,jk) = zzwi + zDt_2 * MIN( zWvi, 0._wp )
- zws(ji,jj,jk) = zzws - zDt_2 * MAX( zWvs, 0._wp )
- zwd(ji,jj,jk) = 1._wp - zzwi - zzws - zDt_2 * ( - MAX( zWvi, 0._wp ) + MIN( zWvs, 0._wp ) )
- END_3D
- END SELECT
- DO_2D( 0, 0, 0, 0 ) !* Surface boundary conditions
- zwi(ji,jj,1) = 0._wp
- zzws = - zDt_2 * ( avm(ji,jj+1,2) + avm(ji,jj,2) ) &
- & / ( e3v(ji,jj,1,Kaa) * e3vw(ji,jj,2,Kmm) ) * wvmask(ji,jj,2)
- zWvs = ( wi(ji,jj ,2) + wi(ji,jj+1,2) ) / e3v(ji,jj,1,Kaa)
- zws(ji,jj,1 ) = zzws - zDt_2 * MAX( zWvs, 0._wp )
- zwd(ji,jj,1 ) = 1._wp - zzws - zDt_2 * ( MIN( zWvs, 0._wp ) )
+ END_1D
+ DO_2Dik( 0, 0, 2, jpkm1, 1 )
+ puu(ji,jj,jk,Kaa) = puu(ji,jj,jk,Kaa) - zwi(ji,jk) / zwd(ji,jk-1) * puu(ji,jj,jk-1,Kaa)
END_2D
- ELSE
- SELECT CASE( nldf_dyn )
- CASE( np_lap_i ) ! rotated lateral mixing: add its vertical mixing (akzu)
- DO_3D( 0, 0, 0, 0, 1, jpkm1 )
- zzwi = - zDt_2 * ( avm(ji,jj+1,jk ) + avm(ji,jj,jk ) + akzv(ji,jj,jk ) ) &
- & / ( e3v(ji,jj,jk,Kaa) * e3vw(ji,jj,jk ,Kmm) ) * wvmask(ji,jj,jk )
- zzws = - zDt_2 * ( avm(ji,jj+1,jk+1) + avm(ji,jj,jk+1) + akzv(ji,jj,jk+1) ) &
- & / ( e3v(ji,jj,jk,Kaa) * e3vw(ji,jj,jk+1,Kmm) ) * wvmask(ji,jj,jk+1)
- zwi(ji,jj,jk) = zzwi
- zws(ji,jj,jk) = zzws
- zwd(ji,jj,jk) = 1._wp - zzwi - zzws
- END_3D
- CASE DEFAULT ! iso-level lateral mixing
- DO_3D( 0, 0, 0, 0, 1, jpkm1 )
- zzwi = - zDt_2 * ( avm(ji,jj+1,jk ) + avm(ji,jj,jk ) ) &
- & / ( e3v(ji,jj,jk,Kaa) * e3vw(ji,jj,jk ,Kmm) ) * wvmask(ji,jj,jk )
- zzws = - zDt_2 * ( avm(ji,jj+1,jk+1) + avm(ji,jj,jk+1) ) &
- & / ( e3v(ji,jj,jk,Kaa) * e3vw(ji,jj,jk+1,Kmm) ) * wvmask(ji,jj,jk+1)
- zwi(ji,jj,jk) = zzwi
- zws(ji,jj,jk) = zzws
- zwd(ji,jj,jk) = 1._wp - zzwi - zzws
- END_3D
- END SELECT
- DO_2D( 0, 0, 0, 0 ) !* Surface boundary conditions
- zwi(ji,jj,1) = 0._wp
- zwd(ji,jj,1) = 1._wp - zws(ji,jj,1)
- END_2D
- ENDIF
- !
- ! !== Apply semi-implicit top/bottom friction ==!
- !
- ! Only needed for semi-implicit bottom friction setup. The explicit
- ! bottom friction has been included in "u(v)a" which act as the R.H.S
- ! column vector of the tri-diagonal matrix equation
- !
- IF( ln_drgimp ) THEN
- DO_2D( 0, 0, 0, 0 )
- ikv = mbkv(ji,jj) ! (deepest ocean u- and v-points)
- zwd(ji,jj,ikv) = zwd(ji,jj,ikv) - zDt_2*( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) ) &
- & / e3v(ji,jj,ikv,Kaa)
+ !
+ DO_1Di( 0, 0 ) !== thrid recurrence : SOLk = ( Lk - Uk * Ek+1 ) / Dk ==!
+ puu(ji,jj,jpkm1,Kaa) = puu(ji,jj,jpkm1,Kaa) / zwd(ji,jpkm1)
+ END_1D
+ DO_2Dik( 0, 0, jpk-2, 1, -1 )
+ puu(ji,jj,jk,Kaa) = ( puu(ji,jj,jk,Kaa) - zws(ji,jk) * puu(ji,jj,jk+1,Kaa) ) / zwd(ji,jk)
END_2D
- IF ( ln_isfcav.OR.ln_drgice_imp ) THEN
- DO_2D( 0, 0, 0, 0 )
- ikv = mikv(ji,jj) ! (first wet ocean u- and v-points)
- zwd(ji,jj,ikv) = zwd(ji,jj,ikv) - zDt_2*( rCdU_top(ji,jj+1)+rCdU_top(ji,jj) ) &
+ !
+ !
+ ! !== Vertical diffusion on v ==!
+ !
+ ! !* Matrix construction
+ IF( ln_zad_Aimp ) THEN !!
+ SELECT CASE( nldf_dyn )
+ CASE( np_lap_i ) ! rotated lateral mixing: add its vertical mixing (akzv)
+ DO_2Dik( 0, 0, 1, jpkm1, 1 )
+ z1_e3va = 1._wp / e3v(ji,jj,jk,Kaa) ! after scale factor at V-point
+ zzwi = - zDt_2 * ( ( avm(ji,jj+1,jk ) + avm(ji,jj,jk ) ) + akzv(ji,jj,jk ) ) & ! add () for NP repro
+ & / e3vw(ji,jj,jk ,Kmm) * z1_e3va * wvmask(ji,jj,jk )
+ zzws = - zDt_2 * ( ( avm(ji,jj+1,jk+1) + avm(ji,jj,jk+1) ) + akzv(ji,jj,jk+1) ) & ! add () for NP repro
+ & / e3vw(ji,jj,jk+1,Kmm) * z1_e3va * wvmask(ji,jj,jk+1)
+ zWvi = ( wi(ji,jj,jk ) + wi(ji,jj+1,jk ) ) * z1_e3va
+ zWvs = ( wi(ji,jj,jk+1) + wi(ji,jj+1,jk+1) ) * z1_e3va
+ zwi(ji,jk) = zzwi + zDt_2 * MIN( zWvi, 0._wp )
+ zws(ji,jk) = zzws - zDt_2 * MAX( zWvs, 0._wp )
+ zwd(ji,jk) = 1._wp - zzwi - zzws - zDt_2 * ( - MAX( zWvi, 0._wp ) + MIN( zWvs, 0._wp ) )
+ END_2D
+ CASE DEFAULT ! iso-level lateral mixing
+ DO_2Dik( 0, 0, 1, jpkm1, 1 )
+ z1_e3va = 1._wp / e3v(ji,jj,jk,Kaa) ! after scale factor at V-point
+ zzwi = - zDt_2 * ( avm(ji,jj+1,jk ) + avm(ji,jj,jk ) ) &
+ & / e3vw(ji,jj,jk ,Kmm) * z1_e3va * wvmask(ji,jj,jk )
+ zzws = - zDt_2 * ( avm(ji,jj+1,jk+1) + avm(ji,jj,jk+1) ) &
+ & / e3vw(ji,jj,jk+1,Kmm) * z1_e3va * wvmask(ji,jj,jk+1)
+ zWvi = ( wi(ji,jj,jk ) + wi(ji,jj+1,jk ) ) * z1_e3va
+ zWvs = ( wi(ji,jj,jk+1) + wi(ji,jj+1,jk+1) ) * z1_e3va
+ zwi(ji,jk) = zzwi + zDt_2 * MIN( zWvi, 0._wp )
+ zws(ji,jk) = zzws - zDt_2 * MAX( zWvs, 0._wp )
+ zwd(ji,jk) = 1._wp - zzwi - zzws - zDt_2 * ( - MAX( zWvi, 0._wp ) + MIN( zWvs, 0._wp ) )
+ END_2D
+ END SELECT
+ DO_1Di( 0, 0 ) !* Surface boundary conditions
+ zwi(ji,1) = 0._wp
+ zzws = - zDt_2 * ( avm(ji,jj+1,2) + avm(ji,jj,2) ) &
+ & / ( e3v(ji,jj,1,Kaa) * e3vw(ji,jj,2,Kmm) ) * wvmask(ji,jj,2)
+ zWvs = ( wi(ji,jj ,2) + wi(ji,jj+1,2) ) / e3v(ji,jj,1,Kaa)
+ zws(ji,1 ) = zzws - zDt_2 * MAX( zWvs, 0._wp )
+ zwd(ji,1 ) = 1._wp - zzws - zDt_2 * ( MIN( zWvs, 0._wp ) )
+ END_1D
+ ELSE
+ SELECT CASE( nldf_dyn )
+ CASE( np_lap_i ) ! rotated lateral mixing: add its vertical mixing (akzu)
+ DO_2Dik( 0, 0, 1, jpkm1, 1 )
+ zzwi = - zDt_2 * ( ( avm(ji,jj+1,jk ) + avm(ji,jj,jk ) ) + akzv(ji,jj,jk ) ) & ! add () for NP repro
+ & / ( e3v(ji,jj,jk,Kaa) * e3vw(ji,jj,jk ,Kmm) ) * wvmask(ji,jj,jk )
+ zzws = - zDt_2 * ( ( avm(ji,jj+1,jk+1) + avm(ji,jj,jk+1) ) + akzv(ji,jj,jk+1) ) & ! add () for NP repro
+ & / ( e3v(ji,jj,jk,Kaa) * e3vw(ji,jj,jk+1,Kmm) ) * wvmask(ji,jj,jk+1)
+ zwi(ji,jk) = zzwi
+ zws(ji,jk) = zzws
+ zwd(ji,jk) = 1._wp - zzwi - zzws
+ END_2D
+ CASE DEFAULT ! iso-level lateral mixing
+ DO_2Dik( 0, 0, 1, jpkm1, 1 )
+ zzwi = - zDt_2 * ( avm(ji,jj+1,jk ) + avm(ji,jj,jk ) ) &
+ & / ( e3v(ji,jj,jk,Kaa) * e3vw(ji,jj,jk ,Kmm) ) * wvmask(ji,jj,jk )
+ zzws = - zDt_2 * ( avm(ji,jj+1,jk+1) + avm(ji,jj,jk+1) ) &
+ & / ( e3v(ji,jj,jk,Kaa) * e3vw(ji,jj,jk+1,Kmm) ) * wvmask(ji,jj,jk+1)
+ zwi(ji,jk) = zzwi
+ zws(ji,jk) = zzws
+ zwd(ji,jk) = 1._wp - zzwi - zzws
+ END_2D
+ END SELECT
+ DO_1Di( 0, 0 ) !* Surface boundary conditions
+ zwi(ji,1) = 0._wp
+ zwd(ji,1) = 1._wp - zws(ji,1)
+ END_1D
+ ENDIF
+ !
+ ! !== Apply semi-implicit top/bottom friction ==!
+ !
+ ! Only needed for semi-implicit bottom friction setup. The explicit
+ ! bottom friction has been included in "u(v)a" which act as the R.H.S
+ ! column vector of the tri-diagonal matrix equation
+ !
+ IF( ln_drgimp ) THEN
+ DO_1Di( 0, 0 )
+ ikv = mbkv(ji,jj) ! (deepest ocean u- and v-points)
+ zwd(ji,ikv) = zwd(ji,ikv) - zDt_2*( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) ) &
& / e3v(ji,jj,ikv,Kaa)
- END_2D
+ END_1D
+ IF ( ln_isfcav.OR.ln_drgice_imp ) THEN
+ DO_1Di( 0, 0 )
+ ikv = mikv(ji,jj) ! (first wet ocean u- and v-points)
+ zwd(ji,ikv) = zwd(ji,ikv) - zDt_2*( rCdU_top(ji,jj+1)+rCdU_top(ji,jj) ) &
+ & / e3v(ji,jj,ikv,Kaa)
+ END_1D
+ ENDIF
ENDIF
- ENDIF
- ! Matrix inversion
- !-----------------------------------------------------------------------
- ! solve m.x = y where m is a tri diagonal matrix ( jpk*jpk )
- !
- ! ( zwd1 zws1 0 0 0 )( zwx1 ) ( zwy1 )
- ! ( zwi2 zwd2 zws2 0 0 )( zwx2 ) ( zwy2 )
- ! ( 0 zwi3 zwd3 zws3 0 )( zwx3 )=( zwy3 )
- ! ( ... )( ... ) ( ... )
- ! ( 0 0 0 zwik zwdk )( zwxk ) ( zwyk )
- !
- ! m is decomposed in the product of an upper and lower triangular matrix
- ! The 3 diagonal terms are in 2d arrays: zwd, zws, zwi
- ! The solution (after velocity) is in 2d array va
- !-----------------------------------------------------------------------
- !
- DO_3D( 0, 0, 0, 0, 2, jpkm1 ) !== First recurrence : Dk = Dk - Lk * Uk-1 / Dk-1 (increasing k) ==
- zwd(ji,jj,jk) = zwd(ji,jj,jk) - zwi(ji,jj,jk) * zws(ji,jj,jk-1) / zwd(ji,jj,jk-1)
- END_3D
- !
- DO_2D( 0, 0, 0, 0 ) !== second recurrence: SOLk = RHSk - Lk / Dk-1 Lk-1 ==!
+ ! Matrix inversion
+ !-----------------------------------------------------------------------
+ ! solve m.x = y where m is a tri diagonal matrix ( jpk*jpk )
+ !
+ ! ( zwd1 zws1 0 0 0 )( zwx1 ) ( zwy1 )
+ ! ( zwi2 zwd2 zws2 0 0 )( zwx2 ) ( zwy2 )
+ ! ( 0 zwi3 zwd3 zws3 0 )( zwx3 )=( zwy3 )
+ ! ( ... )( ... ) ( ... )
+ ! ( 0 0 0 zwik zwdk )( zwxk ) ( zwyk )
+ !
+ ! m is decomposed in the product of an upper and lower triangular matrix
+ ! The 3 diagonal terms are in 2d arrays: zwd, zws, zwi
+ ! The solution (after velocity) is in 2d array va
+ !-----------------------------------------------------------------------
+ !
+ DO_2Dik( 0, 0, 2, jpkm1, 1 ) !== First recurrence : Dk = Dk - Lk * Uk-1 / Dk-1 (increasing k) ==
+ zwd(ji,jk) = zwd(ji,jk) - zwi(ji,jk) * zws(ji,jk-1) / zwd(ji,jk-1)
+ END_2D
+ !
+ DO_1Di( 0, 0 ) !== second recurrence: SOLk = RHSk - Lk / Dk-1 Lk-1 ==!
#if defined key_RK3
- ! ! RK3: use only vtau (not vtau_b)
- pvv(ji,jj,1,Kaa) = pvv(ji,jj,1,Kaa) + rDt * vtau(ji,jj) &
- & / ( e3v(ji,jj,1,Kaa) * rho0 ) * vmask(ji,jj,1)
+ ! ! RK3: use only vtau (not vtau_b)
+ pvv(ji,jj,1,Kaa) = pvv(ji,jj,1,Kaa) + rDt * vtauV(ji,jj) &
+ & / ( e3v(ji,jj,1,Kaa) * rho0 ) * vmask(ji,jj,1)
#else
- pvv(ji,jj,1,Kaa) = pvv(ji,jj,1,Kaa) + zDt_2*( vtau_b(ji,jj) + vtau(ji,jj) ) &
- & / ( e3v(ji,jj,1,Kaa) * rho0 ) * vmask(ji,jj,1)
+ ! ! MLF: average of vtau and vtau_b
+ pvv(ji,jj,1,Kaa) = pvv(ji,jj,1,Kaa) + zDt_2*( vtau_b(ji,jj) + vtauV(ji,jj) ) &
+ & / ( e3v(ji,jj,1,Kaa) * rho0 ) * vmask(ji,jj,1)
#endif
- END_2D
- DO_3D( 0, 0, 0, 0, 2, jpkm1 )
- pvv(ji,jj,jk,Kaa) = pvv(ji,jj,jk,Kaa) - zwi(ji,jj,jk) / zwd(ji,jj,jk-1) * pvv(ji,jj,jk-1,Kaa)
- END_3D
- !
- DO_2D( 0, 0, 0, 0 ) !== third recurrence : SOLk = ( Lk - Uk * SOLk+1 ) / Dk ==!
- pvv(ji,jj,jpkm1,Kaa) = pvv(ji,jj,jpkm1,Kaa) / zwd(ji,jj,jpkm1)
- END_2D
- DO_3DS( 0, 0, 0, 0, jpk-2, 1, -1 )
- pvv(ji,jj,jk,Kaa) = ( pvv(ji,jj,jk,Kaa) - zws(ji,jj,jk) * pvv(ji,jj,jk+1,Kaa) ) / zwd(ji,jj,jk)
- END_3D
+ END_1D
+ DO_2Dik( 0, 0, 2, jpkm1, 1 )
+ pvv(ji,jj,jk,Kaa) = pvv(ji,jj,jk,Kaa) - zwi(ji,jk) / zwd(ji,jk-1) * pvv(ji,jj,jk-1,Kaa)
+ END_2D
+ !
+ DO_1Di( 0, 0 ) !== third recurrence : SOLk = ( Lk - Uk * SOLk+1 ) / Dk ==!
+ pvv(ji,jj,jpkm1,Kaa) = pvv(ji,jj,jpkm1,Kaa) / zwd(ji,jpkm1)
+ END_1D
+ DO_2Dik( 0, 0, jpk-2, 1, -1 )
+ pvv(ji,jj,jk,Kaa) = ( pvv(ji,jj,jk,Kaa) - zws(ji,jk) * pvv(ji,jj,jk+1,Kaa) ) / zwd(ji,jk)
+ END_2D
+ ! ! ================= !
+ END_1D ! i-k slices loop !
+ ! ! ================= !
!
IF( l_trddyn ) THEN ! save the vertical diffusive trends for further diagnostics
ztrdu(:,:,:) = ( puu(:,:,:,Kaa) - puu(:,:,:,Kbb) )*r1_Dt - ztrdu(:,:,:)
diff --git a/src/OCE/DYN/sshwzv.F90 b/src/OCE/DYN/sshwzv.F90
index 0e2569708b8b4419148cddcaa94827a9fa65c3e7..f4c74fb5983d0219e0ddee0466111aa5014d5ef7 100644
--- a/src/OCE/DYN/sshwzv.F90
+++ b/src/OCE/DYN/sshwzv.F90
@@ -24,7 +24,6 @@ MODULE sshwzv
USE isf_oce ! ice shelf
USE dom_oce ! ocean space and time domain variables
USE sbc_oce ! surface boundary condition: ocean
- USE domvvl ! Variable volume
USE divhor ! horizontal divergence
USE phycst ! physical constants
USE bdy_oce , ONLY : ln_bdy, bdytmask ! Open BounDarY
@@ -86,7 +85,6 @@ CONTAINS
INTEGER :: ji, jj, jk ! dummy loop index
REAL(wp) :: zcoef ! local scalar
REAL(wp), DIMENSION(jpi,jpj) :: zhdiv ! 2D workspace
- REAL(wp), DIMENSION(jpi,jpj,jpk) :: z3d ! 3D workspace
!!----------------------------------------------------------------------
!
IF( ln_timing ) CALL timing_start('ssh_nxt')
@@ -175,40 +173,15 @@ CONTAINS
IF(lwp) WRITE(numout,*) 'wzv_MLF : now vertical velocity '
IF(lwp) WRITE(numout,*) '~~~~~~~'
!
- pww(:,:,jpk) = 0._wp ! bottom boundary condition: w=0 (set once for all)
+ pww(:,:,:) = 0._wp ! bottom boundary condition: w=0 (set once for all)
+ ! ! needed over the halos for the output (ww+wi) in diawri.F90
ENDIF
! !------------------------------!
! ! Now Vertical Velocity !
! !------------------------------!
!
- ! !===============================!
- IF( ln_vvl_ztilde .OR. ln_vvl_layer ) THEN !== z_tilde and layer cases ==!
- ! !===============================!
- ALLOCATE( zhdiv(jpi,jpj,jpk) )
- !
- DO jk = 1, jpkm1
- ! horizontal divergence of thickness diffusion transport ( velocity multiplied by e3t)
- ! - ML - note: computation already done in dom_vvl_sf_nxt. Could be optimized (not critical and clearer this way)
- DO_2D( nn_hls-1, nn_hls, nn_hls-1, nn_hls )
- zhdiv(ji,jj,jk) = r1_e1e2t(ji,jj) * ( un_td(ji,jj,jk) - un_td(ji-1,jj,jk) + vn_td(ji,jj,jk) - vn_td(ji,jj-1,jk) )
- END_2D
- END DO
- IF( nn_hls == 1) CALL lbc_lnk('sshwzv', zhdiv, 'T', 1.0_wp) ! - ML - Perhaps not necessary: not used for horizontal "connexions"
- ! ! Is it problematic to have a wrong vertical velocity in boundary cells?
- ! ! Same question holds for hdiv. Perhaps just for security
- ! ! clem: yes it is a problem because ww is used in many other places where we need the halos
- !
- DO_3DS( nn_hls-1, nn_hls, nn_hls-1, nn_hls, jpkm1, 1, -1 ) ! integrate from the bottom the hor. divergence
- ! computation of w
- pww(ji,jj,jk) = pww(ji,jj,jk+1) - ( e3t(ji,jj,jk,Kmm) * hdiv(ji,jj,jk) &
- & + zhdiv(ji,jj,jk) &
- & + r1_Dt * ( e3t(ji,jj,jk,Kaa) &
- & - e3t(ji,jj,jk,Kbb) ) ) * tmask(ji,jj,jk)
- END_3D
- ! IF( ln_vvl_layer ) pww(:,:,:) = 0.e0
- DEALLOCATE( zhdiv )
- ! !=================================!
- ELSEIF( ln_linssh ) THEN !== linear free surface cases ==!
+ ! !=================================!
+ IF( ln_linssh ) THEN !== linear free surface cases ==!
! !=================================!
DO_3DS( nn_hls-1, nn_hls, nn_hls-1, nn_hls, jpkm1, 1, -1 ) ! integrate from the bottom the hor. divergence
pww(ji,jj,jk) = pww(ji,jj,jk+1) - ( e3t(ji,jj,jk,Kmm) * hdiv(ji,jj,jk) ) * tmask(ji,jj,jk)
@@ -220,11 +193,10 @@ CONTAINS
#if defined key_qco
!!gm slightly faster
pww(ji,jj,jk) = pww(ji,jj,jk+1) - ( e3t(ji,jj,jk,Kmm) * hdiv(ji,jj,jk) &
- & + r1_Dt * e3t_0(ji,jj,jk) * ( r3t(ji,jj,Kaa) - r3t(ji,jj,Kbb) ) ) * tmask(ji,jj,jk)
+ & + r1_Dt * e3t_0(ji,jj,jk) * ( r3t(ji,jj,Kaa) - r3t(ji,jj,Kbb) ) ) * tmask(ji,jj,jk)
#else
pww(ji,jj,jk) = pww(ji,jj,jk+1) - ( e3t(ji,jj,jk,Kmm) * hdiv(ji,jj,jk) &
- & + r1_Dt * ( e3t(ji,jj,jk,Kaa) &
- & - e3t(ji,jj,jk,Kbb) ) ) * tmask(ji,jj,jk)
+ & + r1_Dt * ( e3t(ji,jj,jk,Kaa) - e3t(ji,jj,jk,Kbb) ) ) * tmask(ji,jj,jk)
#endif
END_3D
ENDIF
@@ -244,28 +216,28 @@ CONTAINS
! inside computational domain (cosmetic)
DO jk = 1, jpkm1
IF( lk_west ) THEN ! --- West --- !
- DO ji = mi0(2+nn_hls), mi1(2+nn_hls)
+ DO ji = mi0(2+nn_hls,nn_hls), mi1(2+nn_hls,nn_hls)
DO jj = 1, jpj
pww(ji,jj,jk) = 0._wp
END DO
END DO
ENDIF
IF( lk_east ) THEN ! --- East --- !
- DO ji = mi0(jpiglo-1-nn_hls), mi1(jpiglo-1-nn_hls)
+ DO ji = mi0(jpiglo-1-nn_hls,nn_hls), mi1(jpiglo-1-nn_hls,nn_hls)
DO jj = 1, jpj
pww(ji,jj,jk) = 0._wp
END DO
END DO
ENDIF
IF( lk_south ) THEN ! --- South --- !
- DO jj = mj0(2+nn_hls), mj1(2+nn_hls)
+ DO jj = mj0(2+nn_hls,nn_hls), mj1(2+nn_hls,nn_hls)
DO ji = 1, jpi
pww(ji,jj,jk) = 0._wp
END DO
END DO
ENDIF
IF( lk_north ) THEN ! --- North --- !
- DO jj = mj0(jpjglo-1-nn_hls), mj1(jpjglo-1-nn_hls)
+ DO jj = mj0(jpjglo-1-nn_hls,nn_hls), mj1(jpjglo-1-nn_hls,nn_hls)
DO ji = 1, jpi
pww(ji,jj,jk) = 0._wp
END DO
@@ -314,7 +286,8 @@ CONTAINS
IF(lwp) WRITE(numout,*) 'wzv_RK3 : now vertical velocity '
IF(lwp) WRITE(numout,*) '~~~~~ '
!
- pww(:,:,jpk) = 0._wp ! bottom boundary condition: w=0 (set once for all)
+ pww(:,:,:) = 0._wp ! bottom boundary condition: w=0 (set once for all)
+ ! ! needed over the halos for the output (ww+wi) in diawri.F90
ENDIF
!
CALL div_hor( kt, Kbb, Kmm, puu, pvv, ze3div )
@@ -322,30 +295,8 @@ CONTAINS
! ! Now Vertical Velocity !
! !------------------------------!
!
- ! !===============================!
- IF( ln_vvl_ztilde .OR. ln_vvl_layer ) THEN !== z_tilde and layer cases ==!
- ! !===============================!
- ALLOCATE( zhdiv(jpi,jpj,jpk) )
- !
- DO jk = 1, jpkm1
- ! horizontal divergence of thickness diffusion transport ( velocity multiplied by e3t)
- ! - ML - note: computation already done in dom_vvl_sf_nxt. Could be optimized (not critical and clearer this way)
- DO_2D( nn_hls-1, nn_hls, nn_hls-1, nn_hls )
- zhdiv(ji,jj,jk) = r1_e1e2t(ji,jj) * ( un_td(ji,jj,jk) - un_td(ji-1,jj,jk) + vn_td(ji,jj,jk) - vn_td(ji,jj-1,jk) )
- END_2D
- END DO
- IF( nn_hls == 1) CALL lbc_lnk('sshwzv', zhdiv, 'T', 1.0_wp) ! - ML - Perhaps not necessary: not used for horizontal "connexions"
- ! ! Is it problematic to have a wrong vertical velocity in boundary cells?
- ! ! Same question holds for hdiv. Perhaps just for security
- DO_3DS( nn_hls-1, nn_hls, nn_hls-1, nn_hls, jpkm1, 1, -1 ) ! integrate from the bottom the hor. divergence
- pww(ji,jj,jk) = pww(ji,jj,jk+1) - ( ze3div(ji,jj,jk) + zhdiv(ji,jj,jk) &
- & + r1_Dt * ( e3t(ji,jj,jk,Kaa) &
- & - e3t(ji,jj,jk,Kbb) ) ) * tmask(ji,jj,jk)
- END_3D
- !
- DEALLOCATE( zhdiv )
- ! !=================================!
- ELSEIF( ln_linssh ) THEN !== linear free surface cases ==!
+ ! !=================================!
+ IF( ln_linssh ) THEN !== linear free surface cases ==!
! !=================================!
DO_3DS( nn_hls-1, nn_hls, nn_hls-1, nn_hls, jpkm1, 1, -1 ) ! integrate from the bottom the hor. divergence
pww(ji,jj,jk) = pww(ji,jj,jk+1) - ze3div(ji,jj,jk)
@@ -375,28 +326,28 @@ CONTAINS
! inside computational domain (cosmetic)
DO jk = 1, jpkm1
IF( lk_west ) THEN ! --- West --- !
- DO ji = mi0(2+nn_hls), mi1(2+nn_hls)
+ DO ji = mi0(2+nn_hls,nn_hls), mi1(2+nn_hls,nn_hls)
DO jj = 1, jpj
pww(ji,jj,jk) = 0._wp
END DO
END DO
ENDIF
IF( lk_east ) THEN ! --- East --- !
- DO ji = mi0(jpiglo-1-nn_hls), mi1(jpiglo-1-nn_hls)
+ DO ji = mi0(jpiglo-1-nn_hls,nn_hls), mi1(jpiglo-1-nn_hls,nn_hls)
DO jj = 1, jpj
pww(ji,jj,jk) = 0._wp
END DO
END DO
ENDIF
IF( lk_south ) THEN ! --- South --- !
- DO jj = mj0(2+nn_hls), mj1(2+nn_hls)
+ DO jj = mj0(2+nn_hls,nn_hls), mj1(2+nn_hls,nn_hls)
DO ji = 1, jpi
pww(ji,jj,jk) = 0._wp
END DO
END DO
ENDIF
IF( lk_north ) THEN ! --- North --- !
- DO jj = mj0(jpjglo-1-nn_hls), mj1(jpjglo-1-nn_hls)
+ DO jj = mj0(jpjglo-1-nn_hls,nn_hls), mj1(jpjglo-1-nn_hls,nn_hls)
DO ji = 1, jpi
pww(ji,jj,jk) = 0._wp
END DO
@@ -507,24 +458,6 @@ CONTAINS
!
! Calculate Courant numbers
zdt = 2._wp * rn_Dt ! 2*rn_Dt and not rDt (for restartability)
- IF( ln_vvl_ztilde .OR. ln_vvl_layer ) THEN
- DO_3D( nn_hls-1, nn_hls, nn_hls-1, nn_hls, 1, jpkm1 )
- z1_e3t = 1._wp / e3t(ji,jj,jk,Kmm)
- Cu_adv(ji,jj,jk) = zdt * &
- & ( ( MAX( ww(ji,jj,jk) , 0._wp ) - MIN( ww(ji,jj,jk+1) , 0._wp ) ) &
- & + ( MAX( e2u(ji ,jj) * e3u(ji ,jj,jk,Kmm) &
- & * uu (ji ,jj,jk,Kmm) + un_td(ji ,jj,jk), 0._wp ) - &
- & MIN( e2u(ji-1,jj) * e3u(ji-1,jj,jk,Kmm) &
- & * uu (ji-1,jj,jk,Kmm) + un_td(ji-1,jj,jk), 0._wp ) ) &
- & * r1_e1e2t(ji,jj) &
- & + ( MAX( e1v(ji,jj ) * e3v(ji,jj ,jk,Kmm) &
- & * vv (ji,jj ,jk,Kmm) + vn_td(ji,jj ,jk), 0._wp ) - &
- & MIN( e1v(ji,jj-1) * e3v(ji,jj-1,jk,Kmm) &
- & * vv (ji,jj-1,jk,Kmm) + vn_td(ji,jj-1,jk), 0._wp ) ) &
- & * r1_e1e2t(ji,jj) &
- & ) * z1_e3t
- END_3D
- ELSE
DO_3D( nn_hls-1, nn_hls, nn_hls-1, nn_hls, 1, jpkm1 )
z1_e3t = 1._wp / e3t(ji,jj,jk,Kmm)
Cu_adv(ji,jj,jk) = zdt * &
@@ -537,7 +470,6 @@ CONTAINS
& * r1_e1e2t(ji,jj) &
& ) * z1_e3t
END_3D
- ENDIF
CALL iom_put("Courant",Cu_adv)
!
IF( MAXVAL( Cu_adv(:,:,:) ) > Cu_min ) THEN ! Quick check if any breaches anywhere
diff --git a/src/OCE/DYN/wet_dry.F90 b/src/OCE/DYN/wet_dry.F90
index 465134503a2995b5d1544e27f1ee7727011e42ea..f1d5e0fdfcbb0029746dbd8b0e7301b6a0911170 100644
--- a/src/OCE/DYN/wet_dry.F90
+++ b/src/OCE/DYN/wet_dry.F90
@@ -179,10 +179,10 @@ CONTAINS
IF( tmask(ji,jj,1) < 0.5_wp ) CYCLE ! we don't care about land cells
IF( ht_0(ji,jj) - ssh_ref > zdepwd ) CYCLE ! and cells which are unlikely to dry
!
- zflxp(ji,jj) = MAX( zflxu(ji,jj) , 0._wp ) - MIN( zflxu(ji-1,jj ) , 0._wp ) &
- & + MAX( zflxv(ji,jj) , 0._wp ) - MIN( zflxv(ji, jj-1) , 0._wp )
- zflxn(ji,jj) = MIN( zflxu(ji,jj) , 0._wp ) - MAX( zflxu(ji-1,jj ) , 0._wp ) &
- & + MIN( zflxv(ji,jj) , 0._wp ) - MAX( zflxv(ji, jj-1) , 0._wp )
+ zflxp(ji,jj) = ( MAX( zflxu(ji,jj) , 0._wp ) - MIN( zflxu(ji-1,jj ) , 0._wp ) ) & ! add () for NP repro
+ & + ( MAX( zflxv(ji,jj) , 0._wp ) - MIN( zflxv(ji, jj-1) , 0._wp ) )
+ zflxn(ji,jj) = ( MIN( zflxu(ji,jj) , 0._wp ) - MAX( zflxu(ji-1,jj ) , 0._wp ) ) & ! add () for NP repro
+ & + ( MIN( zflxv(ji,jj) , 0._wp ) - MAX( zflxv(ji, jj-1) , 0._wp ) )
!
zdep2 = ht_0(ji,jj) + psshb1(ji,jj) - rn_wdmin1
IF( zdep2 <= 0._wp ) THEN ! add more safty, but not necessary
@@ -217,10 +217,10 @@ CONTAINS
!
ztmp = e1e2t(ji,jj)
!
- zzflxp = MAX( zflxu1(ji,jj) , 0._wp ) - MIN( zflxu1(ji-1,jj ) , 0._wp) &
- & + MAX( zflxv1(ji,jj) , 0._wp ) - MIN( zflxv1(ji, jj-1) , 0._wp)
- zzflxn = MIN( zflxu1(ji,jj) , 0._wp ) - MAX( zflxu1(ji-1,jj ) , 0._wp) &
- & + MIN( zflxv1(ji,jj) , 0._wp ) - MAX( zflxv1(ji, jj-1) , 0._wp)
+ zzflxp = ( MAX( zflxu1(ji,jj) , 0._wp ) - MIN( zflxu1(ji-1,jj ) , 0._wp) ) & ! add () for NP repro
+ & + ( MAX( zflxv1(ji,jj) , 0._wp ) - MIN( zflxv1(ji, jj-1) , 0._wp) )
+ zzflxn = ( MIN( zflxu1(ji,jj) , 0._wp ) - MAX( zflxu1(ji-1,jj ) , 0._wp) ) & ! add () for NP repro
+ & + ( MIN( zflxv1(ji,jj) , 0._wp ) - MAX( zflxv1(ji, jj-1) , 0._wp) )
!
zdep1 = (zzflxp + zzflxn) * z2dt / ztmp
zdep2 = ht_0(ji,jj) + psshb1(ji,jj) - rn_wdmin1 - z2dt * psshemp(ji,jj)
@@ -312,10 +312,10 @@ CONTAINS
IF( tmask(ji, jj, 1 ) < 0.5_wp) CYCLE ! we don't care about land cells
IF( ht_0(ji,jj) > zdepwd ) CYCLE ! and cells which are unlikely to dry
!
- zflxp(ji,jj) = MAX( zflxu(ji,jj) , 0._wp ) - MIN( zflxu(ji-1,jj ) , 0._wp ) &
- & + MAX( zflxv(ji,jj) , 0._wp ) - MIN( zflxv(ji, jj-1) , 0._wp )
- zflxn(ji,jj) = MIN( zflxu(ji,jj) , 0._wp ) - MAX( zflxu(ji-1,jj ) , 0._wp ) &
- & + MIN( zflxv(ji,jj) , 0._wp ) - MAX( zflxv(ji, jj-1) , 0._wp )
+ zflxp(ji,jj) = ( MAX( zflxu(ji,jj) , 0._wp ) - MIN( zflxu(ji-1,jj ) , 0._wp ) ) & ! add () for NP repro
+ & + ( MAX( zflxv(ji,jj) , 0._wp ) - MIN( zflxv(ji, jj-1) , 0._wp ) )
+ zflxn(ji,jj) = ( MIN( zflxu(ji,jj) , 0._wp ) - MAX( zflxu(ji-1,jj ) , 0._wp ) ) & ! add () for NP repro
+ & + ( MIN( zflxv(ji,jj) , 0._wp ) - MAX( zflxv(ji, jj-1) , 0._wp ) )
!
zdep2 = ht_0(ji,jj) + sshn_e(ji,jj) - rn_wdmin1
IF( zdep2 <= 0._wp ) THEN !add more safety, but not necessary
@@ -340,10 +340,10 @@ CONTAINS
!
ztmp = e1e2t(ji,jj)
!
- zzflxp = max(zflxu1(ji,jj), 0._wp) - min(zflxu1(ji-1,jj), 0._wp) &
- & + max(zflxv1(ji,jj), 0._wp) - min(zflxv1(ji, jj-1), 0._wp)
- zzflxn = min(zflxu1(ji,jj), 0._wp) - max(zflxu1(ji-1,jj), 0._wp) &
- & + min(zflxv1(ji,jj), 0._wp) - max(zflxv1(ji, jj-1), 0._wp)
+ zzflxp = ( MAX(zflxu1(ji,jj), 0._wp) - MIN(zflxu1(ji-1,jj), 0._wp) ) & ! add () for NP repro
+ & + ( MAX(zflxv1(ji,jj), 0._wp) - MIN(zflxv1(ji, jj-1), 0._wp) )
+ zzflxn = ( MIN(zflxu1(ji,jj), 0._wp) - MAX(zflxu1(ji-1,jj), 0._wp) ) & ! add () for NP repro
+ & + ( MIN(zflxv1(ji,jj), 0._wp) - MAX(zflxv1(ji, jj-1), 0._wp) )
zdep1 = (zzflxp + zzflxn) * z2dt / ztmp
zdep2 = ht_0(ji,jj) + sshn_e(ji,jj) - rn_wdmin1 - z2dt * zssh_frc(ji,jj)
diff --git a/src/OCE/FLO/floblk.F90 b/src/OCE/FLO/floblk.F90
index 4d7450719ab228425db24064880ac5da1d0ec18a..95b0682aa7b545475ac0cdee78bdebddf2bf6b45 100644
--- a/src/OCE/FLO/floblk.F90
+++ b/src/OCE/FLO/floblk.F90
@@ -105,10 +105,10 @@ CONTAINS
iloop = 0
222 DO jfl = 1, jpnfl
# if ! defined key_mpi_off
- IF( iil(jfl) >= mig(Nis0) .AND. iil(jfl) <= mig(Nie0) .AND. &
- ijl(jfl) >= mjg(Njs0) .AND. ijl(jfl) <= mjg(Nje0) ) THEN
- iiloc(jfl) = iil(jfl) - mig(1) + 1
- ijloc(jfl) = ijl(jfl) - mjg(1) + 1
+ IF( iil(jfl) >= mig(Nis0,nn_hls) .AND. iil(jfl) <= mig(Nie0,nn_hls) .AND. &
+ ijl(jfl) >= mjg(Njs0,nn_hls) .AND. ijl(jfl) <= mjg(Nje0,nn_hls) ) THEN
+ iiloc(jfl) = iil(jfl) - mig(1,nn_hls) + 1
+ ijloc(jfl) = ijl(jfl) - mjg(1,nn_hls) + 1
# else
iiloc(jfl) = iil(jfl)
ijloc(jfl) = ijl(jfl)
diff --git a/src/OCE/FLO/flodom.F90 b/src/OCE/FLO/flodom.F90
index e6536bd9b32af679fe007c8740c59c85b26dab6b..2a0210d4ed8c917a7ccf0e5c3f62f224f961b0a0 100644
--- a/src/OCE/FLO/flodom.F90
+++ b/src/OCE/FLO/flodom.F90
@@ -234,8 +234,8 @@ CONTAINS
zdyad = flo_dstnce( flxx(jfl), flyy(jfl), flxx(jfl), gphif(iimfl(jfl)-1,ijmfl(jfl)-1) )
! Translation of this distances (in meter) in indexes
- zgifl(jfl)= (iimfl(jfl)-0.5) + zdxab/e1u(iimfl(jfl)-1,ijmfl(jfl)) + (mig(1)-1)
- zgjfl(jfl)= (ijmfl(jfl)-0.5) + zdyad/e2v(iimfl(jfl),ijmfl(jfl)-1) + (mjg(1)-1)
+ zgifl(jfl)= (iimfl(jfl)-0.5) + zdxab/e1u(iimfl(jfl)-1,ijmfl(jfl)) + (mig(1,nn_hls)-1)
+ zgjfl(jfl)= (ijmfl(jfl)-0.5) + zdyad/e2v(iimfl(jfl),ijmfl(jfl)-1) + (mjg(1,nn_hls)-1)
zgkfl(jfl) = (( gdepw(iimfl(jfl),ijmfl(jfl),ikmfl(jfl)+1,Kmm) - flzz(jfl) )* ikmfl(jfl)) &
& / ( gdepw(iimfl(jfl),ijmfl(jfl),ikmfl(jfl)+1,Kmm) &
& - gdepw(iimfl(jfl),ijmfl(jfl),ikmfl(jfl) ,Kmm) ) &
diff --git a/src/OCE/FLO/florst.F90 b/src/OCE/FLO/florst.F90
index 59817e085a9eca184af23a95388d14249c2b1117..c855b1b7a4fa4c5cbf5a727ed6a6bcafccde67f8 100644
--- a/src/OCE/FLO/florst.F90
+++ b/src/OCE/FLO/florst.F90
@@ -97,10 +97,10 @@ CONTAINS
!
IF( lk_mpp ) THEN
DO jfl = 1, jpnfl
- IF( (INT(tpifl(jfl)) >= mig(Nis0)) .AND. &
- &(INT(tpifl(jfl)) <= mig(Nie0)) .AND. &
- &(INT(tpjfl(jfl)) >= mjg(Njs0)) .AND. &
- &(INT(tpjfl(jfl)) <= mjg(Nje0)) ) THEN
+ IF( (INT(tpifl(jfl)) >= mig(Nis0,nn_hls)) .AND. &
+ &(INT(tpifl(jfl)) <= mig(Nie0,nn_hls)) .AND. &
+ &(INT(tpjfl(jfl)) >= mjg(Njs0,nn_hls)) .AND. &
+ &(INT(tpjfl(jfl)) <= mjg(Nje0,nn_hls)) ) THEN
iperproc(narea) = iperproc(narea)+1
ENDIF
END DO
diff --git a/src/OCE/FLO/flowri.F90 b/src/OCE/FLO/flowri.F90
index 7451c1be5466f3c065006ca7d7901f8762667c41..9c3473ffb68b03c78e8e7f84b843b78a64e435e2 100644
--- a/src/OCE/FLO/flowri.F90
+++ b/src/OCE/FLO/flowri.F90
@@ -103,8 +103,8 @@ CONTAINS
IF( lk_mpp ) THEN
- iafloc = mi1( iafl )
- ibfloc = mj1( ibfl )
+ iafloc = mi1( iafl, nn_hls )
+ ibfloc = mj1( ibfl, nn_hls )
IF( Nis0 <= iafloc .AND. iafloc <= Nie0 .AND. &
& Njs0 <= ibfloc .AND. ibfloc <= Nje0 ) THEN
diff --git a/src/OCE/ICB/icbclv.F90 b/src/OCE/ICB/icbclv.F90
index 0121cbb85729a5a193a633326addb5cf8f062f32..bb26759d023ea239f988e5075b39e7e4e460c876 100644
--- a/src/OCE/ICB/icbclv.F90
+++ b/src/OCE/ICB/icbclv.F90
@@ -132,8 +132,8 @@ CONTAINS
!
newpt%lon = glamt(ji,jj) ! at t-point (centre of the cell)
newpt%lat = gphit(ji,jj)
- newpt%xi = REAL( mig(ji), wp ) - ( nn_hls - 1 )
- newpt%yj = REAL( mjg(jj), wp ) - ( nn_hls - 1 )
+ newpt%xi = REAL( mig(ji,nn_hls), wp ) - ( nn_hls - 1 )
+ newpt%yj = REAL( mjg(jj,nn_hls), wp ) - ( nn_hls - 1 )
!
newpt%uvel = 0._wp ! initially at rest
newpt%vvel = 0._wp
diff --git a/src/OCE/ICB/icbdyn.F90 b/src/OCE/ICB/icbdyn.F90
index 323758f4fec5b553339ddd001baf4bd5b7936dca..0de3d453ccf241f9fde7bc1731f9646b127e4fc9 100644
--- a/src/OCE/ICB/icbdyn.F90
+++ b/src/OCE/ICB/icbdyn.F90
@@ -197,10 +197,10 @@ CONTAINS
IF( ii == ii0 .AND. ij == ij0 ) RETURN ! berg remains in the same cell
!
! map into current processor
- ii0 = mi1( ii0 )
- ij0 = mj1( ij0 )
- ii = mi1( ii )
- ij = mj1( ij )
+ ii0 = mi1( ii0, nn_hls )
+ ij0 = mj1( ij0, nn_hls )
+ ii = mi1( ii , nn_hls )
+ ij = mj1( ij , nn_hls )
!
! assume icb is grounded if tmask(ii,ij,1) or tmask(ii,ij,ikb), depending of the option is not 0
IF ( ln_M2016 .AND. ln_icb_grd ) THEN
diff --git a/src/OCE/ICB/icbini.F90 b/src/OCE/ICB/icbini.F90
index d7bd2624c38eab5be0807f39bb84ee1dd42bd486..0fd183888b268417514f67040252ae8ab9e29d60 100644
--- a/src/OCE/ICB/icbini.F90
+++ b/src/OCE/ICB/icbini.F90
@@ -140,7 +140,7 @@ CONTAINS
DO_2D( 1, 1, 1, 1 )
src_calving_hflx(ji,jj) = narea
- src_calving (ji,jj) = nicbpack * mjg(jj) + mig(ji)
+ src_calving (ji,jj) = nicbpack * mjg(jj,nn_hls) + mig(ji,nn_hls)
END_2D
CALL lbc_lnk( 'icbini', src_calving_hflx, 'T', 1._wp )
CALL lbc_lnk( 'icbini', src_calving , 'T', 1._wp )
@@ -156,7 +156,7 @@ CONTAINS
i2 = INT( i3/nicbpack )
i1 = i3 - i2*nicbpack
i3 = INT( src_calving_hflx(ji,jj) )
- IF( i1 == mig(ji) .AND. i3 == narea ) THEN
+ IF( i1 == mig(ji,nn_hls) .AND. i3 == narea ) THEN
IF( nicbdi < 0 ) THEN ; nicbdi = ji
ELSE ; nicbei = ji
ENDIF
@@ -172,7 +172,7 @@ CONTAINS
i2 = INT( i3/nicbpack )
i1 = i3 - i2*nicbpack
i3 = INT( src_calving_hflx(ji,jj) )
- IF( i2 == mjg(jj) .AND. i3 == narea ) THEN
+ IF( i2 == mjg(jj,nn_hls) .AND. i3 == narea ) THEN
IF( nicbdj < 0 ) THEN ; nicbdj = jj
ELSE ; nicbej = jj
ENDIF
@@ -361,8 +361,8 @@ CONTAINS
rn_test_box(1) < glamt(ji,jj) .AND. glamt(ji,jj) < rn_test_box(2) .AND. &
rn_test_box(3) < gphit(ji,jj) .AND. gphit(ji,jj) < rn_test_box(4) ) THEN
localberg%mass_scaling = rn_mass_scaling(iberg)
- localpt%xi = REAL( mig(ji) - (nn_hls-1), wp )
- localpt%yj = REAL( mjg(jj) - (nn_hls-1), wp )
+ localpt%xi = REAL( mig(ji,nn_hls) - (nn_hls-1), wp )
+ localpt%yj = REAL( mjg(jj,nn_hls) - (nn_hls-1), wp )
CALL icb_utl_interp( localpt%xi, localpt%yj, plat=localpt%lat, plon=localpt%lon )
localpt%mass = rn_initial_mass (iberg)
localpt%thickness = rn_initial_thickness(iberg)
diff --git a/src/OCE/ICB/icblbc.F90 b/src/OCE/ICB/icblbc.F90
index fa901486ad787a06b6d74fe792c714972c3e2b8c..6a8823f1a773a6b1f152df6b2f0602c21904989b 100644
--- a/src/OCE/ICB/icblbc.F90
+++ b/src/OCE/ICB/icblbc.F90
@@ -90,9 +90,9 @@ CONTAINS
this => first_berg
DO WHILE( ASSOCIATED(this) )
pt => this%current_point
- IF( pt%xi > REAL(mig(nicbei),wp) + 0.5_wp ) THEN
+ IF( pt%xi > REAL(mig(nicbei,nn_hls),wp) + 0.5_wp ) THEN
pt%xi = ricb_right + MOD(pt%xi, 1._wp ) - 1._wp
- ELSE IF( pt%xi < REAL(mig(nicbdi),wp) - 0.5_wp ) THEN
+ ELSE IF( pt%xi < REAL(mig(nicbdi,nn_hls),wp) - 0.5_wp ) THEN
pt%xi = ricb_left + MOD(pt%xi, 1._wp )
ENDIF
this => this%next
@@ -125,10 +125,10 @@ CONTAINS
DO WHILE( ASSOCIATED(this) )
pt => this%current_point
ijne = INT( pt%yj + 0.5 )
- IF( pt%yj > REAL(mjg(nicbej),wp) + 0.5_wp ) THEN
+ IF( pt%yj > REAL(mjg(nicbej,nn_hls),wp) + 0.5_wp ) THEN
!
iine = INT( pt%xi + 0.5 )
- ipts = nicbfldpts (mi1(iine))
+ ipts = nicbfldpts (mi1(iine,nn_hls))
!
! moving across the cut line means both position and
! velocity must change
@@ -228,7 +228,7 @@ CONTAINS
this => first_berg
DO WHILE (ASSOCIATED(this))
pt => this%current_point
- IF( ipe_E >= 0 .AND. pt%xi > REAL(mig(nicbei),wp) + 0.5_wp - (nn_hls-1) ) THEN
+ IF( ipe_E >= 0 .AND. pt%xi > REAL(mig(nicbei,nn_hls),wp) + 0.5_wp - (nn_hls-1) ) THEN
tmpberg => this
this => this%next
ibergs_to_send_e = ibergs_to_send_e + 1
@@ -241,7 +241,7 @@ CONTAINS
! now pack it into buffer and delete from list
CALL icb_pack_into_buffer( tmpberg, obuffer_e, ibergs_to_send_e)
CALL icb_utl_delete(first_berg, tmpberg)
- ELSE IF( ipe_W >= 0 .AND. pt%xi < REAL(mig(nicbdi),wp) - 0.5_wp - (nn_hls-1) ) THEN
+ ELSE IF( ipe_W >= 0 .AND. pt%xi < REAL(mig(nicbdi,nn_hls),wp) - 0.5_wp - (nn_hls-1) ) THEN
tmpberg => this
this => this%next
ibergs_to_send_w = ibergs_to_send_w + 1
@@ -320,7 +320,7 @@ CONTAINS
this => first_berg
DO WHILE (ASSOCIATED(this))
pt => this%current_point
- IF( ipe_N >= 0 .AND. pt%yj > REAL(mjg(nicbej),wp) + 0.5_wp - (nn_hls-1) ) THEN
+ IF( ipe_N >= 0 .AND. pt%yj > REAL(mjg(nicbej,nn_hls),wp) + 0.5_wp - (nn_hls-1) ) THEN
tmpberg => this
this => this%next
ibergs_to_send_n = ibergs_to_send_n + 1
@@ -330,7 +330,7 @@ CONTAINS
ENDIF
CALL icb_pack_into_buffer( tmpberg, obuffer_n, ibergs_to_send_n)
CALL icb_utl_delete(first_berg, tmpberg)
- ELSE IF( ipe_S >= 0 .AND. pt%yj < REAL(mjg(nicbdj),wp) - 0.5_wp - (nn_hls-1) ) THEN
+ ELSE IF( ipe_S >= 0 .AND. pt%yj < REAL(mjg(nicbdj,nn_hls),wp) - 0.5_wp - (nn_hls-1) ) THEN
tmpberg => this
this => this%next
ibergs_to_send_s = ibergs_to_send_s + 1
@@ -441,10 +441,10 @@ CONTAINS
this => first_berg
DO WHILE (ASSOCIATED(this))
pt => this%current_point
- IF( pt%xi < REAL(mig(nicbdi),wp) - 0.5_wp - (nn_hls-1) .OR. &
- pt%xi > REAL(mig(nicbei),wp) + 0.5_wp - (nn_hls-1) .OR. &
- pt%yj < REAL(mjg(nicbdj),wp) - 0.5_wp - (nn_hls-1) .OR. &
- pt%yj > REAL(mjg(nicbej),wp) + 0.5_wp - (nn_hls-1) ) THEN
+ IF( pt%xi < REAL(mig(nicbdi,nn_hls),wp) - 0.5_wp - (nn_hls-1) .OR. &
+ pt%xi > REAL(mig(nicbei,nn_hls),wp) + 0.5_wp - (nn_hls-1) .OR. &
+ pt%yj < REAL(mjg(nicbdj,nn_hls),wp) - 0.5_wp - (nn_hls-1) .OR. &
+ pt%yj > REAL(mjg(nicbej,nn_hls),wp) + 0.5_wp - (nn_hls-1) ) THEN
i = i + 1
WRITE(numicb,*) 'berg lost in halo: ', this%number(:)
WRITE(numicb,*) ' ', nimpp, njmpp
@@ -514,8 +514,8 @@ CONTAINS
DO WHILE (ASSOCIATED(this))
pt => this%current_point
iine = INT( pt%xi + 0.5 ) + (nn_hls-1)
- iproc = nicbflddest(mi1(iine))
- IF( pt%yj > REAL(mjg(nicbej),wp) + 0.5_wp - (nn_hls-1) ) THEN
+ iproc = nicbflddest(mi1(iine,nn_hls))
+ IF( pt%yj > REAL(mjg(nicbej,nn_hls),wp) + 0.5_wp - (nn_hls-1) ) THEN
IF( iproc == ifldproc ) THEN
!
IF( iproc /= narea ) THEN
@@ -593,9 +593,9 @@ CONTAINS
pt => this%current_point
iine = INT( pt%xi + 0.5 ) + (nn_hls-1)
ijne = INT( pt%yj + 0.5 ) + (nn_hls-1)
- ipts = nicbfldpts (mi1(iine))
- iproc = nicbflddest(mi1(iine))
- IF( pt%yj > REAL(mjg(nicbej),wp) + 0.5_wp - (nn_hls-1) ) THEN
+ ipts = nicbfldpts (mi1(iine,nn_hls))
+ iproc = nicbflddest(mi1(iine,nn_hls))
+ IF( pt%yj > REAL(mjg(nicbej,nn_hls),wp) + 0.5_wp - (nn_hls-1) ) THEN
IF( iproc == ifldproc ) THEN
!
! moving across the cut line means both position and
diff --git a/src/OCE/ICB/icbrst.F90 b/src/OCE/ICB/icbrst.F90
index 092b56e5860f47825f7bb949b252f319f7108633..9e7560197effae6afbeb7d27427d16c7aa752ee1 100644
--- a/src/OCE/ICB/icbrst.F90
+++ b/src/OCE/ICB/icbrst.F90
@@ -90,8 +90,8 @@ CONTAINS
ii = INT( localpt%xi + 0.5 ) + ( nn_hls-1 )
ij = INT( localpt%yj + 0.5 ) + ( nn_hls-1 )
! Only proceed if this iceberg is on the local processor (excluding halos).
- IF ( ii >= mig(Nis0) .AND. ii <= mig(Nie0) .AND. &
- & ij >= mjg(Njs0) .AND. ij <= mjg(Nje0) ) THEN
+ IF ( ii >= mig(Nis0,nn_hls) .AND. ii <= mig(Nie0,nn_hls) .AND. &
+ & ij >= mjg(Njs0,nn_hls) .AND. ij <= mjg(Nje0,nn_hls) ) THEN
CALL iom_get( ncid, jpdom_unknown, 'number', zdata(:) , ktime=jn, kstart=(/1/), kcount=(/nkounts/) )
localberg%number(:) = INT(zdata(:))
@@ -244,16 +244,16 @@ CONTAINS
! global attributes
IF( lk_mpp ) THEN
! Set domain parameters (assume jpdom_local_full)
- nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_number_total' , jpnij )
- nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_number' , narea-1 )
- nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_dimensions_ids' , (/ 1 , 2 /) )
- nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_size_global' , (/ Ni0glo , Nj0glo /) )
- nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_size_local' , (/ Ni_0 , Nj_0 /) )
- nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_position_first' , (/ mig0(Nis0), mjg0(Njs0) /) )
- nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_position_last' , (/ mig0(Nie0), mjg0(Nje0) /) )
- nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_halo_size_start', (/ 0 , 0 /) )
- nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_halo_size_end' , (/ 0 , 0 /) )
- nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_type' , 'BOX' )
+ nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_number_total' , jpnij )
+ nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_number' , narea-1 )
+ nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_dimensions_ids' , (/ 1 , 2 /) )
+ nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_size_global' , (/ Ni0glo , Nj0glo /) )
+ nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_size_local' , (/ Ni_0 , Nj_0 /) )
+ nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_position_first' , (/ mig(Nis0,0), mjg(Njs0,0) /) )
+ nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_position_last' , (/ mig(Nie0,0), mjg(Nje0,0) /) )
+ nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_halo_size_start', (/ 0 , 0 /) )
+ nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_halo_size_end' , (/ 0 , 0 /) )
+ nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_type' , 'BOX' )
ENDIF
IF (associated(first_berg)) then
diff --git a/src/OCE/ICB/icbthm.F90 b/src/OCE/ICB/icbthm.F90
index c39500dbed34d641ae5accd5ccd17a69c01e0e83..200e915b8722d5bcd3133d3f85d395754dc4a61a 100644
--- a/src/OCE/ICB/icbthm.F90
+++ b/src/OCE/ICB/icbthm.F90
@@ -31,6 +31,8 @@ MODULE icbthm
PUBLIC icb_thm ! routine called in icbstp.F90 module
+ !! * Substitutions
+# include "do_loop_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
!! $Id: icbthm.F90 15088 2021-07-06 13:03:34Z acc $
@@ -48,7 +50,7 @@ CONTAINS
!!----------------------------------------------------------------------
INTEGER, INTENT(in) :: kt ! timestep number, just passed to icb_utl_print_berg
!
- INTEGER :: ii, ij, jk, ikb
+ INTEGER :: ii, ij, ji, jj, jk, ikb
REAL(wp) :: zM, zT, zW, zL, zSST, zVol, zLn, zWn, zTn, znVol, zIC, zDn, zD, zvb, zub, ztb
REAL(wp) :: zMv, zMe, zMb, zmelt, zdvo, zdvob, zdva, zdM, zSs, zdMe, zdMb, zdMv
REAL(wp) :: zSSS, zfzpt
@@ -112,9 +114,9 @@ CONTAINS
zxi = pt%xi ! position in (i,j) referential
zyj = pt%yj
ii = INT( zxi + 0.5 ) ! T-cell of the berg
- ii = mi1( ii + (nn_hls-1) )
+ ii = mi1( ii + (nn_hls-1), nn_hls )
ij = INT( zyj + 0.5 )
- ij = mj1( ij + (nn_hls-1) )
+ ij = mj1( ij + (nn_hls-1), nn_hls )
zVol = zT * zW * zL
! Environment
@@ -287,8 +289,10 @@ CONTAINS
! now use melt and associated heat flux in ocean (or not)
!
IF(.NOT. ln_passive_mode ) THEN
- emp (:,:) = emp (:,:) - berg_grid%floating_melt(:,:)
- qns (:,:) = qns (:,:) + berg_grid%calving_hflx (:,:)
+ DO_2D( 0, 0, 0, 0 )
+ emp(ji,jj) = emp(ji,jj) - berg_grid%floating_melt(ji,jj)
+ qns(ji,jj) = qns(ji,jj) + berg_grid%calving_hflx (ji,jj)
+ END_2D
ENDIF
!
END SUBROUTINE icb_thm
diff --git a/src/OCE/ICB/icbutl.F90 b/src/OCE/ICB/icbutl.F90
index 873245fcd6b19d8f83119228191153f9cf2b3198..780d05df039e847e4e8623833ecd591d85580a04 100644
--- a/src/OCE/ICB/icbutl.F90
+++ b/src/OCE/ICB/icbutl.F90
@@ -26,8 +26,8 @@ MODULE icbutl
USE icb_oce ! define iceberg arrays
USE sbc_oce ! ocean surface boundary conditions
#if defined key_si3
- USE ice, ONLY: u_ice, v_ice, hm_i ! SI3 variables
- USE icevar ! ice_var_sshdyn
+ USE ice, ONLY: u_ice, v_ice, at_i, vt_i ! SI3 variables
+ USE icevar ! ice_var_sshdyn
USE sbc_ice, ONLY: snwice_mass, snwice_mass_b
#endif
@@ -57,6 +57,7 @@ MODULE icbutl
PUBLIC icb_utl_heat ! routine called in icbdia module
!! * Substitutions
+# include "do_loop_substitute.h90"
# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
@@ -101,7 +102,11 @@ CONTAINS
CALL lbc_lnk_icb( 'icbutl', ua_e , 'U', -1._wp, 1, 1 )
CALL lbc_lnk_icb( 'icbutl', va_e , 'V', -1._wp, 1, 1 )
#if defined key_si3
- hi_e(1:jpi, 1:jpj) = hm_i (:,:)
+ WHERE( at_i(:,:) /= 0._wp )
+ hi_e(1:jpi,1:jpj) = vt_i(:,:) / at_i(:,:)
+ ELSEWHERE
+ hi_e(1:jpi,1:jpj) = 0._wp
+ ENDWHERE
ui_e(1:jpi, 1:jpj) = u_ice(:,:)
vi_e(1:jpi, 1:jpj) = v_ice(:,:)
!
@@ -312,18 +317,18 @@ CONTAINS
!
IF (TRIM(cd_type) == 'T' ) THEN
ierr = 0
- IF ( kii < mig( 1 ) ) THEN ; ierr = ierr + 1
- ELSEIF( kii >= mig(jpi) ) THEN ; ierr = ierr + 1
+ IF ( kii < mig( 1 ,nn_hls) ) THEN ; ierr = ierr + 1
+ ELSEIF( kii >= mig(jpi,nn_hls) ) THEN ; ierr = ierr + 1
ENDIF
!
- IF ( kij < mjg( 1 ) ) THEN ; ierr = ierr + 1
- ELSEIF( kij >= mjg(jpj) ) THEN ; ierr = ierr + 1
+ IF ( kij < mjg( 1 ,nn_hls) ) THEN ; ierr = ierr + 1
+ ELSEIF( kij >= mjg(jpj,nn_hls) ) THEN ; ierr = ierr + 1
ENDIF
!
IF ( ierr > 0 ) THEN
WRITE(numicb,*) 'bottom left corner T point out of bound'
- WRITE(numicb,*) pi, kii, mig( 1 ), mig(jpi)
- WRITE(numicb,*) pj, kij, mjg( 1 ), mjg(jpj)
+ WRITE(numicb,*) pi, kii, mig( 1,nn_hls ), mig(jpi,nn_hls)
+ WRITE(numicb,*) pj, kij, mjg( 1,nn_hls ), mjg(jpj,nn_hls)
WRITE(numicb,*) pmsk
CALL FLUSH(numicb)
CALL ctl_stop('STOP','icb_utl_bilin_e: an icebergs coordinates is out of valid range (out of bound error).' , &
@@ -335,13 +340,13 @@ CONTAINS
! find position in this processor. Prevent near edge problems (see #1389)
! (PM) will be useless if extra halo is used in NEMO
!
- IF ( kii <= mig(1)-1 ) THEN ; kii = 0
- ELSEIF( kii > mig(jpi) ) THEN ; kii = jpi
- ELSE ; kii = mi1(kii)
+ IF ( kii <= mig(1,nn_hls)-1 ) THEN ; kii = 0
+ ELSEIF( kii > mig(jpi,nn_hls) ) THEN ; kii = jpi
+ ELSE ; kii = mi1(kii,nn_hls)
ENDIF
- IF ( kij <= mjg(1)-1 ) THEN ; kij = 0
- ELSEIF( kij > mjg(jpj) ) THEN ; kij = jpj
- ELSE ; kij = mj1(kij)
+ IF ( kij <= mjg(1,nn_hls)-1 ) THEN ; kij = 0
+ ELSEIF( kij > mjg(jpj,nn_hls) ) THEN ; kij = jpj
+ ELSE ; kij = mj1(kij,nn_hls)
ENDIF
!
! define mask array
@@ -462,8 +467,8 @@ CONTAINS
zj = pj - REAL(ij,wp)
! conversion to local domain (no need to do a sanity check already done in icbpos)
- ii = mi1(ii) + (nn_hls-1)
- ij = mj1(ij) + (nn_hls-1)
+ ii = mi1(ii,nn_hls) + (nn_hls-1)
+ ij = mj1(ij,nn_hls) + (nn_hls-1)
!
IF( 0.0_wp <= zi .AND. zi < 0.5_wp ) THEN
IF( 0.0_wp <= zj .AND. zj < 0.5_wp ) THEN ! NE quadrant
diff --git a/src/OCE/IOM/iom.F90 b/src/OCE/IOM/iom.F90
index 8a1b561b3ec092a49f1eca76c1f554869e37322b..6244df8c386c83acc0df99ac11ce873ba98783d7 100644
--- a/src/OCE/IOM/iom.F90
+++ b/src/OCE/IOM/iom.F90
@@ -469,11 +469,11 @@ CONTAINS
CALL xios_add_child(filegroup_hdl, file_hdl, 'wrestart')
IF(nxioso.eq.1) THEN
CALL xios_set_file_attr( "wrestart", type="one_file", enabled=.TRUE.,&
- mode="write", output_freq=xios_timestep)
+ mode="write", output_freq=xios_timestep)
IF(lwp) write(numout,*) 'OPEN ', TRIM(cdrst_file), ' in one_file mode'
ELSE
CALL xios_set_file_attr( "wrestart", type="multiple_file", enabled=.TRUE.,&
- mode="write", output_freq=xios_timestep)
+ mode="write", output_freq=xios_timestep, min_digits=4)
IF(lwp) write(numout,*) 'OPEN ', TRIM(cdrst_file), ' in multiple_file mode'
ENDIF
CALL xios_set_file_attr( "wrestart", name=TRIM(cdrst_file))
@@ -498,6 +498,8 @@ CONTAINS
REAL(sp), OPTIONAL, INTENT(IN), DIMENSION(:, :) :: rs2
REAL(dp), OPTIONAL, INTENT(IN), DIMENSION(:, :, :) :: rd3
REAL(sp), OPTIONAL, INTENT(IN), DIMENSION(:, :, :) :: rs3
+ CHARACTER(len=30) :: clgsuf
+ INTEGER, DIMENSION(2) :: ihls
#if defined key_xios
TYPE(xios_field) :: field_hdl
TYPE(xios_file) :: file_hdl
@@ -506,40 +508,66 @@ CONTAINS
!define fields for restart context
CALL xios_add_child(file_hdl, field_hdl, sdfield)
+ ! Determine number of halo points
+ IF( PRESENT(rd3) ) THEN
+ ihls = arr_hls( SIZE(rd3, 1), SIZE(rd3, 2), ldsize=.TRUE. )
+ ELSEIF( PRESENT(rs3) ) THEN
+ ihls = arr_hls( SIZE(rs3, 1), SIZE(rs3, 2), ldsize=.TRUE. )
+ ELSEIF( PRESENT(rd2) ) THEN
+ ihls = arr_hls( SIZE(rd2, 1), SIZE(rd2, 2), ldsize=.TRUE. )
+ ELSEIF( PRESENT(rs2) ) THEN
+ ihls = arr_hls( SIZE(rs2, 1), SIZE(rs2, 2), ldsize=.TRUE. )
+ ELSE
+ ihls(:) = 0
+ ENDIF
+
+ ! Choose horizontal grid based on number of halo points
+ IF( ihls(1) == 0 .AND. ihls(2) == 0 ) THEN ! Inner domain only
+ clgsuf = "_inner"
+ ELSEIF( ihls(1) == nn_hls .AND. ihls(2) == nn_hls ) THEN ! nn_hls halo points
+ clgsuf = ""
+ ELSEIF( ihls(1) == 1 .AND. ihls(2) == 1 ) THEN ! 1 halo point, nn_hls > 1
+ clgsuf = "_halo1"
+ ELSE
+ WRITE(ctmp1,*) 'iom_set_rstw_active: unsupported array shape with number of i-j halo points:'
+ WRITE(ctmp2,*) ihls(1), 'x', ihls(2)
+ CALL ctl_stop(ctmp1, ctmp2)
+ ENDIF
+
IF(PRESENT(rd3)) THEN
- CALL xios_set_attr (field_hdl, enabled = .TRUE., name = sdfield, &
- domain_ref = "grid_N", &
- axis_ref = iom_axis(size(rd3, 3)), &
- prec = 8, operation = "instant" )
+ CALL xios_set_attr (field_hdl, enabled = .TRUE., name = sdfield, &
+ domain_ref = "grid_N"//TRIM(clgsuf), &
+ axis_ref = iom_axis(size(rd3, 3)), &
+ prec = 8, operation = "instant" )
ELSEIF(PRESENT(rs3)) THEN
- CALL xios_set_attr (field_hdl, enabled = .TRUE., name = sdfield, &
- domain_ref = "grid_N", &
- axis_ref = iom_axis(size(rd3, 3)), &
- prec = 4, operation = "instant" )
+ CALL xios_set_attr (field_hdl, enabled = .TRUE., name = sdfield, &
+ domain_ref = "grid_N"//TRIM(clgsuf), &
+ axis_ref = iom_axis(size(rd3, 3)), &
+ prec = 4, operation = "instant" )
ELSEIF(PRESENT(rd2)) THEN
- CALL xios_set_attr (field_hdl, enabled = .TRUE., name = sdfield, &
- domain_ref = "grid_N", prec = 8, &
- operation = "instant" )
+ CALL xios_set_attr (field_hdl, enabled = .TRUE., name = sdfield, &
+ domain_ref = "grid_N"//TRIM(clgsuf), prec = 8, &
+ operation = "instant" )
ELSEIF(PRESENT(rs2)) THEN
- CALL xios_set_attr (field_hdl, enabled = .TRUE., name = sdfield, &
- domain_ref = "grid_N", prec = 4, &
- operation = "instant" )
+ CALL xios_set_attr (field_hdl, enabled = .TRUE., name = sdfield, &
+ domain_ref = "grid_N"//TRIM(clgsuf), prec = 4, &
+ operation = "instant" )
ELSEIF(PRESENT(rd1)) THEN
- CALL xios_set_attr (field_hdl, enabled = .TRUE., name = sdfield, &
- axis_ref = iom_axis(size(rd1, 1)), &
- prec = 8, operation = "instant" )
+ CALL xios_set_attr (field_hdl, enabled = .TRUE., name = sdfield, &
+ axis_ref = iom_axis(size(rd1, 1)), &
+ prec = 8, operation = "instant" )
ELSEIF(PRESENT(rs1)) THEN
- CALL xios_set_attr (field_hdl, enabled = .TRUE., name = sdfield, &
- axis_ref = iom_axis(size(rd1, 1)), &
- prec = 4, operation = "instant" )
+ CALL xios_set_attr (field_hdl, enabled = .TRUE., name = sdfield, &
+ axis_ref = iom_axis(size(rd1, 1)), &
+ prec = 4, operation = "instant" )
ELSEIF(PRESENT(rd0)) THEN
- CALL xios_set_attr (field_hdl, enabled = .TRUE., name = sdfield, &
- scalar_ref = "grid_scalar", prec = 8, &
- operation = "instant" )
+ CALL xios_set_attr (field_hdl, enabled = .TRUE., name = sdfield, &
+ scalar_ref = "grid_scalar", prec = 8, &
+ operation = "instant" )
ELSEIF(PRESENT(rs0)) THEN
- CALL xios_set_attr (field_hdl, enabled = .TRUE., name = sdfield, &
- scalar_ref = "grid_scalar", prec = 4, &
- operation = "instant" )
+ CALL xios_set_attr (field_hdl, enabled = .TRUE., name = sdfield, &
+ scalar_ref = "grid_scalar", prec = 4, &
+ operation = "instant" )
ENDIF
#endif
END SUBROUTINE iom_set_rstw_active
@@ -615,6 +643,10 @@ CONTAINS
CALL xios_get_handle("domain_definition",domaingroup_hdl)
CALL xios_add_child(domaingroup_hdl, domain_hdl, "grid_N")
+ CALL xios_add_child(domaingroup_hdl, domain_hdl, "grid_N_halo1")
+ CALL xios_add_child(domaingroup_hdl, domain_hdl, "grid_N_inner")
+ CALL xios_set_domain_attr("grid_N_halo1", name="grid_N")
+ CALL xios_set_domain_attr("grid_N_inner", name="grid_N")
CALL set_grid("N", glamt, gphit, .TRUE., ld_rstr)
CALL xios_get_handle("axis_definition",axisgroup_hdl)
@@ -1203,6 +1235,7 @@ CONTAINS
INTEGER :: ji, jj ! loop counters
INTEGER :: irankpv !
INTEGER :: ind1, ind2 ! substring index
+ INTEGER, DIMENSION(2) :: ihls ! halo size determined from array shape (XIOS only)
INTEGER, DIMENSION(jpmax_dims) :: istart ! starting point to read for each axis
INTEGER, DIMENSION(jpmax_dims) :: icnt ! number of value to read along each axis
INTEGER, DIMENSION(jpmax_dims) :: idimsz ! size of the dimensions of the variable
@@ -1217,12 +1250,25 @@ CONTAINS
LOGICAL :: ll_only3rd ! T => if kstart, kcount present then *only* use values for 3rd spatial dimension.
INTEGER :: inlev ! number of levels for 3D data
REAL(dp) :: gma, gmi
+ REAL(dp), DIMENSION(:,:), ALLOCATABLE :: zwrk2d ! temporary arrays for reading into an array
+ REAL(dp), DIMENSION(:,:,:), ALLOCATABLE :: zwrk3d ! smaller than jpi-jpj (XIOS only)
!---------------------------------------------------------------------
CHARACTER(LEN=lc) :: context
!
CALL set_xios_context(kiomid, context)
+ ! Array shape information
inlev = -1
- IF( PRESENT(pv_r3d) ) inlev = SIZE(pv_r3d, 3)
+ IF( PRESENT(pv_r1d) ) THEN
+ irankpv = 1
+ ishape(1:1) = SHAPE(pv_r1d)
+ ELSE IF( PRESENT(pv_r2d) ) THEN
+ irankpv = 2
+ ishape(1:2) = SHAPE(pv_r2d)
+ ELSE IF( PRESENT(pv_r3d) ) THEN
+ irankpv = 3
+ ishape(1:3) = SHAPE(pv_r3d)
+ inlev = ishape(3)
+ ENDIF
!
idom = kdom
istop = nstop
@@ -1264,7 +1310,6 @@ CONTAINS
itime = 1
IF( PRESENT(ktime) ) itime = ktime
!
- irankpv = 1 * COUNT( (/PRESENT(pv_r1d)/) ) + 2 * COUNT( (/PRESENT(pv_r2d)/) ) + 3 * COUNT( (/PRESENT(pv_r3d)/) )
WRITE(clrankpv, fmt='(i1)') irankpv
WRITE(cldmspc , fmt='(i1)') idmspc
!
@@ -1312,7 +1357,7 @@ CONTAINS
ENDIF
ELSE ! not a 1D array as pv_r1d requires jpdom_unknown
! we do not read the overlap and the extra-halos -> from Nis0 to Nie0 and from Njs0 to Nje0
- IF( idom == jpdom_global ) istart(1:2) = (/ mig0(Nis0), mjg0(Njs0) /)
+ IF( idom == jpdom_global ) istart(1:2) = (/ mig(Nis0,0), mjg(Njs0,0) /)
icnt(1:2) = (/ Ni_0, Nj_0 /)
IF( PRESENT(pv_r3d) ) THEN
IF( idom == jpdom_auto_xy ) THEN
@@ -1338,17 +1383,24 @@ CONTAINS
! check that icnt matches the input array
!-
IF( idom == jpdom_unknown ) THEN
- IF( irankpv == 1 ) ishape(1:1) = SHAPE(pv_r1d)
- IF( irankpv == 2 ) ishape(1:2) = SHAPE(pv_r2d)
- IF( irankpv == 3 ) ishape(1:3) = SHAPE(pv_r3d)
+ ix1 = 1 ; ix2 = icnt(1) ; iy1 = 1 ; iy2 = icnt(2) ! index of the array to be read
ctmp1 = 'd'
ELSE
- IF( irankpv == 2 ) THEN
- ishape(1:2) = SHAPE(pv_r2d(Nis0:Nie0,Njs0:Nje0 )) ; ctmp1 = 'd(Nis0:Nie0,Njs0:Nje0)'
- ENDIF
- IF( irankpv == 3 ) THEN
- ishape(1:3) = SHAPE(pv_r3d(Nis0:Nie0,Njs0:Nje0,:)) ; ctmp1 = 'd(Nis0:Nie0,Njs0:Nje0,:)'
+ IF( ishape(1) == Ni_0 .AND. ishape(2) == Nj_0 ) THEN ! array with 0 halo
+ ix1 = 1 ; ix2 = Ni_0 ; iy1 = 1 ; iy2 = Nj_0 ! index of the array to be read
+ ctmp1 = 'd(:,:'
+ ELSEIF( ishape(1) == jpi .AND. ishape(2) == jpj ) THEN ! array with nn_hls halos
+ ix1 = Nis0 ; ix2 = Nie0 ; iy1 = Njs0 ; iy2 = Nje0 ! index of the array to be read
+ ctmp1 = 'd(Nis0:Nie0,Njs0:Nje0'
+ ELSEIF( ishape(1) == Ni_0+2 .AND. ishape(2) == Nj_0+2 ) THEN ! nn_hls = 2 and array with 1 halo
+ ix1 = 2 ; ix2 = Ni_0+1 ; iy1 = 2 ; iy2 = Nj_0+1 ! index of the array to be read
+ ctmp1 = 'd(2:Ni_0+1,2:Ni_0+1'
+ ELSE
+ CALL ctl_stop( 'iom_get_123d: should have been an impossible case...' )
ENDIF
+ ishape(1:2) = (/ Ni_0, Nj_0 /) ! update and force ishape to match the inner domain
+ IF( irankpv == 3 ) ctmp1 = TRIM(ctmp1)//',:'
+ ctmp1 = TRIM(ctmp1)//')'
ENDIF
DO jl = 1, irankpv
WRITE( ctmp2, FMT="(', ', i1,'): ', i5,' /= icnt(', i1,'):', i5)" ) jl, ishape(jl), jl, icnt(jl)
@@ -1361,11 +1413,6 @@ CONTAINS
!-
IF( idvar > 0 .AND. istop == nstop ) THEN ! no additional errors until this point...
!
- ! find the right index of the array to be read
- IF( idom /= jpdom_unknown ) THEN ; ix1 = Nis0 ; ix2 = Nie0 ; iy1 = Njs0 ; iy2 = Nje0
- ELSE ; ix1 = 1 ; ix2 = icnt(1) ; iy1 = 1 ; iy2 = icnt(2)
- ENDIF
-
CALL iom_nf90_get( kiomid, idvar, inbdim, istart, icnt, ix1, ix2, iy1, iy2, pv_r1d, pv_r2d, pv_r3d )
IF( istop == nstop ) THEN ! no additional errors until this point...
@@ -1373,13 +1420,15 @@ CONTAINS
cl_type = 'T'
IF( PRESENT(cd_type) ) cl_type = cd_type
- zsgn = 1._wp
- IF( PRESENT(psgn ) ) zsgn = psgn
- !--- overlap areas and extra hallows (mpp)
- IF( PRESENT(pv_r2d) .AND. idom /= jpdom_unknown .AND. cl_type /= 'Z' ) THEN
- CALL lbc_lnk( 'iom', pv_r2d, cl_type, zsgn, kfillmode = kfill )
- ELSEIF( PRESENT(pv_r3d) .AND. idom /= jpdom_unknown .AND. cl_type /= 'Z' ) THEN
- CALL lbc_lnk( 'iom', pv_r3d, cl_type, zsgn, kfillmode = kfill )
+ !--- halos and NP folding (NP folding to be done even if no halos)
+ IF( idom /= jpdom_unknown .AND. cl_type /= 'Z' .AND. ( PRESENT(pv_r2d) .OR. PRESENT(pv_r3d) ) ) THEN
+ zsgn = 1._wp
+ IF( PRESENT(psgn ) ) zsgn = psgn
+ IF( PRESENT(pv_r2d) ) THEN
+ CALL lbc_lnk( 'iom', pv_r2d, cl_type, zsgn, kfillmode = kfill, ldfull = .TRUE. )
+ ELSEIF( PRESENT(pv_r3d) ) THEN
+ CALL lbc_lnk( 'iom', pv_r3d, cl_type, zsgn, kfillmode = kfill, ldfull = .TRUE. )
+ ENDIF
ENDIF
!
ELSE
@@ -1401,17 +1450,40 @@ CONTAINS
cl_type = 'T'
IF( PRESENT(cd_type) ) cl_type = cd_type
+ ! We do not know whether pv_r[23]d will have halo points during context initialisation in iom_set_vars_active,
+ ! so we must always read to an array on the full grid (1:jpi,1:jpj), then copy the correct part to pv_r[23]d
+ IF( irankpv > 1 .AND. idom /= jpdom_unknown .AND. cl_type /= 'Z' ) THEN
+ llok = (ishape(1) == jpi) .AND. (ishape(2) == jpj)
+ ihls = arr_hls( ishape(1), ishape(2), ldtile=.FALSE., ldsize=.TRUE. )
+ ELSE
+ llok = .TRUE.
+ ENDIF
+
IF( PRESENT(pv_r3d) ) THEN
IF(lwp) WRITE(numout,*) 'XIOS RST READ (3D): ',TRIM(cdvar)
- CALL xios_recv_field( TRIM(cdvar), pv_r3d(:, :, :))
+ IF( .NOT. llok ) THEN
+ ALLOCATE( zwrk3d(jpi,jpj,inlev) )
+ CALL xios_recv_field( trim(cdvar), zwrk3d(:,:,:) )
+ pv_r3d(:,:,:) = zwrk3d(A1Di(ihls(1)),A1Dj(ihls(2)),:)
+ DEALLOCATE( zwrk3d )
+ ELSE
+ CALL xios_recv_field( trim(cdvar), pv_r3d(:,:,:) )
+ ENDIF
IF(idom /= jpdom_unknown .AND. cl_type /= 'Z' ) THEN
- CALL lbc_lnk( 'iom', pv_r3d, cl_type, zsgn, kfillmode = kfill)
+ CALL lbc_lnk( 'iom', pv_r3d, cl_type, zsgn, kfillmode = kfill, ldfull = .TRUE. )
ENDIF
ELSEIF( PRESENT(pv_r2d) ) THEN
IF(lwp) WRITE(numout,*) 'XIOS RST READ (2D): ', TRIM(cdvar)
- CALL xios_recv_field( TRIM(cdvar), pv_r2d(:, :))
+ IF( .NOT. llok ) THEN
+ ALLOCATE( zwrk2d(jpi,jpj) )
+ CALL xios_recv_field( trim(cdvar), zwrk2d(:,:) )
+ pv_r2d(:,:) = zwrk2d(A1Di(ihls(1)),A1Dj(ihls(2)))
+ DEALLOCATE( zwrk2d )
+ ELSE
+ CALL xios_recv_field( trim(cdvar), pv_r2d(:,:) )
+ ENDIF
IF(idom /= jpdom_unknown .AND. cl_type /= 'Z' ) THEN
- CALL lbc_lnk('iom', pv_r2d, cl_type, zsgn, kfillmode = kfill)
+ CALL lbc_lnk('iom', pv_r2d, cl_type, zsgn, kfillmode = kfill, ldfull = .TRUE. )
ENDIF
ELSEIF( PRESENT(pv_r1d) ) THEN
IF(lwp) WRITE(numout,*) 'XIOS RST READ (1D): ', TRIM(cdvar)
@@ -2035,7 +2107,7 @@ CONTAINS
REAL(sp), DIMENSION(:,:), INTENT(in) :: pfield2d
IF( iom_use(cdname) ) THEN
#if defined key_xios
- IF( is_tile(pfield2d) == 1 ) THEN
+ IF( is_tile(SIZE(pfield2d, 1), SIZE(pfield2d, 2)) ) THEN
CALL xios_send_field( cdname, pfield2d, ntile - 1 )
ELSE IF( .NOT. l_istiled .OR. ntile == nijtile ) THEN
CALL xios_send_field( cdname, pfield2d )
@@ -2051,7 +2123,7 @@ CONTAINS
REAL(dp), DIMENSION(:,:), INTENT(in) :: pfield2d
IF( iom_use(cdname) ) THEN
#if defined key_xios
- IF( is_tile(pfield2d) == 1 ) THEN
+ IF( is_tile(SIZE(pfield2d, 1), SIZE(pfield2d, 2)) ) THEN
CALL xios_send_field( cdname, pfield2d, ntile - 1 )
ELSE IF( .NOT. l_istiled .OR. ntile == nijtile ) THEN
CALL xios_send_field( cdname, pfield2d )
@@ -2067,7 +2139,7 @@ CONTAINS
REAL(sp), DIMENSION(:,:,:), INTENT(in) :: pfield3d
IF( iom_use(cdname) ) THEN
#if defined key_xios
- IF( is_tile(pfield3d) == 1 ) THEN
+ IF( is_tile(SIZE(pfield3d, 1), SIZE(pfield3d, 2)) ) THEN
CALL xios_send_field( cdname, pfield3d, ntile - 1 )
ELSE IF( .NOT. l_istiled .OR. ntile == nijtile ) THEN
CALL xios_send_field( cdname, pfield3d )
@@ -2083,7 +2155,7 @@ CONTAINS
REAL(dp), DIMENSION(:,:,:), INTENT(in) :: pfield3d
IF( iom_use(cdname) ) THEN
#if defined key_xios
- IF( is_tile(pfield3d) == 1 ) THEN
+ IF( is_tile(SIZE(pfield3d, 1), SIZE(pfield3d, 2)) ) THEN
CALL xios_send_field( cdname, pfield3d, ntile - 1 )
ELSE IF( .NOT. l_istiled .OR. ntile == nijtile ) THEN
CALL xios_send_field( cdname, pfield3d )
@@ -2099,7 +2171,7 @@ CONTAINS
REAL(sp), DIMENSION(:,:,:,:), INTENT(in) :: pfield4d
IF( iom_use(cdname) ) THEN
#if defined key_xios
- IF( is_tile(pfield4d) == 1 ) THEN
+ IF( is_tile(SIZE(pfield4d, 1), SIZE(pfield4d, 2)) ) THEN
CALL xios_send_field( cdname, pfield4d, ntile - 1 )
ELSE IF( .NOT. l_istiled .OR. ntile == nijtile ) THEN
CALL xios_send_field( cdname, pfield4d )
@@ -2115,7 +2187,7 @@ CONTAINS
REAL(dp), DIMENSION(:,:,:,:), INTENT(in) :: pfield4d
IF( iom_use(cdname) ) THEN
#if defined key_xios
- IF( is_tile(pfield4d) == 1 ) THEN
+ IF( is_tile(SIZE(pfield4d, 1), SIZE(pfield4d, 2)) ) THEN
CALL xios_send_field( cdname, pfield4d, ntile - 1 )
ELSE IF( .NOT. l_istiled .OR. ntile == nijtile ) THEN
CALL xios_send_field( cdname, pfield4d )
@@ -2338,18 +2410,24 @@ CONTAINS
REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: plon
REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: plat
!
- REAL(wp), DIMENSION(A2D(0),jpk) :: zmask
+ REAL(wp), DIMENSION(T2D(0),jpk) :: zmask
INTEGER :: jn
INTEGER, DIMENSION(nijtile) :: ini, inj, idb
LOGICAL, INTENT(IN) :: ldxios, ldrxios
!!----------------------------------------------------------------------
!
- CALL iom_set_domain_attr("grid_"//cdgrd, ni_glo=Ni0glo,nj_glo=Nj0glo,ibegin=mig0(Nis0)-1,jbegin=mjg0(Njs0)-1,ni=Ni_0,nj=Nj_0)
- CALL iom_set_domain_attr("grid_"//cdgrd, data_dim=2, data_ibegin = -nn_hls, data_ni=jpi, data_jbegin = -nn_hls, data_nj=jpj)
-
- CALL iom_set_domain_attr("grid_"//cdgrd//"_inner", ni_glo = Ni0glo, nj_glo = Nj0glo, &
- & ibegin = mig0(Nis0) - 1, jbegin = mjg0(Njs0) - 1, ni = Ni_0, nj = Nj_0)
- CALL iom_set_domain_attr("grid_"//cdgrd//"_inner", data_dim=2, data_ibegin = 0, data_ni=Ni_0, data_jbegin = 0, data_nj=Nj_0)
+ ! nn_hls halo points
+ CALL iom_set_domain_attr("grid_"//cdgrd, &
+ & ni_glo=Ni0glo, nj_glo=Nj0glo, ibegin=mig(Nis0,0)-1, jbegin=mjg(Njs0,0)-1, ni=Ni_0, nj=Nj_0, &
+ & data_dim=2, data_ibegin=-nn_hls, data_ni=jpi, data_jbegin=-nn_hls, data_nj=jpj )
+ ! 1 halo point, nn_hls > 1
+ CALL iom_set_domain_attr("grid_"//cdgrd//"_halo1", &
+ & ni_glo=Ni0glo, nj_glo=Nj0glo, ibegin=mig(Nis0,0)-1, jbegin=mjg(Njs0,0)-1, ni=Ni_0, nj=Nj_0, &
+ & data_dim=2, data_ibegin=-1, data_ni=Ni_0+2, data_jbegin=-1, data_nj=Nj_0+2 )
+ ! Inner domain only
+ CALL iom_set_domain_attr("grid_"//cdgrd//"_inner", &
+ & ni_glo=Ni0glo, nj_glo=Nj0glo, ibegin=mig(Nis0,0)-1, jbegin=mjg(Njs0,0)-1, ni=Ni_0, nj=Nj_0, &
+ & data_dim=2, data_ibegin=0, data_ni=Ni_0, data_jbegin=0, data_nj=Nj_0 )
IF( ln_tile ) THEN
DO jn = 1, nijtile
@@ -2358,14 +2436,23 @@ CONTAINS
idb(jn) = -nn_hls ! Tile data offset (halo size)
END DO
- ! Tile_[ij]begin are defined with respect to the processor data domain, so data_[ij]begin is added
+ ! Data includes all halo points
CALL iom_set_domain_attr("grid_"//cdgrd, ntiles=nijtile, &
- & tile_ibegin=ntsi_a(1:nijtile) + idb(:) - 1, tile_jbegin=ntsj_a(1:nijtile) + idb(:) - 1, &
+ & tile_ibegin=ntsi_a(1:nijtile) - nn_hls - 1, tile_jbegin=ntsj_a(1:nijtile) - nn_hls - 1, &
+ & tile_ni=ini(:), tile_nj=inj(:), &
+ & tile_data_ibegin=idb(:), tile_data_jbegin=idb(:), &
+ & tile_data_ni=ini(:) - 2 * idb(:), tile_data_nj=inj(:) - 2 * idb(:))
+ ! Data contains one halo point (less than nn_hls)
+ idb(:) = -1
+ CALL iom_set_domain_attr("grid_"//cdgrd//"_halo1", ntiles=nijtile, &
+ & tile_ibegin=ntsi_a(1:nijtile) - nn_hls - 1, tile_jbegin=ntsj_a(1:nijtile) - nn_hls - 1, &
& tile_ni=ini(:), tile_nj=inj(:), &
& tile_data_ibegin=idb(:), tile_data_jbegin=idb(:), &
& tile_data_ni=ini(:) - 2 * idb(:), tile_data_nj=inj(:) - 2 * idb(:))
+ ! Data contains no halo points
+ idb(:) = 0
CALL iom_set_domain_attr("grid_"//cdgrd//"_inner", ntiles=nijtile, &
- & tile_ibegin=ntsi_a(1:nijtile) + idb(:) - 1, tile_jbegin=ntsj_a(1:nijtile) + idb(:) - 1, &
+ & tile_ibegin=ntsi_a(1:nijtile) - nn_hls - 1, tile_jbegin=ntsj_a(1:nijtile) - nn_hls - 1, &
& tile_ni=ini(:), tile_nj=inj(:), &
& tile_data_ibegin=idb(:), tile_data_jbegin=idb(:), &
& tile_data_ni=ini(:) - 2 * idb(:), tile_data_nj=inj(:) - 2 * idb(:))
@@ -2389,8 +2476,10 @@ CONTAINS
END SELECT
!
CALL iom_set_domain_attr( "grid_"//cdgrd , mask=RESHAPE(zmask(:,:,1),(/Ni_0*Nj_0 /)) /= 0. )
- CALL iom_set_grid_attr ( "grid_"//cdgrd//"_3D" , mask=RESHAPE(zmask(:,:,:),(/Ni_0,Nj_0,jpk/)) /= 0. )
+ CALL iom_set_domain_attr( "grid_"//cdgrd//"_halo1" , mask=RESHAPE(zmask(:,:,1),(/Ni_0*Nj_0 /)) /= 0. )
CALL iom_set_domain_attr( "grid_"//cdgrd//"_inner" , mask=RESHAPE(zmask(:,:,1),(/Ni_0*Nj_0 /)) /= 0. )
+ CALL iom_set_grid_attr ( "grid_"//cdgrd//"_3D" , mask=RESHAPE(zmask(:,:,:),(/Ni_0,Nj_0,jpk/)) /= 0. )
+ CALL iom_set_grid_attr ( "grid_"//cdgrd//"_3D_halo1", mask=RESHAPE(zmask(:,:,:),(/Ni_0,Nj_0,jpk/)) /= 0. )
CALL iom_set_grid_attr ( "grid_"//cdgrd//"_3D_inner", mask=RESHAPE(zmask(:,:,:),(/Ni_0,Nj_0,jpk/)) /= 0. )
ENDIF
!
@@ -2428,7 +2517,7 @@ CONTAINS
END SELECT
!
z_fld(:,:) = 1._wp
- CALL lbc_lnk( 'iom', z_fld, cdgrd, -1.0_wp ) ! Working array for location of northfold
+ CALL lbc_lnk( 'iom', z_fld, cdgrd, -1.0_wp, ldfull = .TRUE. ) ! Working array for location of northfold
!
! Cell vertices that can be defined
DO_2D( 0, 0, 0, 0 )
@@ -2474,8 +2563,8 @@ CONTAINS
!
! CALL dom_ngb( -168.53_wp, 65.03_wp, ix, iy, 'T' ) ! i-line that passes through Bering Strait: Reference latitude (used in plots)
CALL dom_ngb( 180.0_wp, 90.0_wp, ix, iy, 'T' ) ! i-line that passes near the North Pole : Reference latitude (used in plots)
- CALL iom_set_domain_attr("gznl", ni_glo=Ni0glo, nj_glo=Nj0glo, ibegin=mig0(Nis0)-1, jbegin=mjg0(Njs0)-1, ni=Ni_0, nj=Nj_0)
- CALL iom_set_domain_attr("gznl", data_dim=2, data_ibegin = -nn_hls, data_ni = jpi, data_jbegin = -nn_hls, data_nj = jpj)
+ CALL iom_set_domain_attr("gznl", ni_glo=Ni0glo, nj_glo=Nj0glo, ibegin=mig(Nis0,0)-1, jbegin=mjg(Njs0,0)-1, ni=Ni_0, nj=Nj_0)
+ CALL iom_set_domain_attr("gznl", data_dim=2, data_ibegin=0, data_ni=Ni_0, data_jbegin=0, data_nj=Nj_0)
CALL iom_set_domain_attr("gznl", lonvalue = real(zlon, dp), &
& latvalue = real(RESHAPE(plat(Nis0:Nie0, Njs0:Nje0),(/ Ni_0*Nj_0 /)),dp))
CALL iom_set_zoom_domain_attr("ptr", ibegin=ix-1, jbegin=0, ni=1, nj=Nj0glo)
diff --git a/src/OCE/IOM/iom_nf90.F90 b/src/OCE/IOM/iom_nf90.F90
index c49d9538e007c312f57e69b2fcb05786be34a42f..38d9943cd6de362e2e7beb650e2b0de87b7e2e57 100644
--- a/src/OCE/IOM/iom_nf90.F90
+++ b/src/OCE/IOM/iom_nf90.F90
@@ -40,6 +40,8 @@ MODULE iom_nf90
MODULE PROCEDURE iom_nf90_rp0123d_dp
END INTERFACE
+ !! * Substitutions
+# include "do_loop_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
!! $Id: iom_nf90.F90 14433 2021-02-11 08:06:49Z smasson $
@@ -144,16 +146,16 @@ CONTAINS
END SELECT
CALL iom_nf90_check(NF90_DEF_DIM( if90id, 'time_counter', NF90_UNLIMITED, idmy ), clinfo)
! global attributes
- CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_number_total' , jpnij ), clinfo)
- CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_number' , narea-1 ), clinfo)
- CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_dimensions_ids' , (/ 1 , 2 /) ), clinfo)
- CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_size_global' , (/ Ni0glo , Nj0glo /) ), clinfo)
- CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_size_local' , (/ Ni_0 , Nj_0 /) ), clinfo)
- CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_position_first' , (/ mig0(Nis0), mjg0(Njs0) /) ), clinfo)
- CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_position_last' , (/ mig0(Nie0), mjg0(Nje0) /) ), clinfo)
- CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_halo_size_start', (/ 0 , 0 /) ), clinfo)
- CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_halo_size_end' , (/ 0 , 0 /) ), clinfo)
- CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_type' , 'BOX' ), clinfo)
+ CALL iom_nf90_check(NF90_PUT_ATT(if90id,NF90_GLOBAL, 'DOMAIN_number_total' , jpnij ), clinfo)
+ CALL iom_nf90_check(NF90_PUT_ATT(if90id,NF90_GLOBAL, 'DOMAIN_number' , narea-1 ), clinfo)
+ CALL iom_nf90_check(NF90_PUT_ATT(if90id,NF90_GLOBAL, 'DOMAIN_dimensions_ids' , (/ 1 , 2 /) ), clinfo)
+ CALL iom_nf90_check(NF90_PUT_ATT(if90id,NF90_GLOBAL, 'DOMAIN_size_global' , (/ Ni0glo , Nj0glo /) ), clinfo)
+ CALL iom_nf90_check(NF90_PUT_ATT(if90id,NF90_GLOBAL, 'DOMAIN_size_local' , (/ Ni_0 , Nj_0 /) ), clinfo)
+ CALL iom_nf90_check(NF90_PUT_ATT(if90id,NF90_GLOBAL, 'DOMAIN_position_first' , (/ mig(Nis0,0), mjg(Njs0,0) /) ), clinfo)
+ CALL iom_nf90_check(NF90_PUT_ATT(if90id,NF90_GLOBAL, 'DOMAIN_position_last' , (/ mig(Nie0,0), mjg(Nje0,0) /) ), clinfo)
+ CALL iom_nf90_check(NF90_PUT_ATT(if90id,NF90_GLOBAL, 'DOMAIN_halo_size_start', (/ 0 , 0 /) ), clinfo)
+ CALL iom_nf90_check(NF90_PUT_ATT(if90id,NF90_GLOBAL, 'DOMAIN_halo_size_end' , (/ 0 , 0 /) ), clinfo)
+ CALL iom_nf90_check(NF90_PUT_ATT(if90id,NF90_GLOBAL, 'DOMAIN_type' , 'BOX' ), clinfo)
ELSE !* the file should be open for read mode so it must exist...
CALL ctl_stop( TRIM(clinfo), ' should be impossible case...' )
ENDIF
@@ -544,7 +546,7 @@ CONTAINS
INTEGER :: idvar ! variable id
INTEGER :: jd ! dimension loop counter
INTEGER :: ix1, ix2, iy1, iy2 ! subdomain indexes
- INTEGER, DIMENSION(4) :: idimsz ! dimensions size
+ INTEGER, DIMENSION(3) :: ishape ! dimensions size
INTEGER, DIMENSION(4) :: idimid ! dimensions id
CHARACTER(LEN=256) :: clinfo ! info character
INTEGER :: if90id ! nf90 file identifier
@@ -627,11 +629,9 @@ CONTAINS
itype = NF90_DOUBLE
ENDIF
IF( PRESENT(pv_r0d) ) THEN
- CALL iom_nf90_check(NF90_DEF_VAR( if90id, TRIM(cdvar), itype, &
- & iom_file(kiomid)%nvid(idvar) ), clinfo )
+ CALL iom_nf90_check(NF90_DEF_VAR( if90id, TRIM(cdvar), itype, iom_file(kiomid)%nvid(idvar) ), clinfo )
ELSE
- CALL iom_nf90_check(NF90_DEF_VAR( if90id, TRIM(cdvar), itype, idimid(1:idims), &
- & iom_file(kiomid)%nvid(idvar) ), clinfo )
+ CALL iom_nf90_check(NF90_DEF_VAR( if90id, TRIM(cdvar), itype, idimid(1:idims), iom_file(kiomid)%nvid(idvar) ), clinfo )
ENDIF
lchunk = .false.
IF( snc4set%luse .AND. idims == 4 ) lchunk = .true.
@@ -673,23 +673,13 @@ CONTAINS
ENDIF
! on what kind of domain must the data be written?
IF( PRESENT(pv_r2d) .OR. PRESENT(pv_r3d) ) THEN
- idimsz(1:2) = iom_file(kiomid)%dimsz(1:2,idvar)
- IF( idimsz(1) == Ni_0 .AND. idimsz(2) == Nj_0 ) THEN
- ix1 = Nis0 ; ix2 = Nie0 ; iy1 = Njs0 ; iy2 = Nje0
- ELSEIF( idimsz(1) == jpi .AND. idimsz(2) == jpj ) THEN
- ix1 = 1 ; ix2 = jpi ; iy1 = 1 ; iy2 = jpj
- ELSEIF( idimsz(1) == jpi .AND. idimsz(2) == jpj ) THEN
- ix1 = 1 ; ix2 = jpi ; iy1 = 1 ; iy2 = jpj
- ELSE
- CALL ctl_stop( 'iom_nf90_rp0123d: should have been an impossible case...' )
- ENDIF
! write dimension variables if it is not already done
! =============
! trick: is defined to 0 => dimension variable are defined but not yet written
IF( iom_file(kiomid)%dimsz(1, 4) == 0 ) THEN ! time_counter = 0
- CALL iom_nf90_check( NF90_PUT_VAR( if90id, 1, glamt(ix1:ix2, iy1:iy2) ), clinfo )
- CALL iom_nf90_check( NF90_PUT_VAR( if90id, 2, gphit(ix1:ix2, iy1:iy2) ), clinfo )
+ CALL iom_nf90_check( NF90_PUT_VAR( if90id, 1, glamt(T2D(0)) ), clinfo )
+ CALL iom_nf90_check( NF90_PUT_VAR( if90id, 2, gphit(T2D(0)) ), clinfo )
SELECT CASE (iom_file(kiomid)%comp)
CASE ('OCE')
CALL iom_nf90_check( NF90_PUT_VAR( if90id, 3, gdept_1d ), clinfo )
@@ -704,6 +694,19 @@ CONTAINS
iom_file(kiomid)%dimsz(1, 4) = 1 ! so we don't enter this IF case any more...
IF(lwp) WRITE(numout,*) TRIM(clinfo)//' write dimension variables done'
ENDIF
+
+ IF( PRESENT(pv_r2d) ) ishape(1:2) = SHAPE(pv_r2d)
+ IF( PRESENT(pv_r3d) ) ishape(1:3) = SHAPE(pv_r3d)
+ IF( ishape(1) == Ni_0 .AND. ishape(2) == Nj_0 ) THEN ! array with 0 halo
+ ix1 = 1 ; ix2 = Ni_0 ; iy1 = 1 ; iy2 = Nj_0
+ ELSEIF( ishape(1) == jpi .AND. ishape(2) == jpj ) THEN ! array with nn_hls halos
+ ix1 = Nis0 ; ix2 = Nie0 ; iy1 = Njs0 ; iy2 = Nje0
+ ELSEIF( ishape(1) == Ni_0+2 .AND. ishape(2) == Nj_0+2 ) THEN ! nn_hls = 2 and array with 1 halo
+ ix1 = 2 ; ix2 = Ni_0+1 ; iy1 = 2 ; iy2 = Nj_0+1
+ ELSE
+ CALL ctl_stop( 'iom_nf90_rp0123d: should have been an impossible case...' )
+ ENDIF
+
ENDIF
! write the data
@@ -712,7 +715,7 @@ CONTAINS
CALL iom_nf90_check( NF90_PUT_VAR( if90id, idvar, pv_r0d ), clinfo )
ELSEIF( PRESENT(pv_r1d) ) THEN
CALL iom_nf90_check( NF90_PUT_VAR( if90id, idvar, pv_r1d(:) ), clinfo )
- ELSEIF( PRESENT(pv_r2d) ) THEN
+ ELSEIF( PRESENT(pv_r2d) ) THEN
CALL iom_nf90_check( NF90_PUT_VAR( if90id, idvar, pv_r2d(ix1:ix2,iy1:iy2) ), clinfo )
ELSEIF( PRESENT(pv_r3d) ) THEN
CALL iom_nf90_check( NF90_PUT_VAR( if90id, idvar, pv_r3d(ix1:ix2,iy1:iy2,:) ), clinfo )
diff --git a/src/OCE/IOM/prtctl.F90 b/src/OCE/IOM/prtctl.F90
index fae7c0d8041cfef5ebb1e57b6e1b6e3026ae14f2..74152ddf1bfce030146aa0e2c93105e8af297819 100644
--- a/src/OCE/IOM/prtctl.F90
+++ b/src/OCE/IOM/prtctl.F90
@@ -7,7 +7,7 @@ MODULE prtctl
!! 3.4 ! 11-11 (C. Harris) decomposition changes for running with CICE
!!----------------------------------------------------------------------
USE dom_oce ! ocean space and time domain variables
- USE domutl, ONLY : is_tile
+ USE domutl, ONLY : lbnd_ij
USE in_out_manager ! I/O manager
USE mppini ! distributed memory computing
USE lib_mpp ! distributed memory computing
@@ -50,39 +50,49 @@ CONTAINS
CHARACTER(len=*) , INTENT(in), OPTIONAL :: clinfo2
CHARACTER(len=*) , INTENT(in), OPTIONAL :: clinfo3
INTEGER , INTENT(in), OPTIONAL :: kdim
+ INTEGER, DIMENSION(2) :: ibndg, ibndm1, ibndm2
!
+ ibndg(1) = Nis0 ; ibndg(2) = Njs0
+ IF( PRESENT(mask1) ) THEN ; ibndm1 = lbnd_ij(mask1) ; ELSE ; ibndm1 = ibndg ; ENDIF
+ IF( PRESENT(mask2) ) THEN ; ibndm2 = lbnd_ij(mask2) ; ELSE ; ibndm2 = ibndg ; ENDIF
+
IF( PRESENT(tab2d_2) ) THEN
- CALL prt_ctl_t(ktab2d_1 = is_tile(tab2d_1), ktab3d_1 = 0, ktab4d_1 = 0, ktab2d_2 = is_tile(tab2d_2), ktab3d_2 = 0, &
- & tab2d_1 = REAL(tab2d_1, 2*wp), tab2d_2 = REAL(tab2d_2, 2*wp), &
- & mask1 = mask1, mask2 = mask2, &
- & clinfo = clinfo, clinfo1 = clinfo1, clinfo2 = clinfo2, clinfo3 = clinfo3 )
- ELSEIF( PRESENT(tab3d_2) ) THEN
- CALL prt_ctl_t(ktab2d_1 = 0, ktab3d_1 = is_tile(tab3d_1), ktab4d_1 = 0, ktab2d_2 = 0, ktab3d_2 = is_tile(tab3d_2), &
- & tab3d_1 = REAL(tab3d_1, 2*wp), tab3d_2 = REAL(tab3d_2, 2*wp), &
- & mask1 = mask1, mask2 = mask2, &
- & clinfo = clinfo, clinfo1 = clinfo1, clinfo2 = clinfo2, clinfo3 = clinfo3, kdim = kdim )
- ELSEIF( PRESENT(tab2d_1) ) THEN
- CALL prt_ctl_t(ktab2d_1 = is_tile(tab2d_1), ktab3d_1 = 0, ktab4d_1 = 0, ktab2d_2 = 0, ktab3d_2 = 0, &
- & tab2d_1 = REAL(tab2d_1,2*wp), &
- & mask1 = mask1, &
- & clinfo = clinfo, clinfo1 = clinfo1, clinfo3 = clinfo3 )
- ELSEIF( PRESENT(tab3d_1) ) THEN
- CALL prt_ctl_t(ktab2d_1 = 0, ktab3d_1 = is_tile(tab3d_1), ktab4d_1 = 0, ktab2d_2 = 0, ktab3d_2 = 0, &
- & tab3d_1 = REAL(tab3d_1, 2*wp), &
- & mask1 = mask1, &
- & clinfo = clinfo, clinfo1 = clinfo1, clinfo3 = clinfo3, kdim = kdim )
+ CALL prt_ctl_t(ktab2d_1=lbnd_ij(tab2d_1), ktab3d_1=ibndg, ktab4d_1=ibndg, &
+ & ktab2d_2=lbnd_ij(tab2d_2), ktab3d_2=ibndg, &
+ & tab2d_1=REAL(tab2d_1, 2*wp), tab2d_2=REAL(tab2d_2, 2*wp), &
+ & kmask1=ibndm1, kmask2=ibndm2, mask1=mask1, mask2=mask2, &
+ & clinfo=clinfo, clinfo1=clinfo1, clinfo2=clinfo2, clinfo3=clinfo3 )
+ ELSEIF( PRESENT(tab3d_2) ) THEN
+ CALL prt_ctl_t(ktab2d_1=ibndg, ktab3d_1=lbnd_ij(tab3d_1), ktab4d_1=ibndg, &
+ & ktab2d_2=ibndg, ktab3d_2=lbnd_ij(tab3d_2), &
+ & tab3d_1=REAL(tab3d_1, 2*wp), tab3d_2=REAL(tab3d_2, 2*wp), &
+ & kmask1=ibndm1, kmask2=ibndm2, mask1=mask1, mask2=mask2, &
+ & clinfo=clinfo, clinfo1=clinfo1, clinfo2=clinfo2, clinfo3=clinfo3, kdim=kdim )
+ ELSEIF( PRESENT(tab2d_1) ) THEN
+ CALL prt_ctl_t(ktab2d_1=lbnd_ij(tab2d_1), ktab3d_1=ibndg, ktab4d_1=ibndg, &
+ & ktab2d_2=ibndg, ktab3d_2=ibndg, &
+ & tab2d_1=REAL(tab2d_1, 2*wp), &
+ & kmask1=ibndm1, kmask2=ibndm2, mask1=mask1, &
+ & clinfo=clinfo, clinfo1=clinfo1, clinfo3=clinfo3 )
+ ELSEIF( PRESENT(tab3d_1) ) THEN
+ CALL prt_ctl_t(ktab2d_1=ibndg, ktab3d_1=lbnd_ij(tab3d_1), ktab4d_1=ibndg, &
+ & ktab2d_2=ibndg, ktab3d_2=ibndg, &
+ & tab3d_1=REAL(tab3d_1, 2*wp), &
+ & kmask1=ibndm1, kmask2=ibndm2, mask1=mask1, &
+ & clinfo=clinfo, clinfo1=clinfo1, clinfo3=clinfo3, kdim=kdim )
ELSEIF( PRESENT(tab4d_1) ) THEN
- CALL prt_ctl_t(ktab2d_1 = 0, ktab3d_1 = 0, ktab4d_1 = is_tile(tab4d_1), ktab2d_2 = 0, ktab3d_2 = 0, &
- & tab4d_1 = REAL(tab4d_1, 2*wp), &
- & mask1 = mask1, &
- & clinfo = clinfo, clinfo1 = clinfo1, clinfo3 = clinfo3, kdim = kdim )
+ CALL prt_ctl_t(ktab2d_1=ibndg, ktab3d_1=ibndg, ktab4d_1=lbnd_ij(tab4d_1), &
+ & ktab2d_2=ibndg, ktab3d_2=ibndg, &
+ & tab4d_1=REAL(tab4d_1, 2*wp), &
+ & kmask1=ibndm1, kmask2=ibndm2, mask1=mask1, &
+ & clinfo=clinfo, clinfo1=clinfo1, clinfo3=clinfo3, kdim=kdim )
ENDIF
END SUBROUTINE prt_ctl
SUBROUTINE prt_ctl_t (tab2d_1, ktab2d_1, tab3d_1, ktab3d_1, tab4d_1, ktab4d_1, tab2d_2, ktab2d_2, tab3d_2, ktab3d_2, &
- & mask1, mask2, clinfo, clinfo1, clinfo2, clinfo3, kdim )
+ & mask1, kmask1, mask2, kmask2, clinfo, clinfo1, clinfo2, clinfo3, kdim )
!!----------------------------------------------------------------------
!! *** ROUTINE prt_ctl ***
!!
@@ -118,22 +128,23 @@ CONTAINS
!! kdim : k- direction for 3D arrays
!! clinfo3 : additional information
!!----------------------------------------------------------------------
- INTEGER , INTENT(in) :: ktab2d_1, ktab3d_1, ktab4d_1, ktab2d_2, ktab3d_2
- REAL(2*wp), DIMENSION(A2D_T(ktab2d_1)) , INTENT(in), OPTIONAL :: tab2d_1
- REAL(2*wp), DIMENSION(A2D_T(ktab3d_1),:) , INTENT(in), OPTIONAL :: tab3d_1
- REAL(2*wp), DIMENSION(A2D_T(ktab4d_1),:,:), INTENT(in), OPTIONAL :: tab4d_1
- REAL(2*wp), DIMENSION(A2D_T(ktab2d_2)) , INTENT(in), OPTIONAL :: tab2d_2
- REAL(2*wp), DIMENSION(A2D_T(ktab3d_2),:) , INTENT(in), OPTIONAL :: tab3d_2
- REAL(wp), DIMENSION(:,:,:) , INTENT(in), OPTIONAL :: mask1
- REAL(wp), DIMENSION(:,:,:) , INTENT(in), OPTIONAL :: mask2
+ INTEGER, DIMENSION(2), INTENT(in) :: ktab2d_1, ktab3d_1, ktab4d_1, ktab2d_2, ktab3d_2, kmask1, kmask2
+ REAL(2*wp), DIMENSION(AB2D(ktab2d_1)) , INTENT(in), OPTIONAL :: tab2d_1
+ REAL(2*wp), DIMENSION(AB2D(ktab3d_1),:) , INTENT(in), OPTIONAL :: tab3d_1
+ REAL(2*wp), DIMENSION(AB2D(ktab4d_1),:,:) , INTENT(in), OPTIONAL :: tab4d_1
+ REAL(2*wp), DIMENSION(AB2D(ktab2d_2)) , INTENT(in), OPTIONAL :: tab2d_2
+ REAL(2*wp), DIMENSION(AB2D(ktab3d_2),:) , INTENT(in), OPTIONAL :: tab3d_2
+ REAL(wp), DIMENSION(AB2D(kmask1),:) , INTENT(in), OPTIONAL :: mask1
+ REAL(wp), DIMENSION(AB2D(kmask2),:) , INTENT(in), OPTIONAL :: mask2
CHARACTER(len=*), DIMENSION(:) , INTENT(in), OPTIONAL :: clinfo ! information about the tab3d array
CHARACTER(len=*) , INTENT(in), OPTIONAL :: clinfo1
CHARACTER(len=*) , INTENT(in), OPTIONAL :: clinfo2
CHARACTER(len=*) , INTENT(in), OPTIONAL :: clinfo3
INTEGER , INTENT(in), OPTIONAL :: kdim
!
- CHARACTER(len=30) :: cl1, cl2
+ CHARACTER(len=30) :: cl1, cl2, cl3
CHARACTER(len=6) :: clfmt
+ CHARACTER(len=1) :: cli1
INTEGER :: jn, jl, kdir
INTEGER :: iis, iie, jjs, jje
INTEGER :: itra, inum
@@ -158,7 +169,6 @@ CONTAINS
! Loop over each sub-domain, i.e. the total number of processors ijsplt
DO jl = 1, SIZE(nall_ictls)
- ! define shoter names...
iis = MAX( nall_ictls(jl), ntsi )
iie = MIN( nall_ictle(jl), ntei )
jjs = MAX( nall_jctls(jl), ntsj )
@@ -168,7 +178,9 @@ CONTAINS
ELSE ; inum = numprt_oce(jl)
ENDIF
- ! Compute the sum control only where the tile domain and control print area overlap
+ ! Compute the sum control only where the inner domain and control print area overlap.
+ ! Note that if tiling is enabled and currently active, the inner domain is that of the current tile.
+ ! Otherwise, the inner domain is that of the current MPI domain (i.e. Nis0:Nie0, Njs0:Nje0)
IF( iie >= iis .AND. jje >= jjs ) THEN
DO jn = 1, itra
@@ -188,32 +200,32 @@ CONTAINS
! 2D arrays
IF( PRESENT(tab2d_1) ) THEN
- IF( PRESENT(mask1) ) THEN ; zsum1 = SUM( tab2d_1(iis:iie,jjs:jje) * mask1(iis:iie,jjs:jje,1) )
- ELSE ; zsum1 = SUM( tab2d_1(iis:iie,jjs:jje) )
+ IF( PRESENT(mask1) ) THEN ; zsum1 = SUM( tab2d_1(iis:iie,jjs:jje) * mask1(iis:iie,jjs:jje,1) )
+ ELSE ; zsum1 = SUM( tab2d_1(iis:iie,jjs:jje) )
ENDIF
ENDIF
IF( PRESENT(tab2d_2) ) THEN
- IF( PRESENT(mask2) ) THEN ; zsum2 = SUM( tab2d_2(iis:iie,jjs:jje) * mask2(iis:iie,jjs:jje,1) )
- ELSE ; zsum2 = SUM( tab2d_2(iis:iie,jjs:jje) )
+ IF( PRESENT(mask2) ) THEN ; zsum2 = SUM( tab2d_2(iis:iie,jjs:jje) * mask2(iis:iie,jjs:jje,1) )
+ ELSE ; zsum2 = SUM( tab2d_2(iis:iie,jjs:jje) )
ENDIF
ENDIF
! 3D arrays
IF( PRESENT(tab3d_1) ) THEN
- IF( PRESENT(mask1) ) THEN ; zsum1 = SUM( tab3d_1(iis:iie,jjs:jje,1:kdir) * mask1(iis:iie,jjs:jje,1:kdir) )
- ELSE ; zsum1 = SUM( tab3d_1(iis:iie,jjs:jje,1:kdir) )
+ IF( PRESENT(mask1) ) THEN ; zsum1 = SUM( tab3d_1(iis:iie,jjs:jje,1:kdir) * mask1(iis:iie,jjs:jje,1:kdir) )
+ ELSE ; zsum1 = SUM( tab3d_1(iis:iie,jjs:jje,1:kdir) )
ENDIF
ENDIF
IF( PRESENT(tab3d_2) ) THEN
- IF( PRESENT(mask2) ) THEN ; zsum2 = SUM( tab3d_2(iis:iie,jjs:jje,1:kdir) * mask2(iis:iie,jjs:jje,1:kdir) )
- ELSE ; zsum2 = SUM( tab3d_2(iis:iie,jjs:jje,1:kdir) )
+ IF( PRESENT(mask2) ) THEN ; zsum2 = SUM( tab3d_2(iis:iie,jjs:jje,1:kdir) * mask2(iis:iie,jjs:jje,1:kdir) )
+ ELSE ; zsum2 = SUM( tab3d_2(iis:iie,jjs:jje,1:kdir) )
ENDIF
ENDIF
! 4D arrays
IF( PRESENT(tab4d_1) ) THEN
- IF( PRESENT(mask1) ) THEN ; zsum1 = SUM( tab4d_1(iis:iie,jjs:jje,1:kdir,jn) * mask1(iis:iie,jjs:jje,1:kdir) )
- ELSE ; zsum1 = SUM( tab4d_1(iis:iie,jjs:jje,1:kdir,jn) )
+ IF( PRESENT(mask1) ) THEN ; zsum1 = SUM( tab4d_1(iis:iie,jjs:jje,1:kdir,jn) * mask1(iis:iie,jjs:jje,1:kdir) )
+ ELSE ; zsum1 = SUM( tab4d_1(iis:iie,jjs:jje,1:kdir,jn) )
ENDIF
ENDIF
@@ -243,8 +255,31 @@ CONTAINS
WRITE(inum, "(3x,a,' : ',"//clfmt//",3x,a,' : ',"//clfmt//")") cl1, zsum1, cl2, zsum2
ELSE
WRITE(inum, "(3x,a,' : ',"//clfmt//" )") cl1, zsum1
- ENDIF
+ ENDIF
+ ! replace .false. by .true. to switch on theses prints of the last inner line
+ IF( .FALSE. .AND. l_IdoNFold .AND. jje == Nje0 ) THEN
+ IF( PRESENT(tab2d_1) ) THEN
+ WRITE(cli1, '(i1)') INT(LOG10(REAL(iie-iis+1,wp))) + 1 ! how many digits to we need to write ?
+ WRITE(cl3, "(i"//cli1//")") iie-iis+1
+ WRITE(inum, "(a,"//TRIM(cl3)//clfmt//")") 'Last line '//TRIM(cl1)//' ', tab2d_1(iis:iie,jje)
+ ENDIF
+ IF( PRESENT(tab3d_1) ) THEN
+ WRITE(cli1, '(i1)') INT(LOG10(REAL((iie-iis+1)*kdir,wp))) + 1 ! how many digits to we need to write ?
+ WRITE(cl3, "(i"//cli1//")") (iie-iis+1)*kdir
+ WRITE(inum, "(a,"//TRIM(cl3)//clfmt//")") 'Last line '//TRIM(cl1)//' ', tab3d_1(iis:iie,jje,1:kdir)
+ ENDIF
+ IF( PRESENT(tab2d_2) ) THEN
+ WRITE(cli1, '(i1)') INT(LOG10(REAL(iie-iis+1,wp))) + 1 ! how many digits to we need to write ?
+ WRITE(cl3, "(i"//cli1//")") iie-iis+1
+ WRITE(inum, "(a,"//TRIM(cl3)//clfmt//")") 'Last line '//TRIM(cl2)//' ', tab2d_2(iis:iie,jje)
+ ENDIF
+ IF( PRESENT(tab3d_2) ) THEN
+ WRITE(cli1, '(i1)') INT(LOG10(REAL((iie-iis+1)*kdir,wp))) + 1 ! how many digits to we need to write ?
+ WRITE(cl3, "(i"//cli1//")") (iie-iis+1)*kdir
+ WRITE(inum, "(a,"//TRIM(cl3)//clfmt//")") 'Last line '//TRIM(cl2)//' ', tab3d_2(iis:iie,jje,1:kdir)
+ ENDIF
+ ENDIF
END DO
ENDIF
IF( jpnij == 1 ) CALL FLUSH(inum)
@@ -460,22 +495,22 @@ CONTAINS
!
idg = MAXVAL( (/ nall_ictls(jl), nall_ictle(jl), nall_jctls(jl), nall_jctle(jl) /) ) ! temporary use of idg
idg = INT(LOG10(REAL(idg,wp))) + 1 ! how many digits do we use?
- idg2 = MAXVAL( (/ mig0(nall_ictls(jl)), mig0(nall_ictle(jl)), mjg0(nall_jctls(jl)), mjg0(nall_jctle(jl)) /) )
+ idg2 = MAXVAL( (/ mig(nall_ictls(jl),0), mig(nall_ictle(jl),0), mjg(nall_jctls(jl),0), mjg(nall_jctle(jl),0) /) )
idg2 = INT(LOG10(REAL(idg2,wp))) + 1 ! how many digits do we use?
WRITE(clfmt2, "('(18x, 13a1, a9, i', i1, ', a2, i',i1,', a2, 13a1)')") idg, idg2
WRITE(clfmt3, "('(18x, a1, ', i2,'x, a1)')") 13+9+idg+2+idg2+2+13 - 2
WRITE(clfmt4, "('(', i2,'x, a9, i', i1,', a2, i', i1,', a2, ', i2,'x, a9, i', i1,', a2, i', i1,', a2)')") &
& 18-7, idg, idg2, 13+9+idg+2+idg2+2+13 - (2+idg+2+idg2+2+8), idg, idg2
- WRITE(inum,clfmt2) ('-', ji=1,13), ' jctle = ', nall_jctle(jl), ' (', mjg0(nall_jctle(jl)), ') ', ('-', ji=1,13)
+ WRITE(inum,clfmt2) ('-', ji=1,13), ' jctle = ', nall_jctle(jl), ' (', mjg(nall_jctle(jl),0), ') ', ('-', ji=1,13)
WRITE(inum,clfmt3) '|', '|'
WRITE(inum,clfmt3) '|', '|'
WRITE(inum,clfmt3) '|', '|'
- WRITE(inum,clfmt4) ' ictls = ', nall_ictls(jl), ' (', mig0(nall_ictls(jl)), ') ', &
- & ' ictle = ', nall_ictle(jl), ' (', mig0(nall_ictle(jl)), ') '
+ WRITE(inum,clfmt4) ' ictls = ', nall_ictls(jl), ' (', mig(nall_ictls(jl),0), ') ', &
+ & ' ictle = ', nall_ictle(jl), ' (', mig(nall_ictle(jl),0), ') '
WRITE(inum,clfmt3) '|', '|'
WRITE(inum,clfmt3) '|', '|'
WRITE(inum,clfmt3) '|', '|'
- WRITE(inum,clfmt2) ('-', ji=1,13), ' jctls = ', nall_jctls(jl), ' (', mjg0(nall_jctls(jl)), ') ', ('-', ji=1,13)
+ WRITE(inum,clfmt2) ('-', ji=1,13), ' jctls = ', nall_jctls(jl), ' (', mjg(nall_jctls(jl),0), ') ', ('-', ji=1,13)
WRITE(inum,*)
WRITE(inum,*)
!
diff --git a/src/OCE/ISF/isf_oce.F90 b/src/OCE/ISF/isf_oce.F90
index eb62d83e950736590af07f4ac62c4facb15815e4..0ac9e8a5e1fe8cce5d1400fac07e4bf757cbcbfe 100644
--- a/src/OCE/ISF/isf_oce.F90
+++ b/src/OCE/ISF/isf_oce.F90
@@ -13,8 +13,7 @@ MODULE isf_oce
!! isf : define and allocate ice shelf variables
!!----------------------------------------------------------------------
- USE par_oce , ONLY: jpi, jpj, jpk
- USE in_out_manager, ONLY: wp, jpts ! I/O manager
+ USE par_oce
USE lib_mpp , ONLY: ctl_stop, mpp_sum ! MPP library
USE fldread ! read input fields
@@ -22,7 +21,7 @@ MODULE isf_oce
PRIVATE
- PUBLIC isf_alloc, isf_alloc_par, isf_alloc_cav, isf_alloc_cpl, isf_dealloc_cpl
+ PUBLIC isf_alloc, isf_alloc_par, isf_alloc_cav, isf_alloc_cpl
!
!-------------------------------------------------------
! 0 : namelist parameter
@@ -79,33 +78,35 @@ MODULE isf_oce
REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fwfisf_oasis
!
! 2.2 -------- ice shelf cavity melt namelist parameter -------------
- INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: mskisf_cav !:
- INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: misfkt_cav , misfkb_cav !: shallowest and deepest level of the ice shelf
- REAL(wp) , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: rhisf_tbl_cav, rfrac_tbl_cav !: thickness and fraction of deepest cell affected by the ice shelf
- REAL(wp) , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fwfisf_cav , fwfisf_cav_b !: before and now net fwf from the ice shelf [kg/m2/s]
- REAL(wp) , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: risf_cav_tsc , risf_cav_tsc_b !: before and now T & S isf contents [K.m/s & PSU.m/s]
- TYPE(FLD), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: sf_isfcav_fwf !:
+ INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: mskisf_cav !:
+ INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: misfkt_cav , misfkb_cav !: shallowest and deepest level of the ice shelf
+ REAL(wp) , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: rhisf_tbl_cav, rfrac_tbl_cav !: thickness and fraction of deepest cell affected by the ice shelf
+ REAL(wp) , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fwfisf_cav , fwfisf_cav_b !: before and now net fwf from the ice shelf [kg/m2/s]
+ REAL(wp) , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: risf_cav_tsc , risf_cav_tsc_b !: before and now T & S isf contents [K.m/s & PSU.m/s]
+ TYPE(FLD), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: sf_isfcav_fwf !:
!
- REAL(wp) , PUBLIC :: risf_lamb1, risf_lamb2, risf_lamb3 ! freezing point linearization coeficient
+ REAL(wp) , PUBLIC :: risf_lamb1, risf_lamb2, risf_lamb3 !: freezing point linearization coeficient
!
! 2.3 -------- ice shelf param. melt namelist parameter -------------
- INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: mskisf_par !:
- INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: misfkt_par , misfkb_par !:
- REAL(wp) , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: rhisf_tbl_par, rfrac_tbl_par !:
- REAL(wp) , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fwfisf_par , fwfisf_par_b !: before and now net fwf from the ice shelf [kg/m2/s]
- REAL(wp) , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: risf_par_tsc , risf_par_tsc_b !: before and now T & S isf contents [K.m/s & PSU.m/s]
- TYPE(FLD), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: sf_isfpar_fwf !:
+ INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: mskisf_par !:
+ INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: misfkt_par , misfkb_par !:
+ REAL(wp) , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: rhisf_tbl_par, rfrac_tbl_par !:
+ REAL(wp) , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fwfisf_par , fwfisf_par_b !: before and now net fwf from the ice shelf [kg/m2/s]
+ REAL(wp) , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: risf_par_tsc , risf_par_tsc_b !: before and now T & S isf contents [K.m/s & PSU.m/s]
+ TYPE(FLD), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: sf_isfpar_fwf !:
!
- REAL(wp) , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: rhisf0_tbl_par !: thickness of tbl (initial value) [m]
- REAL(wp) , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: risfLeff !:
+ REAL(wp) , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: rhisf0_tbl_par !: thickness of tbl (initial value) [m]
+ REAL(wp) , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: risfLeff !:
!
! 2.4 -------- coupling namelist parameter -------------
INTEGER , PUBLIC :: nstp_iscpl !:
REAL(wp), PUBLIC :: rdt_iscpl !:
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: risfcpl_ssh, risfcpl_cons_ssh, risfcpl_cons_ssh_b !:
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: risfcpl_vol, risfcpl_cons_vol, risfcpl_cons_vol_b !:
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: risfcpl_tsc, risfcpl_cons_tsc, risfcpl_cons_tsc_b !:
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: risfcpl_ssh, risfcpl_cons_ssh !:
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: risfcpl_vol, risfcpl_cons_vol !:
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: risfcpl_tsc, risfcpl_cons_tsc !:
!
+ !! * Substitutions
+# include "do_loop_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
!! $Id: sbcisf.F90 10536 2019-01-16 19:21:09Z mathiot $
@@ -125,20 +126,12 @@ CONTAINS
INTEGER :: ierr, ialloc
!!----------------------------------------------------------------------
ierr = 0 ! set to zero if no array to be allocated
- !
- ALLOCATE(risfLeff(jpi,jpj), STAT=ialloc)
- ierr = ierr + ialloc
- !
- ALLOCATE(misfkt_par(jpi,jpj), misfkb_par(jpi,jpj), STAT=ialloc )
- ierr = ierr + ialloc
- !
- ALLOCATE( rfrac_tbl_par(jpi,jpj), STAT=ialloc)
- ierr = ierr + ialloc
- !
- ALLOCATE( rhisf_tbl_par(jpi,jpj), rhisf0_tbl_par(jpi,jpj), STAT=ialloc)
- ierr = ierr + ialloc
- !
- ALLOCATE( mskisf_par(jpi,jpj), STAT=ialloc)
+ ! -------------------- !
+ ! == REDUCED ARRAYS == !
+ ! -------------------- !
+ ALLOCATE( misfkt_par (A2D(0)) , misfkb_par (A2D(0)) , rfrac_tbl_par(A2D(0)) , &
+ & rhisf_tbl_par(A2D(0)) , rhisf0_tbl_par(A2D(0)) , &
+ & risfLeff (A2D(0)) , mskisf_par (A2D(0)) , STAT=ialloc )
ierr = ierr + ialloc
!
CALL mpp_sum ( 'isf', ierr )
@@ -159,14 +152,10 @@ CONTAINS
INTEGER :: ierr, ialloc
!!----------------------------------------------------------------------
ierr = 0 ! set to zero if no array to be allocated
- !
- ALLOCATE(misfkt_cav(jpi,jpj), misfkb_cav(jpi,jpj), STAT=ialloc )
- ierr = ierr + ialloc
- !
- ALLOCATE( rfrac_tbl_cav(jpi,jpj), STAT=ialloc)
- ierr = ierr + ialloc
- !
- ALLOCATE( rhisf_tbl_cav(jpi,jpj), STAT=ialloc)
+ ! -------------------- !
+ ! == REDUCED ARRAYS == !
+ ! -------------------- !
+ ALLOCATE( misfkt_cav(A2D(0)), misfkb_cav(A2D(0)), rfrac_tbl_cav(A2D(0)) , rhisf_tbl_cav(A2D(0)) , STAT=ialloc )
ierr = ierr + ialloc
!
CALL mpp_sum ( 'isf', ierr )
@@ -185,46 +174,25 @@ CONTAINS
INTEGER :: ierr, ialloc
!!----------------------------------------------------------------------
ierr = 0
- !
- ALLOCATE( risfcpl_ssh(jpi,jpj) , risfcpl_tsc(jpi,jpj,jpk,jpts) , risfcpl_vol(jpi,jpj,jpk) , STAT=ialloc )
+ ! ----------------- !
+ ! == FULL ARRAYS == !
+ ! ----------------- !
+ ALLOCATE( risfcpl_ssh (jpi,jpj) , risfcpl_vol (jpi,jpj,jpk) , &
+ & risfcpl_cons_ssh(jpi,jpj) , risfcpl_cons_vol(jpi,jpj,jpk) , STAT=ialloc )
+ ierr = ierr + ialloc
+ ! -------------------- !
+ ! == REDUCED ARRAYS == !
+ ! -------------------- !
+ ALLOCATE( risfcpl_tsc (A2D(0),jpk,jpts) , &
+ & risfcpl_cons_tsc(A2D(0),jpk,jpts) , STAT=ialloc )
ierr = ierr + ialloc
- !
- risfcpl_tsc(:,:,:,:) = 0._wp ; risfcpl_vol(:,:,:) = 0._wp ; risfcpl_ssh(:,:) = 0._wp
-
- IF ( ln_isfcpl_cons ) THEN
- ALLOCATE( risfcpl_cons_tsc(jpi,jpj,jpk,jpts) , risfcpl_cons_vol(jpi,jpj,jpk) , risfcpl_cons_ssh(jpi,jpj) , STAT=ialloc )
- ierr = ierr + ialloc
- !
- risfcpl_cons_tsc(:,:,:,:) = 0._wp ; risfcpl_cons_vol(:,:,:) = 0._wp ; risfcpl_cons_ssh(:,:) = 0._wp
- !
- END IF
!
CALL mpp_sum ( 'isf', ierr )
IF( ierr /= 0 ) CALL ctl_stop('STOP','isfcpl: failed to allocate arrays.')
!
END SUBROUTINE isf_alloc_cpl
-
- SUBROUTINE isf_dealloc_cpl()
- !!---------------------------------------------------------------------
- !! *** ROUTINE isf_dealloc_cpl ***
- !!
- !! ** Purpose : de-allocate useless public 3d array used for ice sheet coupling
- !!
- !!----------------------------------------------------------------------
- INTEGER :: ierr, ialloc
- !!----------------------------------------------------------------------
- ierr = 0
- !
- DEALLOCATE( risfcpl_ssh , risfcpl_tsc , risfcpl_vol , STAT=ialloc )
- ierr = ierr + ialloc
- !
- CALL mpp_sum ( 'isf', ierr )
- IF( ierr /= 0 ) CALL ctl_stop('STOP','isfcpl: failed to deallocate arrays.')
- !
- END SUBROUTINE isf_dealloc_cpl
-
-
+
SUBROUTINE isf_alloc()
!!---------------------------------------------------------------------
!! *** ROUTINE isf_alloc ***
@@ -237,52 +205,29 @@ CONTAINS
!
ierr = 0 ! set to zero if no array to be allocated
!
- ALLOCATE( fwfisf_par (jpi,jpj) , fwfisf_cav (jpi,jpj) , &
- & fwfisf_oasis(jpi,jpj) , STAT=ialloc )
- ierr = ierr + ialloc
- !
- ALLOCATE( risf_par_tsc(jpi,jpj,jpts) , STAT=ialloc )
- ierr = ierr + ialloc
- !
- ALLOCATE( risf_cav_tsc(jpi,jpj,jpts) , STAT=ialloc )
- ierr = ierr + ialloc
- !
+ ! ----------------- !
+ ! == FULL ARRAYS == !
+ ! ----------------- !
+ ALLOCATE( fwfisf_par (jpi,jpj) , fwfisf_cav (jpi,jpj) , risfload(jpi,jpj) , &
#if ! defined key_RK3
- ! MLF : need to allocate before arrays
- ALLOCATE( fwfisf_par_b(jpi,jpj) , fwfisf_cav_b(jpi,jpj) , STAT=ialloc )
- ierr = ierr + ialloc
- !
- ALLOCATE( risf_par_tsc_b(jpi,jpj,jpts) , STAT=ialloc )
- ierr = ierr + ialloc
- !
- ALLOCATE( risf_cav_tsc_b(jpi,jpj,jpts) , STAT=ialloc )
- ierr = ierr + ialloc
+ & fwfisf_par_b(jpi,jpj) , fwfisf_cav_b(jpi,jpj) , & ! MLF : need to allocate before arrays
#endif
- !
- ALLOCATE( risfload(jpi,jpj) , STAT=ialloc )
+ & STAT=ialloc )
ierr = ierr + ialloc
!
- ALLOCATE( mskisf_cav(jpi,jpj) , STAT=ialloc )
+ ! -------------------- !
+ ! == REDUCED ARRAYS == !
+ ! -------------------- !
+ ALLOCATE( fwfisf_oasis(A2D(0)) , risf_par_tsc (A2D(0),jpts) , risf_cav_tsc (A2D(0),jpts) , mskisf_cav(A2D(0)) , &
+#if ! defined key_RK3
+ & risf_par_tsc_b(A2D(0),jpts) , risf_cav_tsc_b(A2D(0),jpts) , & ! MLF : need to allocate before arrays
+#endif
+ & STAT=ialloc )
ierr = ierr + ialloc
!
CALL mpp_sum ( 'isf', ierr )
IF( ierr /= 0 ) CALL ctl_stop( 'STOP', 'isf: failed to allocate arrays.' )
!
- ! initalisation of fwf and tsc array to 0
- risfload (:,:) = 0._wp
- fwfisf_oasis(:,:) = 0._wp
-#if defined key_RK3
- fwfisf_par (:,:) = 0._wp
- fwfisf_cav (:,:) = 0._wp
- risf_cav_tsc(:,:,:) = 0._wp
- risf_par_tsc(:,:,:) = 0._wp
-#else
- fwfisf_par (:,:) = 0._wp ; fwfisf_par_b (:,:) = 0._wp
- fwfisf_cav (:,:) = 0._wp ; fwfisf_cav_b (:,:) = 0._wp
- risf_cav_tsc(:,:,:) = 0._wp ; risf_cav_tsc_b(:,:,:) = 0._wp
- risf_par_tsc(:,:,:) = 0._wp ; risf_par_tsc_b(:,:,:) = 0._wp
-#endif
- !
END SUBROUTINE isf_alloc
!!======================================================================
diff --git a/src/OCE/ISF/isfcav.F90 b/src/OCE/ISF/isfcav.F90
index 27ca9912e3048a007d28409609a5ff3e046372a8..29dc6b16e0a2b39d0e167330a5dd73100aacb9db 100644
--- a/src/OCE/ISF/isfcav.F90
+++ b/src/OCE/ISF/isfcav.F90
@@ -14,18 +14,19 @@ MODULE isfcav
!!----------------------------------------------------------------------
USE isf_oce ! ice shelf public variables
!
- USE isfrst , ONLY: isfrst_write, isfrst_read ! ice shelf restart read/write subroutine
+ USE isfrst , ONLY: isfrst_read ! ice shelf restart read/write subroutine
USE isfutils , ONLY: debug ! ice shelf debug subroutine
- USE isftbl , ONLY: isf_tbl ! ice shelf top boundary layer properties subroutine
+ USE isftbl ! ice shelf top boundary layer properties subroutine
USE isfcavmlt, ONLY: isfcav_mlt ! ice shelf melt formulation subroutine
USE isfcavgam, ONLY: isfcav_gammats ! ice shelf melt exchange coeficient subroutine
USE isfdiags , ONLY: isf_diags_flx ! ice shelf diags subroutine
+ USE zdfdrg , ONLY: rCd0_top, r_ke0_top ! vertical physics: top/bottom drag coef.
!
USE oce , ONLY: ts, uu, vv, rn2 ! ocean dynamics and tracers
USE dom_oce ! ocean space and time domain
- USE par_oce , ONLY: jpi,jpj ! ocean space and time domain
- USE phycst , ONLY: grav,rho0,rho0_rcp,r1_rho0_rcp ! physical constants
- USE eosbn2 , ONLY: ln_teos10 ! use ln_teos10 or not
+ USE par_oce ! ocean space and time domain
+ USE phycst ! physical constants
+ USE eosbn2 , ONLY: eos_fzp, ln_teos10 ! equation of state & use ln_teos10 or not
!
USE in_out_manager ! I/O manager
USE iom ! I/O library
@@ -49,7 +50,7 @@ MODULE isfcav
!!----------------------------------------------------------------------
CONTAINS
- SUBROUTINE isf_cav( kt, Kmm, ptsc, pqfwf )
+ SUBROUTINE isf_cav( kt, Kmm, ptsc, pfwf )
!!---------------------------------------------------------------------
!! *** ROUTINE isf_cav ***
!!
@@ -67,123 +68,183 @@ CONTAINS
!! ** Convention : all fluxes are from isf to oce
!!
!!---------------------------------------------------------------------
- !!-------------------------- OUT --------------------------------------
- REAL(wp), DIMENSION(jpi,jpj) , INTENT(inout) :: pqfwf ! ice shelf fwf
- REAL(wp), DIMENSION(jpi,jpj,jpts), INTENT(inout) :: ptsc ! T & S ice shelf cavity contents
- !!-------------------------- IN --------------------------------------
- INTEGER, INTENT(in) :: Kmm ! ocean time level index
INTEGER, INTENT(in) :: kt ! ocean time step
+ INTEGER, INTENT(in) :: Kmm ! ocean time level index
+ REAL(wp), DIMENSION(A2D(0),jpts), INTENT(inout) :: ptsc ! T & S ice shelf cavity contents
+ REAL(wp), DIMENSION(A2D(0)) , INTENT(inout) :: pfwf ! ice shelf fwf
+ !!
+ INTEGER :: iconv, ji, jj, jk, ikt
+ REAL(wp) :: zerr
+ REAL(wp) :: zcoef, zdku, zdkv
+ INTEGER , PARAMETER :: iconv_max = 100
+ LOGICAL , DIMENSION(A2D(0)) :: l_converged ! true when melting converges (per grid point)
+ REAL(wp), DIMENSION(A2D(0)) :: ztfrz ! tbl freezing temperature
+ REAL(wp), DIMENSION(A2D(0)) :: zqlat, zqoce, zqhc ! heat fluxes
+ REAL(wp), DIMENSION(A2D(0)) :: zqh_b, zRc !
+ REAL(wp), DIMENSION(A2D(0)) :: zgammat, zgammas ! exchange coeficient
+ REAL(wp), DIMENSION(A2D(0)) :: zttbl, zstbl ! temp. and sal. in top boundary layer
+ REAL(wp), DIMENSION(A2D(0)) :: zustar ! u*
+ REAL(wp), DIMENSION(A2D(0)) :: zutbl, zvtbl ! top boundary layer velocity
+ REAL(wp), DIMENSION(A2D(0),jpk) :: zvel, ze3 ! u and v at T points and e3t
+ REAL(wp), DIMENSION(:,:), ALLOCATABLE :: ztmp ! temporary array
!!---------------------------------------------------------------------
- LOGICAL :: lit
- INTEGER :: nit, ji, jj, ikt
- REAL(wp) :: zerr
- REAL(wp) :: zcoef, zdku, zdkv
- REAL(wp), DIMENSION(jpi,jpj) :: zqlat, zqoce, zqhc, zqh ! heat fluxes
- REAL(wp), DIMENSION(jpi,jpj) :: zqh_b, zRc !
- REAL(wp), DIMENSION(jpi,jpj) :: zgammat, zgammas ! exchange coeficient
- REAL(wp), DIMENSION(jpi,jpj) :: zttbl, zstbl ! temp. and sal. in top boundary layer
- !!---------------------------------------------------------------------
!
- ! compute T/S/U/V for the top boundary layer
- CALL isf_tbl(Kmm, ts(:,:,:,jp_tem,Kmm), zttbl(:,:),'T', misfkt_cav, rhisf_tbl_cav, misfkb_cav, rfrac_tbl_cav )
- CALL isf_tbl(Kmm, ts(:,:,:,jp_sal,Kmm), zstbl(:,:),'T', misfkt_cav, rhisf_tbl_cav, misfkb_cav, rfrac_tbl_cav )
+ DO_3D( 0 ,0, 0, 0, 1, jpk )
+ ze3(ji,jj,jk) = e3t(ji,jj,jk,Kmm)
+ END_3D
+ !
+ !===============================
+ ! 1.: compute T and S in the tbl
+ !===============================
+ CALL isf_tbl_avg( misfkt_cav, misfkb_cav, rhisf_tbl_cav, rfrac_tbl_cav, ze3, ts(:,:,:,jp_tem,Kmm), & ! <<== in
+ & zttbl ) ! ==>> out
!
- ! output T/S/U/V for the top boundary layer
- CALL iom_put('ttbl_cav',zttbl(:,:) * mskisf_cav(:,:))
- CALL iom_put('stbl' ,zstbl(:,:) * mskisf_cav(:,:))
+ CALL isf_tbl_avg( misfkt_cav, misfkb_cav, rhisf_tbl_cav, rfrac_tbl_cav, ze3, ts(:,:,:,jp_sal,Kmm), & ! <<== in
+ & zstbl ) ! ==>> out
+ !
+ !==========================================
+ ! 2.: compute velocity in the tbl if needed
+ !==========================================
+ IF ( TRIM(cn_gammablk) == 'vel_stab' .OR. TRIM(cn_gammablk) == 'vel' ) THEN
+ ! compute velocity in tbl
+ DO_3D( 0, 0, 0, 0, 1, jpk )
+ zvel(ji,jj,jk) = 0.5_wp * ( uu(ji-1,jj,jk,Kmm) + uu(ji,jj,jk,Kmm) )
+ END_3D
+ CALL isf_tbl_avg( misfkt_cav, misfkb_cav, rhisf_tbl_cav, rfrac_tbl_cav, ze3, zvel, & ! <<== in
+ & zutbl ) ! ==>> out
+ !
+ DO_3D( 0, 0, 0, 0, 1, jpk )
+ zvel(ji,jj,jk) = 0.5_wp * ( vv(ji,jj-1,jk,Kmm) + vv(ji,jj,jk,Kmm) )
+ END_3D
+ CALL isf_tbl_avg( misfkt_cav, misfkb_cav, rhisf_tbl_cav, rfrac_tbl_cav, ze3, zvel, & ! <<== in
+ & zvtbl ) ! ==>> out
+ !
+ ! compute ustar (AD15 eq. 27)
+ DO_2D( 0, 0, 0, 0 )
+ zustar(ji,jj) = SQRT( rCd0_top(ji,jj) * ( ( zutbl(ji,jj)*zutbl(ji,jj) + zvtbl(ji,jj)*zvtbl(ji,jj) ) + r_ke0_top ) &
+ & ) * mskisf_cav(ji,jj)
+ END_2D
+ !
+ !
+ ELSE
+ zustar(:,:) = 0._wp ! not used
+ ENDIF
!
- ! initialisation
+ !==============================
+ ! 3.: compute ice shelf melting
+ !==============================
+ ! --- initialisation --- !
IF ( TRIM(cn_gammablk) == 'vel_stab' ) THEN
- zqoce(:,:) = -pqfwf(:,:) * rLfusisf !
- zqh_b(:,:) = ptsc(:,:,jp_tem) * rho0_rcp ! last time step total heat fluxes (to speed up convergence)
-
+ !
DO_2D( 0, 0, 0, 0 )
+ zqoce(ji,jj) = -pfwf(ji,jj) * rLfusisf * mskisf_cav(ji,jj)
+ zqh_b(ji,jj) = ptsc(ji,jj,jp_tem) * rho0_rcp * mskisf_cav(ji,jj) ! last time step total heat fluxes (to speed up convergence)
+
ikt = mikt(ji,jj)
! compute Rc number (as done in zdfric.F90)
!!gm better to do it like in the new zdfric.F90 i.e. avm weighted Ri computation
zcoef = 0.5_wp / e3w(ji,jj,ikt+1,Kmm)
! ! shear of horizontal velocity
- zdku = zcoef * ( uu(ji-1,jj ,ikt ,Kmm) + uu(ji,jj,ikt ,Kmm) &
- & -uu(ji-1,jj ,ikt+1,Kmm) - uu(ji,jj,ikt+1,Kmm) )
- zdkv = zcoef * ( vv(ji ,jj-1,ikt ,Kmm) + vv(ji,jj,ikt ,Kmm) &
- & -vv(ji ,jj-1,ikt+1,Kmm) - vv(ji,jj,ikt+1,Kmm) )
+ zdku = zcoef * ( ( uu(ji-1,jj ,ikt ,Kmm) + uu(ji,jj,ikt ,Kmm) ) & ! add () for NP repro
+ & - ( uu(ji-1,jj ,ikt+1,Kmm) + uu(ji,jj,ikt+1,Kmm) ) )
+ zdkv = zcoef * ( ( vv(ji ,jj-1,ikt ,Kmm) + vv(ji,jj,ikt ,Kmm) ) & ! add () for NP repro
+ & - ( vv(ji ,jj-1,ikt+1,Kmm) + vv(ji,jj,ikt+1,Kmm) ) )
! ! richardson number (minimum value set to zero)
- zRc(ji,jj) = MAX(rn2(ji,jj,ikt+1), 1.e-20_wp) / MAX( zdku*zdku + zdkv*zdkv, 1.e-20_wp )
+ zRc(ji,jj) = MAX( rn2(ji,jj,ikt+1), 1.e-20_wp ) / MAX( zdku*zdku + zdkv*zdkv, 1.e-20_wp )
END_2D
- CALL lbc_lnk( 'isfmlt', zRc, 'T', 1._wp )
+ !
ENDIF
!
- ! compute ice shelf melting
- nit = 1 ; lit = .TRUE.
- DO WHILE ( lit ) ! maybe just a constant number of iteration as in blk_core is fine
+ ! Calculate freezing temperature (overwritten only in case cn_isfcav_mlt="3eq")
+ CALL eos_fzp( zstbl(:,:), ztfrz(:,:), risfdep(:,:), kbnd=0 )
+ !
+ ! --- iteration loop --- !
+ iconv = 0
+ l_converged(:,:) = .FALSE.
+ ! Convergence calculated until all sub-domain grid points have converged
+ ! Calculations keep going for all grid points until sub-domain convergence (vectorisation optimisation)
+ ! but values are not taken into account (results independant of MPI partitioning)
+ !
+ DO WHILE ( ( .NOT. ALL (l_converged(:,:)) ) .AND. iconv < iconv_max )
+ iconv = iconv + 1
!
- ! compute gammat everywhere (2d)
- ! useless if melt specified
+ ! compute gammat everywhere (2d) - useless if melt specified
IF ( TRIM(cn_isfcav_mlt) .NE. 'spe' ) THEN
- CALL isfcav_gammats( Kmm, zttbl, zstbl, zqoce , pqfwf, zRc, &
- & zgammat, zgammas )
+ CALL isfcav_gammats( Kmm, l_converged, zustar, zttbl, zstbl, zqoce, pfwf, zRc, & ! <<== in
+ & zgammat, zgammas ) ! ==>> inout
END IF
!
! compute tfrz, latent heat and melt (2d)
- CALL isfcav_mlt(kt, zgammat, zgammas, zttbl, zstbl, &
- & zqhc , zqoce, pqfwf )
+ CALL isfcav_mlt( kt, l_converged, zgammat, zgammas, zttbl, zstbl, & ! <<== in
+ & zqhc, zqoce, pfwf, ztfrz ) ! ==>> inout
!
! define if we need to iterate
SELECT CASE ( cn_gammablk )
- CASE ( 'spe','vel' )
- ! no convergence needed
- lit = .FALSE.
+ CASE ( 'spe', 'vel' )
+ l_converged(:,:) = .TRUE. ! no convergence needed
CASE ( 'vel_stab' )
- ! compute error between 2 iterations
- zerr = 0._wp
- DO_2D( 0, 0, 0, 0 )
- zerr = MAX( zerr, ABS(zqhc(ji,jj)+zqoce(ji,jj) - zqh_b(ji,jj)) )
+ DO_2D( 0, 0, 0, 0 ) ! compute error between 2 iterations
+ IF ( .NOT. l_converged(ji,jj) ) THEN
+ zerr = ABS( zqhc(ji,jj) + zqoce(ji,jj) - zqh_b(ji,jj) )
+ IF( zerr <= 0.01_wp ) THEN ! convergence is reached
+ l_converged(ji,jj) = .TRUE.
+ ELSE ! converge is not yet reached
+ l_converged(ji,jj) = .FALSE.
+ zqh_b(ji,jj) = zqhc(ji,jj) + zqoce(ji,jj)
+ ENDIF
+ ENDIF
END_2D
- CALL mpp_max( 'isfcav', zerr ) ! max over the global domain
!
- ! define if iteration needed
- IF (nit >= 100) THEN ! too much iteration
- CALL ctl_stop( 'STOP', 'isf_cav: vel_stab gamma formulation had too many iterations ...' )
- ELSE IF ( zerr <= 0.01_wp ) THEN ! convergence is achieve
- lit = .FALSE.
- ELSE ! converge is not yet achieve
- nit = nit + 1
- zqh_b(:,:) = zqhc(:,:)+zqoce(:,:)
- END IF
END SELECT
!
END DO
+ IF( iconv == iconv_max ) CALL ctl_stop( 'STOP', 'isf_cav: vel_stab gamma formulation had too many iterations ...' ) ! too many iterations
!
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
- ! compute heat and water flux ( > 0 from isf to oce)
- pqfwf(ji,jj) = pqfwf(ji,jj) * mskisf_cav(ji,jj)
- zqoce(ji,jj) = zqoce(ji,jj) * mskisf_cav(ji,jj)
- zqhc (ji,jj) = zqhc(ji,jj) * mskisf_cav(ji,jj)
- !
+ !
+ DO_2D( 0, 0, 0, 0 )
! compute heat content flux ( > 0 from isf to oce)
- zqlat(ji,jj) = - pqfwf(ji,jj) * rLfusisf ! 2d latent heat flux (W/m2)
- !
- ! total heat flux ( > 0 from isf to oce)
- zqh(ji,jj) = ( zqhc (ji,jj) + zqoce(ji,jj) )
+ zqlat(ji,jj) = - pfwf(ji,jj) * rLfusisf ! 2d latent heat flux (W/m2)
!
! set temperature content
- ptsc(ji,jj,jp_tem) = zqh(ji,jj) * r1_rho0_rcp
+ ptsc(ji,jj,jp_tem) = ( zqhc(ji,jj) + zqoce(ji,jj) ) * r1_rho0_rcp
END_2D
- CALL lbc_lnk( 'isfmlt', pqfwf, 'T', 1.0_wp)
!
! output fluxes
- CALL isf_diags_flx( Kmm, misfkt_cav, misfkb_cav, rhisf_tbl_cav, rfrac_tbl_cav, 'cav', pqfwf, zqoce, zqlat, zqhc)
+ CALL isf_diags_flx( Kmm, misfkt_cav, misfkb_cav, rhisf_tbl_cav, rfrac_tbl_cav, 'cav', pfwf, zqoce, zqlat, zqhc )
!
-#if ! defined key_RK3
- ! MLF: write restart variables (qoceisf, qhcisf, fwfisf for now and before)
- IF (lrst_oce) CALL isfrst_write(kt, 'cav', ptsc, pqfwf)
-#endif
+ ! --- output --- !
+ CALL iom_put( 'ttbl_cav' , zttbl (:,:) * mskisf_cav(:,:) )
+ CALL iom_put( 'stbl' , zstbl (:,:) * mskisf_cav(:,:) )
+ CALL iom_put( 'isfgammat', zgammat(:,:) * mskisf_cav(:,:) )
+ CALL iom_put( 'isfgammas', zgammas(:,:) * mskisf_cav(:,:) )
+ IF ( TRIM(cn_gammablk) == 'vel_stab' .OR. TRIM(cn_gammablk) == 'vel' ) THEN
+ CALL iom_put( 'isfustar', zustar )
+ CALL iom_put( 'utbl' , zutbl * mskisf_cav )
+ CALL iom_put( 'vtbl' , zvtbl * mskisf_cav )
+ ENDIF
+ !
+ CALL iom_put('isftfrz_cav' , ztfrz(:,:) * mskisf_cav(:,:) ) ! freezing point at the interface
+ CALL iom_put('isfthermald_cav', ( zttbl(:,:) - ztfrz(:,:) ) * mskisf_cav(:,:) ) ! thermal driving at the interface
!
+ IF( cn_isfcav_mlt == '3eq' ) THEN ! conductive heat flux through the ice
+ ALLOCATE( ztmp(A2D(0)) )
+ DO_2D( 0, 0, 0, 0 )
+ ztmp(ji,jj) = rhoisf * rcpisf * rkappa / MAX( risfdep(ji,jj), 1.e-20 ) * ( ztfrz(ji,jj) - rtsurf ) * mskisf_cav(ji,jj)
+ END_2D
+ CALL iom_put('qconisf', ztmp )
+ DEALLOCATE( ztmp )
+ ENDIF
+ !
+ ! --- debug --- !
IF ( ln_isfdebug ) THEN
IF(lwp) WRITE(numout,*) ''
- CALL debug('isf_cav: ptsc T',ptsc(:,:,1))
- CALL debug('isf_cav: ptsc S',ptsc(:,:,2))
- CALL debug('isf_cav: pqfwf fwf',pqfwf(:,:))
+ CALL debug( 'isfcav: gammaT ', zgammat(:,:) )
+ CALL debug( 'isfcav: gammaS ', zgammas(:,:) )
+ CALL debug( 'isfcav: ptsc T ', ptsc(:,:,1) )
+ CALL debug( 'isfcav: ptsc S ', ptsc(:,:,2) )
+ CALL debug( 'isfcav: qhc ', zqhc (:,:) )
+ CALL debug( 'isfcav: qoce ', zqoce(:,:) )
+ CALL debug( 'isfcav: fwf ', pfwf (:,:) )
IF(lwp) WRITE(numout,*) ''
END IF
!
@@ -196,27 +257,31 @@ CONTAINS
!! ** Purpose : initialisation of variable needed to compute melt under an ice shelf
!!
!!----------------------------------------------------------------------
- INTEGER :: ierr
+ INTEGER :: ierr
+ INTEGER :: ji, jj ! dummy loop indices
!!---------------------------------------------------------------------
!
!==============
! 0: allocation
!==============
- !
CALL isf_alloc_cav()
!
!==================
! 1: initialisation
!==================
- !
- ! top and bottom level of the 'top boundary layer'
- misfkt_cav(:,:) = mikt(:,:) ; misfkb_cav(:,:) = 1
- !
- ! thickness of 'tbl' and fraction of bottom cell affected by 'tbl'
- rhisf_tbl_cav(:,:) = 0.0_wp ; rfrac_tbl_cav(:,:) = 0.0_wp
- !
- ! cavity mask
- mskisf_cav(:,:) = (1._wp - tmask(:,:,1)) * ssmask(:,:)
+ DO_2D( 0, 0, 0, 0 )
+ ! top and bottom level of the 'top boundary layer'
+ misfkt_cav(ji,jj) = mikt(ji,jj)
+ misfkb_cav(ji,jj) = 1
+ !
+ ! thickness of 'tbl' and fraction of bottom cell affected by 'tbl'
+ rhisf_tbl_cav(ji,jj) = 0.0_wp
+ rfrac_tbl_cav(ji,jj) = 0.0_wp
+ !
+ ! cavity mask
+ mskisf_cav(ji,jj) = ( 1._wp - tmask(ji,jj,1) ) * ssmask(ji,jj)
+ !
+ END_2D
!
#if ! defined key_RK3
!================
@@ -239,7 +304,7 @@ CONTAINS
CASE( 'spe' )
ALLOCATE( sf_isfcav_fwf(1), STAT=ierr )
- ALLOCATE( sf_isfcav_fwf(1)%fnow(jpi,jpj,1), sf_isfcav_fwf(1)%fdta(jpi,jpj,1,2) )
+ ALLOCATE( sf_isfcav_fwf(1)%fnow(A2D(0),1), sf_isfcav_fwf(1)%fdta(A2D(0),1,2) )
CALL fld_fill( sf_isfcav_fwf, (/ sn_isfcav_fwf /), cn_isfdir, 'isf_cav_init', 'read fresh water flux isf data', 'namisf' )
IF(lwp) WRITE(numout,*)
diff --git a/src/OCE/ISF/isfcavgam.F90 b/src/OCE/ISF/isfcavgam.F90
index 6c0ac2a4d94db9b728d48603e65d1d2f31f548ef..de68f6e8555a504685d29be8ce7a4fe4af58ca9b 100644
--- a/src/OCE/ISF/isfcavgam.F90
+++ b/src/OCE/ISF/isfcavgam.F90
@@ -11,15 +11,13 @@ MODULE isfcavgam
!!----------------------------------------------------------------------
USE isf_oce
USE isfutils, ONLY: debug
- USE isftbl , ONLY: isf_tbl
USE oce , ONLY: uu, vv ! ocean dynamics
USE phycst , ONLY: grav, vkarmn ! physical constant
USE eosbn2 , ONLY: eos_rab ! equation of state
- USE zdfdrg , ONLY: rCd0_top, r_ke0_top ! vertical physics: top/bottom drag coef.
- USE iom , ONLY: iom_put !
USE lib_mpp , ONLY: ctl_stop
+ USE par_oce ! ocean space and time domain
USE dom_oce ! ocean space and time domain
USE in_out_manager ! I/O manager
!
@@ -39,88 +37,46 @@ MODULE isfcavgam
!!----------------------------------------------------------------------
CONTAINS
!
- !!-----------------------------------------------------------------------------------------------------
- !! PUBLIC SUBROUTINES
- !!-----------------------------------------------------------------------------------------------------
- !
- SUBROUTINE isfcav_gammats( Kmm, pttbl, pstbl, pqoce, pqfwf, pRc, pgt, pgs )
+ SUBROUTINE isfcav_gammats( Kmm, l_converged, pustar, pttbl, pstbl, pqoce, pfwf, pRc, pgt, pgs )
!!----------------------------------------------------------------------
!! ** Purpose : compute the coefficient echange for heat and fwf flux
!!
!! ** Method : select the gamma formulation
!! 3 method available (cst, vel and vel_stab)
!!---------------------------------------------------------------------
- !!-------------------------- OUT -------------------------------------
- REAL(wp), DIMENSION(jpi,jpj), INTENT( out) :: pgt , pgs ! gamma t and gamma s
- !!-------------------------- IN -------------------------------------
- INTEGER :: Kmm ! ocean time level index
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pqoce, pqfwf ! isf heat and fwf
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pttbl, pstbl ! top boundary layer tracer
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pRc ! Richardson number
- !!---------------------------------------------------------------------
- REAL(wp), DIMENSION(jpi,jpj) :: zutbl, zvtbl ! top boundary layer velocity
+ INTEGER , INTENT(in ) :: Kmm ! ocean time level index
+ LOGICAL , DIMENSION(A2D(0)), INTENT(in ) :: l_converged ! true when melting converges (per grid point)
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in ) :: pustar ! u*
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in ) :: pttbl, pstbl ! top boundary layer tracer
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in ) :: pqoce, pfwf ! isf heat and fwf
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in ) :: pRc ! Richardson number
+ REAL(wp), DIMENSION(A2D(0)), INTENT(inout) :: pgt, pgs ! gamma t and gamma s
!!---------------------------------------------------------------------
!
- !==========================================
- ! 1.: compute velocity in the tbl if needed
- !==========================================
+ ! --- compute gamma --- !
!
- SELECT CASE ( cn_gammablk )
- CASE ( 'spe' )
- ! gamma is constant (specified in namelist)
- ! nothing to do
- CASE ('vel', 'vel_stab')
- ! compute velocity in tbl
- CALL isf_tbl(Kmm, uu(:,:,:,Kmm) ,zutbl(:,:),'U', miku, rhisf_tbl_cav)
- CALL isf_tbl(Kmm, vv(:,:,:,Kmm) ,zvtbl(:,:),'V', mikv, rhisf_tbl_cav)
- !
- ! mask velocity in tbl with ice shelf mask
- zutbl(:,:) = zutbl(:,:) * mskisf_cav(:,:)
- zvtbl(:,:) = zvtbl(:,:) * mskisf_cav(:,:)
+ SELECT CASE( cn_gammablk )
+ CASE( 'spe' ) ! gamma is constant (specified in namelist)
!
- ! output
- CALL iom_put('utbl',zutbl(:,:))
- CALL iom_put('vtbl',zvtbl(:,:))
- CASE DEFAULT
- CALL ctl_stop('STOP','method to compute gamma (cn_gammablk) is unknown (should not see this)')
- END SELECT
- !
- !==========================================
- ! 2.: compute gamma
- !==========================================
- !
- SELECT CASE ( cn_gammablk )
- CASE ( 'spe' ) ! gamma is constant (specified in namelist)
pgt(:,:) = rn_gammat0
pgs(:,:) = rn_gammas0
- CASE ( 'vel' ) ! gamma is proportional to u*
- CALL gammats_vel ( zutbl, zvtbl, rCd0_top, r_ke0_top, pgt, pgs )
- CASE ( 'vel_stab' ) ! gamma depends of stability of boundary layer and u*
- CALL gammats_vel_stab (Kmm, pttbl, pstbl, zutbl, zvtbl, rCd0_top, r_ke0_top, pqoce, pqfwf, pRc, pgt, pgs )
+ !
+ CASE( 'vel' ) ! gamma is proportional to u*
+ !
+ CALL gammats_vel( pustar, pgt, pgs )
+ !
+ CASE( 'vel_stab' ) ! gamma depends of stability of boundary layer and u*
+ !
+ CALL gammats_vel_stab( Kmm, l_converged, pustar, pttbl, pstbl, pqoce, pfwf, pRc, pgt, pgs )
+ !
CASE DEFAULT
CALL ctl_stop('STOP','method to compute gamma (cn_gammablk) is unknown (should not see this)')
END SELECT
!
- !==========================================
- ! 3.: output and debug
- !==========================================
- !
- CALL iom_put('isfgammat', pgt(:,:))
- CALL iom_put('isfgammas', pgs(:,:))
- !
- IF (ln_isfdebug) THEN
- CALL debug( 'isfcav_gam pgt:', pgt(:,:) )
- CALL debug( 'isfcav_gam pgs:', pgs(:,:) )
- END IF
- !
END SUBROUTINE isfcav_gammats
!
- !!-----------------------------------------------------------------------------------------------------
- !! PRIVATE SUBROUTINES
- !!-----------------------------------------------------------------------------------------------------
- !
- SUBROUTINE gammats_vel( putbl, pvtbl, pCd, pke2, & ! <<== in
- & pgt, pgs ) ! ==>> out gammats [m/s]
+ SUBROUTINE gammats_vel( pustar, & ! <<== in
+ & pgt, pgs ) ! ==>> out gammats [m/s]
!!----------------------------------------------------------------------
!! ** Purpose : compute the coefficient echange coefficient
!!
@@ -128,33 +84,22 @@ CONTAINS
!!
!! ** Reference : Asay-Davis et al., Geosci. Model Dev., 9, 2471-2497, 2016
!!---------------------------------------------------------------------
- !!-------------------------- OUT -------------------------------------
- REAL(wp), DIMENSION(jpi,jpj), INTENT( out) :: pgt, pgs ! gammat and gammas [m/s]
- !!-------------------------- IN -------------------------------------
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: putbl, pvtbl ! velocity in the losch top boundary layer
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pCd ! drag coefficient
- REAL(wp), INTENT(in ) :: pke2 ! background velocity
- !!---------------------------------------------------------------------
- INTEGER :: ji, jj ! loop index
- REAL(wp), DIMENSION(jpi,jpj) :: zustar
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in ) :: pustar ! u*
+ REAL(wp), DIMENSION(A2D(0)), INTENT(inout) :: pgt, pgs ! gammat and gammas [m/s]
+ !!
+ INTEGER :: ji, jj ! loop index
!!---------------------------------------------------------------------
!
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
- ! compute ustar (AD15 eq. 27)
- zustar(ji,jj) = SQRT( pCd(ji,jj) * ( putbl(ji,jj) * putbl(ji,jj) + pvtbl(ji,jj) * pvtbl(ji,jj) + pke2 ) ) * mskisf_cav(ji,jj)
- !
- ! Compute gammats
- pgt(ji,jj) = zustar(ji,jj) * rn_gammat0
- pgs(ji,jj) = zustar(ji,jj) * rn_gammas0
+ DO_2D( 0, 0, 0, 0 )
+ pgt(ji,jj) = pustar(ji,jj) * rn_gammat0
+ pgs(ji,jj) = pustar(ji,jj) * rn_gammas0
END_2D
!
- ! output ustar
- CALL iom_put('isfustar',zustar(:,:))
!
END SUBROUTINE gammats_vel
- SUBROUTINE gammats_vel_stab( Kmm, pttbl, pstbl, putbl, pvtbl, pCd, pke2, pqoce, pqfwf, pRc, & ! <<== in
- & pgt , pgs ) ! ==>> out gammats [m/s]
+ SUBROUTINE gammats_vel_stab( Kmm, l_converged, pustar, pttbl, pstbl, pqoce, pfwf, pRc, & ! <<== in
+ & pgt , pgs ) ! ==>> out gammats [m/s]
!!----------------------------------------------------------------------
!! ** Purpose : compute the coefficient echange coefficient
!!
@@ -162,91 +107,81 @@ CONTAINS
!!
!! ** Reference : Holland and Jenkins, 1999, JPO, p1787-1800
!!---------------------------------------------------------------------
- !!-------------------------- OUT -------------------------------------
- REAL(wp), DIMENSION(jpi,jpj), INTENT( out) :: pgt, pgs ! gammat and gammas
- !!-------------------------- IN -------------------------------------
- INTEGER :: Kmm ! ocean time level index
- REAL(wp), INTENT(in ) :: pke2 ! background velocity squared
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pqoce, pqfwf ! surface heat flux and fwf flux
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pCd ! drag coeficient
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: putbl, pvtbl ! velocity in the losch top boundary layer
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pttbl, pstbl ! tracer in the losch top boundary layer
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pRc ! Richardson number
- !!---------------------------------------------------------------------
- INTEGER :: ji, jj ! loop index
- INTEGER :: ikt ! local integer
- REAL(wp) :: zdku, zdkv ! U, V shear
- REAL(wp) :: zPr, zSc ! Prandtl and Scmidth number
- REAL(wp) :: zmob, zmols ! Monin Obukov length, coriolis factor at T point
- REAL(wp) :: zbuofdep, zhnu ! Bouyancy length scale, sublayer tickness
- REAL(wp) :: zhmax ! limitation of mol
- REAL(wp) :: zetastar ! stability parameter
- REAL(wp) :: zgmolet, zgmoles, zgturb ! contribution of modelecular sublayer and turbulence
- REAL(wp) :: zcoef ! temporary coef
- REAL(wp) :: zdep
- REAL(wp) :: zeps = 1.0e-20_wp
- REAL(wp), PARAMETER :: zxsiN = 0.052_wp ! dimensionless constant
- REAL(wp), PARAMETER :: znu = 1.95e-6_wp ! kinamatic viscosity of sea water (m2.s-1)
- REAL(wp), DIMENSION(2) :: zts, zab
- REAL(wp), DIMENSION(jpi,jpj) :: zustar ! friction velocity
+ INTEGER , INTENT(in ) :: Kmm ! ocean time level index
+ LOGICAL , DIMENSION(A2D(0)), INTENT(in ) :: l_converged ! true when melting converges (per grid point)
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in ) :: pustar ! u*
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in ) :: pttbl, pstbl ! tracer in the losch top boundary layer
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in ) :: pqoce, pfwf ! surface heat flux and fwf flux
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in ) :: pRc ! Richardson number
+ REAL(wp), DIMENSION(A2D(0)), INTENT(inout) :: pgt, pgs ! gammat and gammas
+ !!
+ INTEGER :: ji, jj ! loop index
+ INTEGER :: ikt ! local integer
+ REAL(wp) :: zmob, zmols ! Monin Obukov length, coriolis factor at T point
+ REAL(wp) :: zbuofdep, zhnu ! Bouyancy length scale, sublayer tickness
+ REAL(wp) :: zhmax ! limitation of mol
+ REAL(wp) :: zetastar ! stability parameter
+ REAL(wp) :: zgmolet, zgmoles, zgturb ! contribution of modelecular sublayer and turbulence
+ REAL(wp) :: zdep
+ REAL(wp), PARAMETER :: zxsiN = 0.052_wp ! dimensionless constant
+ REAL(wp), PARAMETER :: znu = 1.95e-6_wp ! kinamatic viscosity of sea water (m2.s-1)
+ REAL(wp), PARAMETER :: zPr = 13.8_wp
+ REAL(wp), PARAMETER :: zSc = 2432.0_wp
+ REAL(wp), DIMENSION(jpts) :: zts, zab
!!---------------------------------------------------------------------
!
- ! compute Pr and Sc number (eq ??)
- zPr = 13.8_wp
- zSc = 2432.0_wp
- !
! compute gamma mole (eq ??)
zgmolet = 12.5_wp * zPr ** (2.0/3.0) - 6.0_wp
zgmoles = 12.5_wp * zSc ** (2.0/3.0) - 6.0_wp
!
! compute gamma
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
-
- ikt = mikt(ji,jj)
-
- ! compute ustar
- zustar(ji,jj) = SQRT( pCd(ji,jj) * ( putbl(ji,jj) * putbl(ji,jj) + pvtbl(ji,jj) * pvtbl(ji,jj) + pke2 ) )
-
- IF( zustar(ji,jj) == 0._wp ) THEN ! only for kt = 1 I think
- pgt(ji,jj) = rn_gammat0
- pgs(ji,jj) = rn_gammas0
- ELSE
- ! compute bouyancy
- zts(jp_tem) = pttbl(ji,jj)
- zts(jp_sal) = pstbl(ji,jj)
- zdep = gdepw(ji,jj,ikt,Kmm)
- !
- CALL eos_rab( zts, zdep, zab, Kmm )
- !
- ! compute length scale (Eq ??)
- zbuofdep = grav * ( zab(jp_tem) * pqoce(ji,jj) - zab(jp_sal) * pqfwf(ji,jj) )
- !
- ! compute Monin Obukov Length
- ! Maximum boundary layer depth (Eq ??)
- zhmax = gdept(ji,jj,mbkt(ji,jj),Kmm) - gdepw(ji,jj,mikt(ji,jj),Kmm) -0.001_wp
- !
- ! Compute Monin obukhov length scale at the surface and Ekman depth: (Eq ??)
- zmob = zustar(ji,jj) ** 3 / (vkarmn * (zbuofdep + zeps))
- zmols = SIGN(1._wp, zmob) * MIN(ABS(zmob), zhmax) * tmask(ji,jj,ikt)
- !
- ! compute eta* (stability parameter) (Eq ??)
- zetastar = 1._wp / ( SQRT(1._wp + MAX( 0._wp, zxsiN * zustar(ji,jj) &
- & / MAX( 1.e-20, ABS(ff_t(ji,jj)) * zmols * pRc(ji,jj) ) )))
- !
- ! compute the sublayer thickness (Eq ??)
- zhnu = 5 * znu / MAX( 1.e-20, zustar(ji,jj) )
+ DO_2D( 0, 0, 0, 0 )
+ !
+ IF ( .NOT. l_converged(ji,jj) ) THEN
!
- ! compute gamma turb (Eq ??)
- zgturb = 1._wp / vkarmn * LOG(zustar(ji,jj) * zxsiN * zetastar * zetastar / MAX( 1.e-10, ABS(ff_t(ji,jj)) * zhnu )) &
- & + 1._wp / ( 2 * zxsiN * zetastar ) - 1._wp / vkarmn
+ ikt = mikt(ji,jj)
!
- ! compute gammats
- pgt(ji,jj) = zustar(ji,jj) / (zgturb + zgmolet)
- pgs(ji,jj) = zustar(ji,jj) / (zgturb + zgmoles)
- END IF
+ IF( pustar(ji,jj) == 0._wp ) THEN ! only for kt = 1 I think
+ pgt(ji,jj) = rn_gammat0
+ pgs(ji,jj) = rn_gammas0
+ ELSE
+ ! compute bouyancy
+ zts(jp_tem) = pttbl(ji,jj)
+ zts(jp_sal) = pstbl(ji,jj)
+ zdep = gdepw(ji,jj,ikt,Kmm)
+ !
+ CALL eos_rab( zts, zdep, zab, Kmm )
+ !
+ ! compute length scale (Eq ??)
+ zbuofdep = grav * ( zab(jp_tem) * pqoce(ji,jj) - zab(jp_sal) * pfwf(ji,jj) )
+ !
+ ! compute Monin Obukov Length
+ ! Maximum boundary layer depth (Eq ??)
+ zhmax = gdept(ji,jj,mbkt(ji,jj),Kmm) - gdepw(ji,jj,ikt,Kmm) -0.001_wp
+ !
+ ! Compute Monin obukhov length scale at the surface and Ekman depth: (Eq ??)
+ zmob = pustar(ji,jj) ** 3 / (vkarmn * (zbuofdep + 1.e-20_wp ))
+ zmols = SIGN(1._wp, zmob) * MIN(ABS(zmob), zhmax) * tmask(ji,jj,ikt)
+ !
+ ! compute eta* (stability parameter) (Eq ??)
+ zetastar = 1._wp / ( SQRT(1._wp + MAX( 0._wp, zxsiN * pustar(ji,jj) &
+ & / MAX( 1.e-20, ABS(ff_t(ji,jj)) * zmols * pRc(ji,jj) ) )))
+ !
+ ! compute the sublayer thickness (Eq ??)
+ zhnu = 5 * znu / MAX( 1.e-20, pustar(ji,jj) )
+ !
+ ! compute gamma turb (Eq ??)
+ zgturb = 1._wp / vkarmn * LOG(pustar(ji,jj) * zxsiN * zetastar * zetastar / MAX( 1.e-10_wp, ABS(ff_t(ji,jj)) * zhnu )) &
+ & + 1._wp / ( 2 * zxsiN * zetastar ) - 1._wp / vkarmn
+ !
+ ! compute gammats
+ pgt(ji,jj) = pustar(ji,jj) / (zgturb + zgmolet)
+ pgs(ji,jj) = pustar(ji,jj) / (zgturb + zgmoles)
+ ENDIF
+ !
+ ENDIF
+ !
END_2D
- ! output ustar
- CALL iom_put('isfustar',zustar(:,:))
END SUBROUTINE gammats_vel_stab
diff --git a/src/OCE/ISF/isfcavmlt.F90 b/src/OCE/ISF/isfcavmlt.F90
index 665d75bbc60ca44af283e8ee5f7ead3aa319ea3e..e5a2ab260d68ddde3638d63d82d1a253065ef2d1 100644
--- a/src/OCE/ISF/isfcavmlt.F90
+++ b/src/OCE/ISF/isfcavmlt.F90
@@ -11,20 +11,16 @@ MODULE isfcavmlt
!! isfcav_mlt : compute or read ice shelf fwf/heat fluxes from isf
!! to oce
!!----------------------------------------------------------------------
-
USE isf_oce ! ice shelf
- USE isftbl , ONLY: isf_tbl ! ice shelf depth average
- USE isfutils,ONLY: debug ! debug subroutine
+ USE par_oce ! ocean space and time domain
USE dom_oce ! ocean space and time domain
USE phycst , ONLY: rcp, rho0, rho0_rcp ! physical constants
- USE eosbn2 , ONLY: eos_fzp ! equation of state
USE in_out_manager ! I/O manager
- USE iom , ONLY: iom_put ! I/O library
USE fldread , ONLY: fld_read, FLD, FLD_N !
- USE lib_fortran, ONLY: glob_sum !
- USE lib_mpp , ONLY: ctl_stop !
+ USE lib_fortran, ONLY: glob_sum_vec
+ USE lib_mpp , ONLY: ctl_stop
IMPLICIT NONE
PRIVATE
@@ -40,60 +36,51 @@ MODULE isfcavmlt
!!----------------------------------------------------------------------
CONTAINS
-! -------------------------------------------------------------------------------------------------------
-! -------------------------------- PUBLIC SUBROUTINE ----------------------------------------------------
-! -------------------------------------------------------------------------------------------------------
- SUBROUTINE isfcav_mlt(kt, pgt, pgs , pttbl, pstbl, &
- & pqhc, pqoce, pqfwf )
+ SUBROUTINE isfcav_mlt( kt, l_converged, pgt, pgs , pttbl, pstbl, &
+ & pqhc, pqoce, pfwf, ptfrz )
!!----------------------------------------------------------------------
!!
!! *** ROUTINE isfcav_mlt ***
!!
!! ** Purpose : compute or read ice shelf fwf/heat fluxes in the ice shelf cavity
!!
- !!-------------------------- OUT -------------------------------------
- REAL(wp), DIMENSION(jpi,jpj), INTENT( out) :: pqhc, pqoce, pqfwf ! heat and fwf fluxes
- !!-------------------------- IN -------------------------------------
- INTEGER, INTENT(in) :: kt
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pgt , pgs ! gamma t and gamma s
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pttbl, pstbl ! top boundary layer tracer
+ !!---------------------------------------------------------------------
+ INTEGER, INTENT(in) :: kt
+ LOGICAL , DIMENSION(A2D(0)), INTENT(in ) :: l_converged ! true when melting converges (per grid point)
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in ) :: pgt, pgs ! gamma t and gamma s
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in ) :: pttbl, pstbl ! top boundary layer tracer
+ REAL(wp), DIMENSION(A2D(0)), INTENT(inout) :: pqhc, pqoce, pfwf ! heat and fwf fluxes
+ REAL(wp), DIMENSION(A2D(0)), INTENT(inout) :: ptfrz ! tbl freezing temperature
!!---------------------------------------------------------------------
!
! compute latent heat and melt (2d)
SELECT CASE ( cn_isfcav_mlt )
CASE ( 'spe' ) ! ice shelf melt specified (read input file, and heat fluxes derived from
- CALL isfcav_mlt_spe( kt, pstbl, &
- & pqhc, pqoce, pqfwf )
+ !
+ CALL isfcav_mlt_spe ( kt, l_converged, pqhc, pqoce, pfwf, ptfrz )
+ !
CASE ( '2eq' ) ! ISOMIP formulation (2 equations) for volume flux (Hunter et al., 2006)
- CALL isfcav_mlt_2eq( pgt, pttbl, pstbl, &
- & pqhc , pqoce, pqfwf )
+ !
+ CALL isfcav_mlt_2eq ( l_converged, pgt, pttbl, pqhc, pqoce, pfwf, ptfrz )
+ !
CASE ( '3eq' ) ! ISOMIP+ formulation (3 equations) for volume flux (Asay-Davis et al., 2015)
- CALL isfcav_mlt_3eq( pgt, pgs , pttbl, pstbl, &
- & pqhc, pqoce, pqfwf )
+ !
+ CALL isfcav_mlt_3eq ( l_converged, pgt, pgs , pttbl, pstbl, pqhc, pqoce, pfwf, ptfrz )
+ !
CASE ( 'oasis' ) ! fwf pass trough oasis
- CALL isfcav_mlt_oasis( kt, pstbl, &
- & pqhc, pqoce, pqfwf )
+ !
+ CALL isfcav_mlt_oasis( kt, l_converged, pqhc, pqoce, pfwf, ptfrz )
+ !
CASE DEFAULT
CALL ctl_stop('STOP', 'unknown isf melt formulation : cn_isfcav (should not see this)')
END SELECT
!
- IF (ln_isfdebug) THEN
- IF(lwp) WRITE(numout,*) ''
- CALL debug( 'isfcav_mlt qhc :', pqhc (:,:) )
- CALL debug( 'isfcav_mlt qoce :', pqoce(:,:) )
- CALL debug( 'isfcav_mlt qfwf :', pqfwf(:,:) )
- IF(lwp) WRITE(numout,*) ''
- END IF
- !
END SUBROUTINE isfcav_mlt
-! -------------------------------------------------------------------------------------------------------
-! -------------------------------- PRIVATE SUBROUTINE ---------------------------------------------------
-! -------------------------------------------------------------------------------------------------------
- SUBROUTINE isfcav_mlt_spe(kt, pstbl, & ! <<== in
- & pqhc , pqoce, pqfwf ) ! ==>> out
+ SUBROUTINE isfcav_mlt_spe( kt, l_converged, & ! <<== in
+ & pqhc, pqoce, pfwf, ptfrz ) ! ==>> inout
!!----------------------------------------------------------------------
!!
!! *** ROUTINE isfcav_mlt_spe ***
@@ -102,34 +89,30 @@ CONTAINS
!! - compute ocea-ice heat flux (assuming it is equal to latent heat)
!! - compute heat content flux
!!---------------------------------------------------------------------
- !!-------------------------- OUT -------------------------------------
- REAL(wp), DIMENSION(jpi,jpj), INTENT( out) :: pqhc, pqoce, pqfwf ! heat content, latent heat and fwf fluxes
- !!-------------------------- IN -------------------------------------
- INTEGER , INTENT(in ) :: kt ! current time step
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pstbl ! salinity in tbl
- !!--------------------------------------------------------------------
- REAL(wp), DIMENSION(jpi,jpj) :: ztfrz ! tbl freezing temperature
+ INTEGER , INTENT(in ) :: kt ! current time step
+ LOGICAL , DIMENSION(A2D(0)), INTENT(in ) :: l_converged ! true when melting converges (per grid point)
+ REAL(wp), DIMENSION(A2D(0)), INTENT(inout) :: pqhc, pqoce, pfwf ! heat content, latent heat and fwf fluxes
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in ) :: ptfrz ! tbl freezing temp
+ !!
+ INTEGER :: ji, jj ! dummy loop indices
!!--------------------------------------------------------------------
!
- ! Compute freezing temperature
- CALL eos_fzp( pstbl(:,:), ztfrz(:,:), risfdep(:,:) )
- !
! read input file of fwf (from isf to oce; ie melt)
CALL fld_read ( kt, 1, sf_isfcav_fwf )
!
- ! define fwf and qoce
- ! ocean heat flux is assume to be equal to the latent heat
- pqfwf(:,:) = sf_isfcav_fwf(1)%fnow(:,:,1) ! fwf ( > 0 from isf to oce)
- pqoce(:,:) = - pqfwf(:,:) * rLfusisf ! ocean heat flux ( > 0 from isf to oce)
- pqhc (:,:) = pqfwf(:,:) * ztfrz(:,:) * rcp ! heat content flux ( > 0 from isf to oce)
- !
- ! output freezing point at the interface
- CALL iom_put('isftfrz_cav', ztfrz(:,:) * mskisf_cav(:,:) )
+ ! define fwf and qoce (ocean heat flux is assume to be equal to the latent heat)
+ DO_2D( 0, 0, 0, 0 )
+ IF ( .NOT. l_converged(ji,jj) ) THEN
+ pfwf (ji,jj) = sf_isfcav_fwf(1)%fnow(ji,jj,1) * mskisf_cav(ji,jj) ! fwf ( > 0 from isf to oce)
+ pqoce(ji,jj) = - pfwf(ji,jj) * rLfusisf * mskisf_cav(ji,jj) ! ocean heat flux ( > 0 from isf to oce)
+ pqhc (ji,jj) = pfwf(ji,jj) * ptfrz(ji,jj) * rcp * mskisf_cav(ji,jj) ! heat content flux ( > 0 from isf to oce)
+ ENDIF
+ END_2D
!
END SUBROUTINE isfcav_mlt_spe
- SUBROUTINE isfcav_mlt_2eq(pgt , pttbl, pstbl, & ! <<== in
- & pqhc, pqoce, pqfwf ) ! ==>> out
+ SUBROUTINE isfcav_mlt_2eq( l_converged, pgt , pttbl, & ! <<== in
+ & pqhc, pqoce, pfwf, ptfrz ) ! ==>> inout
!!----------------------------------------------------------------------
!!
!! *** ROUTINE isfcav_mlt_2eq ***
@@ -138,43 +121,39 @@ CONTAINS
!!
!! ** Method : The ice shelf melt latent heat is defined as being equal to the ocean/ice heat flux.
!! From this we can derived the fwf, ocean/ice heat flux and the heat content flux as being :
- !! qfwf = Gammat * rho0 * Cp * ( Tw - Tfrz ) / Lf
+ !! fwf = Gammat * rho0 * Cp * ( Tw - Tfrz ) / Lf
!! qhoce = qlat
- !! qhc = qfwf * Cp * Tfrz
+ !! qhc = fwf * Cp * Tfrz
!!
!! ** Reference : Hunter, J. R.: Specification for test models of ice shelf cavities,
!! Tech. Rep. June, Antarctic Climate & Ecosystems Cooperative Research Centre, available at:
!! http://staff.acecrc.org.au/~bkgalton/ISOMIP/test_cavities.pdf (last access: 21 July 2016), 2006.
!!
- !!-------------------------- OUT -------------------------------------
- REAL(wp), DIMENSION(jpi,jpj), INTENT( out) :: pqhc, pqoce, pqfwf ! hean content, ocean-ice heat and fwf fluxes
- !!-------------------------- IN -------------------------------------
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pgt ! temperature exchange coeficient
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pttbl, pstbl ! temperature and salinity in top boundary layer
!!--------------------------------------------------------------------
- REAL(wp), DIMENSION(jpi,jpj) :: ztfrz ! freezing temperature
- REAL(wp), DIMENSION(jpi,jpj) :: zthd ! thermal driving
+ LOGICAL , DIMENSION(A2D(0)), INTENT(in ) :: l_converged ! true when melting converges (per grid point)
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in ) :: pgt ! temperature exchange coeficient
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in ) :: pttbl ! temperature and salinity in top boundary layer
+ REAL(wp), DIMENSION(A2D(0)), INTENT(inout) :: pqhc, pqoce, pfwf ! hean content, ocean-ice heat and fwf fluxes
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in ) :: ptfrz ! tbl freezing temp
+ !!
+ INTEGER :: ji, jj ! dummy loop indices
!!--------------------------------------------------------------------
!
- ! Calculate freezing temperature
- CALL eos_fzp( pstbl(:,:), ztfrz(:,:), risfdep(:,:) )
- !
- ! thermal driving
- zthd (:,:) = ( pttbl(:,:) - ztfrz(:,:) ) * mskisf_cav(:,:)
- !
- ! compute ocean-ice heat flux and then derive fwf assuming that ocean heat flux equal latent heat
- pqfwf(:,:) = pgt(:,:) * rho0_rcp * zthd(:,:) / rLfusisf ! fresh water flux ( > 0 from isf to oce)
- pqoce(:,:) = - pqfwf(:,:) * rLfusisf ! ocea-ice flux ( > 0 from isf to oce)
- pqhc (:,:) = pqfwf(:,:) * ztfrz(:,:) * rcp ! heat content flux ( > 0 from isf to oce)
- !
- ! output thermal driving and freezinpoint at the ice shelf interface
- CALL iom_put('isfthermald_cav', zthd )
- CALL iom_put('isftfrz_cav' , ztfrz(:,:) * mskisf_cav(:,:) )
+ DO_2D( 0, 0, 0, 0 )
+ !
+ ! compute ocean-ice heat flux and then derive fwf assuming that ocean heat flux equal latent heat
+ IF ( .NOT. l_converged(ji,jj) ) THEN
+ pfwf (ji,jj) = pgt (ji,jj) * rho0_rcp * ( pttbl(ji,jj) - ptfrz(ji,jj) ) / rLfusisf * mskisf_cav(ji,jj) ! fresh water flux ( > 0 from isf to oce)
+ pqoce(ji,jj) = - pfwf(ji,jj) * rLfusisf * mskisf_cav(ji,jj) ! ocea-ice flux ( > 0 from isf to oce)
+ pqhc (ji,jj) = pfwf(ji,jj) * ptfrz(ji,jj) * rcp * mskisf_cav(ji,jj) ! heat content flux ( > 0 from isf to oce)
+ !
+ ENDIF
+ END_2D
!
END SUBROUTINE isfcav_mlt_2eq
- SUBROUTINE isfcav_mlt_3eq(pgt, pgs , pttbl, pstbl, & ! <<== in
- & pqhc, pqoce, pqfwf ) ! ==>> out
+ SUBROUTINE isfcav_mlt_3eq( l_converged, pgt, pgs , pttbl, pstbl, & ! <<== in
+ & pqhc, pqoce, pfwf, ptfrz ) ! ==>> inout
!!----------------------------------------------------------------------
!!
!! *** ROUTINE isfcav_mlt_3eq ***
@@ -194,71 +173,58 @@ CONTAINS
!! MISMIP v. 3 (MISMIP +), ISOMIP v. 2 (ISOMIP +) and MISOMIP v. 1 (MISOMIP1),
!! Geosci. Model Dev., 9, 2471-2497, https://doi.org/10.5194/gmd-9-2471-2016, 2016.
!!
- !!-------------------------- OUT -------------------------------------
- REAL(wp), DIMENSION(jpi,jpj), INTENT( out) :: pqhc, pqoce, pqfwf ! latent heat and fwf fluxes
- !!-------------------------- IN -------------------------------------
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pgt , pgs ! heat/salt exchange coeficient
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pttbl, pstbl ! mean temperature and salinity in top boundary layer
!!--------------------------------------------------------------------
- REAL(wp) :: zeps1,zeps2,zeps3,zeps4,zeps6,zeps7 ! dummy local scalar for quadratic equation resolution
- REAL(wp) :: zaqe,zbqe,zcqe,zaqer,zdis,zsfrz,zcfac ! dummy local scalar for quadratic equation resolution
- REAL(wp) :: zeps = 1.e-20
- REAL(wp), DIMENSION(jpi,jpj) :: ztfrz ! freezing point
- REAL(wp), DIMENSION(jpi,jpj) :: zqcon ! conductive flux through the ice shelf
- REAL(wp), DIMENSION(jpi,jpj) :: zthd ! thermal driving
- !
+ LOGICAL , DIMENSION(A2D(0)), INTENT(in ) :: l_converged ! true when melting converges (per grid point)
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in ) :: pgt , pgs ! heat/salt exchange coeficient
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in ) :: pttbl, pstbl ! mean temperature and salinity in top boundary layer
+ REAL(wp), DIMENSION(A2D(0)), INTENT(inout) :: pqhc, pqoce, pfwf ! latent heat and fwf fluxes
+ REAL(wp), DIMENSION(A2D(0)), INTENT(inout) :: ptfrz ! tbl freezing temp
+ !!
INTEGER :: ji, jj ! dummy loop indices
+ REAL(wp) :: zeps1, zeps2, zeps3, zeps4, zeps6, zeps7 ! dummy local scalar for quadratic equation resolution
+ REAL(wp) :: zaqe, zbqe, zcqe, zaqer, zdis, zsfrz, zcfac ! dummy local scalar for quadratic equation resolution
!!--------------------------------------------------------------------
!
! compute upward heat flux zhtflx and upward water flux zwflx
! Resolution of a 3d equation from equation 24, 25 and 26 (note conduction through the ice has been added to Eq 24)
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
- !
- ! compute coeficient to solve the 2nd order equation
- zeps1 = rho0_rcp * pgt(ji,jj)
- zeps2 = rLfusisf * rho0 * pgs(ji,jj)
- zeps3 = rhoisf * rcpisf * rkappa / MAX(risfdep(ji,jj),zeps)
- zeps4 = risf_lamb2 + risf_lamb3 * risfdep(ji,jj)
- zeps6 = zeps4 - pttbl(ji,jj)
- zeps7 = zeps4 - rtsurf
- !
- ! solve the 2nd order equation to find zsfrz
- zaqe = risf_lamb1 * (zeps1 + zeps3)
- zaqer = 0.5_wp / MIN(zaqe,-zeps)
- zbqe = zeps1 * zeps6 + zeps3 * zeps7 - zeps2
- zcqe = zeps2 * pstbl(ji,jj)
- zdis = zbqe * zbqe - 4.0_wp * zaqe * zcqe
- !
- ! Presumably zdis can never be negative because gammas is very small compared to gammat
- zsfrz=(-zbqe - SQRT(zdis)) * zaqer
- IF ( zsfrz < 0.0_wp ) zsfrz=(-zbqe + SQRT(zdis)) * zaqer ! check this if this if is needed
- !
- ! compute t freeze (eq. 25)
- ztfrz(ji,jj) = zeps4 + risf_lamb1 * zsfrz
- !
- ! thermal driving
- zthd(ji,jj) = ( pttbl(ji,jj) - ztfrz(ji,jj) )
- !
- ! compute the upward water and heat flux (eq. 24 and eq. 26)
- pqfwf(ji,jj) = - rho0 * pgs(ji,jj) * ( zsfrz - pstbl(ji,jj) ) / MAX(zsfrz,zeps) ! fresh water flux ( > 0 from isf to oce)
- pqoce(ji,jj) = - rho0_rcp * pgt(ji,jj) * zthd (ji,jj) ! ocean-ice heat flux ( > 0 from isf to oce)
- pqhc (ji,jj) = rcp * pqfwf(ji,jj) * ztfrz(ji,jj) ! heat content flux ( > 0 from isf to oce)
+ DO_2D( 0, 0, 0, 0 )
!
- zqcon(ji,jj) = zeps3 * ( ztfrz(ji,jj) - rtsurf )
+ IF ( .NOT. l_converged(ji,jj) ) THEN
+ ! compute coeficient to solve the 2nd order equation
+ zeps1 = rho0_rcp * pgt(ji,jj)
+ zeps2 = rLfusisf * rho0 * pgs(ji,jj)
+ zeps3 = rhoisf * rcpisf * rkappa / MAX(risfdep(ji,jj),1.e-20)
+ zeps4 = risf_lamb2 + risf_lamb3 * risfdep(ji,jj)
+ zeps6 = zeps4 - pttbl(ji,jj)
+ zeps7 = zeps4 - rtsurf
+ !
+ ! solve the 2nd order equation to find zsfrz
+ zaqe = risf_lamb1 * (zeps1 + zeps3)
+ zaqer = 0.5_wp / MIN(zaqe,-1.e-20)
+ zbqe = zeps1 * zeps6 + zeps3 * zeps7 - zeps2
+ zcqe = zeps2 * pstbl(ji,jj)
+ zdis = zbqe * zbqe - 4.0_wp * zaqe * zcqe
+ !
+ ! Presumably zdis can never be negative because gammas is very small compared to gammat
+ zsfrz=(-zbqe - SQRT(zdis)) * zaqer
+ IF ( zsfrz < 0.0_wp ) zsfrz=(-zbqe + SQRT(zdis)) * zaqer ! check this if this if is needed
+ !
+ ! compute t freeze (eq. 25)
+ ptfrz(ji,jj) = zeps4 + risf_lamb1 * zsfrz
+ !
+ ! compute the upward water and heat flux (eq. 24 and eq. 26)
+ pfwf (ji,jj) = - rho0 * pgs(ji,jj) * ( zsfrz - pstbl(ji,jj) ) / MAX(zsfrz,1.e-20) * mskisf_cav(ji,jj) ! fresh water flux ( > 0 from isf to oce)
+ pqoce(ji,jj) = - rho0_rcp * pgt(ji,jj) * ( pttbl(ji,jj) - ptfrz(ji,jj) ) * mskisf_cav(ji,jj) ! ocean-ice heat flux ( > 0 from isf to oce)
+ pqhc (ji,jj) = rcp * pfwf(ji,jj) * ptfrz(ji,jj) * mskisf_cav(ji,jj) ! heat content flux ( > 0 from isf to oce)
+ !
+ ENDIF
!
END_2D
!
- ! output conductive heat flux through the ice
- CALL iom_put('qconisf', zqcon(:,:) * mskisf_cav(:,:) )
- !
- ! output thermal driving and freezing point at the interface
- CALL iom_put('isfthermald_cav', zthd (:,:) * mskisf_cav(:,:) )
- CALL iom_put('isftfrz_cav' , ztfrz(:,:) * mskisf_cav(:,:) )
- !
END SUBROUTINE isfcav_mlt_3eq
- SUBROUTINE isfcav_mlt_oasis(kt, pstbl, & ! <<== in
- & pqhc , pqoce, pqfwf ) ! ==>> out
+ SUBROUTINE isfcav_mlt_oasis( kt, l_converged, & ! <<== in
+ & pqhc, pqoce, pfwf, ptfrz ) ! ==>> inout
!!----------------------------------------------------------------------
!! *** ROUTINE isfcav_mlt_oasis ***
!!
@@ -269,44 +235,38 @@ CONTAINS
!! - scale fwf and compute heat fluxes
!!
!!---------------------------------------------------------------------
- !!-------------------------- OUT -------------------------------------
- REAL(wp), DIMENSION(jpi,jpj), INTENT( out) :: pqhc, pqoce, pqfwf ! heat content, latent heat and fwf fluxes
- !!-------------------------- IN -------------------------------------
- INTEGER , INTENT(in ) :: kt ! current time step
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pstbl ! salinity in tbl
- !!--------------------------------------------------------------------
- REAL(wp) :: zfwf_fld, zfwf_oasis ! total fwf in the forcing fields (pattern) and from the oasis interface (amount)
- REAL(wp), DIMENSION(jpi,jpj) :: ztfrz ! tbl freezing temperature
- REAL(wp), DIMENSION(jpi,jpj) :: zfwf ! 2d fwf map after scaling
+ INTEGER , INTENT(in ) :: kt ! current time step
+ LOGICAL , DIMENSION(A2D(0)), INTENT(in ) :: l_converged ! true when melting converges (per grid point)
+ REAL(wp), DIMENSION(A2D(0)), INTENT(inout) :: pqhc, pqoce, pfwf ! heat content, latent heat and fwf fluxes
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in ) :: ptfrz ! tbl freezing temp
+ !!
+ INTEGER :: ji, jj
+ REAL(wp), DIMENSION(A2D(0),2) :: ztmp
+ REAL(wp), DIMENSION(2) :: zbg
!!--------------------------------------------------------------------
!
- ! Calculate freezing temperature
- CALL eos_fzp( pstbl(:,:), ztfrz(:,:), risfdep(:,:) )
- !
! read input file of fwf from isf to oce
CALL fld_read ( kt, 1, sf_isfcav_fwf )
!
- ! ice shelf 2d map
- zfwf(:,:) = sf_isfcav_fwf(1)%fnow(:,:,1)
- !
- ! compute glob sum from input file
- ! (PM) should consider delay sum as in fwb (1 time step offset if I well understood)
- zfwf_fld = glob_sum('isfcav_mlt', e1e2t(:,:) * zfwf(:,:))
+ DO_2D( 0, 0, 0, 0 )
+ ! ice shelf 2d map
+ IF ( .NOT. l_converged(ji,jj) ) pfwf(ji,jj) = sf_isfcav_fwf(1)%fnow(ji,jj,1)
+ ztmp(ji,jj,1) = e1e2t(ji,jj) * pfwf(ji,jj)
+ ztmp(ji,jj,2) = e1e2t(ji,jj) * fwfisf_oasis(ji,jj)
+ END_2D
!
- ! compute glob sum from atm->oce ice shelf fwf
+ ! compute glob sum from input file and from atm->oce ice shelf fwf
! (PM) should consider delay sum as in fwb (1 time step offset if I well understood)
- zfwf_oasis = glob_sum('isfcav_mlt', e1e2t(:,:) * fwfisf_oasis(:,:))
+ zbg = glob_sum_vec( 'isfcav_mlt', ztmp )
!
- ! scale fwf
- zfwf(:,:) = zfwf(:,:) * zfwf_oasis / zfwf_fld
- !
- ! define fwf and qoce
- ! ocean heat flux is assume to be equal to the latent heat
- pqfwf(:,:) = zfwf(:,:) ! fwf ( > 0 from isf to oce)
- pqoce(:,:) = - pqfwf(:,:) * rLfusisf ! ocean heat flux ( > 0 from isf to oce)
- pqhc (:,:) = pqfwf(:,:) * ztfrz(:,:) * rcp ! heat content flux ( > 0 from isf to oce)
- !
- CALL iom_put('isftfrz_cav', ztfrz * mskisf_cav(:,:) )
+ ! compute the upward water and heat flux (ocean heat flux is assume to be equal to the latent heat)
+ DO_2D( 0, 0, 0, 0 )
+ IF ( .NOT. l_converged(ji,jj) ) THEN
+ pfwf (ji,jj) = pfwf(ji,jj) * zbg(2) / zbg(1) * mskisf_cav(ji,jj) ! scale fwf
+ pqoce(ji,jj) = - pfwf(ji,jj) * rLfusisf * mskisf_cav(ji,jj) ! ocean heat flux ( > 0 from isf to oce)
+ pqhc (ji,jj) = pfwf(ji,jj) * ptfrz(ji,jj) * rcp * mskisf_cav(ji,jj) ! heat content flux ( > 0 from isf to oce)
+ ENDIF
+ END_2D
!
END SUBROUTINE isfcav_mlt_oasis
diff --git a/src/OCE/ISF/isfcpl.F90 b/src/OCE/ISF/isfcpl.F90
index b035cd5e6095a4206dedf0ccd81f612125a55e3c..e2e9464b976aabd3222cc165f074435147fa64c5 100644
--- a/src/OCE/ISF/isfcpl.F90
+++ b/src/OCE/ISF/isfcpl.F90
@@ -11,13 +11,12 @@ MODULE isfcpl
!!----------------------------------------------------------------------
!! isfrst : read/write iceshelf variables in/from restart
!!----------------------------------------------------------------------
+ USE par_oce ! ocean space and time domain
USE oce ! ocean dynamics and tracers
#if defined key_qco
USE domqco , ONLY : dom_qco_zgr ! vertical scale factor interpolation
#elif defined key_linssh
! ! fix in time coordinate
-#else
- USE domvvl , ONLY : dom_vvl_zgr ! vertical scale factor interpolation
#endif
USE domutl , ONLY : dom_ngb ! find the closest grid point from a given lon/lat position
USE isf_oce ! ice shelf variable
@@ -32,7 +31,6 @@ MODULE isfcpl
PRIVATE
PUBLIC isfcpl_rst_write, isfcpl_init ! iceshelf restart read and write
- PUBLIC isfcpl_ssh, isfcpl_tra, isfcpl_vol, isfcpl_cons ! iceshelf correction for ssh, tra, dyn and conservation
TYPE isfcons
INTEGER :: ii ! i global
@@ -79,6 +77,13 @@ CONTAINS
! allocation and initialisation to 0
CALL isf_alloc_cpl()
!
+ risfcpl_tsc (:,:,:,:) = 0._wp
+ risfcpl_cons_tsc(:,:,:,:) = 0._wp
+ risfcpl_vol (:,:,:) = 0._wp
+ risfcpl_cons_vol(:,:,:) = 0._wp
+ risfcpl_ssh (:,:) = 0._wp
+ risfcpl_cons_ssh(:,:) = 0._wp
+ !
! check presence of variable needed for coupling
! iom_varid return 0 if not found
id = 1
@@ -115,11 +120,11 @@ CONTAINS
!
! all before fields set to now values
ts (:,:,:,:,Kbb) = ts (:,:,:,:,Kmm)
- uu (:,:,:,Kbb) = uu (:,:,:,Kmm)
- vv (:,:,:,Kbb) = vv (:,:,:,Kmm)
+ uu (:,:,:,Kbb) = uu (:,:,:,Kmm)
+ vv (:,:,:,Kbb) = vv (:,:,:,Kmm)
ssh (:,:,Kbb) = ssh (:,:,Kmm)
#if ! defined key_qco && ! defined key_linssh
- e3t(:,:,:,Kbb) = e3t(:,:,:,Kmm)
+ e3t (:,:,:,Kbb) = e3t (:,:,:,Kmm)
#endif
END SUBROUTINE isfcpl_init
@@ -135,23 +140,30 @@ CONTAINS
INTEGER, INTENT(in) :: Kmm ! ocean time level index
!!----------------------------------------------------------------------
INTEGER :: jk ! loop index
- REAL(wp), DIMENSION(jpi,jpj,jpk) :: ze3t, ze3u, ze3v, zgdepw ! for qco substitution
+ REAL(wp), DIMENSION(jpi,jpj,jpk) :: ztmp ! for qco substitution
!!----------------------------------------------------------------------
!
+ CALL iom_rstput( kt, nitrst, numrow, 'tmask' , tmask )
+ CALL iom_rstput( kt, nitrst, numrow, 'ssmask' , ssmask )
+ !
+ DO jk = 1, jpk
+ ztmp(:,:,jk) = e3t(:,:,jk,Kmm)
+ END DO
+ CALL iom_rstput( kt, nitrst, numrow, 'e3t_n' , ztmp )
DO jk = 1, jpk
- ze3t(:,:,jk) = e3t(:,:,jk,Kmm)
- ze3u(:,:,jk) = e3u(:,:,jk,Kmm)
- ze3v(:,:,jk) = e3v(:,:,jk,Kmm)
+ ztmp(:,:,jk) = e3u(:,:,jk,Kmm)
+ END DO
+ CALL iom_rstput( kt, nitrst, numrow, 'e3u_n' , ztmp )
+ DO jk = 1, jpk
+ ztmp(:,:,jk) = e3v(:,:,jk,Kmm)
+ END DO
+ CALL iom_rstput( kt, nitrst, numrow, 'e3v_n' , ztmp )
!
- zgdepw(:,:,jk) = gdepw(:,:,jk,Kmm)
+ DO jk = 1, jpk
+ ztmp(:,:,jk) = gdepw(:,:,jk,Kmm)
END DO
+ CALL iom_rstput( kt, nitrst, numrow, 'gdepw_n', ztmp )
!
- CALL iom_rstput( kt, nitrst, numrow, 'tmask' , tmask )
- CALL iom_rstput( kt, nitrst, numrow, 'ssmask' , ssmask )
- CALL iom_rstput( kt, nitrst, numrow, 'e3t_n' , ze3t )
- CALL iom_rstput( kt, nitrst, numrow, 'e3u_n' , ze3u )
- CALL iom_rstput( kt, nitrst, numrow, 'e3v_n' , ze3v )
- CALL iom_rstput( kt, nitrst, numrow, 'gdepw_n', zgdepw )
!
END SUBROUTINE isfcpl_rst_write
@@ -166,13 +178,14 @@ CONTAINS
!!
!!----------------------------------------------------------------------
!!
- INTEGER, INTENT(in) :: Kbb, Kmm, Kaa ! ocean time level indices
+ INTEGER, INTENT(in) :: Kbb, Kmm, Kaa ! ocean time level indices
!!----------------------------------------------------------------------
- INTEGER :: ji, jj, jd, jk !! loop index
- INTEGER :: jip1, jim1, jjp1, jjm1
+ INTEGER :: ji, jj, jd, jk !! loop index
+ INTEGER :: jip1, jim1, jjp1, jjm1
+ INTEGER :: ibnd
!!
- REAL(wp):: zsummsk
- REAL(wp), DIMENSION(jpi,jpj) :: zdssmask, zssmask0, zssmask_b, zssh
+ REAL(wp):: zdssmask, zsummsk
+ REAL(wp), DIMENSION(jpi,jpj) :: zssmask0, zssmask_b, zssh
!!----------------------------------------------------------------------
!
CALL iom_get( numror, jpdom_auto, 'ssmask' , zssmask_b ) ! need to extrapolate T/S
@@ -185,26 +198,36 @@ CONTAINS
!
DO jd = 1, nn_drown
!
- zdssmask(:,:) = ssmask(:,:) - zssmask0(:,:)
- DO_2D( 0, 0, 0, 0 )
+ IF ( MOD(jd,2) == 0 ) THEN ! even
+ ibnd = nn_hls-1
+ ELSEIF( MOD(jd,2) == 1 ) THEN ! odd
+ ibnd = 0
+ ENDIF
+
+ DO_2D( ibnd, ibnd, ibnd, ibnd )
+ zdssmask = ssmask(ji,jj) - zssmask0(ji,jj)
+
jip1=ji+1 ; jim1=ji-1
jjp1=jj+1 ; jjm1=jj-1
!
zsummsk = zssmask0(jip1,jj) + zssmask0(jim1,jj) + zssmask0(ji,jjp1) + zssmask0(ji,jjm1)
!
- IF (zdssmask(ji,jj) == 1._wp .AND. zsummsk /= 0._wp) THEN
- ssh(ji,jj,Kmm)=( zssh(jip1,jj)*zssmask0(jip1,jj) &
- & + zssh(jim1,jj)*zssmask0(jim1,jj) &
- & + zssh(ji,jjp1)*zssmask0(ji,jjp1) &
- & + zssh(ji,jjm1)*zssmask0(ji,jjm1)) / zsummsk
+ IF (zdssmask == 1._wp .AND. zsummsk /= 0._wp) THEN
+ ssh(ji,jj,Kmm)=( ( zssh(jip1,jj)*zssmask0(jip1,jj) + zssh(jim1,jj)*zssmask0(jim1,jj) ) & ! add () for NP repro
+ & + ( zssh(ji,jjp1)*zssmask0(ji,jjp1) + zssh(ji,jjm1)*zssmask0(ji,jjm1) ) ) / zsummsk
zssmask_b(ji,jj) = 1._wp
ENDIF
END_2D
- CALL lbc_lnk( 'isfcpl', ssh(:,:,Kmm), 'T', 1.0_wp, zssmask_b(:,:), 'T', 1.0_wp )
- !
- zssh(:,:) = ssh(:,:,Kmm)
- zssmask0(:,:) = zssmask_b(:,:)
!
+ ! update ssh and mask
+ DO_2D( ibnd, ibnd, ibnd, ibnd )
+ zssh (ji,jj) = ssh (ji,jj,Kmm)
+ zssmask0(ji,jj) = zssmask_b(ji,jj)
+ END_2D
+
+ IF( ibnd == 0 ) THEN
+ CALL lbc_lnk( 'isfcpl', zssh(:,:), 'T', 1.0_wp, zssmask0(:,:), 'T', 1.0_wp )
+ ENDIF
!
END DO
!
@@ -222,12 +245,6 @@ CONTAINS
CALL dom_qco_zgr(Kbb, Kmm)
#elif defined key_linssh
! linear ssh : fix in time coord.
-#else
- DO jk = 1, jpk
- e3t(:,:,jk,Kmm) = e3t_0(:,:,jk) * ( 1._wp + (ht_0(:,:) + ssh(:,:,Kmm)) * r1_ht_0(:,:) )
- END DO
- e3t(:,:,:,Kbb) = e3t(:,:,:,Kmm)
- CALL dom_vvl_zgr(Kbb, Kmm, Kaa)
#endif
!
END SUBROUTINE isfcpl_ssh
@@ -244,19 +261,16 @@ CONTAINS
!!----------------------------------------------------------------------
INTEGER, INTENT(in) :: Kmm ! ocean time level index
!!----------------------------------------------------------------------
- REAL(wp), DIMENSION(jpi,jpj,jpk) :: ztmask_b
+ REAL(wp), DIMENSION(jpi,jpj,jpk) :: ztmask_b, ztmask0
+ REAL(wp), DIMENSION(jpi,jpj,jpk,jpts) :: zts0
!REAL(wp), DIMENSION(:,:,: ), INTENT(in ) :: pdepw_b !! depth w before
!!
- INTEGER :: ji, jj, jk, jd !! loop index
- INTEGER :: jip1, jim1, jjp1, jjm1, jkp1, jkm1
+ INTEGER :: ji, jj, jk, jd !! loop index
+ INTEGER :: jip1, jim1, jjp1, jjm1, jkp1, jkm1
+ INTEGER :: ibnd
!!
- REAL(wp):: zsummsk
- REAL(wp):: zdz, zdzm1, zdzp1
- !!
- REAL(wp), DIMENSION(jpi,jpj) :: zdmask
- REAL(wp), DIMENSION(jpi,jpj,jpk) :: ztmask0, zwmaskn
- REAL(wp), DIMENSION(jpi,jpj,jpk) :: ztmask1, zwmaskb, ztmp3d
- REAL(wp), DIMENSION(jpi,jpj,jpk,jpts) :: zts0
+ REAL(wp):: zdmask, zsummsk
+ REAL(wp):: zdz, zdzm1, zdzp1
!!----------------------------------------------------------------------
!
CALL iom_get( numror, jpdom_auto, 'tmask' , ztmask_b ) ! need to extrapolate T/S
@@ -301,69 +315,77 @@ CONTAINS
! END DO
! END IF
- zts0(:,:,:,:) = ts(:,:,:,:,Kmm)
- ztmask0(:,:,:) = ztmask_b(:,:,:)
- ztmask1(:,:,:) = ztmask_b(:,:,:)
+ zts0 (:,:,:,:) = ts (:,:,:,:,Kmm)
+ ztmask0(:,:,:) = ztmask_b(:,:,:)
!
! iterate the extrapolation processes nn_drown times
DO jd = 1,nn_drown ! resolution dependent (OK for ISOMIP+ case)
- DO jk = 1,jpk-1
- !
+
+ IF ( MOD(jd,2) == 0 ) THEN ! even
+ ibnd = nn_hls-1
+ ELSEIF( MOD(jd,2) == 1 ) THEN ! odd
+ ibnd = 0
+ ENDIF
+
+ DO_3D( ibnd, ibnd, ibnd, ibnd, 1, jpkm1 )
! define new wet cell
- zdmask(:,:) = tmask(:,:,jk) - ztmask0(:,:,jk);
+ zdmask = tmask(ji,jj,jk) - ztmask0(ji,jj,jk)
+
+ jip1=ji+1; jim1=ji-1;
+ jjp1=jj+1; jjm1=jj-1;
!
- DO_2D( 0, 0, 0, 0 )
- jip1=ji+1; jim1=ji-1;
- jjp1=jj+1; jjm1=jj-1;
- !
- ! check if a wet neigbourg cell is present
- zsummsk = ztmask0(jip1,jj ,jk) + ztmask0(jim1,jj ,jk) &
- + ztmask0(ji ,jjp1,jk) + ztmask0(ji ,jjm1,jk)
+ ! check if a wet neigbourg cell is present
+ zsummsk = ztmask0(jip1,jj ,jk) + ztmask0(jim1,jj ,jk) &
+ & + ztmask0(ji ,jjp1,jk) + ztmask0(ji ,jjm1,jk)
+ !
+ ! if neigbourg wet cell available at the same level
+ IF( zdmask == 1._wp .AND. zsummsk /= 0._wp ) THEN
!
- ! if neigbourg wet cell available at the same level
- IF ( zdmask(ji,jj) == 1._wp .AND. zsummsk /= 0._wp ) THEN
- !
- ! horizontal basic extrapolation
- ts(ji,jj,jk,1,Kmm)=( zts0(jip1,jj ,jk,1) * ztmask0(jip1,jj ,jk) &
+ ! horizontal basic extrapolation
+ ts(ji,jj,jk,1,Kmm)=( zts0(jip1,jj ,jk,1) * ztmask0(jip1,jj ,jk) &
& + zts0(jim1,jj ,jk,1) * ztmask0(jim1,jj ,jk) &
& + zts0(ji ,jjp1,jk,1) * ztmask0(ji ,jjp1,jk) &
& + zts0(ji ,jjm1,jk,1) * ztmask0(ji ,jjm1,jk) ) / zsummsk
- ts(ji,jj,jk,2,Kmm)=( zts0(jip1,jj ,jk,2) * ztmask0(jip1,jj ,jk) &
+ ts(ji,jj,jk,2,Kmm)=( zts0(jip1,jj ,jk,2) * ztmask0(jip1,jj ,jk) &
& + zts0(jim1,jj ,jk,2) * ztmask0(jim1,jj ,jk) &
& + zts0(ji ,jjp1,jk,2) * ztmask0(ji ,jjp1,jk) &
& + zts0(ji ,jjm1,jk,2) * ztmask0(ji ,jjm1,jk) ) / zsummsk
- !
- ! update mask for next pass
- ztmask1(ji,jj,jk)=1
- !
+ !
+ ! update mask for next pass
+ ztmask_b(ji,jj,jk)=1
+ !
! in case no neigbourg wet cell available at the same level
! check if a wet cell is available below
- ELSEIF (zdmask(ji,jj) == 1._wp .AND. zsummsk == 0._wp) THEN
- !
- ! vertical extrapolation if horizontal extrapolation failed
- jkm1=max(1,jk-1) ; jkp1=min(jpk,jk+1)
- !
- ! check if a wet neigbourg cell is present
- zsummsk = ztmask0(ji,jj,jkm1) + ztmask0(ji,jj,jkp1)
- IF (zdmask(ji,jj) == 1._wp .AND. zsummsk /= 0._wp ) THEN
- ts(ji,jj,jk,1,Kmm)=( zts0(ji,jj,jkp1,1)*ztmask0(ji,jj,jkp1) &
+ ELSEIF( zdmask == 1._wp .AND. zsummsk == 0._wp ) THEN
+ !
+ ! vertical extrapolation if horizontal extrapolation failed
+ jkm1=MAX(1,jk-1) ; jkp1=MIN(jpk,jk+1)
+ !
+ ! check if a wet neigbourg cell is present
+ zsummsk = ztmask0(ji,jj,jkm1) + ztmask0(ji,jj,jkp1)
+ IF( zdmask == 1._wp .AND. zsummsk /= 0._wp ) THEN
+ ts(ji,jj,jk,1,Kmm)=( zts0(ji,jj,jkp1,1)*ztmask0(ji,jj,jkp1) &
& + zts0(ji,jj,jkm1,1)*ztmask0(ji,jj,jkm1)) / zsummsk
- ts(ji,jj,jk,2,Kmm)=( zts0(ji,jj,jkp1,2)*ztmask0(ji,jj,jkp1) &
+ ts(ji,jj,jk,2,Kmm)=( zts0(ji,jj,jkp1,2)*ztmask0(ji,jj,jkp1) &
& + zts0(ji,jj,jkm1,2)*ztmask0(ji,jj,jkm1)) / zsummsk
- !
- ! update mask for next pass
- ztmask1(ji,jj,jk)=1._wp
- END IF
+ !
+ ! update mask for next pass
+ ztmask_b(ji,jj,jk)=1._wp
END IF
- END_2D
- END DO
- !
- CALL lbc_lnk( 'isfcpl', ts(:,:,:,jp_tem,Kmm), 'T', 1.0_wp, ts(:,:,:,jp_sal,Kmm), 'T', 1.0_wp, ztmask1, 'T', 1.0_wp)
- !
+ END IF
+ !
+ END_3D
+
! update temperature and salinity and mask
- zts0(:,:,:,:) = ts(:,:,:,:,Kmm)
- ztmask0(:,:,:) = ztmask1(:,:,:)
+ DO_3D( ibnd, ibnd, ibnd, ibnd, 1, jpk )
+ zts0 (ji,jj,jk,1) = ts (ji,jj,jk,1,Kmm)
+ zts0 (ji,jj,jk,2) = ts (ji,jj,jk,2,Kmm)
+ ztmask0(ji,jj,jk) = ztmask_b(ji,jj,jk)
+ END_3D
!
+ IF( ibnd == 0 ) THEN
+ CALL lbc_lnk( 'isfcpl', zts0(:,:,:,1), 'T', 1.0_wp, zts0(:,:,:,2), 'T', 1.0_wp, ztmask0(:,:,:), 'T', 1.0_wp )
+ ENDIF
!
END DO ! nn_drown
!
@@ -374,7 +396,7 @@ CONTAINS
! sanity check
! -----------------------------------------------------------------------------------------
! case we open a cell but no neigbour cells available to get an estimate of T and S
- DO_3D( 0, 0, 0, 0, 1,jpk-1 )
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
IF (tmask(ji,jj,jk) == 1._wp .AND. ts(ji,jj,jk,2,Kmm) == 0._wp) &
& CALL ctl_stop('STOP', 'failing to fill all new weet cell, &
& try increase nn_drown or activate XXXX &
@@ -455,25 +477,29 @@ CONTAINS
!
END_2D
!
- CALL lbc_lnk( 'isfcpl', risfcpl_vol, 'T', 1.0_wp )
- !
! 3.0: set total correction (div, tr(:,:,:,:,Krhs), ssh)
!
! 3.1: mask volume flux divergence correction
- risfcpl_vol(:,:,:) = risfcpl_vol(:,:,:) * tmask(:,:,:)
+ DO_3D( 0, 0, 0, 0, 1, jpk )
+ risfcpl_vol(ji,jj,jk) = risfcpl_vol(ji,jj,jk) * tmask(ji,jj,jk)
+ END_3D
!
! 3.2: get 3d tr(:,:,:,:,Krhs) increment to apply at the first time step
! temperature and salt content flux computed using local ts(:,:,:,:,Kmm)
! (very simple advection scheme)
! (>0 out)
- risfcpl_tsc(:,:,:,jp_tem) = -risfcpl_vol(:,:,:) * ts(:,:,:,jp_tem,Kmm)
- risfcpl_tsc(:,:,:,jp_sal) = -risfcpl_vol(:,:,:) * ts(:,:,:,jp_sal,Kmm)
+ DO_3D( 0, 0, 0, 0, 1, jpk )
+ risfcpl_tsc(ji,jj,jk,jp_tem) = -risfcpl_vol(ji,jj,jk) * ts(ji,jj,jk,jp_tem,Kmm)
+ risfcpl_tsc(ji,jj,jk,jp_sal) = -risfcpl_vol(ji,jj,jk) * ts(ji,jj,jk,jp_sal,Kmm)
+ END_3D
!
! 3.3: ssh correction (for dynspg_ts)
- risfcpl_ssh(:,:) = 0.0
- DO jk = 1,jpk
- risfcpl_ssh(:,:) = risfcpl_ssh(:,:) + risfcpl_vol(:,:,jk) * r1_e1e2t(:,:)
- END DO
+ DO_2D( 0, 0, 0, 0 )
+ risfcpl_ssh(ji,jj) = 0.0
+ END_2D
+ DO_3D( 0, 0, 0, 0, 1, jpk )
+ risfcpl_ssh(ji,jj) = risfcpl_ssh(ji,jj) + risfcpl_vol(ji,jj,jk) * r1_e1e2t(ji,jj)
+ END_3D
!
END SUBROUTINE isfcpl_vol
@@ -507,21 +533,17 @@ CONTAINS
REAL(wp) :: z1_sum, z1_rdtiscpl
REAL(wp) :: zdtem, zdsal, zdvol, zratio ! tem, sal, vol increment
REAL(wp) :: zlon , zlat ! target location
- REAL(wp), DIMENSION(jpi,jpj,jpk) :: ztmask_b ! mask before
- REAL(wp), DIMENSION(jpi,jpj,jpk) :: ze3t_b ! scale factor before
- REAL(wp), DIMENSION(jpi,jpj,jpk) :: zt_b ! scale factor before
- REAL(wp), DIMENSION(jpi,jpj,jpk) :: zs_b ! scale factor before
+ REAL(wp), DIMENSION(A2D(0),jpk) :: ztmask_b ! mask before
+ REAL(wp), DIMENSION(A2D(0),jpk) :: ze3t_b ! scale factor before
+ REAL(wp), DIMENSION(A2D(0),jpk) :: ztmp ! scale factor before
!!----------------------------------------------------------------------
!==============================================================================
! 1.0: initialisation
!==============================================================================
-
! get restart variable
CALL iom_get( numror, jpdom_auto, 'tmask' , ztmask_b(:,:,:) ) ! need to extrapolate T/S
- CALL iom_get( numror, jpdom_auto, 'e3t_n' , ze3t_b(:,:,:) )
- CALL iom_get( numror, jpdom_auto, 'tn' , zt_b(:,:,:) )
- CALL iom_get( numror, jpdom_auto, 'sn' , zs_b(:,:,:) )
+
! compute run length
nstp_iscpl = nitend - nit000 + 1
@@ -540,32 +562,36 @@ CONTAINS
! 2.0: diagnose the heat, salt and volume input and compute the correction variable
! for case where we wet a cell or cell still wet (no change in cell status)
!==============================================================================
+ CALL iom_get( numror, jpdom_auto, 'e3t_n' , ze3t_b(:,:,:) )
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
+ ! volume diff
+ zdvol = e3t(ji,jj,jk,Kmm) * tmask (ji,jj,jk) &
+ & - ze3t_b(ji,jj,jk ) * ztmask_b(ji,jj,jk)
+ ! volume differences in each cell (>0 means correction is an outward flux)
+ ! in addition to the geometry change unconservation, need to add the divergence correction as it is flux across the boundary
+ risfcpl_cons_vol(ji,jj,jk) = ( zdvol * e1e2t(ji,jj) + risfcpl_vol(ji,jj,jk) ) * z1_rdtiscpl
+ END_3D
- DO jk = 1,jpk-1
- DO jj = Njs0,Nje0
- DO ji = Nis0,Nie0
-
- ! volume diff
- zdvol = e3t(ji,jj,jk,Kmm) * tmask (ji,jj,jk) &
- & - ze3t_b(ji,jj,jk ) * ztmask_b(ji,jj,jk)
-
- ! heat diff
- zdtem = ts (ji,jj,jk,jp_tem,Kmm) * e3t(ji,jj,jk,Kmm) * tmask (ji,jj,jk) &
- - zt_b(ji,jj,jk) * ze3t_b(ji,jj,jk) * ztmask_b(ji,jj,jk)
-
- ! salt diff
- zdsal = ts(ji,jj,jk,jp_sal,Kmm) * e3t(ji,jj,jk,Kmm) * tmask (ji,jj,jk) &
- - zs_b(ji,jj,jk) * ze3t_b(ji,jj,jk) * ztmask_b(ji,jj,jk)
+ CALL iom_get( numror, jpdom_auto, 'tn' , ztmp(:,:,:) )
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
+ ! heat diff
+ zdtem = ts (ji,jj,jk,jp_tem,Kmm) * e3t(ji,jj,jk,Kmm) * tmask (ji,jj,jk) &
+ & - ztmp(ji,jj,jk) * ze3t_b(ji,jj,jk) * ztmask_b(ji,jj,jk)
+ ! heat differences in each cell (>0 means correction is an outward flux)
+ ! in addition to the geometry change unconservation, need to add the divergence correction as it is flux across the boundary
+ risfcpl_cons_tsc(ji,jj,jk,jp_tem) = ( - zdtem * e1e2t(ji,jj) + risfcpl_tsc(ji,jj,jk,jp_tem) ) * z1_rdtiscpl
+ END_3D
- ! volume, heat and salt differences in each cell (>0 means correction is an outward flux)
- ! in addition to the geometry change unconservation, need to add the divergence correction as it is flux across the boundary
- risfcpl_cons_vol(ji,jj,jk) = ( zdvol * e1e2t(ji,jj) + risfcpl_vol(ji,jj,jk) ) * z1_rdtiscpl
- risfcpl_cons_tsc(ji,jj,jk,jp_sal) = ( - zdsal * e1e2t(ji,jj) + risfcpl_tsc(ji,jj,jk,jp_sal) ) * z1_rdtiscpl
- risfcpl_cons_tsc(ji,jj,jk,jp_tem) = ( - zdtem * e1e2t(ji,jj) + risfcpl_tsc(ji,jj,jk,jp_tem) ) * z1_rdtiscpl
+ CALL iom_get( numror, jpdom_auto, 'sn' , ztmp(:,:,:) )
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
+ ! salt diff
+ zdsal = ts(ji,jj,jk,jp_sal,Kmm) * e3t(ji,jj,jk,Kmm) * tmask (ji,jj,jk) &
+ & - ztmp(ji,jj,jk) * ze3t_b(ji,jj,jk) * ztmask_b(ji,jj,jk)
- END DO
- END DO
- END DO
+ ! salt differences in each cell (>0 means correction is an outward flux)
+ ! in addition to the geometry change unconservation, need to add the divergence correction as it is flux across the boundary
+ risfcpl_cons_tsc(ji,jj,jk,jp_sal) = ( - zdsal * e1e2t(ji,jj) + risfcpl_tsc(ji,jj,jk,jp_sal) ) * z1_rdtiscpl
+ END_3D
!
!==============================================================================
! 3.0: diagnose the heat, salt and volume input and compute the correction variable
@@ -575,16 +601,15 @@ CONTAINS
! compute the total number of point receiving a correction increment for each processor
! local
nisfl(:)=0
- DO jk = 1,jpk-1
- DO jj = Njs0,Nje0
- DO ji = Nis0,Nie0
- jip1=MIN(ji+1,jpi) ; jim1=MAX(ji-1,1) ; jjp1=MIN(jj+1,jpj) ; jjm1=MAX(jj-1,1) ;
- IF ( tmask(ji,jj,jk) == 0._wp .AND. ztmask_b(ji,jj,jk) == 1._wp ) THEN
- nisfl(narea) = nisfl(narea) + MAX(SUM(tmask(jim1:jip1,jjm1:jjp1,jk)),1._wp)
- ENDIF
- ENDDO
- ENDDO
- ENDDO
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
+ jip1=MIN(ji+1,jpi)
+ jim1=MAX(ji-1,1 )
+ jjp1=MIN(jj+1,jpj)
+ jjm1=MAX(jj-1,1 )
+ IF( tmask(ji,jj,jk) == 0._wp .AND. ztmask_b(ji,jj,jk) == 1._wp ) THEN
+ nisfl(narea) = nisfl(narea) + MAX(SUM(tmask(jim1:jip1,jjm1:jjp1,jk)),1._wp)
+ ENDIF
+ END_3D
!
! global
CALL mpp_sum('isfcpl',nisfl )
@@ -597,46 +622,42 @@ CONTAINS
! start computing the correction and fill zisfpts
! local
jisf = 0
- DO jk = 1,jpk-1
- DO jj = Njs0,Nje0
- DO ji = Nis0,Nie0
- IF ( tmask(ji,jj,jk) == 0._wp .AND. ztmask_b(ji,jj,jk) == 1._wp ) THEN
-
- jip1=MIN(ji+1,jpi) ; jim1=MAX(ji-1,1) ; jjp1=MIN(jj+1,jpj) ; jjm1=MAX(jj-1,1) ;
-
- zdvol = risfcpl_cons_vol(ji,jj,jk )
- zdsal = risfcpl_cons_tsc(ji,jj,jk,jp_sal)
- zdtem = risfcpl_cons_tsc(ji,jj,jk,jp_tem)
-
- IF ( SUM( tmask(jim1:jip1,jjm1:jjp1,jk) ) > 0._wp ) THEN
- ! spread correction amoung neigbourg wet cells (horizontal direction first)
- ! as it is a rude correction corner and lateral cell have the same weight
- !
- z1_sum = 1._wp / SUM( tmask(jim1:jip1,jjm1:jjp1,jk) )
- !
- ! lateral cells
- IF (tmask(jip1,jj ,jk) == 1) CALL update_isfpts(zisfpts, jisf, jip1, jj , jk, zdvol, zdsal, zdtem, z1_sum)
- IF (tmask(jim1,jj ,jk) == 1) CALL update_isfpts(zisfpts, jisf, jim1, jj , jk, zdvol, zdsal, zdtem, z1_sum)
- IF (tmask(ji ,jjp1,jk) == 1) CALL update_isfpts(zisfpts, jisf, ji , jjp1, jk, zdvol, zdsal, zdtem, z1_sum)
- IF (tmask(ji ,jjm1,jk) == 1) CALL update_isfpts(zisfpts, jisf, ji , jjm1, jk, zdvol, zdsal, zdtem, z1_sum)
- !
- ! corner cells
- IF (tmask(jip1,jjm1,jk) == 1) CALL update_isfpts(zisfpts, jisf, jip1, jjm1, jk, zdvol, zdsal, zdtem, z1_sum)
- IF (tmask(jim1,jjm1,jk) == 1) CALL update_isfpts(zisfpts, jisf, jim1, jjm1, jk, zdvol, zdsal, zdtem, z1_sum)
- IF (tmask(jim1,jjp1,jk) == 1) CALL update_isfpts(zisfpts, jisf, jim1, jjp1, jk, zdvol, zdsal, zdtem, z1_sum)
- IF (tmask(jip1,jjp1,jk) == 1) CALL update_isfpts(zisfpts, jisf, jip1, jjp1, jk, zdvol, zdsal, zdtem, z1_sum)
- !
- ELSE IF ( tmask(ji,jj,jk+1) == 1._wp ) THEN
- ! spread correction amoung neigbourg wet cells (vertical direction)
- CALL update_isfpts(zisfpts, jisf, ji , jj , jk+1, zdvol, zdsal, zdtem, 1.0_wp, 0)
- ELSE
- ! need to find where to put correction in later on
- CALL update_isfpts(zisfpts, jisf, ji , jj , jk , zdvol, zdsal, zdtem, 1.0_wp, 1)
- END IF
- END IF
- END DO
- END DO
- END DO
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
+ IF ( tmask(ji,jj,jk) == 0._wp .AND. ztmask_b(ji,jj,jk) == 1._wp ) THEN
+
+ jip1=MIN(ji+1,jpi) ; jim1=MAX(ji-1,1) ; jjp1=MIN(jj+1,jpj) ; jjm1=MAX(jj-1,1) ;
+
+ zdvol = risfcpl_cons_vol(ji,jj,jk )
+ zdsal = risfcpl_cons_tsc(ji,jj,jk,jp_sal)
+ zdtem = risfcpl_cons_tsc(ji,jj,jk,jp_tem)
+
+ IF ( SUM( tmask(jim1:jip1,jjm1:jjp1,jk) ) > 0._wp ) THEN
+ ! spread correction amoung neigbourg wet cells (horizontal direction first)
+ ! as it is a rude correction corner and lateral cell have the same weight
+ !
+ z1_sum = 1._wp / SUM( tmask(jim1:jip1,jjm1:jjp1,jk) )
+ !
+ ! lateral cells
+ IF (tmask(jip1,jj ,jk) == 1) CALL update_isfpts(zisfpts, jisf, jip1, jj , jk, zdvol, zdsal, zdtem, z1_sum)
+ IF (tmask(jim1,jj ,jk) == 1) CALL update_isfpts(zisfpts, jisf, jim1, jj , jk, zdvol, zdsal, zdtem, z1_sum)
+ IF (tmask(ji ,jjp1,jk) == 1) CALL update_isfpts(zisfpts, jisf, ji , jjp1, jk, zdvol, zdsal, zdtem, z1_sum)
+ IF (tmask(ji ,jjm1,jk) == 1) CALL update_isfpts(zisfpts, jisf, ji , jjm1, jk, zdvol, zdsal, zdtem, z1_sum)
+ !
+ ! corner cells
+ IF (tmask(jip1,jjm1,jk) == 1) CALL update_isfpts(zisfpts, jisf, jip1, jjm1, jk, zdvol, zdsal, zdtem, z1_sum)
+ IF (tmask(jim1,jjm1,jk) == 1) CALL update_isfpts(zisfpts, jisf, jim1, jjm1, jk, zdvol, zdsal, zdtem, z1_sum)
+ IF (tmask(jim1,jjp1,jk) == 1) CALL update_isfpts(zisfpts, jisf, jim1, jjp1, jk, zdvol, zdsal, zdtem, z1_sum)
+ IF (tmask(jip1,jjp1,jk) == 1) CALL update_isfpts(zisfpts, jisf, jip1, jjp1, jk, zdvol, zdsal, zdtem, z1_sum)
+ !
+ ELSE IF ( tmask(ji,jj,jk+1) == 1._wp ) THEN
+ ! spread correction amoung neigbourg wet cells (vertical direction)
+ CALL update_isfpts(zisfpts, jisf, ji , jj , jk+1, zdvol, zdsal, zdtem, 1.0_wp, 0)
+ ELSE
+ ! need to find where to put correction in later on
+ CALL update_isfpts(zisfpts, jisf, ji , jj , jk , zdvol, zdsal, zdtem, 1.0_wp, 1)
+ END IF
+ END IF
+ END_3D
!
! share data among all processes because for some point we need to find the closest wet point (could be on other process)
DO jproc=1,jpnij
@@ -686,19 +707,22 @@ CONTAINS
!==============================================================================
!
! mask
- risfcpl_cons_vol(:,:,: ) = risfcpl_cons_vol(:,:,: ) * tmask(:,:,:)
- risfcpl_cons_tsc(:,:,:,jp_sal) = risfcpl_cons_tsc(:,:,:,jp_sal) * tmask(:,:,:)
- risfcpl_cons_tsc(:,:,:,jp_tem) = risfcpl_cons_tsc(:,:,:,jp_tem) * tmask(:,:,:)
- !
- ! add lbclnk
- CALL lbc_lnk( 'isfcpl', risfcpl_cons_tsc(:,:,:,jp_tem), 'T', 1.0_wp, risfcpl_cons_tsc(:,:,:,jp_sal), 'T', 1.0_wp, &
- & risfcpl_cons_vol(:,:,:) , 'T', 1.0_wp)
+ DO_3D( 0, 0, 0, 0, 1, jpk )
+ risfcpl_cons_vol(ji,jj,jk ) = risfcpl_cons_vol(ji,jj,jk ) * tmask(ji,jj,jk)
+ risfcpl_cons_tsc(ji,jj,jk,jp_sal) = risfcpl_cons_tsc(ji,jj,jk,jp_sal) * tmask(ji,jj,jk)
+ risfcpl_cons_tsc(ji,jj,jk,jp_tem) = risfcpl_cons_tsc(ji,jj,jk,jp_tem) * tmask(ji,jj,jk)
+ END_3D
!
! ssh correction (for dynspg_ts)
- DO jk = 1,jpk
- risfcpl_cons_ssh(:,:) = risfcpl_cons_ssh(:,:) + risfcpl_cons_vol(:,:,jk)
- END DO
- risfcpl_cons_ssh(:,:) = risfcpl_cons_ssh(:,:) * r1_e1e2t(:,:)
+ DO_3D( 0, 0, 0, 0, 1, jpk )
+ risfcpl_cons_ssh(ji,jj) = risfcpl_cons_ssh(ji,jj) + risfcpl_cons_vol(ji,jj,jk)
+ END_3D
+ DO_2D( 0, 0, 0, 0 )
+ risfcpl_cons_ssh(ji,jj) = risfcpl_cons_ssh(ji,jj) * r1_e1e2t(ji,jj)
+ END_2D
+ !
+ ! deallocate list of point receiving correction
+ DEALLOCATE( zisfpts )
!
END SUBROUTINE isfcpl_cons
!
@@ -736,7 +760,8 @@ CONTAINS
END IF
!
! update isfpts structure
- sisfpts(kpts) = isfcons(mig(ki), mjg(kj), kk, pratio * pdvol, pratio * pdsal, pratio * pdtem, glamt(ki,kj), gphit(ki,kj), ifind )
+ sisfpts(kpts) = isfcons(mig(ki,0), mjg(kj,0), kk, pratio * pdvol, pratio * pdsal, pratio * pdtem, &
+ & glamt(ki,kj), gphit(ki,kj), ifind )
!
END SUBROUTINE update_isfpts
!
@@ -760,9 +785,8 @@ CONTAINS
iig = ki ; ijg = kj
IF ( kfind == 1 ) CALL dom_ngb( plon, plat, iig, ijg,'T', kk)
!
- ! fill the correction array
- DO jj = mj0(ijg),mj1(ijg)
- DO ji = mi0(iig),mi1(iig)
+ DO jj = mj0(ijg,0),mj1(ijg,0)
+ DO ji = mi0(iig,0),mi1(iig,0)
! correct the vol_flx and corresponding heat/salt flx in the closest cell
risfcpl_cons_vol(ji,jj,kk) = risfcpl_cons_vol(ji,jj,kk ) + pvolinc
risfcpl_cons_tsc(ji,jj,kk,jp_sal) = risfcpl_cons_tsc(ji,jj,kk,jp_sal) + psalinc
diff --git a/src/OCE/ISF/isfdiags.F90 b/src/OCE/ISF/isfdiags.F90
index b9f97736462037f2497b7722ffe64a890895dddd..6f9ec1e04cbfed1d8f04d5f7da816ef65cf09139 100644
--- a/src/OCE/ISF/isfdiags.F90
+++ b/src/OCE/ISF/isfdiags.F90
@@ -13,6 +13,7 @@ MODULE isfdiags
!!----------------------------------------------------------------------
USE in_out_manager ! I/O manager
+ USE par_oce ! ocean space and time domain
USE dom_oce
USE isf_oce ! ice shelf variable
USE iom !
@@ -34,7 +35,7 @@ MODULE isfdiags
CONTAINS
- SUBROUTINE isf_diags_flx(Kmm, ktop, kbot, phtbl, pfrac, cdisf, pqfwf, pqoce, pqlat, pqhc)
+ SUBROUTINE isf_diags_flx( Kmm, ktop, kbot, phtbl, pfrac, cdisf, pfwf, pqoce, pqlat, pqhc )
!!---------------------------------------------------------------------
!! *** ROUTINE isf_diags_flx ***
!!
@@ -42,39 +43,37 @@ CONTAINS
!! from isf to oce fwf, latent heat, heat content fluxes
!!
!!----------------------------------------------------------------------
- !!-------------------------- OUT -------------------------------------
- !!-------------------------- IN -------------------------------------
- INTEGER, INTENT(in) :: Kmm ! ocean time level index
- INTEGER , DIMENSION(jpi,jpj), INTENT(in) :: ktop , kbot ! top and bottom level of the tbl
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: phtbl, pfrac ! thickness of the tbl and fraction of last cell affected by the tbl
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pqfwf, pqoce, pqlat, pqhc ! 2d var to map in 3d
- CHARACTER(LEN=3), INTENT(in) :: cdisf ! parametrisation or interactive melt
+ INTEGER, INTENT(in) :: Kmm ! ocean time level index
+ INTEGER , DIMENSION(A2D(0)), INTENT(in) :: ktop , kbot ! top and bottom level of the tbl
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: phtbl, pfrac ! thickness of the tbl and fraction of last cell affected by the tbl
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pfwf, pqoce, pqlat, pqhc ! 2d var to map in 3d
+ CHARACTER(LEN=3), INTENT(in) :: cdisf ! parametrisation or interactive melt
!!---------------------------------------------------------------------
- CHARACTER(LEN=256) :: cvarqfwf , cvarqoce , cvarqlat , cvarqhc
- CHARACTER(LEN=256) :: cvarqfwf3d, cvarqoce3d, cvarqlat3d, cvarqhc3d
+ CHARACTER(LEN=256) :: cvarfwf , cvarqoce , cvarqlat , cvarqhc
+ CHARACTER(LEN=256) :: cvarfwf3d, cvarqoce3d, cvarqlat3d, cvarqhc3d
!!---------------------------------------------------------------------
!
! output melt
- cvarqfwf = 'fwfisf_'//cdisf ; cvarqfwf3d = 'fwfisf3d_'//cdisf
+ cvarfwf = 'fwfisf_'//cdisf ; cvarfwf3d = 'fwfisf3d_'//cdisf
cvarqoce = 'qoceisf_'//cdisf ; cvarqoce3d = 'qoceisf3d_'//cdisf
cvarqlat = 'qlatisf_'//cdisf ; cvarqlat3d = 'qlatisf3d_'//cdisf
cvarqhc = 'qhcisf_'//cdisf ; cvarqhc3d = 'qhcisf3d_'//cdisf
!
! output 2d melt rate, latent heat and heat content flux from the injected water
- CALL iom_put( TRIM(cvarqfwf), pqfwf(:,:) ) ! mass flux ( > 0 from isf to oce)
+ CALL iom_put( TRIM(cvarfwf) , pfwf(:,:) ) ! mass flux ( > 0 from isf to oce)
CALL iom_put( TRIM(cvarqoce), pqoce(:,:) ) ! oce to ice flux ( > 0 from isf to oce)
CALL iom_put( TRIM(cvarqlat), pqlat(:,:) ) ! latent heat flux ( > 0 from isf to oce)
CALL iom_put( TRIM(cvarqhc) , pqhc (:,:) ) ! heat content flux ( > 0 from isf to oce)
!
! output 3d Diagnostics
- IF ( iom_use( TRIM(cvarqfwf3d) ) ) CALL isf_diags_2dto3d( Kmm, ktop, kbot, phtbl, pfrac, TRIM(cvarqfwf3d) , pqfwf(:,:))
+ IF ( iom_use( TRIM(cvarfwf3d) ) ) CALL isf_diags_2dto3d( Kmm, ktop, kbot, phtbl, pfrac, TRIM(cvarfwf3d) , pfwf(:,:))
IF ( iom_use( TRIM(cvarqoce3d) ) ) CALL isf_diags_2dto3d( Kmm, ktop, kbot, phtbl, pfrac, TRIM(cvarqoce3d) , pqoce(:,:))
IF ( iom_use( TRIM(cvarqlat3d) ) ) CALL isf_diags_2dto3d( Kmm, ktop, kbot, phtbl, pfrac, TRIM(cvarqlat3d) , pqoce(:,:))
IF ( iom_use( TRIM(cvarqhc3d) ) ) CALL isf_diags_2dto3d( Kmm, ktop, kbot, phtbl, pfrac, TRIM(cvarqhc3d) , pqhc (:,:))
!
END SUBROUTINE
- SUBROUTINE isf_diags_2dto3d(Kmm, ktop, kbot, phtbl, pfrac, cdvar, pvar2d)
+ SUBROUTINE isf_diags_2dto3d( Kmm, ktop, kbot, phtbl, pfrac, cdvar, pvar2d )
!!---------------------------------------------------------------------
!! *** ROUTINE isf_diags_2dto3d ***
!!
@@ -82,25 +81,23 @@ CONTAINS
!! (ie uniformaly spread into the top boundary layer or parametrisation layer)
!!
!!----------------------------------------------------------------------
- !!-------------------------- OUT -------------------------------------
- !!-------------------------- IN -------------------------------------
- INTEGER, INTENT(in) :: Kmm ! ocean time level index
- INTEGER , DIMENSION(jpi,jpj), INTENT(in) :: ktop , kbot ! top and bottom level of the tbl
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: phtbl, pfrac ! thickness of the tbl and fraction of last cell affected by the tbl
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pvar2d ! 2d var to map in 3d
- CHARACTER(LEN=*), INTENT(in) :: cdvar
+ INTEGER, INTENT(in) :: Kmm ! ocean time level index
+ INTEGER , DIMENSION(A2D(0)), INTENT(in) :: ktop , kbot ! top and bottom level of the tbl
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: phtbl, pfrac ! thickness of the tbl and fraction of last cell affected by the tbl
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pvar2d ! 2d var to map in 3d
+ CHARACTER(LEN=*), INTENT(in) :: cdvar
!!---------------------------------------------------------------------
- INTEGER :: ji, jj, jk ! loop indices
- INTEGER :: ikt, ikb ! top and bottom level of the tbl
- REAL(wp), DIMENSION(jpi,jpj) :: zvar2d !
- REAL(wp), DIMENSION(jpi,jpj,jpk) :: zvar3d ! 3d var to output
+ INTEGER :: ji, jj, jk ! loop indices
+ INTEGER :: ikt, ikb ! top and bottom level of the tbl
+ REAL(wp), DIMENSION(A2D(0)) :: zvar2d !
+ REAL(wp), DIMENSION(A2D(0),jpk) :: zvar3d ! 3d var to output
!!---------------------------------------------------------------------
!
! compute 3d output
zvar2d(:,:) = pvar2d(:,:) / phtbl(:,:)
zvar3d(:,:,:) = 0._wp
!
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
ikt = ktop(ji,jj)
ikb = kbot(ji,jj)
DO jk = ikt, ikb - 1
@@ -109,7 +106,7 @@ CONTAINS
zvar3d(ji,jj,ikb) = zvar2d(ji,jj) * e3t(ji,jj,ikb,Kmm) * pfrac(ji,jj)
END_2D
!
- CALL iom_put( TRIM(cdvar) , zvar3d(:,:,:))
+ CALL iom_put( TRIM(cdvar) , zvar3d(:,:,:) )
!
END SUBROUTINE isf_diags_2dto3d
diff --git a/src/OCE/ISF/isfdynatf.F90 b/src/OCE/ISF/isfdynatf.F90
index 3be8abf8e6424ae90471f22ea261d8a3eb679543..17fd37b6e984e79e506657a702540fee4b4cd49c 100644
--- a/src/OCE/ISF/isfdynatf.F90
+++ b/src/OCE/ISF/isfdynatf.F90
@@ -7,12 +7,13 @@ MODULE isfdynatf
!!-------------------------------------------------------------------------
!!-------------------------------------------------------------------------
- !! isfnxt : apply correction needed for the ice shelf to ensure conservation
+ !! isfdynatf : apply correction needed for the ice shelf to ensure conservation
!!-------------------------------------------------------------------------
USE isf_oce
USE phycst , ONLY: r1_rho0 ! physical constant
+ USE par_oce ! ocean space and time domain
USE dom_oce ! time and space domain
USE oce, ONLY : ssh ! sea-surface height for qco substitution
@@ -26,66 +27,52 @@ MODULE isfdynatf
!! * Substitutions
# include "do_loop_substitute.h90"
# include "domzgr_substitute.h90"
-
CONTAINS
- SUBROUTINE isf_dynatf ( kt, Kmm, pe3t_f, pcoef )
+ SUBROUTINE isf_dynatf ( kt, Kmm, pe3t_f )
!!--------------------------------------------------------------------
!! *** ROUTINE isf_dynatf ***
!!
!! ** Purpose : compute the ice shelf volume filter correction for cavity, param, ice sheet coupling case
!!
!!-------------------------- OUT -------------------------------------
- INTEGER , INTENT(in ) :: kt ! ocean time step
- INTEGER , INTENT(in ) :: Kmm ! ocean time level index
- REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pe3t_f ! time filtered scale factor to be corrected
- !
- REAL(wp) , INTENT(in ) :: pcoef ! rn_atfp * rn_Dt * r1_rho0
+ INTEGER , INTENT(in ) :: kt ! ocean time step
+ INTEGER , INTENT(in ) :: Kmm ! ocean time level index
+ REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pe3t_f ! time filtered scale factor to be corrected
!!--------------------------------------------------------------------
- INTEGER :: jk ! loop index
+ INTEGER :: ji, jj, jk ! loop index
+ REAL(wp) :: ztmp
!!--------------------------------------------------------------------
!
! ice shelf cavity
- IF ( ln_isfcav_mlt ) CALL isf_dynatf_mlt(Kmm, pe3t_f, misfkt_cav, misfkb_cav, rhisf_tbl_cav, rfrac_tbl_cav, fwfisf_cav, fwfisf_cav_b, pcoef)
+ IF( ln_isfcav_mlt ) THEN
+ DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ ztmp = rn_atfp * rn_Dt * ( fwfisf_cav_b(ji,jj) - fwfisf_cav(ji,jj) ) / ( ht(ji,jj,Kmm) + 1._wp - ssmask(ji,jj) ) * r1_rho0
+ !
+ DO jk = 1, jpkm1
+ pe3t_f(ji,jj,jk) = pe3t_f(ji,jj,jk) + tmask(ji,jj,jk) * ztmp * e3t(ji,jj,jk,Kmm)
+ END DO
+ END_2D
+ ENDIF
!
! ice shelf parametrised
- IF ( ln_isfpar_mlt ) CALL isf_dynatf_mlt(Kmm, pe3t_f, misfkt_par, misfkb_par, rhisf_tbl_par, rfrac_tbl_par, fwfisf_par, fwfisf_par_b, pcoef)
+ IF( ln_isfpar_mlt ) THEN
+ DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ ztmp = rn_atfp * rn_Dt * ( fwfisf_par_b(ji,jj) - fwfisf_par(ji,jj) ) / ( ht(ji,jj,Kmm) + 1._wp - ssmask(ji,jj) ) * r1_rho0
+ !
+ DO jk = 1, jpkm1
+ pe3t_f(ji,jj,jk) = pe3t_f(ji,jj,jk) + tmask(ji,jj,jk) * ztmp * e3t(ji,jj,jk,Kmm)
+ END DO
+ END_2D
+ ENDIF
!
- IF ( ln_isfcpl .AND. ln_rstart .AND. kt == nit000+1 ) THEN
- DO jk = 1, jpkm1
- pe3t_f(:,:,jk) = pe3t_f(:,:,jk) - pcoef * risfcpl_vol(:,:,jk) * r1_e1e2t(:,:)
- END DO
+ ! if coupled
+ IF( ln_isfcpl .AND. ln_rstart .AND. kt == nit000+1 ) THEN
+ DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 )
+ pe3t_f(ji,jj,jk) = pe3t_f(ji,jj,jk) - rn_atfp * rn_Dt * risfcpl_vol(ji,jj,jk) * r1_e1e2t(ji,jj)
+ END_3D
END IF
!
END SUBROUTINE isf_dynatf
- SUBROUTINE isf_dynatf_mlt ( Kmm, pe3t_f, ktop, kbot, phtbl, pfrac, pfwf, pfwf_b, pcoef )
- !!--------------------------------------------------------------------
- !! *** ROUTINE isf_dynatf_mlt ***
- !!
- !! ** Purpose : compute the ice shelf volume filter correction for cavity or param
- !!
- !!-------------------------- IN -------------------------------------
- INTEGER , INTENT(in ) :: Kmm ! ocean time level index
- REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pe3t_f ! time-filtered scale factor to be corrected
- INTEGER , DIMENSION(jpi,jpj) , INTENT(in ) :: ktop , kbot ! top and bottom level of tbl
- REAL(wp), DIMENSION(jpi,jpj) , INTENT(in ) :: pfrac, phtbl ! fraction of bottom cell included in tbl, tbl thickness
- REAL(wp), DIMENSION(jpi,jpj) , INTENT(in ) :: pfwf , pfwf_b ! now/before fwf
- REAL(wp), INTENT(in ) :: pcoef ! rn_atfp * rn_Dt * r1_rho0
- !!----------------------------------------------------------------------
- INTEGER :: ji,jj,jk
- REAL(wp), DIMENSION(jpi,jpj) :: zfwfinc
- !!----------------------------------------------------------------------
- !
- ! compute fwf conservation correction
- zfwfinc(:,:) = pcoef * ( pfwf_b(:,:) - pfwf(:,:) ) / ( ht(:,:) + 1._wp - ssmask(:,:) ) * r1_rho0
- !
- ! add the increment
- DO jk = 1, jpkm1
- pe3t_f(:,:,jk) = pe3t_f(:,:,jk) + tmask(:,:,jk) * zfwfinc(:,:) &
- & * e3t(:,:,jk,Kmm)
- END DO
- !
- END SUBROUTINE isf_dynatf_mlt
-
END MODULE isfdynatf
diff --git a/src/OCE/ISF/isfhdiv.F90 b/src/OCE/ISF/isfhdiv.F90
index 58275063b8743b75dd3c88f9a8ad348c8304c0a3..5e5807e2c3aa81c1fd87f98f8d580c2c1b2f2cf5 100644
--- a/src/OCE/ISF/isfhdiv.F90
+++ b/src/OCE/ISF/isfhdiv.F90
@@ -15,6 +15,7 @@ MODULE isfhdiv
USE isf_oce ! ice shelf
+ USE par_oce ! ocean space and time domain
USE dom_oce ! time and space domain
USE phycst , ONLY: r1_rho0 ! physical constant
USE in_out_manager !
@@ -24,10 +25,10 @@ MODULE isfhdiv
PRIVATE
PUBLIC isf_hdiv
+
!! * Substitutions
# include "do_loop_substitute.h90"
# include "domzgr_substitute.h90"
-
CONTAINS
SUBROUTINE isf_hdiv( kt, Kmm, phdiv )
@@ -39,25 +40,29 @@ CONTAINS
!! increment)
!!
!!----------------------------------------------------------------------
+ INTEGER, INTENT(in) :: kt
+ INTEGER, INTENT(in) :: Kmm ! ocean time level index
REAL(wp), DIMENSION(:,:,:), INTENT( inout ) :: phdiv ! horizontal divergence
!!----------------------------------------------------------------------
- INTEGER, INTENT(in) :: kt
- INTEGER, INTENT(in) :: Kmm ! ocean time level index
!
IF ( ln_isf ) THEN
!
#if defined key_RK3
! ice shelf cavity contribution (RK3)
- IF ( ln_isfcav_mlt ) CALL isf_hdiv_mlt(misfkt_cav, misfkb_cav, rhisf_tbl_cav, rfrac_tbl_cav, fwfisf_cav, phdiv)
+ IF ( ln_isfcav_mlt ) CALL isf_hdiv_mlt(misfkt_cav, misfkb_cav, rhisf_tbl_cav, rfrac_tbl_cav, &
+ & fwfisf_cav, phdiv)
!
! ice shelf parametrisation contribution (RK3)
- IF ( ln_isfpar_mlt ) CALL isf_hdiv_mlt(misfkt_par, misfkb_par, rhisf_tbl_par, rfrac_tbl_par, fwfisf_par, phdiv)
+ IF ( ln_isfpar_mlt ) CALL isf_hdiv_mlt(misfkt_par, misfkb_par, rhisf_tbl_par, rfrac_tbl_par, &
+ fwfisf_par, phdiv)
#else
! ice shelf cavity contribution (MLF)
- IF ( ln_isfcav_mlt ) CALL isf_hdiv_mlt(misfkt_cav, misfkb_cav, rhisf_tbl_cav, rfrac_tbl_cav, fwfisf_cav, phdiv, fwfisf_cav_b)
+ IF ( ln_isfcav_mlt ) CALL isf_hdiv_mlt(misfkt_cav, misfkb_cav, rhisf_tbl_cav, rfrac_tbl_cav, &
+ & fwfisf_cav, phdiv, fwfisf_cav_b)
!
! ice shelf parametrisation contribution (MLF)
- IF ( ln_isfpar_mlt ) CALL isf_hdiv_mlt(misfkt_par, misfkb_par, rhisf_tbl_par, rfrac_tbl_par, fwfisf_par, phdiv, fwfisf_par_b)
+ IF ( ln_isfpar_mlt ) CALL isf_hdiv_mlt(misfkt_par, misfkb_par, rhisf_tbl_par, rfrac_tbl_par, &
+ fwfisf_par, phdiv, fwfisf_par_b)
#endif
!
! ice sheet coupling contribution
@@ -81,7 +86,7 @@ CONTAINS
END SUBROUTINE isf_hdiv
- SUBROUTINE isf_hdiv_mlt(ktop, kbot, phtbl, pfrac, pfwf, phdiv, pfwf_b)
+ SUBROUTINE isf_hdiv_mlt( ktop, kbot, phtbl, pfrac, pfwf, phdiv, pfwf_b )
!!----------------------------------------------------------------------
!! *** SUBROUTINE sbc_isf_div ***
!!
@@ -92,45 +97,42 @@ CONTAINS
!!
!! ** Action : phdivn increased by the ice shelf outflow
!!----------------------------------------------------------------------
- REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT(inout) :: phdiv
- !!----------------------------------------------------------------------
- INTEGER , DIMENSION(jpi,jpj) , INTENT(in ) :: ktop , kbot
- REAL(wp), DIMENSION(jpi,jpj) , INTENT(in ) :: pfrac, phtbl
- REAL(wp), DIMENSION(jpi,jpj) , INTENT(in ) :: pfwf
- REAL(wp), DIMENSION(:,:) , OPTIONAL, INTENT(in ) :: pfwf_b
+ INTEGER , DIMENSION(A2D(0)) , INTENT(in ) :: ktop , kbot
+ REAL(wp), DIMENSION(A2D(0)) , INTENT(in ) :: pfrac, phtbl
+ REAL(wp), DIMENSION(jpi,jpj) , INTENT(in ) :: pfwf
+ REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT(inout) :: phdiv
+ REAL(wp), DIMENSION(:,:) , OPTIONAL, INTENT(in ) :: pfwf_b
!!----------------------------------------------------------------------
INTEGER :: ji, jj, jk ! dummy loop indices
INTEGER :: ikt, ikb
- REAL(wp), DIMENSION(A2D(nn_hls)) :: zhdiv
+ REAL(wp) :: zhdiv
!!----------------------------------------------------------------------
!
!== fwf distributed over several levels ==!
!
- ! compute integrated divergence correction
- DO_2D( nn_hls-1, nn_hls, nn_hls-1, nn_hls )
+ ! update divergence at each level affected by ice shelf top boundary layer
+ DO_2D( 0, 0, 0, 0 )
+ ! compute integrated divergence correction
#if defined key_RK3
- zhdiv(ji,jj) = pfwf(ji,jj) * r1_rho0 / phtbl(ji,jj)
+ zhdiv = pfwf(ji,jj) * r1_rho0 / phtbl(ji,jj)
#else
- zhdiv(ji,jj) = 0.5_wp * ( pfwf(ji,jj) + pfwf_b(ji,jj) ) * r1_rho0 / phtbl(ji,jj)
+ zhdiv = 0.5_wp * ( pfwf(ji,jj) + pfwf_b(ji,jj) ) * r1_rho0 / phtbl(ji,jj)
#endif
- END_2D
- !
- ! update divergence at each level affected by ice shelf top boundary layer
- DO_2D_OVR( nn_hls-1, nn_hls, nn_hls-1, nn_hls )
+ !
ikt = ktop(ji,jj)
ikb = kbot(ji,jj)
! level fully include in the ice shelf boundary layer
DO jk = ikt, ikb - 1
- phdiv(ji,jj,jk) = phdiv(ji,jj,jk) - zhdiv(ji,jj)
+ phdiv(ji,jj,jk) = phdiv(ji,jj,jk) - zhdiv
END DO
! level partially include in ice shelf boundary layer
- phdiv(ji,jj,ikb) = phdiv(ji,jj,ikb) - zhdiv(ji,jj) * pfrac(ji,jj)
+ phdiv(ji,jj,ikb) = phdiv(ji,jj,ikb) - zhdiv * pfrac(ji,jj)
END_2D
!
END SUBROUTINE isf_hdiv_mlt
- SUBROUTINE isf_hdiv_cpl(Kmm, pqvol, phdiv)
+ SUBROUTINE isf_hdiv_cpl( Kmm, pqvol, phdiv )
!!----------------------------------------------------------------------
!! *** SUBROUTINE isf_hdiv_cpl ***
!!
@@ -143,17 +145,15 @@ CONTAINS
!! ** Action : phdivn increased by the ice shelf outflow
!!
!!----------------------------------------------------------------------
- REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: phdiv
- !!----------------------------------------------------------------------
- INTEGER, INTENT(in) :: Kmm ! ocean time level index
- REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in ) :: pqvol
+ INTEGER, INTENT(in) :: Kmm ! ocean time level index
+ REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in ) :: pqvol
+ REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: phdiv
!!----------------------------------------------------------------------
- INTEGER :: ji, jj, jk
+ INTEGER :: ji, jj, jk
!!----------------------------------------------------------------------
!
- DO_3D_OVR( nn_hls-1, nn_hls, nn_hls-1, nn_hls, 1, jpk )
- phdiv(ji,jj,jk) = phdiv(ji,jj,jk) + pqvol(ji,jj,jk) * r1_e1e2t(ji,jj) &
- & / e3t(ji,jj,jk,Kmm)
+ DO_3D( 0, 0, 0, 0, 1, jpk )
+ phdiv(ji,jj,jk) = phdiv(ji,jj,jk) + pqvol(ji,jj,jk) * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm)
END_3D
!
END SUBROUTINE isf_hdiv_cpl
diff --git a/src/OCE/ISF/isfload.F90 b/src/OCE/ISF/isfload.F90
index a069cdf5d126bb61db99c67ae358bca283062d9e..d9a0d6e6b05302210ee5318b719811b7f0c9c3d1 100644
--- a/src/OCE/ISF/isfload.F90
+++ b/src/OCE/ISF/isfload.F90
@@ -12,6 +12,7 @@ MODULE isfload
USE isf_oce, ONLY: cn_isfload, rn_isfload_T, rn_isfload_S ! ice shelf variables
+ USE par_oce ! ocean space and time domain
USE dom_oce ! vertical scale factor
USE eosbn2 , ONLY: eos ! eos routine
@@ -76,19 +77,18 @@ CONTAINS
INTEGER :: ji, jj, jk
INTEGER :: ikt
REAL(wp), DIMENSION(jpi,jpj) :: zrhdtop_isf ! water density displaced by the ice shelf (at the interface)
- REAL(wp), DIMENSION(jpi,jpj,jpts) :: zts_top ! water properties displaced by the ice shelf
+ REAL(wp), DIMENSION(jpi,jpj,jpts) :: zts_top ! water properties displaced by the ice shelf
+ REAL(wp), DIMENSION(jpi,jpj) :: zdept ! depth at T-level
REAL(wp), DIMENSION(jpi,jpj,jpk) :: zrhd ! water density displaced by the ice shelf
!!----------------------------------------------------------------------
!
! !- assume water displaced by the ice shelf is at T=rn_isfload_T and S=rn_isfload_S (rude)
- zts_top(:,:,jp_tem) = rn_isfload_T ; zts_top(:,:,jp_sal) = rn_isfload_S
+ zts_top(:,:,jp_tem) = rn_isfload_T
+ zts_top(:,:,jp_sal) = rn_isfload_S
!
DO jk = 1, jpk !- compute density of the water displaced by the ice shelf
-#if defined key_qco && key_isf
- CALL eos( zts_top(:,:,:), gdept_0(:,:,jk), zrhd(:,:,jk) )
-#else
- CALL eos( zts_top(:,:,:), gdept(:,:,jk,Kmm), zrhd(:,:,jk) )
-#endif
+ zdept(:,:) = gdept_0(:,:,jk)
+ CALL eos( zts_top(:,:,:), zdept(:,:), zrhd(:,:,jk) )
END DO
!
! !- compute rhd at the ice/oce interface (ice shelf side)
@@ -101,29 +101,16 @@ CONTAINS
!
IF ( ikt > 1 ) THEN
! ! top layer of the ice shelf
-#if defined key_qco && key_isf
pload(ji,jj) = pload(ji,jj) + zrhd(ji,jj,1) * e3w_0(ji,jj,1)
!
- DO jk = 2, ikt-1 ! core layers of the ice shelf
+ DO jk = 2, ikt-1 ! core layers of the ice shelf (!!st half sum of rhd 1/2 applied in hpg)
pload(ji,jj) = pload(ji,jj) + (zrhd(ji,jj,jk-1) + zrhd(ji,jj,jk)) * e3w_0(ji,jj,jk)
- END DO
+ END DO
! ! deepest part of the ice shelf (between deepest T point and ice/ocean interface
pload(ji,jj) = pload(ji,jj) + ( zrhdtop_isf(ji,jj) + zrhd(ji,jj,ikt-1) ) &
& * ( risfdep(ji,jj) - gdept_0(ji,jj,ikt-1) )
-#else
- pload(ji,jj) = pload(ji,jj) &
- & + zrhd (ji,jj,1) * e3w(ji,jj,1,Kmm)
- !
- DO jk = 2, ikt-1 ! core layers of the ice shelf
- pload(ji,jj) = pload(ji,jj) + (zrhd(ji,jj,jk-1) + zrhd(ji,jj,jk)) &
- & * e3w(ji,jj,jk,Kmm)
- END DO
- ! ! deepest part of the ice shelf (between deepest T point and ice/ocean interface
- pload(ji,jj) = pload(ji,jj) + ( zrhdtop_isf(ji,jj) + zrhd(ji,jj,ikt-1) ) &
- & * ( risfdep(ji,jj) - gdept(ji,jj,ikt-1,Kmm) )
-#endif
!
- END IF
+ ENDIF
END_2D
!
END SUBROUTINE isf_load_uniform
diff --git a/src/OCE/ISF/isfpar.F90 b/src/OCE/ISF/isfpar.F90
index 31f36368762f0646fae4f86c8d75a8a02449c917..06096122df82591e56118e2950a845561c66b7c1 100644
--- a/src/OCE/ISF/isfpar.F90
+++ b/src/OCE/ISF/isfpar.F90
@@ -16,15 +16,17 @@ MODULE isfpar
!!----------------------------------------------------------------------
USE isf_oce ! ice shelf
!
- USE isfrst , ONLY: isfrst_write, isfrst_read ! ice shelf restart read/write subroutine
- USE isftbl , ONLY: isf_tbl_ktop, isf_tbl_lvl ! ice shelf top boundary layer properties subroutine
+ USE isfrst , ONLY: isfrst_read ! ice shelf restart read/write subroutine
+ USE isftbl ! ice shelf top boundary layer properties subroutine
USE isfparmlt, ONLY: isfpar_mlt ! ice shelf melt formulation subroutine
USE isfdiags , ONLY: isf_diags_flx ! ice shelf diags subroutine
USE isfutils , ONLY: debug, read_2dcstdta ! ice shelf debug subroutine
!
- USE dom_oce , ONLY: bathy ! ocean space and time domain
- USE par_oce , ONLY: jpi,jpj ! ocean space and time domain
- USE phycst , ONLY: r1_rho0_rcp ! physical constants
+ USE oce , ONLY: ts ! ocean dynamics and tracers
+ USE dom_oce ! ocean space and time domain
+ USE par_oce ! ocean space and time domain
+ USE phycst ! physical constants
+ USE eosbn2 , ONLY: eos_fzp ! equation of state
!
USE in_out_manager ! I/O manager
USE iom ! I/O library
@@ -37,6 +39,7 @@ MODULE isfpar
!! * Substitutions
# include "do_loop_substitute.h90"
+# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
!! $Id: sbcisf.F90 10536 2019-01-16 19:21:09Z mathiot $
@@ -44,7 +47,7 @@ MODULE isfpar
!!----------------------------------------------------------------------
CONTAINS
- SUBROUTINE isf_par( kt, Kmm, ptsc, pqfwf )
+ SUBROUTINE isf_par( kt, Kmm, ptsc, pfwf )
!!---------------------------------------------------------------------
!! *** ROUTINE isf_par ***
!!
@@ -60,50 +63,64 @@ CONTAINS
!! ** Convention : all fluxes are from isf to oce
!!
!!---------------------------------------------------------------------
- !!-------------------------- OUT --------------------------------------
- REAL(wp), DIMENSION(jpi,jpj) , INTENT(inout) :: pqfwf
- REAL(wp), DIMENSION(jpi,jpj,jpts), INTENT(inout) :: ptsc
- !!-------------------------- IN --------------------------------------
INTEGER, INTENT(in) :: kt ! ocean time step
INTEGER, INTENT(in) :: Kmm ! ocean time level index
- !!---------------------------------------------------------------------
- INTEGER :: ji, jj
- REAL(wp), DIMENSION(jpi,jpj) :: zqoce, zqhc, zqlat, zqh
+ REAL(wp), DIMENSION(A2D(0)) , INTENT(inout) :: pfwf
+ REAL(wp), DIMENSION(A2D(0),jpts), INTENT(inout) :: ptsc
+ !!
+ INTEGER :: ji, jj, jk
+ REAL(wp), DIMENSION(A2D(0)) :: ztfrz, ztavg ! tbl freezing and averaged temperatures
+ REAL(wp), DIMENSION(A2D(0)) :: zqoce, zqhc, zqlat
+ REAL(wp), DIMENSION(A2D(0),jpk) :: ztfrz3d, ztmp
!!---------------------------------------------------------------------
!
+ ! Mean freezing point
+ CALL eos_fzp( ts, Kmm, ztfrz3d, 0 )
+!!st DO_3D( 0 ,0, 0, 0, 1, jpk )
+!!st ztmp(ji,jj,jk) = gdept(ji,jj,jk,Kmm)
+!!st END_3D
+!!st CALL eos_fzp( ts(A2D(0),:,jp_sal,Kmm), ztfrz3d(:,:,:), ztmp )
+ !
+ DO_3D( 0 ,0, 0, 0, 1, jpk )
+ ztmp(ji,jj,jk) = e3t (ji,jj,jk,Kmm)
+ END_3D
+ CALL isf_tbl_avg( misfkt_par, misfkb_par, rhisf_tbl_par, rfrac_tbl_par, ztmp, ztfrz3d, & ! <<== in
+ & ztfrz ) ! ==>> out
+
+ ! Mean temperature (only for bg03)
+ CALL isf_tbl_avg( misfkt_par, misfkb_par, rhisf_tbl_par, rfrac_tbl_par, ztmp, ts(A2D(0),:,jp_tem,Kmm), & ! <<== in
+ & ztavg ) ! ==>> out
+
! compute heat content, latent heat and melt fluxes (2d)
- CALL isfpar_mlt( kt, Kmm, zqhc, zqoce, pqfwf )
+ CALL isfpar_mlt( kt, Kmm, ztfrz, ztavg, zqhc, zqoce, pfwf )
!
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
- ! compute heat and water flux (from isf to oce)
- pqfwf(ji,jj) = pqfwf(ji,jj) * mskisf_par(ji,jj)
- zqoce(ji,jj) = zqoce(ji,jj) * mskisf_par(ji,jj)
- zqhc (ji,jj) = zqhc(ji,jj) * mskisf_par(ji,jj)
- !
+ DO_2D( 0, 0, 0, 0 )
! compute latent heat flux (from isf to oce)
- zqlat(ji,jj) = - pqfwf(ji,jj) * rLfusisf ! 2d latent heat flux (W/m2)
- !
- ! total heat flux (from isf to oce)
- zqh(ji,jj) = ( zqhc (ji,jj) + zqoce(ji,jj) )
+ zqlat(ji,jj) = - pfwf(ji,jj) * rLfusisf ! 2d latent heat flux (W/m2)
!
! set temperature content
- ptsc(ji,jj,jp_tem) = zqh(ji,jj) * r1_rho0_rcp
+ ptsc(ji,jj,jp_tem) = ( zqhc (ji,jj) + zqoce(ji,jj) ) * r1_rho0_rcp
END_2D
!
! output fluxes
- CALL isf_diags_flx( Kmm, misfkt_par, misfkb_par, rhisf_tbl_par, rfrac_tbl_par, 'par', pqfwf, zqoce, zqlat, zqhc)
+ CALL isf_diags_flx( Kmm, misfkt_par, misfkb_par, rhisf_tbl_par, rfrac_tbl_par, 'par', pfwf, zqoce, zqlat, zqhc )
!
-#if ! defined key_RK3
- ! MLF: write restart variables (qoceisf, qhcisf, fwfisf for now and before)
- IF (lrst_oce) CALL isfrst_write(kt, 'par', ptsc, pqfwf)
+ ! outputs
+ CALL iom_put('isftfrz_par', ztfrz(:,:) * mskisf_par(:,:) ) ! freezing temperature
+ IF( cn_isfpar_mlt == 'bg03' ) THEN
+ CALL iom_put('ttbl_par', ztavg(:,:) * mskisf_par(:,:) ) ! ttbl
+ CALL iom_put('isfthermald_par',( ztavg(:,:) - ztfrz(:,:) ) * mskisf_par(:,:) ) ! thermal driving
+ ENDIF
!
-#endif
+ ! debugs
IF ( ln_isfdebug ) THEN
IF(lwp) WRITE(numout,*)
- CALL debug('isf_par: ptsc T',ptsc(:,:,1))
- CALL debug('isf_par: ptsc S',ptsc(:,:,2))
- CALL debug('isf_par: pqfwf fwf',pqfwf(:,:))
- IF(lwp) WRITE(numout,*)
+ CALL debug('isf_par: ptsc T', ptsc (:,:,1))
+ CALL debug('isf_par: ptsc S', ptsc (:,:,2))
+ CALL debug( 'isfpar: qhc ', zqhc (:,:) )
+ CALL debug( 'isfpar: qoce ', zqoce(:,:) )
+ CALL debug( 'isfpar: fwf ', pfwf (:,:) )
+ IF(lwp) WRITE(numout,*) ''
END IF
!
END SUBROUTINE isf_par
@@ -115,36 +132,43 @@ CONTAINS
!! ** Purpose : initialisation of the variable needed for the parametrisation of ice shelf melt
!!
!!----------------------------------------------------------------------
- INTEGER :: ierr
- REAL(wp), DIMENSION(jpi,jpj) :: ztblmax, ztblmin
+ INTEGER :: ierr
+ INTEGER :: ji, jj ! dummy loop indices
+ REAL(wp), DIMENSION(A2D(0)) :: ztblmax, ztblmin
!!----------------------------------------------------------------------
!
- ! allocation
+ !==============
+ ! 0: allocation
+ !==============
CALL isf_alloc_par()
!
- ! initialisation
- misfkt_par(:,:) = 1 ; misfkb_par(:,:) = 1
- rhisf_tbl_par(:,:) = 1e-20 ; rfrac_tbl_par(:,:) = 0.0_wp
+ !==================
+ ! 1: initialisation
+ !==================
+ DO_2D( 0, 0, 0, 0 )
+ misfkt_par (ji,jj) = 1
+ misfkb_par (ji,jj) = 1
+ rhisf_tbl_par(ji,jj) = 1e-20
+ rfrac_tbl_par(ji,jj) = 0.0_wp
+ END_2D
!
! define isf tbl tickness, top and bottom indice
- CALL read_2dcstdta(TRIM(sn_isfpar_zmax%clname), TRIM(sn_isfpar_zmax%clvar), ztblmax)
- CALL read_2dcstdta(TRIM(sn_isfpar_zmin%clname), TRIM(sn_isfpar_zmin%clvar), ztblmin)
- !
- ! mask ice shelf parametrisation location
- ztblmax(:,:) = ztblmax(:,:) * ssmask(:,:)
- ztblmin(:,:) = ztblmin(:,:) * ssmask(:,:)
- !
- ! if param used under an ice shelf overwrite ztblmin by the ice shelf draft
- WHERE ( risfdep > 0._wp .AND. ztblmin > 0._wp )
- ztblmin(:,:) = risfdep(:,:)
- END WHERE
+ CALL read_2dcstdta( TRIM(sn_isfpar_zmax%clname), TRIM(sn_isfpar_zmax%clvar), ztblmax )
+ CALL read_2dcstdta( TRIM(sn_isfpar_zmin%clname), TRIM(sn_isfpar_zmin%clvar), ztblmin )
!
- ! ensure ztblmax <= bathy
- WHERE ( ztblmax(:,:) > bathy(:,:) )
- ztblmax(:,:) = bathy(:,:)
- END WHERE
+ DO_2D( 0, 0, 0, 0 )
+ ! mask ice shelf parametrisation location
+ ztblmax(ji,jj) = ztblmax(ji,jj) * ssmask(ji,jj)
+ ztblmin(ji,jj) = ztblmin(ji,jj) * ssmask(ji,jj)
+ !
+ ! if param used under an ice shelf overwrite ztblmin by the ice shelf draft
+ IF( risfdep(ji,jj) > 0._wp .AND. ztblmin(ji,jj) > 0._wp ) ztblmin(ji,jj) = risfdep(ji,jj)
+ !
+ ! ensure ztblmax <= bathy
+ ztblmax(ji,jj) = MIN( ztblmax(ji,jj), bathy(ji,jj) )
+ END_2D
!
- ! compute ktop and update ztblmin to gdepw_0(misfkt_par)
+ ! compute ktop and update ztblmin to gdepw_0 at misfkt_par
CALL isf_tbl_ktop(ztblmin, misfkt_par) ! out: misfkt_par
! ! inout: ztblmin
!
@@ -158,16 +182,22 @@ CONTAINS
END WHERE
!
#if ! defined key_RK3
+ !================
+ ! 2: read restart
+ !================
! MLF: read par variable from restart
- IF ( ln_rstart ) CALL isfrst_read('par', risf_par_tsc, fwfisf_par, risf_par_tsc_b, fwfisf_par_b)
+ IF ( ln_rstart ) CALL isfrst_read( 'par', risf_par_tsc, fwfisf_par, risf_par_tsc_b, fwfisf_par_b )
#endif
!
+ !==========================================
+ ! 3: specific allocation and initialisation (depending of scheme choice)
+ !==========================================
SELECT CASE ( TRIM(cn_isfpar_mlt) )
!
CASE ( 'spe' )
!
ALLOCATE( sf_isfpar_fwf(1), STAT=ierr )
- ALLOCATE( sf_isfpar_fwf(1)%fnow(jpi,jpj,1), sf_isfpar_fwf(1)%fdta(jpi,jpj,1,2) )
+ ALLOCATE( sf_isfpar_fwf(1)%fnow(A2D(0),1), sf_isfpar_fwf(1)%fdta(A2D(0),1,2) )
CALL fld_fill( sf_isfpar_fwf, (/ sn_isfpar_fwf /), cn_isfdir, 'isf_par_init', 'read fresh water flux isf data', 'namisf' )
!
IF(lwp) WRITE(numout,*)
@@ -185,7 +215,7 @@ CONTAINS
CASE ( 'oasis' )
!
ALLOCATE( sf_isfpar_fwf(1), STAT=ierr )
- ALLOCATE( sf_isfpar_fwf(1)%fnow(jpi,jpj,1), sf_isfpar_fwf(1)%fdta(jpi,jpj,1,2) )
+ ALLOCATE( sf_isfpar_fwf(1)%fnow(A2D(0),1), sf_isfpar_fwf(1)%fdta(A2D(0),1,2) )
CALL fld_fill( sf_isfpar_fwf, (/ sn_isfpar_fwf /), cn_isfdir, 'isf_par_init', 'read fresh water flux isf data', 'namisf' )
!
IF(lwp) WRITE(numout,*)
diff --git a/src/OCE/ISF/isfparmlt.F90 b/src/OCE/ISF/isfparmlt.F90
index 237e3bee3b9cf5ad4c03b0f10c48be235440d9ae..a4c63aadd48a88654380da2f3784920ce4dd974c 100644
--- a/src/OCE/ISF/isfparmlt.F90
+++ b/src/OCE/ISF/isfparmlt.F90
@@ -8,19 +8,17 @@ MODULE isfparmlt
!!----------------------------------------------------------------------
USE isf_oce ! ice shelf
- USE isftbl , ONLY: isf_tbl ! ice shelf depth average
- USE isfutils,ONLY: debug ! debug subroutine
+ USE isftbl ! ice shelf depth average
+ USE par_oce ! ocean space and time domain
USE dom_oce ! ocean space and time domain
USE oce , ONLY: ts ! ocean dynamics and tracers
USE phycst , ONLY: rcp, rho0 ! physical constants
- USE eosbn2 , ONLY: eos_fzp ! equation of state
USE in_out_manager ! I/O manager
- USE iom , ONLY: iom_put ! I/O library
USE fldread , ONLY: fld_read, FLD, FLD_N !
- USE lib_fortran, ONLY: glob_sum !
- USE lib_mpp , ONLY: ctl_stop !
+ USE lib_fortran, ONLY: glob_sum_vec
+ USE lib_mpp , ONLY: ctl_stop
IMPLICIT NONE
@@ -28,9 +26,9 @@ MODULE isfparmlt
PUBLIC isfpar_mlt
-
!! * Substitutions
# include "domzgr_substitute.h90"
+# include "do_loop_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
!! $Id: sbcisf.F90 10536 2019-01-16 19:21:09Z mathiot $
@@ -38,11 +36,8 @@ MODULE isfparmlt
!!----------------------------------------------------------------------
CONTAINS
-! -------------------------------------------------------------------------------------------------------
-! -------------------------------- PUBLIC SUBROUTINE ----------------------------------------------------
-! -------------------------------------------------------------------------------------------------------
- SUBROUTINE isfpar_mlt( kt, Kmm, pqhc, pqoce, pqfwf )
+ SUBROUTINE isfpar_mlt( kt, Kmm, ptfrz, ptavg, pqhc, pqoce, pfwf )
!!---------------------------------------------------------------------
!! *** ROUTINE isfpar_mlt ***
!!
@@ -53,76 +48,63 @@ CONTAINS
!! 1 : Specified melt flux
!! 2 : Beckmann & Goose parameterization
!!
- !!-------------------------- OUT -------------------------------------
- REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pqfwf, pqoce, pqhc ! fresh water, ice-ocean heat and heat content fluxes
- !!-------------------------- IN -------------------------------------
+ !!---------------------------------------------------------------------
INTEGER, INTENT(in) :: kt ! ocean time step
INTEGER, INTENT(in) :: Kmm ! ocean time level index
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in ) :: ptfrz, ptavg ! tbl freezing and averaged temperatures
+ REAL(wp), DIMENSION(A2D(0)), INTENT(inout) :: pfwf, pqoce, pqhc ! fresh water, ice-ocean heat and heat content fluxes
!!---------------------------------------------------------------------
!
! Choose among the available ice shelf parametrisation
SELECT CASE ( cn_isfpar_mlt )
CASE ( 'spe' ) ! specified runoff in depth (Mathiot et al., 2017 in preparation)
- CALL isfpar_mlt_spe(kt, Kmm, pqhc, pqoce, pqfwf)
+ !
+ CALL isfpar_mlt_spe( kt, Kmm, ptfrz, pqhc, pqoce, pfwf )
+ !
CASE ( 'bg03' ) ! Beckmann and Goosse parametrisation
- CALL isfpar_mlt_bg03(kt, Kmm, pqhc, pqoce, pqfwf)
+ !
+ CALL isfpar_mlt_bg03( kt, Kmm, ptfrz, ptavg, pqhc, pqoce, pfwf )
+ !
CASE ( 'oasis' )
- CALL isfpar_mlt_oasis( kt, Kmm, pqhc, pqoce, pqfwf)
+ !
+ CALL isfpar_mlt_oasis( kt, Kmm, ptfrz, pqhc, pqoce, pfwf )
+ !
CASE DEFAULT
CALL ctl_stop('STOP', 'unknown isf melt formulation : cn_isfpar (should not see this)')
END SELECT
!
- IF (ln_isfdebug) THEN
- IF(lwp) WRITE(numout,*) ''
- CALL debug( 'isfpar_mlt qhc :', pqhc (:,:) )
- CALL debug( 'isfpar_mlt qoce :', pqoce(:,:) )
- CALL debug( 'isfpar_mlt qfwf :', pqfwf(:,:) )
- IF(lwp) WRITE(numout,*) ''
- END IF
- !
END SUBROUTINE isfpar_mlt
-! -------------------------------------------------------------------------------------------------------
-! -------------------------------- PRIVATE SUBROUTINE ---------------------------------------------------
-! -------------------------------------------------------------------------------------------------------
- SUBROUTINE isfpar_mlt_spe(kt, Kmm, pqhc, pqoce, pqfwf)
+ SUBROUTINE isfpar_mlt_spe( kt, Kmm, ptfrz, pqhc, pqoce, pfwf )
!!---------------------------------------------------------------------
!! *** ROUTINE isfpar_mlt_spe ***
!!
!! ** Purpose : prescribed ice shelf melting in case ice shelf cavities are closed.
!! data read into a forcing files.
!!
- !!-------------------------- OUT -------------------------------------
- REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pqhc, pqfwf, pqoce ! fresh water and ice-ocean heat fluxes
- !!-------------------------- IN -------------------------------------
- INTEGER, INTENT(in) :: kt
- INTEGER, INTENT(in) :: Kmm ! ocean time level index
!!--------------------------------------------------------------------
- INTEGER :: jk
- REAL(wp), DIMENSION(jpi,jpj,jpk) :: ztfrz3d
- REAL(wp), DIMENSION(jpi,jpj) :: ztfrz
+ INTEGER, INTENT(in) :: kt
+ INTEGER, INTENT(in) :: Kmm ! ocean time level index
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in ) :: ptfrz ! tbl freezing temp
+ REAL(wp), DIMENSION(A2D(0)), INTENT(inout) :: pqhc, pfwf, pqoce ! fresh water and ice-ocean heat fluxes
+ !!
+ INTEGER :: ji, jj ! dummy loop indices
!!--------------------------------------------------------------------
!
- ! 0. ------------Read specified fwf from isf to oce
- CALL fld_read ( kt, 1, sf_isfpar_fwf )
- !
- ! compute ptfrz
- ! 1. ------------Mean freezing point
- DO jk = 1,jpk
- CALL eos_fzp(ts(:,:,jk,jp_sal,Kmm), ztfrz3d(:,:,jk), gdept(:,:,jk,Kmm))
- END DO
- CALL isf_tbl(Kmm, ztfrz3d, ztfrz, 'T', misfkt_par, rhisf_tbl_par, misfkb_par, rfrac_tbl_par )
+ ! Read specified fwf from isf to oce
+ CALL fld_read ( kt, 1, sf_isfpar_fwf )
!
- pqfwf(:,:) = sf_isfpar_fwf(1)%fnow(:,:,1) ! fresh water flux from the isf (fwfisf <0 mean melting) ( > 0 from isf to oce)
- pqoce(:,:) = - pqfwf(:,:) * rLfusisf ! ocean/ice shelf flux assume to be equal to latent heat flux ( > 0 from isf to oce)
- pqhc (:,:) = pqfwf(:,:) * ztfrz(:,:) * rcp ! heat content flux ( > 0 from isf to oce)
+ DO_2D( 0, 0, 0, 0 )
+ pfwf(ji,jj) = sf_isfpar_fwf(1)%fnow(ji,jj,1) * mskisf_par(ji,jj) ! fresh water flux from the isf (fwfisf <0 mean melting) ( > 0 from isf to oce)
+ pqoce(ji,jj) = - pfwf(ji,jj) * rLfusisf * mskisf_par(ji,jj) ! ocean/ice shelf flux assume to be equal to latent heat flux ( > 0 from isf to oce)
+ pqhc (ji,jj) = pfwf(ji,jj) * ptfrz(ji,jj) * rcp * mskisf_par(ji,jj) ! heat content flux ( > 0 from isf to oce)
+ END_2D
!
- CALL iom_put('isftfrz_par', ztfrz(:,:) * mskisf_par(:,:) )
!
END SUBROUTINE isfpar_mlt_spe
- SUBROUTINE isfpar_mlt_bg03(kt, Kmm, pqhc, pqoce, pqfwf)
+ SUBROUTINE isfpar_mlt_bg03( kt, Kmm, ptfrz, ptavg, pqhc, pqoce, pfwf )
!!---------------------------------------------------------------------
!! *** ROUTINE isfpar_mlt_bg03 ***
!!
@@ -137,45 +119,25 @@ CONTAINS
!! ** Reference : Beckmann and Goosse (2003), "A parameterization of ice shelf-ocean
!! interaction for climate models", Ocean Modelling 5(2003) 157-170.
!!----------------------------------------------------------------------
- !!-------------------------- OUT -------------------------------------
- REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pqhc, pqfwf, pqoce ! fresh water and ice-ocean heat fluxes
- !!-------------------------- IN -------------------------------------
- INTEGER, INTENT(in) :: kt
- INTEGER, INTENT(in) :: Kmm ! ocean time level index
- !!--------------------------------------------------------------------
- INTEGER :: jk
- REAL(wp), DIMENSION(jpi,jpj,jpk) :: ztfrz3d ! freezing point
- REAL(wp), DIMENSION(jpi,jpj) :: ztfrz ! freezing point
- REAL(wp), DIMENSION(jpi,jpj) :: ztavg ! temperature avg
+ INTEGER, INTENT(in) :: kt
+ INTEGER, INTENT(in) :: Kmm ! ocean time level index
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in ) :: ptfrz, ptavg ! tbl freezing and averaged temp
+ REAL(wp), DIMENSION(A2D(0)), INTENT(inout) :: pqhc, pfwf, pqoce ! fresh water and ice-ocean heat fluxes
+ !!
+ INTEGER :: ji, jj ! dummy loop indices
!!----------------------------------------------------------------------
!
- ! 0. ------------Mean freezing point
- DO jk = 1,jpk
- CALL eos_fzp(ts(:,:,jk,jp_sal,Kmm), ztfrz3d(:,:,jk), gdept(:,:,jk,Kmm))
- END DO
- CALL isf_tbl(Kmm, ztfrz3d, ztfrz, 'T', misfkt_par, rhisf_tbl_par, misfkb_par, rfrac_tbl_par )
- !
- ! 1. ------------Mean temperature
- CALL isf_tbl(Kmm, ts(:,:,:,jp_tem,Kmm), ztavg, 'T', misfkt_par, rhisf_tbl_par, misfkb_par, rfrac_tbl_par )
- !
- ! 2. ------------Net heat flux and fresh water flux due to the ice shelf
- pqfwf(:,:) = rho0 * rcp * rn_isfpar_bg03_gt0 * risfLeff(:,:) * e1t(:,:) * (ztavg(:,:) - ztfrz(:,:) ) * r1_e1e2t(:,:) / rLfusisf ! ( > 0 from isf to oce)
- pqoce(:,:) = - pqfwf(:,:) * rLfusisf ! ocean/ice shelf flux assume to be equal to latent heat flux ( > 0 from isf to oce)
- pqhc (:,:) = pqfwf(:,:) * ztfrz(:,:) * rcp ! heat content flux ( > 0 from isf to oce)
- !
- ! 3. ------------BG03 output
- ! output ttbl
- CALL iom_put('ttbl_par', ztavg(:,:) * mskisf_par(:,:) )
- !
- ! output thermal driving
- CALL iom_put('isfthermald_par',( ztavg(:,:) - ztfrz(:,:) ) * mskisf_par(:,:))
- !
- ! output freezing point used to define the thermal driving and heat content fluxes
- CALL iom_put('isftfrz_par', ztfrz(:,:) * mskisf_par(:,:) )
+ ! Net heat flux and fresh water flux due to the ice shelf
+ DO_2D( 0, 0, 0, 0 )
+ pfwf (ji,jj) = rho0 * rcp * rn_isfpar_bg03_gt0 * risfLeff(ji,jj) * e1t(ji,jj) * ( ptavg(ji,jj) - ptfrz(ji,jj) ) &
+ & * r1_e1e2t(ji,jj) / rLfusisf * mskisf_par(ji,jj) ! ( > 0 from isf to oce)
+ pqoce(ji,jj) = - pfwf(ji,jj) * rLfusisf * mskisf_par(ji,jj) ! ocean/ice shelf flux assume to be equal to latent heat flux ( > 0 from isf to oce)
+ pqhc (ji,jj) = pfwf(ji,jj) * ptfrz(ji,jj) * rcp * mskisf_par(ji,jj) ! heat content flux ( > 0 from isf to oce)
+ END_2D
!
END SUBROUTINE isfpar_mlt_bg03
- SUBROUTINE isfpar_mlt_oasis(kt, Kmm, pqhc , pqoce, pqfwf )
+ SUBROUTINE isfpar_mlt_oasis( kt, Kmm, ptfrz, pqhc , pqoce, pfwf )
!!----------------------------------------------------------------------
!! *** ROUTINE isfpar_mlt_oasis ***
!!
@@ -186,50 +148,37 @@ CONTAINS
!! - scale fwf and compute heat fluxes
!!
!!---------------------------------------------------------------------
- !!-------------------------- OUT -------------------------------------
- REAL(wp), DIMENSION(jpi,jpj), INTENT( out) :: pqhc, pqoce, pqfwf ! heat content, latent heat and fwf fluxes
- !!-------------------------- IN -------------------------------------
- INTEGER , INTENT(in ) :: kt ! current time step
- INTEGER , INTENT(in ) :: Kmm ! ocean time level index
- !!--------------------------------------------------------------------
- INTEGER :: jk ! loop index
- REAL(wp) :: zfwf_fld, zfwf_oasis ! total fwf in the forcing fields (pattern) and from the cpl interface (amount)
- REAL(wp), DIMENSION(jpi,jpj) :: ztfrz ! tbl freezing temperature
- REAL(wp), DIMENSION(jpi,jpj) :: zfwf ! 2d fwf map after scaling
- REAL(wp), DIMENSION(jpi,jpj,jpk) :: ztfrz3d
+ INTEGER , INTENT(in ) :: kt ! current time step
+ INTEGER , INTENT(in ) :: Kmm ! ocean time level index
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in ) :: ptfrz ! tbl freezing temp
+ REAL(wp), DIMENSION(A2D(0)), INTENT(inout) :: pqhc, pqoce, pfwf ! heat content, latent heat and fwf fluxes
+ !!
+ INTEGER :: ji, jj ! dummy loop indices
+ REAL(wp), DIMENSION(A2D(0),2) :: ztmp
+ REAL(wp), DIMENSION(2) :: zbg
!!--------------------------------------------------------------------
!
- ! 0. ------------Read specified runoff
- CALL fld_read ( kt, 1, sf_isfpar_fwf )
- !
- ! 1. ------------Mean freezing point (needed for heat content flux)
- DO jk = 1,jpk
- CALL eos_fzp(ts(:,:,jk,jp_sal,Kmm), ztfrz3d(:,:,jk), gdept(:,:,jk,Kmm))
- END DO
- CALL isf_tbl(Kmm, ztfrz3d, ztfrz, 'T', misfkt_par, rhisf_tbl_par, misfkb_par, rfrac_tbl_par )
+ ! Read specified fwf from isf to oce
+ CALL fld_read ( kt, 1, sf_isfpar_fwf )
!
- ! 2. ------------Scale isf melt pattern with total amount from oasis
- ! ice shelf 2d map of fwf from isf to oce
- zfwf(:,:) = sf_isfpar_fwf(1)%fnow(:,:,1)
+ DO_2D( 0, 0, 0, 0 )
+ ! ice shelf 2d map
+ pfwf(ji,jj) = sf_isfpar_fwf(1)%fnow(ji,jj,1)
+ ztmp(ji,jj,1) = e1e2t(ji,jj) * pfwf(ji,jj)
+ ztmp(ji,jj,2) = e1e2t(ji,jj) * fwfisf_oasis(ji,jj)
+ END_2D
!
- ! compute glob sum from input file
- ! (PM) should we consider delay sum as in fwb ? (it will offset by 1 time step if I understood well)
- zfwf_fld = glob_sum('isfcav_mlt', e1e2t(:,:) * zfwf(:,:))
+ ! compute glob sum from input file and from atm->oce ice shelf fwf
+ ! (PM) should consider delay sum as in fwb (1 time step offset if I well understood)
+ zbg = glob_sum_vec( 'isfpar_mlt', ztmp )
!
- ! compute glob sum from atm->oce ice shelf fwf
- ! (PM) should we consider delay sum as in fwb ?
- zfwf_oasis = glob_sum('isfcav_mlt', e1e2t(:,:) * fwfisf_oasis(:,:))
- !
- ! scale fwf
- zfwf(:,:) = zfwf(:,:) * zfwf_oasis / zfwf_fld
- !
- ! 3. -----------Define fwf and qoce
+ ! Define fwf and qoce
! ocean heat flux is assume to be equal to the latent heat
- pqfwf(:,:) = zfwf(:,:) ! fwf ( > 0 from isf to oce)
- pqoce(:,:) = - pqfwf(:,:) * rLfusisf ! ocean heat flux ( > 0 from isf to oce) (assumed to be the latent heat flux)
- pqhc (:,:) = pqfwf(:,:) * ztfrz(:,:) * rcp ! heat content flux ( > 0 from isf to oce)
- !
- CALL iom_put('isftfrz_par', ztfrz )
+ DO_2D( 0, 0, 0, 0 )
+ pfwf (ji,jj) = pfwf(ji,jj) * zbg(2) / zbg(1) * mskisf_par(ji,jj) ! scale fwf ( > 0 from isf to oce)
+ pqoce(ji,jj) = - pfwf(ji,jj) * rLfusisf * mskisf_par(ji,jj) ! ocean heat flux ( > 0 from isf to oce) (assumed to be the latent heat flux)
+ pqhc (ji,jj) = pfwf(ji,jj) * ptfrz(ji,jj) * rcp * mskisf_par(ji,jj) ! heat content flux ( > 0 from isf to oce)
+ END_2D
!
END SUBROUTINE isfpar_mlt_oasis
diff --git a/src/OCE/ISF/isfrst.F90 b/src/OCE/ISF/isfrst.F90
index 696605ff15e1bc6d1bf0932ffba5c91fd8b1bc99..a6302a54a33c2a767aa8c25ab8f5aa105e6e5b8e 100644
--- a/src/OCE/ISF/isfrst.F90
+++ b/src/OCE/ISF/isfrst.F90
@@ -10,7 +10,7 @@ MODULE isfrst
!! isfrst : read/write iceshelf variables in/from restart
!!----------------------------------------------------------------------
!
- USE par_oce, ONLY: jpi,jpj,jpk,jpts ! time and space domain
+ USE par_oce ! time and space domain
!
USE in_out_manager ! I/O manager
USE iom ! I/O library
@@ -21,6 +21,8 @@ MODULE isfrst
PUBLIC isfrst_read, isfrst_write ! iceshelf restart read and write
+ !! * Substitutions
+# include "do_loop_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
!! $Id: sbcisf.F90 10536 2019-01-16 19:21:09Z mathiot $
@@ -33,13 +35,12 @@ CONTAINS
!!
!! isfrst_read : read iceshelf variables from restart
!!
- !!-------------------------- OUT --------------------------------------
- REAL(wp), DIMENSION(jpi,jpj) , INTENT( out) :: pfwf_b
- REAL(wp), DIMENSION(jpi,jpj,jpts), INTENT( out) :: ptsc_b
- !!-------------------------- IN --------------------------------------
- CHARACTER(LEN=3) , INTENT(in ) :: cdisf
- REAL(wp), DIMENSION(jpi,jpj) , INTENT(in ) :: pfwf
- REAL(wp), DIMENSION(jpi,jpj,jpts), INTENT(in ) :: ptsc
+ !!----------------------------------------------------------------------
+ CHARACTER(LEN=3) , INTENT(in ) :: cdisf
+ REAL(wp), DIMENSION(A2D(0),jpts), INTENT(in ) :: ptsc
+ REAL(wp), DIMENSION(jpi,jpj) , INTENT(in ) :: pfwf
+ REAL(wp), DIMENSION(A2D(0),jpts), INTENT( out) :: ptsc_b
+ REAL(wp), DIMENSION(jpi,jpj) , INTENT( out) :: pfwf_b
!!----------------------------------------------------------------------
CHARACTER(LEN=256) :: cfwf_b, chc_b, csc_b
!!----------------------------------------------------------------------
@@ -68,11 +69,11 @@ CONTAINS
!!
!! isfrst_write : write iceshelf variables in restart
!!
- !!-------------------------- IN --------------------------------------
- INTEGER , INTENT(in ) :: kt
- CHARACTER(LEN=3) , INTENT(in ) :: cdisf
- REAL(wp), DIMENSION(jpi,jpj) , INTENT(in ) :: pfwf
- REAL(wp), DIMENSION(jpi,jpj,jpts), INTENT(in ) :: ptsc
+ !!---------------------------------------------------------------------
+ INTEGER , INTENT(in ) :: kt
+ CHARACTER(LEN=3) , INTENT(in ) :: cdisf
+ REAL(wp), DIMENSION(jpi,jpj) , INTENT(in ) :: pfwf
+ REAL(wp), DIMENSION(A2D(0),jpts), INTENT(in ) :: ptsc
!!---------------------------------------------------------------------
CHARACTER(LEN=256) :: cfwf_b, chc_b, csc_b
!!---------------------------------------------------------------------
diff --git a/src/OCE/ISF/isfstp.F90 b/src/OCE/ISF/isfstp.F90
index edc5f92aae6060c14f99019bedbceb57e0b01b80..1c847f9b4c621da3473c68560fee060d26925032 100644
--- a/src/OCE/ISF/isfstp.F90
+++ b/src/OCE/ISF/isfstp.F90
@@ -13,20 +13,22 @@ MODULE isfstp
!! isfstp : compute iceshelf melt and heat flux
!!----------------------------------------------------------------------
USE isf_oce ! isf variables
+ USE isfrst , ONLY: isfrst_write ! ice shelf restart read/write subroutine
USE isfload, ONLY: isf_load ! ice shelf load
USE isftbl , ONLY: isf_tbl_lvl ! ice shelf boundary layer
USE isfpar , ONLY: isf_par, isf_par_init ! ice shelf parametrisation
USE isfcav , ONLY: isf_cav, isf_cav_init ! ice shelf cavity
USE isfcpl , ONLY: isfcpl_rst_write, isfcpl_init ! isf variables
+ USE oce , ONLY: ssh
+ USE par_oce ! ocean space and time domain
USE dom_oce ! ocean space and time domain
- USE oce , ONLY: ssh ! sea surface height
- USE domvvl, ONLY: ln_vvl_zstar ! zstar logical
USE zdfdrg, ONLY: r_Cdmin_top, r_ke0_top ! vertical physics: top/bottom drag coef.
!
USE lib_mpp, ONLY: ctl_stop, ctl_nam
USE fldread, ONLY: FLD, FLD_N
USE in_out_manager ! I/O manager
+ USE lbclnk
USE timing
IMPLICIT NONE
@@ -35,6 +37,7 @@ MODULE isfstp
PUBLIC isf_stp, isf_init, isf_nam ! routine called in sbcmod and divhor
!! * Substitutions
+# include "do_loop_substitute.h90"
# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
@@ -60,42 +63,49 @@ CONTAINS
INTEGER, INTENT(in) :: kt ! ocean time step
INTEGER, INTENT(in) :: Kmm ! ocean time level index
!
- INTEGER :: jk ! loop index
-#if defined key_qco
- REAL(wp), DIMENSION(jpi,jpj,jpk) :: ze3t ! 3D workspace
-#endif
+ INTEGER :: ji, jj, jk, ikt ! loop index
+ REAL(wp), DIMENSION(A2D(0)) :: zhtmp ! temporary array for thickness
+ REAL(wp), DIMENSION(A2D(0),jpk) :: ze3t ! 3D workspace for key_qco
!!---------------------------------------------------------------------
!
IF( ln_timing ) CALL timing_start('isf')
!
+ ! temporary arrays for key_qco
+ DO_2D( 0 ,0, 0, 0 )
+ zhtmp(ji,jj) = ht(ji,jj,Kmm)
+ DO jk = 1, jpk
+ ze3t(ji,jj,jk) = e3t(ji,jj,jk,Kmm)
+ ENDDO
+ END_2D
+ !
!=======================================================================
! 1.: compute melt and associated heat fluxes in the ice shelf cavities
!=======================================================================
!
IF ( ln_isfcav_mlt ) THEN
!
+ ! --- before time step --- !
#if ! defined key_RK3
- ! MLF : need risf_cav_tsc_b update
- ! 1.1: before time step
- IF ( kt /= nit000 ) THEN
- risf_cav_tsc_b (:,:,:) = risf_cav_tsc (:,:,:)
- fwfisf_cav_b(:,:) = fwfisf_cav(:,:)
+ IF ( kt /= nit000 ) THEN ! MLF : need risf_cav_tsc_b update
+ DO_2D( 0, 0, 0, 0 )
+ risf_cav_tsc_b(ji,jj,:) = risf_cav_tsc(ji,jj,:)
+ fwfisf_cav_b (ji,jj) = fwfisf_cav (ji,jj)
+ END_2D
END IF
#endif
!
- ! 1.2: compute misfkb, rhisf_tbl, rfrac (deepest level, thickness, fraction of deepest cell affected by tbl)
- rhisf_tbl_cav(:,:) = rn_htbl * mskisf_cav(:,:)
-#if defined key_qco
- DO jk = 1, jpk
- ze3t(:,:,jk) = e3t(:,:,jk,Kmm)
- END DO
- CALL isf_tbl_lvl( ht(:,:), ze3t , misfkt_cav, misfkb_cav, rhisf_tbl_cav, rfrac_tbl_cav )
-#else
- CALL isf_tbl_lvl( ht(:,:), e3t(:,:,:,Kmm), misfkt_cav, misfkb_cav, rhisf_tbl_cav, rfrac_tbl_cav )
-#endif
+ ! --- deepest level (misfkb), thickness (rhisf) & fraction of deepest cell affected by tbl (rfrac) --- !
+ DO_2D( 0 ,0, 0, 0 )
+ ! limit the tbl to water depth and to the top level thickness
+ ikt = misfkt_cav(ji,jj) ! tbl top indices
+ rhisf_tbl_cav(ji,jj) = MAX( MIN( rn_htbl * mskisf_cav(ji,jj), zhtmp(ji,jj) ), ze3t(ji,jj,ikt) )
+ END_2D
+
+ CALL isf_tbl_lvl( ze3t, misfkt_cav, rhisf_tbl_cav, & ! <<== in
+ & misfkb_cav, rfrac_tbl_cav ) ! ==>> out
!
- ! 1.3: compute ice shelf melt
- CALL isf_cav( kt, Kmm, risf_cav_tsc, fwfisf_cav )
+ ! --- ice shelf melt (fwfisf) and temperature trend (risf) --- !
+ CALL isf_cav( kt, Kmm, risf_cav_tsc, fwfisf_cav(A2D(0)) ) ! <<==>> inout
!
END IF
!
@@ -105,37 +115,59 @@ CONTAINS
!
IF ( ln_isfpar_mlt ) THEN
!
+ ! --- before time step --- !
#if ! defined key_RK3
- ! MLF : need risf_par_tsc_b update
- ! 2.1: before time step
- IF ( kt /= nit000 ) THEN
- risf_par_tsc_b(:,:,:) = risf_par_tsc(:,:,:)
- fwfisf_par_b (:,:) = fwfisf_par (:,:)
+ IF ( kt /= nit000 ) THEN ! MLF : need risf_par_tsc_b update
+ DO_2D( 0, 0, 0, 0 )
+ risf_par_tsc_b(ji,jj,:) = risf_par_tsc(ji,jj,:)
+ fwfisf_par_b (ji,jj) = fwfisf_par (ji,jj)
+ END_2D
END IF
#endif
!
- ! 2.2: compute misfkb, rhisf_tbl, rfrac (deepest level, thickness, fraction of deepest cell affected by tbl)
+ ! --- deepest level (misfkb), thickness (rhisf) & fraction of deepest cell affected by tbl (rfrac) --- !
! by simplicity, we assume the top level where param applied do not change with time (done in init part)
- rhisf_tbl_par(:,:) = rhisf0_tbl_par(:,:)
-#if defined key_qco
- DO jk = 1, jpk
- ze3t(:,:,jk) = e3t(:,:,jk,Kmm)
- END DO
- CALL isf_tbl_lvl( ht(:,:), ze3t , misfkt_par, misfkb_par, rhisf_tbl_par, rfrac_tbl_par )
-#else
- CALL isf_tbl_lvl( ht(:,:), e3t(:,:,:,Kmm), misfkt_par, misfkb_par, rhisf_tbl_par, rfrac_tbl_par )
-#endif
+ ! limit the tbl to water depth and to the top level thickness
+ DO_2D( 0 ,0, 0, 0 )
+ ikt = misfkt_par(ji,jj) ! tbl top indices
+ rhisf_tbl_par(ji,jj) = MAX( MIN( rhisf0_tbl_par(ji,jj), zhtmp(ji,jj) ), ze3t(ji,jj,ikt) )
+ END_2D
+
+ CALL isf_tbl_lvl( ze3t, misfkt_par, rhisf_tbl_par, & ! <<== in
+ & misfkb_par, rfrac_tbl_par ) ! ==>> out
!
- ! 2.3: compute ice shelf melt
- CALL isf_par( kt, Kmm, risf_par_tsc, fwfisf_par )
+ ! --- ice shelf melt (fwfisf) and temperature trend (risf) --- !
+ CALL isf_par( kt, Kmm, risf_par_tsc, fwfisf_par(A2D(0)) ) ! <<==>> inout
!
END IF
!
- !==================================================================================
- ! 3.: output specific restart variable in case of coupling with an ice sheet model
- !==================================================================================
!
- IF ( ln_isfcpl .AND. lrst_oce ) CALL isfcpl_rst_write(kt, Kmm)
+ !clem: these lbc are needed since we calculate everything in the interior now
+ IF( ln_isfcpl ) THEN
+ CALL lbc_lnk( 'isf_stp', fwfisf_par , 'T', 1.0_wp, fwfisf_cav , 'T', 1.0_wp, &
+#if ! defined key_RK3
+ & fwfisf_par_b, 'T', 1.0_wp, fwfisf_cav_b, 'T', 1.0_wp, &
+#endif
+ & risfcpl_ssh, 'T', 1.0_wp, risfcpl_cons_ssh, 'T', 1.0_wp ) ! needed in dynspg_ts, stp2d
+ CALL lbc_lnk( 'isf_stp', risfcpl_vol, 'T', 1.0_wp ) ! needed in dynspg_ts, stp2d, sshwzv, dynatf
+ ELSE
+ CALL lbc_lnk( 'isf_stp', fwfisf_par , 'T', 1.0_wp, fwfisf_cav , 'T', 1.0_wp, &
+#if ! defined key_RK3
+ & fwfisf_par_b, 'T', 1.0_wp, fwfisf_cav_b, 'T', 1.0_wp &
+ & )
+#endif
+ ENDIF
+ !
+ !==================
+ ! 3.: write restart
+ !==================
+#if ! defined key_RK3
+ ! MLF: write restart variables (qoceisf, qhcisf, fwfisf for now and before)
+ IF( ln_isfcav_mlt .AND. lrst_oce ) CALL isfrst_write( kt, 'cav', risf_cav_tsc , fwfisf_cav )
+ ! MLF: write restart variables (qoceisf, qhcisf, fwfisf for now and before)
+ IF( ln_isfpar_mlt .AND. lrst_oce ) CALL isfrst_write( kt, 'par', risf_par_tsc , fwfisf_par )
+#endif
+ IF( ln_isfcpl .AND. lrst_oce ) CALL isfcpl_rst_write( kt, Kmm )
!
IF( ln_timing ) CALL timing_stop('isf')
!
@@ -164,10 +196,19 @@ CONTAINS
CALL isf_nam() ! Read namelist
!
CALL isf_alloc() ! Allocate public array
+ !
+ ! initalisation of fwf and tsc array to 0
+ risfload (:,:) = 0._wp
+ fwfisf_oasis(:,:) = 0._wp ; fwfisf_par (:,:) = 0._wp ; fwfisf_cav(:,:) = 0._wp
+ risf_cav_tsc(:,:,:) = 0._wp ; risf_par_tsc(:,:,:) = 0._wp
+#if ! defined key_RK3
+ fwfisf_par_b (:,:) = 0._wp ; fwfisf_cav_b (:,:) = 0._wp
+ risf_cav_tsc_b(:,:,:) = 0._wp ; risf_par_tsc_b(:,:,:) = 0._wp
+#endif
!
CALL isf_ctl() ! check option compatibility
!
- IF( ln_isfcav ) CALL isf_load( Kmm, risfload ) ! compute ice shelf load
+ IF( ln_isfcav ) CALL isf_load( Kmm, risfload ) ! compute ice shelf load
!
! terminate routine now if no ice shelf melt formulation specify
IF( ln_isf ) THEN
@@ -200,11 +241,9 @@ CONTAINS
WRITE(numout,*)
!
IF ( ln_isf ) THEN
-#if key_qco
-# if ! defined key_isf
+#if defined key_qco && ! defined key_isf
CALL ctl_stop( 'STOP', 'isf_ctl: ice shelf requires both ln_isf=T AND key_isf activated' )
-# endif
-#endif
+#endif
WRITE(numout,*) ' Add debug print in isf module ln_isfdebug = ', ln_isfdebug
WRITE(numout,*)
WRITE(numout,*) ' melt inside the cavity ln_isfcav_mlt = ', ln_isfcav_mlt
@@ -281,10 +320,7 @@ CONTAINS
IF ( TRIM(cn_isfpar_mlt) == 'oasis' .AND. TRIM(cn_isfcav_mlt) == 'oasis' ) CALL ctl_stop( 'cn_isfpar_mlt = oasis and cn_isfcav_mlt = oasis not coded' )
END IF
!
- ! compatibility ice shelf and vvl
- IF( .NOT. ln_vvl_zstar .AND. ln_isf ) CALL ctl_stop( 'Only vvl_zstar has been tested with ice shelf cavity' )
- !
- END IF
+ ENDIF
END SUBROUTINE isf_ctl
diff --git a/src/OCE/ISF/isftbl.F90 b/src/OCE/ISF/isftbl.F90
index c6b3adc3bea892cb74f29764f47d0e6c65f2d9a6..04d3da35fd3372f49cbba328e3b175017244183b 100644
--- a/src/OCE/ISF/isftbl.F90
+++ b/src/OCE/ISF/isftbl.F90
@@ -15,20 +15,21 @@ MODULE isftbl
USE isf_oce ! ice shelf variables
+ USE par_oce ! ocean space and time domain
USE dom_oce ! vertical scale factor and depth
+ USE domutl, ONLY : lbnd_ij
IMPLICIT NONE
PRIVATE
- PUBLIC isf_tbl, isf_tbl_avg, isf_tbl_lvl, isf_tbl_ktop, isf_tbl_kbot
+ PUBLIC isf_tbl_avg, isf_tbl_lvl, isf_tbl_ktop
!! * Substitutions
# include "do_loop_substitute.h90"
# include "domzgr_substitute.h90"
-
CONTAINS
- SUBROUTINE isf_tbl( Kmm, pvarin, pvarout, cd_ptin, ktop, phtbl, kbot, pfrac )
+ SUBROUTINE isf_tbl( Kmm, pvarin, cd_ptin, ktop, phtbl, pvarout, kbot, pfrac )
!!--------------------------------------------------------------------
!! *** SUBROUTINE isf_tbl ***
!!
@@ -39,83 +40,87 @@ CONTAINS
!! ** Reference : inspired from : Losch, Modeling ice shelf cavities in a z coordinate ocean general circulation model
!! https://doi.org/10.1029/2007JC004368 , 2008
!!
- !!-------------------------- OUT -------------------------------------
- REAL(wp), DIMENSION(jpi,jpj) , INTENT( out) :: pvarout ! 2d average of pvarin
- !!-------------------------- IN -------------------------------------
- INTEGER , INTENT(in ) :: Kmm ! ocean time level index
- CHARACTER(len=1) , INTENT(in ) :: cd_ptin ! point of variable in/out
- REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT(in ) :: pvarin ! 3d variable to average over the tbl
- INTEGER, DIMENSION(jpi,jpj) , INTENT(in ) :: ktop ! top level
- REAL(wp), DIMENSION(jpi,jpj) , INTENT(in ) :: phtbl ! tbl thickness
- !!-------------------------- IN OPTIONAL -----------------------------
- INTEGER, DIMENSION(jpi,jpj), OPTIONAL, INTENT(in ) :: kbot ! bottom level
- REAL(wp), DIMENSION(jpi,jpj), OPTIONAL, INTENT(in ) :: pfrac ! fraction of bottom cell affected by tbl
!!--------------------------------------------------------------------
- INTEGER :: ji, jj ! loop index
- INTEGER , DIMENSION(jpi,jpj) :: ikbot ! bottom level of the tbl
- REAL(wp), DIMENSION(jpi,jpj) :: zvarout ! 2d average of pvarin
- REAL(wp), DIMENSION(jpi,jpj) :: zhtbl ! thickness of the tbl
- REAL(wp), DIMENSION(jpi,jpj) :: zfrac ! thickness of the tbl
- INTEGER :: jk ! loop index
- REAL(wp), DIMENSION(jpi,jpj,jpk) :: ze3t,ze3u,ze3v ! e3
+ INTEGER , INTENT(in ) :: Kmm ! ocean time level index
+ REAL(wp), DIMENSION(A2D(0),jpk) , INTENT(in ) :: pvarin ! 3d variable to average over the tbl
+ CHARACTER(len=1) , INTENT(in ) :: cd_ptin ! point of variable in/out
+ INTEGER, DIMENSION(A2D(0)) , INTENT(in ) :: ktop ! top level
+ REAL(wp), DIMENSION(A2D(0)) , INTENT(in ) :: phtbl ! tbl thickness
+ REAL(wp), DIMENSION(A2D(0)) , INTENT(out) :: pvarout ! 2d average of pvarin
+ INTEGER, DIMENSION(A2D(0)), OPTIONAL, INTENT(in ) :: kbot ! bottom level
+ REAL(wp), DIMENSION(A2D(0)), OPTIONAL, INTENT(in ) :: pfrac ! fraction of bottom cell affected by tbl
+ !!--------------------------------------------------------------------
+ INTEGER :: ji, jj, jk, ikt ! loop index
+ REAL(wp), DIMENSION(A2D(0)) :: zhtbl ! temporary array for thickness
+ INTEGER , DIMENSION(A2D(0)) :: ikbot ! bottom level of the tbl
+ REAL(wp), DIMENSION(A2D(0)) :: zfrac ! thickness of the tbl
+ REAL(wp), DIMENSION(A2D(0),jpk) :: ze3 ! e3
!!--------------------------------------------------------------------
!
SELECT CASE ( cd_ptin )
CASE ( 'U' )
!
- ! copy phtbl (phtbl is INTENT in as we don't want to change it)
- zhtbl = phtbl
+ DO_3D( 0 ,0, 0, 0, 1, jpk )
+ ze3(ji,jj,jk) = e3u(ji,jj,jk,Kmm)
+ END_3D
!
- DO jk = 1, jpk
- ze3u(:,:,jk) = e3u(:,:,jk,Kmm)
- END DO
! compute tbl lvl and thickness
- CALL isf_tbl_lvl( hu(:,:,Kmm), ze3u, ktop, ikbot, zhtbl, zfrac )
+ DO_2D( 0 ,0, 0, 0 )
+ ikt = ktop(ji,jj) ! tbl top indices
+ zhtbl(ji,jj) = MAX( MIN( phtbl(ji,jj), hu(ji,jj,Kmm) ), ze3(ji,jj,ikt) )
+ END_2D
+ CALL isf_tbl_lvl( ze3, ktop, zhtbl, & ! <<== in
+ & ikbot, zfrac ) ! ==>> out
!
! compute tbl property at U point
- CALL isf_tbl_avg( miku, ikbot, zhtbl, zfrac, ze3u, pvarin, zvarout )
+ CALL isf_tbl_avg( miku(A2D(0)), ikbot, zhtbl, zfrac, ze3, pvarin, & ! <<== in
+ & pvarout ) ! ==>> out
!
- ! compute tbl property at T point
- pvarout(1,:) = 0._wp
- DO_2D( nn_hls-1, nn_hls, nn_hls, nn_hls )
- pvarout(ji,jj) = 0.5_wp * (zvarout(ji,jj) + zvarout(ji-1,jj))
- END_2D
- ! lbclnk not needed as a final communication is done after the computation of fwf
- !
CASE ( 'V' )
!
- ! copy phtbl (phtbl is INTENT in as we don't want to change it)
- zhtbl = phtbl
+ DO_3D( 0 ,0, 0, 0, 1, jpk )
+ ze3(ji,jj,jk) = e3v(ji,jj,jk,Kmm)
+ END_3D
!
- DO jk = 1, jpk
- ze3v(:,:,jk) = e3v(:,:,jk,Kmm)
- END DO
! compute tbl lvl and thickness
- CALL isf_tbl_lvl( hv(:,:,Kmm), ze3v, ktop, ikbot, zhtbl, zfrac )
+ DO_2D( 0 ,0, 0, 0 )
+ ikt = ktop(ji,jj) ! tbl top indices
+ zhtbl(ji,jj) = MAX( MIN( phtbl(ji,jj), hv(ji,jj,Kmm) ), ze3(ji,jj,ikt) )
+ END_2D
+ CALL isf_tbl_lvl( ze3, ktop, zhtbl, & ! <<== in
+ & ikbot, zfrac ) ! ==>> out
!
! compute tbl property at V point
- CALL isf_tbl_avg( mikv, ikbot, zhtbl, zfrac, ze3v, pvarin, zvarout )
- !
- ! pvarout is an averaging of wet point
- pvarout(:,1) = 0._wp
- DO_2D( nn_hls, nn_hls, nn_hls-1, nn_hls )
- pvarout(ji,jj) = 0.5_wp * (zvarout(ji,jj) + zvarout(ji,jj-1))
- END_2D
- ! lbclnk not needed as a final communication is done after the computation of fwf
+ CALL isf_tbl_avg( mikv(A2D(0)), ikbot, zhtbl, zfrac, ze3, pvarin, & ! <<== in
+ & pvarout ) ! ==>> out
!
CASE ( 'T' )
+ !
+ DO_3D( 0 ,0, 0, 0, 1, jpk )
+ ze3(ji,jj,jk) = e3t(ji,jj,jk,Kmm)
+ END_3D
!
! compute tbl property at T point
- DO jk = 1, jpk
- ze3t(:,:,jk) = e3t(:,:,jk,Kmm)
- END DO
- CALL isf_tbl_avg( ktop, kbot, phtbl, pfrac, ze3t, pvarin, pvarout )
+ CALL isf_tbl_avg( ktop, kbot, phtbl, pfrac, ze3, pvarin, & ! <<== in
+ & pvarout ) ! ==>> out
!
END SELECT
!
END SUBROUTINE isf_tbl
SUBROUTINE isf_tbl_avg( ktop, kbot, phtbl, pfrac, pe3, pvarin, pvarout )
+ !!--------------------------------------------------------------------
+ INTEGER, DIMENSION(:,:) , INTENT(in ) :: ktop ! top level of the top boundary layer
+ INTEGER, DIMENSION(A2D(0)) , INTENT(in ) :: kbot ! bottom level of the top boundary layer
+ REAL(wp), DIMENSION(A2D(0)) , INTENT(in ) :: phtbl, pfrac ! fraction of bottom level to be affected by the tbl
+ REAL(wp), DIMENSION(A2D(0),jpk), INTENT(in ) :: pe3 ! vertical scale factor
+ REAL(wp), DIMENSION(:,:,:) , INTENT(in ) :: pvarin ! tbl property to average between ktop, kbot over phtbl
+ REAL(wp), DIMENSION(:,:) , INTENT(out) :: pvarout ! tbl property averaged over phtbl between level ktop and kbot
+ !!--------------------------------------------------------------------
+ CALL isf_tbl_avg_t( ktop, lbnd_ij(ktop), kbot, phtbl, pfrac, pe3, pvarin, lbnd_ij(pvarin), pvarout, lbnd_ij(pvarout) )
+ END SUBROUTINE isf_tbl_avg
+
+ SUBROUTINE isf_tbl_avg_t( ktop, ktktop, kbot, phtbl, pfrac, pe3, pvarin, ktvarin, pvarout, ktvarout )
!!--------------------------------------------------------------------
!! *** ROUTINE isf_tbl_avg ***
!!
@@ -124,20 +129,21 @@ CONTAINS
!! ** Method : Depth average is made between the top level ktop and the bottom level kbot
!! over a thickness phtbl. The bottom level is partially counted (pfrac).
!!
- !!-------------------------- OUT -------------------------------------
- REAL(wp), DIMENSION(jpi,jpj) , INTENT( out) :: pvarout ! tbl property averaged over phtbl between level ktop and kbot
- !!-------------------------- IN -------------------------------------
- INTEGER, DIMENSION(jpi,jpj) , INTENT(in ) :: ktop, kbot ! top and bottom level of the top boundary layer
- REAL(wp), DIMENSION(jpi,jpj) , INTENT(in ) :: phtbl, pfrac ! fraction of bottom level to be affected by the tbl
- REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in ) :: pe3 ! vertical scale factor
- REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in ) :: pvarin ! tbl property to average between ktop, kbot over phtbl
!!--------------------------------------------------------------------
- INTEGER :: ji,jj,jk ! loop indices
- INTEGER :: ikt, ikb ! top and bottom levels
+ INTEGER, DIMENSION(2) , INTENT(in ) :: ktvarin, ktktop, ktvarout
+ INTEGER, DIMENSION(AB2D(ktktop)) , INTENT(in ) :: ktop ! top level of the top boundary layer
+ INTEGER, DIMENSION(A2D(0)) , INTENT(in ) :: kbot ! bottom level of the top boundary layer
+ REAL(wp), DIMENSION(A2D(0)) , INTENT(in ) :: phtbl, pfrac ! fraction of bottom level to be affected by the tbl
+ REAL(wp), DIMENSION(A2D(0),jpk) , INTENT(in ) :: pe3 ! vertical scale factor
+ REAL(wp), DIMENSION(AB2D(ktvarin),JPK), INTENT(in ) :: pvarin ! tbl property to average between ktop, kbot over phtbl
+ REAL(wp), DIMENSION(AB2D(ktvarout)) , INTENT(out) :: pvarout ! tbl property averaged over phtbl between level ktop and kbot
+ !!--------------------------------------------------------------------
+ INTEGER :: ji, jj ! loop indices
+ INTEGER :: ikt, ikb ! top and bottom levels
!!--------------------------------------------------------------------
!
! compute tbl top.bottom level and thickness
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
!
! tbl top/bottom indices initialisation
ikt = ktop(ji,jj) ; ikb = kbot(ji,jj)
@@ -150,9 +156,9 @@ CONTAINS
!
END_2D
- END SUBROUTINE isf_tbl_avg
+ END SUBROUTINE isf_tbl_avg_t
- SUBROUTINE isf_tbl_lvl( phw, pe3, ktop, kbot, phtbl, pfrac )
+ SUBROUTINE isf_tbl_lvl( pe3, ktop, phtbl, kbot, pfrac )
!!--------------------------------------------------------------------
!! *** ROUTINE isf_tbl_lvl ***
!!
@@ -160,96 +166,48 @@ CONTAINS
!! - thickness of the top boundary layer
!! - fraction of the bottom level affected by the tbl
!!
- !!-------------------------- OUT --------------------------------------
- INTEGER, DIMENSION(jpi,jpj) , INTENT( out) :: kbot ! bottom level of the top boundary layer
- REAL(wp), DIMENSION(jpi,jpj) , INTENT( out) :: pfrac ! fraction of bottom level in the tbl
- !!-------------------------- IN --------------------------------------
- INTEGER, DIMENSION(jpi,jpj) , INTENT(in ) :: ktop ! top level of the top boundary layer
- REAL(wp), DIMENSION(jpi,jpj) , INTENT(in ) :: phw ! water column thickness
- REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in ) :: pe3 ! vertical scale factor
- !!-------------------------- INOUT ------------------------------------
- REAL(wp), DIMENSION(jpi,jpj) , INTENT(inout) :: phtbl ! top boundary layer thickness
+ !!--------------------------------------------------------------------
+ REAL(wp), DIMENSION(A2D(0),jpk), INTENT(in ) :: pe3 ! vertical scale factor
+ INTEGER, DIMENSION(A2D(0)) , INTENT(in ) :: ktop ! top level of the top boundary layer
+ REAL(wp), DIMENSION(A2D(0)) , INTENT(in ) :: phtbl ! top boundary layer thickness
+ INTEGER, DIMENSION(A2D(0)) , INTENT(out) :: kbot ! bottom level of the top boundary layer
+ REAL(wp), DIMENSION(A2D(0)) , INTENT(out) :: pfrac ! fraction of bottom level in the tbl
!!---------------------------------------------------------------------
- INTEGER :: ji,jj,jk
- INTEGER :: ikt, ikb
+ INTEGER :: ji, jj
+ INTEGER :: ikt, ikb
!!---------------------------------------------------------------------
!
- ! get htbl
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
!
- ! tbl top/bottom indices initialisation
- ikt = ktop(ji,jj)
- !
- ! limit the tbl to water thickness.
- phtbl(ji,jj) = MIN( phtbl(ji,jj), phw(ji,jj) )
- !
- ! thickness of boundary layer must be at least the top level thickness
- phtbl(ji,jj) = MAX( phtbl(ji,jj), pe3(ji,jj,ikt) )
+ ikt = ktop(ji,jj) ! tbl top indices initialisation
!
- END_2D
- !
- ! get ktbl
- CALL isf_tbl_kbot(ktop, phtbl, pe3, kbot)
- !
- ! get pfrac
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ ! --- get kbot --- !
+ ! ! determine the deepest level influenced by the boundary layer
+ ikb = ikt+1
+ DO WHILE( SUM( pe3(ji,jj,ikt:ikb-1) ) < phtbl(ji,jj ) ) ; ikb = ikb + 1 ; END DO
+ kbot(ji,jj) = ikb - 1
!
- ! tbl top/bottom indices initialisation
- ikt = ktop(ji,jj) ; ikb = kbot(ji,jj)
+ ikb = kbot(ji,jj) ! tbl bottom indices initialisation
!
- ! proportion of the bottom cell included in ice shelf boundary layer
+ ! --- get pfrac --- !
+ ! ! proportion of the bottom cell included in ice shelf boundary layer
pfrac(ji,jj) = ( phtbl(ji,jj) - SUM( pe3(ji,jj,ikt:ikb-1) ) ) / pe3(ji,jj,ikb)
!
END_2D
!
END SUBROUTINE isf_tbl_lvl
!
- SUBROUTINE isf_tbl_kbot(ktop, phtbl, pe3, kbot)
- !!--------------------------------------------------------------------
- !! *** ROUTINE isf_tbl_bot ***
- !!
- !! ** Purpose : compute bottom level of the isf top boundary layer
- !!
- !!-------------------------- OUT -------------------------------------
- INTEGER, DIMENSION(jpi,jpj) , INTENT( out) :: kbot ! bottom level of the top boundary layer
- !!-------------------------- IN -------------------------------------
- REAL(wp), DIMENSION(jpi,jpj) , INTENT(in ) :: phtbl ! top boundary layer thickness
- INTEGER, DIMENSION(jpi,jpj) , INTENT(in ) :: ktop ! top level of the top boundary layer
- REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in ) :: pe3 ! vertical scale factor
- !!--------------------------------------------------------------------
- INTEGER :: ji, jj
- INTEGER :: ikt, ikb
- !!--------------------------------------------------------------------
- !
- ! phtbl need to be bounded by water column thickness before
- ! test: if htbl = water column thickness, should return mbathy
- ! test: if htbl = 0 should return ktop (phtbl cap to pe3t(ji,jj,1))
- !
- ! get ktbl
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
- !
- ! determine the deepest level influenced by the boundary layer
- ikt = ktop(ji,jj)
- ikb = ikt
- DO WHILE ( SUM(pe3(ji,jj,ikt:ikb-1)) < phtbl(ji,jj ) ) ; ikb = ikb + 1 ; END DO
- kbot(ji,jj) = ikb - 1
- !
- END_2D
- !
- END SUBROUTINE isf_tbl_kbot
- !
- SUBROUTINE isf_tbl_ktop(pdep, ktop)
+ SUBROUTINE isf_tbl_ktop( pdep, ktop )
!!--------------------------------------------------------------------
!! *** ROUTINE isf_tbl_top ***
!!
!! ** Purpose : compute top level of the isf top boundary layer in case of an ice shelf parametrisation
!!
- !!-------------------------- OUT -------------------------------------
- INTEGER, DIMENSION(jpi,jpj), INTENT( out) :: ktop ! top level affected by the ice shelf parametrisation
- !!-------------------------- IN -------------------------------------
- REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pdep ! top depth of the parametrisation influence
!!--------------------------------------------------------------------
- INTEGER :: ji,jj
+ REAL(wp), DIMENSION(A2D(0)), INTENT(inout) :: pdep ! top depth of the parametrisation influence
+ INTEGER, DIMENSION(A2D(0)), INTENT( out) :: ktop ! top level affected by the ice shelf parametrisation
+ !!--------------------------------------------------------------------
+ INTEGER :: ji, jj
INTEGER :: ikt
!!--------------------------------------------------------------------
!
@@ -260,14 +218,15 @@ CONTAINS
! test: this routine run on isfdraft should return mikt
! test: this routine run with pdep = 0 should return 1
!
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
! comput ktop
ikt = 2
- DO WHILE ( gdepw_0(ji,jj,ikt) <= pdep(ji,jj ) ) ; ikt = ikt + 1 ; END DO
+ DO WHILE ( gdepw_0(ji,jj,ikt) <= pdep(ji,jj) ) ; ikt = ikt + 1 ; END DO
ktop(ji,jj) = ikt - 1
!
! update pdep
- pdep(ji,jj) = gdepw_0(ji,jj,ktop(ji,jj))
+ ikt=ktop(ji,jj)
+ pdep(ji,jj) = gdepw_0(ji,jj,ikt)
END_2D
!
END SUBROUTINE isf_tbl_ktop
diff --git a/src/OCE/ISF/isfutils.F90 b/src/OCE/ISF/isfutils.F90
index 63c489c59abba9230949223abe4a93736a340fcb..af103b46bd5c2d46f435e96adfa7e8062aeab07d 100644
--- a/src/OCE/ISF/isfutils.F90
+++ b/src/OCE/ISF/isfutils.F90
@@ -13,9 +13,9 @@ MODULE isfutils
USE iom , ONLY: iom_open, iom_get, iom_close, jpdom_global ! read input file
USE lib_fortran , ONLY: glob_sum, glob_min, glob_max ! compute global value
- USE par_oce , ONLY: jpi,jpj,jpk, jpnij, Nis0, Nie0, Njs0, Nje0 ! domain size
+ USE par_oce ! domain size
USE dom_oce , ONLY: narea ! local domain
- USE in_out_manager, ONLY: i8, wp, lwp, numout ! miscelenious
+ USE in_out_manager ! miscelenious
USE lib_mpp
IMPLICIT NONE
@@ -28,6 +28,8 @@ MODULE isfutils
PUBLIC read_2dcstdta, debug
+ !! * Substitutions
+# include "do_loop_substitute.h90"
CONTAINS
SUBROUTINE read_2dcstdta(cdfile, cdvar, pvar)
@@ -36,17 +38,16 @@ CONTAINS
!!
!! ** Purpose : read input file
!!
- !!-------------------------- OUT -------------------------------------
- REAL(wp), DIMENSION(jpi,jpj), INTENT( out) :: pvar ! output variable
- !!-------------------------- IN -------------------------------------
- CHARACTER(len=*) , INTENT(in ) :: cdfile ! input file name
- CHARACTER(len=*) , INTENT(in ) :: cdvar ! variable name
+ !!--------------------------------------------------------------------
+ CHARACTER(len=*) , INTENT(in ) :: cdfile ! input file name
+ CHARACTER(len=*) , INTENT(in ) :: cdvar ! variable name
+ REAL(wp), DIMENSION(A2D(0)), INTENT(inout) :: pvar ! output variable
!!--------------------------------------------------------------------
INTEGER :: inum
!!--------------------------------------------------------------------
CALL iom_open( TRIM(cdfile), inum )
- CALL iom_get( inum, jpdom_global, TRIM(cdvar), pvar)
+ CALL iom_get( inum, jpdom_global, TRIM(cdvar), pvar )
CALL iom_close(inum)
END SUBROUTINE read_2dcstdta
@@ -57,16 +58,16 @@ CONTAINS
!!
!! ** Purpose : add debug print for 2d variables
!!
- !!-------------------------- IN -------------------------------------
- CHARACTER(LEN=*) , INTENT(in ) :: cdtxt
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pvar
!!--------------------------------------------------------------------
- REAL(wp) :: zmin, zmax, zsum
- INTEGER(i8) :: imodd, ip
- INTEGER :: imods
- INTEGER :: isums, idums
- INTEGER :: ji,jj,jk
- INTEGER, DIMENSION(jpnij) :: itmps
+ CHARACTER(LEN=*) , INTENT(in) :: cdtxt
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pvar
+ !!--------------------------------------------------------------------
+ REAL(wp) :: zmin, zmax, zsum
+ INTEGER(i8) :: imodd, ip
+ INTEGER :: imods
+ INTEGER :: isums, idums
+ INTEGER :: ji, jj, jk
+ INTEGER, DIMENSION(jpnij) :: itmps
!!--------------------------------------------------------------------
!
! global min/max/sum to check data range and NaN
@@ -110,16 +111,16 @@ CONTAINS
!!
!! ** Purpose : add debug print for 3d variables
!!
- !!-------------------------- IN -------------------------------------
- CHARACTER(LEN=*) , INTENT(in ) :: cdtxt
- REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in ) :: pvar
!!--------------------------------------------------------------------
- REAL(wp) :: zmin, zmax, zsum
- INTEGER(i8) :: imodd, ip
- INTEGER :: imods
- INTEGER :: isums, idums
- INTEGER :: ji,jj,jk
- INTEGER, DIMENSION(jpnij) :: itmps
+ CHARACTER(LEN=*) , INTENT(in) :: cdtxt
+ REAL(wp), DIMENSION(A2D(0),jpk), INTENT(in) :: pvar
+ !!--------------------------------------------------------------------
+ REAL(wp) :: zmin, zmax, zsum
+ INTEGER(i8) :: imodd, ip
+ INTEGER :: imods
+ INTEGER :: isums, idums
+ INTEGER :: ji, jj, jk
+ INTEGER, DIMENSION(jpnij) :: itmps
!!--------------------------------------------------------------------
!
! global min/max/sum to check data range and NaN
diff --git a/src/OCE/LBC/lbc_lnk_call_generic.h90 b/src/OCE/LBC/lbc_lnk_call_generic.h90
index 0d2e2514b826a44537cf2fd8f0cf45c8a3e36a26..b48047de6f9542871df7bbd1fd4dd167c21f65ec 100644
--- a/src/OCE/LBC/lbc_lnk_call_generic.h90
+++ b/src/OCE/LBC/lbc_lnk_call_generic.h90
@@ -26,8 +26,10 @@
& , pt17, cdna17, psgn17, pt18, cdna18, psgn18, pt19, cdna19, psgn19, pt20, cdna20, psgn20 &
& , pt21, cdna21, psgn21, pt22, cdna22, psgn22, pt23, cdna23, psgn23, pt24, cdna24, psgn24 &
& , pt25, cdna25, psgn25, pt26, cdna26, psgn26, pt27, cdna27, psgn27, pt28, cdna28, psgn28 &
- & , pt29, cdna29, psgn29, pt30, cdna30, psgn30 &
- & , kfillmode, pfillval, khls, lsend, lrecv, ld4only )
+ & , pt29, cdna29, psgn29, pt30, cdna30, psgn30, pt31, cdna31, psgn31, pt32, cdna32, psgn32 &
+ & , pt33, cdna33, psgn33, pt34, cdna34, psgn34, pt35, cdna35, psgn35, pt36, cdna36, psgn36 &
+ & , pt37, cdna37, psgn37, pt38, cdna38, psgn38, pt39, cdna39, psgn39, pt40, cdna40, psgn40 &
+ & , kfillmode, pfillval, lsend, lrecv, ld4only, ldfull )
!!---------------------------------------------------------------------
CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine
REAL(PRECISION), DIMENSION(DIMS) , TARGET, CONTIGUOUS, INTENT(inout) :: pt1 ! arrays on which the lbc is applied
@@ -35,29 +37,32 @@
& pt9 , pt10, pt11, pt12, pt13, pt14, pt15, &
& pt16, pt17, pt18, pt19, pt20, pt21, pt22, &
& pt23, pt24, pt25, pt26, pt27, pt28, pt29, &
- & pt30
+ & pt30, pt31, pt32, pt33, pt34, pt35, pt36, &
+ & pt37, pt38, pt39, pt40
CHARACTER(len=1) , INTENT(in ) :: cdna1 ! nature of pt2D. array grid-points
CHARACTER(len=1) , OPTIONAL , INTENT(in ) :: cdna2 , cdna3 , cdna4 , cdna5 , cdna6 , cdna7 , cdna8 , &
& cdna9 , cdna10, cdna11, cdna12, cdna13, cdna14, cdna15, &
& cdna16, cdna17, cdna18, cdna19, cdna20, cdna21, cdna22, &
& cdna23, cdna24, cdna25, cdna26, cdna27, cdna28, cdna29, &
- & cdna30
+ & cdna30, cdna31, cdna32, cdna33, cdna34, cdna35, cdna36, &
+ & cdna37, cdna38, cdna39, cdna40
REAL(PRECISION) , INTENT(in ) :: psgn1 ! sign used across the north fold
REAL(PRECISION) , OPTIONAL , INTENT(in ) :: psgn2 , psgn3 , psgn4 , psgn5 , psgn6 , psgn7 , psgn8 , &
& psgn9 , psgn10, psgn11, psgn12, psgn13, psgn14, psgn15, &
& psgn16, psgn17, psgn18, psgn19, psgn20, psgn21, psgn22, &
& psgn23, psgn24, psgn25, psgn26, psgn27, psgn28, psgn29, &
- & psgn30
+ & psgn30, psgn31, psgn32, psgn33, psgn34, psgn35, psgn36, &
+ & psgn37, psgn38, psgn39, psgn40
INTEGER , OPTIONAL , INTENT(in ) :: kfillmode ! filling method for halo over land (default = constant)
REAL(PRECISION) , OPTIONAL , INTENT(in ) :: pfillval ! background value (used at closed boundaries)
- INTEGER , OPTIONAL , INTENT(in ) :: khls ! halo size, default = nn_hls
LOGICAL, DIMENSION(8), OPTIONAL , INTENT(in ) :: lsend, lrecv ! indicate how communications are to be carried out
LOGICAL , OPTIONAL , INTENT(in ) :: ld4only ! if .T., do only 4-neighbour comm (ignore corners)
+ LOGICAL , OPTIONAL , INTENT(in ) :: ldfull ! .true. if we also update the last line of the inner domain
!!
INTEGER :: kfld ! number of elements that will be attributed
- TYPE(PTR_4d_/**/PRECISION), DIMENSION(30) :: ptab_ptr ! pointer array
- CHARACTER(len=1) , DIMENSION(30) :: cdna_ptr ! nature of ptab_ptr grid-points
- REAL(PRECISION) , DIMENSION(30) :: psgn_ptr ! sign used across the north fold boundary
+ TYPE(PTR_4d_/**/PRECISION), DIMENSION(40) :: ptab_ptr ! pointer array
+ CHARACTER(len=1) , DIMENSION(40) :: cdna_ptr ! nature of ptab_ptr grid-points
+ REAL(PRECISION) , DIMENSION(40) :: psgn_ptr ! sign used across the north fold boundary
!!---------------------------------------------------------------------
!
kfld = 0 ! initial array of pointer size
@@ -95,16 +100,22 @@
IF( PRESENT(psgn28) ) CALL load_ptr_/**/XD/**/_/**/PRECISION( pt28, cdna28, psgn28, ptab_ptr, cdna_ptr, psgn_ptr, kfld )
IF( PRESENT(psgn29) ) CALL load_ptr_/**/XD/**/_/**/PRECISION( pt29, cdna29, psgn29, ptab_ptr, cdna_ptr, psgn_ptr, kfld )
IF( PRESENT(psgn30) ) CALL load_ptr_/**/XD/**/_/**/PRECISION( pt30, cdna30, psgn30, ptab_ptr, cdna_ptr, psgn_ptr, kfld )
+ IF( PRESENT(psgn31) ) CALL load_ptr_/**/XD/**/_/**/PRECISION( pt31, cdna31, psgn31, ptab_ptr, cdna_ptr, psgn_ptr, kfld )
+ IF( PRESENT(psgn32) ) CALL load_ptr_/**/XD/**/_/**/PRECISION( pt32, cdna32, psgn32, ptab_ptr, cdna_ptr, psgn_ptr, kfld )
+ IF( PRESENT(psgn33) ) CALL load_ptr_/**/XD/**/_/**/PRECISION( pt33, cdna33, psgn33, ptab_ptr, cdna_ptr, psgn_ptr, kfld )
+ IF( PRESENT(psgn34) ) CALL load_ptr_/**/XD/**/_/**/PRECISION( pt34, cdna34, psgn34, ptab_ptr, cdna_ptr, psgn_ptr, kfld )
+ IF( PRESENT(psgn35) ) CALL load_ptr_/**/XD/**/_/**/PRECISION( pt35, cdna35, psgn35, ptab_ptr, cdna_ptr, psgn_ptr, kfld )
+ IF( PRESENT(psgn36) ) CALL load_ptr_/**/XD/**/_/**/PRECISION( pt36, cdna36, psgn36, ptab_ptr, cdna_ptr, psgn_ptr, kfld )
+ IF( PRESENT(psgn37) ) CALL load_ptr_/**/XD/**/_/**/PRECISION( pt37, cdna37, psgn37, ptab_ptr, cdna_ptr, psgn_ptr, kfld )
+ IF( PRESENT(psgn38) ) CALL load_ptr_/**/XD/**/_/**/PRECISION( pt38, cdna38, psgn38, ptab_ptr, cdna_ptr, psgn_ptr, kfld )
+ IF( PRESENT(psgn39) ) CALL load_ptr_/**/XD/**/_/**/PRECISION( pt39, cdna39, psgn39, ptab_ptr, cdna_ptr, psgn_ptr, kfld )
+ IF( PRESENT(psgn40) ) CALL load_ptr_/**/XD/**/_/**/PRECISION( pt40, cdna40, psgn40, ptab_ptr, cdna_ptr, psgn_ptr, kfld )
!
-#if ! defined key_mpi2
IF( nn_comm == 1 ) THEN
- CALL lbc_lnk_pt2pt( cdname, ptab_ptr, cdna_ptr, psgn_ptr, kfld, kfillmode, pfillval, khls, lsend, lrecv, ld4only )
+ CALL lbc_lnk_pt2pt( cdname, ptab_ptr, cdna_ptr, psgn_ptr, kfld, kfillmode, pfillval, lsend, lrecv, ld4only, ldfull )
ELSE
- CALL lbc_lnk_neicoll( cdname, ptab_ptr, cdna_ptr, psgn_ptr, kfld, kfillmode, pfillval, khls, lsend, lrecv, ld4only )
+ CALL lbc_lnk_neicoll( cdname, ptab_ptr, cdna_ptr, psgn_ptr, kfld, kfillmode, pfillval, lsend, lrecv, ld4only, ldfull )
ENDIF
-#else
- CALL lbc_lnk_pt2pt( cdname, ptab_ptr, cdna_ptr, psgn_ptr, kfld, kfillmode, pfillval, khls, lsend, lrecv, ld4only )
-#endif
!
END SUBROUTINE lbc_lnk_call_/**/XD/**/_/**/PRECISION
diff --git a/src/OCE/LBC/lbc_lnk_neicoll_generic.h90 b/src/OCE/LBC/lbc_lnk_neicoll_generic.h90
index 3ce416fe1fbf4ed39abd342c0ec78d204abc82d7..1ab6c1b1ff4079f8162077f31fc438557d5402a6 100644
--- a/src/OCE/LBC/lbc_lnk_neicoll_generic.h90
+++ b/src/OCE/LBC/lbc_lnk_neicoll_generic.h90
@@ -1,5 +1,5 @@
- SUBROUTINE lbc_lnk_neicoll_/**/PRECISION( cdname, ptab, cd_nat, psgn, kfld, kfillmode, pfillval, khls, lsend, lrecv, ld4only )
+ SUBROUTINE lbc_lnk_neicoll_/**/PRECISION( cdname, ptab, cd_nat, psgn, kfld, kfillmode, pfillval, lsend, lrecv, ld4only, ldfull )
CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine
TYPE(PTR_4d_/**/PRECISION), DIMENSION(:), INTENT(inout) :: ptab ! pointer of arrays on which apply the b.c.
CHARACTER(len=1), DIMENSION(:), INTENT(in ) :: cd_nat ! nature of array grid-points
@@ -7,265 +7,362 @@
INTEGER , INTENT(in ) :: kfld ! number of pt3d arrays
INTEGER , OPTIONAL, INTENT(in ) :: kfillmode ! filling method for halo over land (default = constant)
REAL(PRECISION), OPTIONAL, INTENT(in ) :: pfillval ! background value (used at closed boundaries)
- INTEGER , OPTIONAL, INTENT(in ) :: khls ! halo size, default = nn_hls
LOGICAL, DIMENSION(8),OPTIONAL, INTENT(in ) :: lsend, lrecv ! communication with other 4 proc
LOGICAL, OPTIONAL, INTENT(in ) :: ld4only ! if .T., do only 4-neighbour comm (ignore corners)
+ LOGICAL , OPTIONAL, INTENT(in ) :: ldfull ! .true. if we also update the last line of the inner domain
!
- INTEGER :: ji, jj, jk , jl, jf, jn ! dummy loop indices
- INTEGER :: ipi, ipj, ipk, ipl, ipf ! dimension of the input array
+ INTEGER :: ji, jj, jk , jl, jf, jn ! dummy loop indices
INTEGER :: ip0i, ip1i, im0i, im1i
INTEGER :: ip0j, ip1j, im0j, im1j
- INTEGER :: ishti, ishtj, ishti2, ishtj2
- INTEGER :: iszS, iszR
+ INTEGER :: ishti, ishtj, ishti1, ishtj1, ishti2, ishtj2
+ INTEGER :: isgni1, isgni2, isgnj1, isgnj2
+ INTEGER :: ii1, ii2, ij1, ij2
+ INTEGER :: inbS, inbR, iszS, iszR
INTEGER :: ierr
- INTEGER :: ihls, idx
+ INTEGER :: ihls, ihlsmax, idx
INTEGER :: impi_nc
INTEGER :: ifill_nfd
INTEGER, DIMENSION(4) :: iwewe, issnn
- INTEGER, DIMENSION(8) :: isizei, ishtSi, ishtRi, ishtPi
- INTEGER, DIMENSION(8) :: isizej, ishtSj, ishtRj, ishtPj
- INTEGER, DIMENSION(8) :: ifill, iszall
- INTEGER, DIMENSION(8) :: jnf
+ INTEGER, DIMENSION( kfld) :: ipi, ipj, ipk, ipl ! dimension of the input array
+ INTEGER, DIMENSION(8,kfld) :: ifill
+ INTEGER, DIMENSION(8,kfld) :: isizei, ishtSi, ishtRi, ishtPi
+ INTEGER, DIMENSION(8,kfld) :: isizej, ishtSj, ishtRj, ishtPj
+ INTEGER, DIMENSION(8) :: jnf
INTEGER, DIMENSION(:), ALLOCATABLE :: iScnt, iRcnt ! number of elements to be sent/received
INTEGER, DIMENSION(:), ALLOCATABLE :: iSdpl, iRdpl ! displacement in halos arrays
- LOGICAL, DIMENSION(8) :: llsend, llrecv
- REAL(PRECISION) :: zland
+ LOGICAL, DIMENSION(8,kfld) :: llsend, llrecv
LOGICAL :: ll4only ! default: 8 neighbourgs
+ REAL(PRECISION) :: zland
!!----------------------------------------------------------------------
!
! ----------------------------------------- !
! 1. local variables initialization !
! ----------------------------------------- !
!
- ipi = SIZE(ptab(1)%pt4d,1)
- ipj = SIZE(ptab(1)%pt4d,2)
- ipk = SIZE(ptab(1)%pt4d,3)
- ipl = SIZE(ptab(1)%pt4d,4)
- ipf = kfld
- !
- IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, ipk, ipl, ipf, ld_lbc = .TRUE. )
- !
! take care of optional parameters
!
- ihls = nn_hls ! default definition
- IF( PRESENT( khls ) ) ihls = khls
- IF( ihls > n_hlsmax ) THEN
- WRITE(ctmp1,*) TRIM(cdname), ' is calling lbc_lnk with khls > n_hlsmax : ', khls, '>', n_hlsmax
- CALL ctl_stop( 'STOP', ctmp1 )
- ENDIF
- IF( ipi /= Ni_0+2*ihls ) THEN
- WRITE(ctmp1,*) TRIM(cdname), ' is calling lbc_lnk with an input array which does not match ihls along i: ', ipi, ihls, Ni_0
- CALL ctl_stop( 'STOP', ctmp1 )
- ENDIF
- IF( ipj /= Nj_0+2*ihls ) THEN
- WRITE(ctmp1,*) TRIM(cdname), ' is calling lbc_lnk with an input array which does not match ihls along j:', ipj, ihls , Nj_0
- CALL ctl_stop( 'STOP', ctmp1 )
- ENDIF
- !
ll4only = .FALSE. ! default definition
IF( PRESENT(ld4only) ) ll4only = ld4only
!
- impi_nc = mpi_nc_com8(ihls) ! default
- IF( ll4only ) impi_nc = mpi_nc_com4(ihls)
- !
zland = 0._wp ! land filling value: zero by default
IF( PRESENT( pfillval ) ) zland = pfillval ! set land value
!
- ! define llsend and llrecv: logicals which say if mpi-neibourgs for send or receive exist or not.
- IF ( PRESENT(lsend) .AND. PRESENT(lrecv) ) THEN ! localy defined neighbourgs
- CALL ctl_stop( 'STOP', 'mpp_nc_generic+lsend and lrecv not yet implemented')
- ELSE IF( PRESENT(lsend) .OR. PRESENT(lrecv) ) THEN
- WRITE(ctmp1,*) TRIM(cdname), ' is calling lbc_lnk with only one of the two arguments lsend or lrecv'
- CALL ctl_stop( 'STOP', ctmp1 )
- ELSE ! default neighbours
- llsend(:) = mpiSnei(ihls,:) >= 0
- IF( ll4only ) llsend(5:8) = .FALSE. ! exclude corners
- llrecv(:) = mpiRnei(ihls,:) >= 0
- IF( ll4only ) llrecv(5:8) = .FALSE. ! exclude corners
- ENDIF
+ ifill_nfd = jpfillcst ! default definition
+ IF( PRESENT(kfillmode) ) ifill_nfd = kfillmode
!
- ! define ifill: which method should be used to fill each parts (sides+corners) of the halos
- ! default definition
- DO jn = 1, 8
- IF( llrecv(jn) ) THEN ; ifill(jn) = jpfillmpi ! with an mpi communication
- ELSEIF( l_SelfPerio(jn) ) THEN ; ifill(jn) = jpfillperio ! with self-periodicity
- ELSEIF( PRESENT(kfillmode) ) THEN ; ifill(jn) = kfillmode ! localy defined
- ELSE ; ifill(jn) = jpfillcst ! constant value (zland)
- ENDIF
- END DO
- ! take care of "indirect self-periodicity" for the corners
- DO jn = 5, 8
- IF(.NOT.l_SelfPerio(jn) .AND. l_SelfPerio(jpwe)) ifill(jn) = jpfillnothing ! no bi-perio but ew-perio: do corners later
- IF(.NOT.l_SelfPerio(jn) .AND. l_SelfPerio(jpso)) ifill(jn) = jpfillnothing ! no bi-perio but ns-perio: do corners later
- END DO
- ! north fold treatment
- IF( l_IdoNFold ) THEN
- ifill_nfd = ifill(jpno) ! if we are here, this means llrecv(jpno) = .false. and l_SelfPerio(jpno) = .false.
- ifill( (/jpno/) ) = jpfillnothing ! we do north fold -> do nothing for northern halo
- ENDIF
-
- ! We first define the localization and size of the parts of the array that will be sent (s), received (r)
- ! or used for periodocity (p). The localization is defined as "the bottom left corner - 1" in i and j directions.
- ! This is a shift that will be applied later in the do loops to pick-up the appropriate part of the array
+ ihlsmax = 0
!
- ! all definitions bellow do not refer to N[ij][se]0 so we can use it with any local value of ihls
- ! ! ________________________
- ip0i = 0 ! im0j = inner |__|________________|__|
- ip1i = ihls ! im1j = inner - halo | |__|__________|__| |
- im1i = ipi-2*ihls ! | | | | | |
- im0i = ipi - ihls ! | | | | | |
- ip0j = 0 ! | | | | | |
- ip1j = ihls ! | |__|__________|__| |
- im1j = ipj-2*ihls ! ip1j = halo |__|__|__________|__|__|
- im0j = ipj - ihls ! ip0j = 0 |__|________________|__|
- ! ! ip0i ip1i im1i im0i
+ DO jf = 1, kfld
+ !
+ ipi(jf) = SIZE(ptab(jf)%pt4d,1)
+ ipj(jf) = SIZE(ptab(jf)%pt4d,2)
+ ipk(jf) = SIZE(ptab(jf)%pt4d,3)
+ ipl(jf) = SIZE(ptab(jf)%pt4d,4)
+ ihls = ( ipi(jf) - Ni_0 ) / 2
+ ihlsmax = MAX(ihls, ihlsmax)
+ !
+ IF( numcom == -1 ) THEN ! test input array shape. Use numcom to do these tests only at the beginning of the run
+ IF( MOD( ipi(jf) - Ni_0, 2 ) /= 0 ) THEN
+ WRITE(ctmp1,*) TRIM(cdname), ' is calling lbc_lnk but the ', jf,'th input array has wong i-size: ', ipi(jf), Ni_0
+ CALL ctl_stop( 'STOP', ctmp1 )
+ ENDIF
+ IF( MOD( ipj(jf) - Nj_0, 2 ) /= 0 ) THEN
+ WRITE(ctmp1,*) TRIM(cdname), ' is calling lbc_lnk but the ', jf,'th input array has wong j-size: ', ipj(jf), Nj_0
+ CALL ctl_stop( 'STOP', ctmp1 )
+ ENDIF
+ IF( ( ipj(jf) - Nj_0 ) / 2 /= ihls ) THEN
+ WRITE(ctmp1,*) TRIM(cdname), ' is calling lbc_lnk but the ', jf,'th input array as wong i and j-size: ', &
+ & ipi(jf), Ni_0, ipj(jf), Nj_0
+ CALL ctl_stop( 'STOP', ctmp1 )
+ ENDIF
+ IF( ihls > n_hlsmax ) THEN
+ WRITE(ctmp1,*) TRIM(cdname), ' is calling lbc_lnk but for the ', jf,'th input array, ', ihls, ' > n_hlsmax = ', &
+ & n_hlsmax
+ CALL ctl_stop( 'STOP', ctmp1 )
+ ENDIF
+ ENDIF
+ !
+ ! define llsend and llrecv: logicals which say if mpi-neibourgs for send or receive exist or not.
+ IF ( PRESENT(lsend) .AND. PRESENT(lrecv) ) THEN ! localy defined neighbourgs
+ CALL ctl_stop( 'STOP', 'mpp_nc_generic+lsend and lrecv not yet implemented')
+ ELSE IF( PRESENT(lsend) .OR. PRESENT(lrecv) ) THEN
+ WRITE(ctmp1,*) TRIM(cdname), ' is calling lbc_lnk with only one of the two arguments lsend or lrecv'
+ CALL ctl_stop( 'STOP', ctmp1 )
+ ELSE ! default neighbours
+ llsend(:,jf) = mpiSnei(ihls,:) >= 0
+ IF( ll4only ) llsend(5:8,jf) = .FALSE. ! exclude corners
+ llrecv(:,jf) = mpiRnei(ihls,:) >= 0
+ IF( ll4only ) llrecv(5:8,jf) = .FALSE. ! exclude corners
+ ENDIF
+ !
+ ! define ifill: which method should be used to fill each parts (sides+corners) of the halos
+ ! default definition
+ DO jn = 1, 8
+ IF( llrecv(jn,jf) ) THEN ; ifill(jn,jf) = jpfillmpi ! with an mpi communication
+ ELSEIF( l_SelfPerio(jn) ) THEN ; ifill(jn,jf) = jpfillperio ! with self-periodicity
+ ELSEIF( PRESENT(kfillmode) ) THEN ; ifill(jn,jf) = kfillmode ! localy defined
+ ELSEIF( ihls == 0 ) THEN ; ifill(jn,jf) = jpfillnothing ! do nothing
+ ELSE ; ifill(jn,jf) = jpfillcst ! constant value (zland)
+ ENDIF
+ END DO
+ ! take care of "indirect self-periodicity" for the corners
+ DO jn = 5, 8
+ IF(.NOT.l_SelfPerio(jn) .AND. l_SelfPerio(jpwe)) ifill(jn,jf) = jpfillnothing ! no bi-perio but ew-perio: do corners later
+ IF(.NOT.l_SelfPerio(jn) .AND. l_SelfPerio(jpso)) ifill(jn,jf) = jpfillnothing ! no bi-perio but ns-perio: do corners later
+ END DO
+ ! north fold treatment
+ IF( l_IdoNFold ) ifill(jpno,jf) = jpfillnothing ! we do north fold -> do nothing for northern halo
+
+ ! We first define the localization and size of the parts of the array that will be sent (s), received (r)
+ ! or used for periodocity (p). The localization is defined as "the bottom left corner - 1" in i and j directions.
+ ! This is a shift that will be applied later in the do loops to pick-up the appropriate part of the array
+ !
+ ! all definitions bellow do not refer to N[ij][se]0 so we can use it with any local value of ihls
+ ! ! ________________________
+ ip0i = 0 ! im0j = inner |__|________________|__|
+ ip1i = ihls ! im1j = inner - halo | |__|__________|__| |
+ im1i = ipi(jf)-2*ihls ! | | | | | |
+ im0i = ipi(jf) - ihls ! | | | | | |
+ ip0j = 0 ! | | | | | |
+ ip1j = ihls ! | |__|__________|__| |
+ im1j = ipj(jf)-2*ihls ! ip1j = halo |__|__|__________|__|__|
+ im0j = ipj(jf) - ihls ! ip0j = 0 |__|________________|__|
+ ! ! ip0i ip1i im1i im0i
+ !
+ iwewe(:) = (/ jpwe,jpea,jpwe,jpea /) ; issnn(:) = (/ jpso,jpso,jpno,jpno /)
+ ! sides: west east south north ; corners: so-we, so-ea, no-we, no-ea
+ isizei(1:4,jf) = (/ ihls, ihls, Ni_0, Ni_0 /) ; isizei(5:8,jf) = ihls ! i- count
+ isizej(1:4,jf) = (/ Nj_0, Nj_0, ihls, ihls /) ; isizej(5:8,jf) = ihls ! j- count
+ ishtSi(1:4,jf) = (/ ip1i, im1i, ip1i, ip1i /) ; ishtSi(5:8,jf) = ishtSi( iwewe,jf ) ! i- shift send data
+ ishtSj(1:4,jf) = (/ ip1j, ip1j, ip1j, im1j /) ; ishtSj(5:8,jf) = ishtSj( issnn,jf ) ! j- shift send data
+ ishtRi(1:4,jf) = (/ ip0i, im0i, ip1i, ip1i /) ; ishtRi(5:8,jf) = ishtRi( iwewe,jf ) ! i- shift recv data
+ ishtRj(1:4,jf) = (/ ip1j, ip1j, ip0j, im0j /) ; ishtRj(5:8,jf) = ishtRj( issnn,jf ) ! j- shift recv data
+ ishtPi(1:4,jf) = (/ im1i, ip1i, ip1i, ip1i /) ; ishtPi(5:8,jf) = ishtPi( iwewe,jf ) ! i- shift perio data
+ ishtPj(1:4,jf) = (/ ip1j, ip1j, im1j, ip1j /) ; ishtPj(5:8,jf) = ishtPj( issnn,jf ) ! j- shift perio data
+ !
+ END DO ! jf
!
- iwewe(:) = (/ jpwe,jpea,jpwe,jpea /) ; issnn(:) = (/ jpso,jpso,jpno,jpno /)
- ! sides: west east south north ; corners: so-we, so-ea, no-we, no-ea
- isizei(1:4) = (/ ihls, ihls, Ni_0, Ni_0 /) ; isizei(5:8) = ihls ! i- count
- isizej(1:4) = (/ Nj_0, Nj_0, ihls, ihls /) ; isizej(5:8) = ihls ! j- count
- ishtSi(1:4) = (/ ip1i, im1i, ip1i, ip1i /) ; ishtSi(5:8) = ishtSi( iwewe ) ! i- shift send data
- ishtSj(1:4) = (/ ip1j, ip1j, ip1j, im1j /) ; ishtSj(5:8) = ishtSj( issnn ) ! j- shift send data
- ishtRi(1:4) = (/ ip0i, im0i, ip1i, ip1i /) ; ishtRi(5:8) = ishtRi( iwewe ) ! i- shift received data location
- ishtRj(1:4) = (/ ip1j, ip1j, ip0j, im0j /) ; ishtRj(5:8) = ishtRj( issnn ) ! j- shift received data location
- ishtPi(1:4) = (/ im1i, ip1i, ip1i, ip1i /) ; ishtPi(5:8) = ishtPi( iwewe ) ! i- shift data used for periodicity
- ishtPj(1:4) = (/ ip1j, ip1j, im1j, ip1j /) ; ishtPj(5:8) = ishtPj( issnn ) ! j- shift data used for periodicity
+ IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, SUM(ipk(:))/kfld, SUM(ipl(:))/kfld, kfld, ld_lbc = .TRUE. )
!
! -------------------------------- !
! 2. Prepare MPI exchanges !
! -------------------------------- !
!
! Allocate local temporary arrays to be sent/received.
- iszS = COUNT( llsend )
- iszR = COUNT( llrecv )
- ALLOCATE( iScnt(iszS), iRcnt(iszR), iSdpl(iszS), iRdpl(iszR) ) ! ok if iszS = 0 or iszR = 0
- iszall(:) = isizei(:) * isizej(:) * ipk * ipl * ipf
- iScnt(:) = PACK( iszall, mask = llsend ) ! ok if mask = .false.
- iRcnt(:) = PACK( iszall, mask = llrecv )
- IF( iszS > 0 ) iSdpl(1) = 0
- DO jn = 2,iszS
+ inbS = COUNT( ANY(llsend,dim=2) ) ! number of snd neighbourgs
+ inbR = COUNT( ANY(llrecv,dim=2) ) ! number of rcv neighbourgs
+ ALLOCATE( iScnt(inbS), iRcnt(inbR), iSdpl(inbS), iRdpl(inbR) ) ! ok if iszS = 0 or iszR = 0
+
+ iScnt(:) = 0 ; idx = 0
+ DO jn = 1, 8
+ IF( COUNT( llsend(jn,:) ) > 0 ) THEN ! we send something to neighbourg jn
+ idx = idx + 1
+ DO jf = 1, kfld
+ IF( llsend(jn,jf) ) iScnt(idx) = iScnt(idx) + isizei(jn,jf) * isizej(jn,jf) * ipk(jf) * ipl(jf)
+ END DO
+ ENDIF
+ END DO
+ IF( inbS > 0 ) iSdpl(1) = 0
+ DO jn = 2,inbS
iSdpl(jn) = iSdpl(jn-1) + iScnt(jn-1) ! with _alltoallv: in units of sendtype
END DO
- IF( iszR > 0 ) iRdpl(1) = 0
- DO jn = 2,iszR
+
+ iRcnt(:) = 0 ; idx = 0
+ DO jn = 1, 8
+ IF( COUNT( llrecv(jn,:) ) > 0 ) THEN ! we get something from neighbourg jn
+ idx = idx + 1
+ DO jf = 1, kfld
+ IF( llrecv(jn,jf) ) iRcnt(idx) = iRcnt(idx) + isizei(jn,jf) * isizej(jn,jf) * ipk(jf) * ipl(jf)
+ END DO
+ ENDIF
+ END DO
+ IF( inbR > 0 ) iRdpl(1) = 0
+ DO jn = 2,inbR
iRdpl(jn) = iRdpl(jn-1) + iRcnt(jn-1) ! with _alltoallv: in units of sendtype
END DO
-
+ !
! Allocate buffer arrays to be sent/received if needed
- iszS = SUM(iszall, mask = llsend) ! send buffer size
+ iszS = SUM(iScnt) ! send buffer size
IF( ALLOCATED(BUFFSND) ) THEN
+ CALL mpi_waitall(8, nreq_p2p, MPI_STATUSES_IGNORE, ierr) ! needed only if PREVIOUS call was using nn_comm = 1 (for tests)
IF( SIZE(BUFFSND) < iszS ) DEALLOCATE(BUFFSND) ! send buffer is too small
ENDIF
IF( .NOT. ALLOCATED(BUFFSND) ) ALLOCATE( BUFFSND(iszS) )
- iszR = SUM(iszall, mask = llrecv) ! recv buffer size
+ iszR = SUM(iRcnt) ! recv buffer size
IF( ALLOCATED(BUFFRCV) ) THEN
IF( SIZE(BUFFRCV) < iszR ) DEALLOCATE(BUFFRCV) ! recv buffer is too small
ENDIF
IF( .NOT. ALLOCATED(BUFFRCV) ) ALLOCATE( BUFFRCV(iszR) )
-
+ !
! fill sending buffer with ptab(jf)%pt4d
- idx = 1
+ idx = 0
DO jn = 1, 8
- IF( llsend(jn) ) THEN
- ishti = ishtSi(jn)
- ishtj = ishtSj(jn)
- DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn)
- BUFFSND(idx) = ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl)
- idx = idx + 1
- END DO ; END DO ; END DO ; END DO ; END DO
- ENDIF
+ DO jf = 1, kfld
+ IF( llsend(jn,jf) ) THEN
+ ishti = ishtSi(jn,jf)
+ ishtj = ishtSj(jn,jf)
+ DO jl = 1, ipl(jf) ; DO jk = 1, ipk(jf) ; DO jj = 1,isizej(jn,jf) ; DO ji = 1,isizei(jn,jf)
+ idx = idx + 1
+ BUFFSND(idx) = ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl)
+ END DO ; END DO ; END DO ; END DO
+ ENDIF
+ END DO
END DO
!
! ------------------------------------------------ !
! 3. Do all MPI exchanges in 1 unique call !
! ------------------------------------------------ !
!
- IF( ln_timing ) CALL tic_tac(.TRUE.)
- CALL mpi_neighbor_alltoallv (BUFFSND, iScnt, iSdpl, MPI_TYPE, BUFFRCV, iRcnt, iRdpl, MPI_TYPE, impi_nc, ierr)
- IF( ln_timing ) CALL tic_tac(.FALSE.)
+ IF( ihlsmax > 0 ) THEN
+ impi_nc = mpi_nc_com8( ihlsmax )
+ IF( ll4only ) impi_nc = mpi_nc_com4( ihlsmax )
+#if ! defined key_mpi2
+ IF( ln_timing ) CALL tic_tac( .TRUE.)
+ CALL mpi_Ineighbor_alltoallv(BUFFSND, iScnt, iSdpl, MPI_TYPE, BUFFRCV, iRcnt, iRdpl, MPI_TYPE, impi_nc, nreq_nei, ierr)
+ IF( ln_timing ) CALL tic_tac(.FALSE.)
+#endif
+ ENDIF
+ nreq_p2p = MPI_REQUEST_NULL ! needed only if we switch between nn_comm = 1 and 2 (for tests)
!
- ! ------------------------- !
- ! 4. Fill all halos !
- ! ------------------------- !
+ ! --------------------------------- !
+ ! 4. Fill all Non-MPI halos !
+ ! --------------------------------- !
!
- idx = 1
- ! MPI3 bug fix when domain decomposition has 2 columns/rows
- IF (jpni .eq. 2) THEN
- IF (jpnj .eq. 2) THEN
+ ! do it first to give (potentially) more time for the communications
+ DO jn = 1, 8
+ DO jf = 1, kfld
+ !
+ IF( ifill(jn,jf) == jpfillcst ) THEN
+ !
+ ishti = ishtRi(jn,jf)
+ ishtj = ishtRj(jn,jf)
+ DO jl = 1, ipl(jf) ; DO jk = 1, ipk(jf) ; DO jj = 1,isizej(jn,jf) ; DO ji = 1,isizei(jn,jf)
+ ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = zland
+ END DO ; END DO ; END DO ; END DO
+ !
+ ELSEIF( ifill(jn,jf) == jpfillperio .OR. ifill(jn,jf) == jpfillcopy ) THEN
+ !
+ IF( jn == jpwe .OR. jn == jpsw .OR. jn == jpnw ) THEN ! western side
+ ishti1 = ishtSi(jpwe,jf) + 1 ; isgni1 = -1
+ IF( ifill(jn,jf) == jpfillperio ) THEN ; ishti2 = ishtRi(jpea,jf) + 1 ; isgni2 = -1
+ ELSE ; ishti2 = ishtSi(jpwe,jf) ; isgni2 = 1
+ ENDIF
+ ELSEIF( jn == jpea .OR. jn == jpse .OR. jn == jpne ) THEN ! eastern side
+ ishti1 = ishtRi(jpea,jf) ; isgni1 = 1
+ IF( ifill(jn,jf) == jpfillperio ) THEN ; ishti2 = ishtSi(jpwe,jf) ; isgni2 = 1
+ ELSE ; ishti2 = ishtRi(jpea,jf) + 1 ; isgni2 = -1
+ ENDIF
+ ELSE ! southern/northern side
+ ishti1 = ishtRi(jn,jf) ; isgni1 = 1
+ ishti2 = ishtSi(jn,jf) ; isgni2 = 1
+ ENDIF
+ IF( jn == jpso .OR. jn == jpsw .OR. jn == jpse ) THEN ! southern side
+ ishtj1 = ishtSj(jpso,jf) + 1 ; isgnj1 = -1
+ IF( ifill(jn,jf) == jpfillperio ) THEN ; ishtj2 = ishtRj(jpno,jf) + 1 ; isgnj2 = -1
+ ELSE ; ishtj2 = ishtSj(jpso,jf) ; isgnj2 = 1
+ ENDIF
+ ELSEIF( jn == jpno .OR. jn == jpnw .OR. jn == jpne ) THEN ! northern side
+ ishtj1 = ishtRj(jpno,jf) ; isgnj1 = 1
+ IF( ifill(jn,jf) == jpfillperio ) THEN ; ishtj2 = ishtSj(jpso,jf) ; isgnj2 = 1
+ ELSE ; ishtj2 = ishtRj(jpno,jf) + 1 ; isgnj2 = -1
+ ENDIF
+ ELSE ! western/eastern side
+ ishtj1 = ishtRj(jn,jf) ; isgnj1 = 1
+ ishtj2 = ishtSj(jn,jf) ; isgnj2 = 1
+ ENDIF
+ !
+ DO jl = 1, ipl(jf) ; DO jk = 1, ipk(jf) ; DO jj = 1,isizej(jn,jf) ; DO ji = 1,isizei(jn,jf)
+ ii1 = ishti1 + ji * isgni1
+ ij1 = ishtj1 + jj * isgnj1
+ ii2 = ishti2 + ( MOD(ji-1, Ni_0) + 1 ) * isgni2 ! warning: Ni_0 my be smaller than isizei(jn,jf)
+ ij2 = ishtj2 + ( MOD(jj-1, Nj_0) + 1 ) * isgnj2 ! warning: Nj_0 my be smaller than isizej(jn,jf)
+ ptab(jf)%pt4d(ii1,ij1,jk,jl) = ptab(jf)%pt4d(ii2,ij2,jk,jl)
+ END DO ; END DO ; END DO ; END DO
+ !
+!!$ ELSEIF( ifill(jn,jf) == jpfillnothing ) THEN ! no filling
+!!$ ELSEIF( ifill(jn,jf) == jpfillmpi ) THEN ! do it later
+ ENDIF
+ END DO ! jf
+ END DO ! jn
+ !
+ ! ----------------------------- !
+ ! 5. Fill all MPI halos !
+ ! ----------------------------- !
+ !
+ CALL mpi_wait( nreq_nei, MPI_STATUS_IGNORE, ierr )
+ !
+ ! --------------------------------------------------------- !
+ ! MPI3 bug fix when domain decomposition has 2 columns/rows !
+ ! --------------------------------------------------------- !
+ !
+ IF( jpni == 2 ) THEN
+ IF( jpnj == 2 ) THEN
jnf(1:8) = (/ 2, 1, 4, 3, 8, 7, 6, 5 /)
ELSE
jnf(1:8) = (/ 2, 1, 3, 4, 6, 5, 8, 7 /)
ENDIF
ELSE
- IF (jpnj .eq. 2) THEN
+ IF( jpnj == 2 ) THEN
jnf(1:8) = (/ 1, 2, 4, 3, 7, 8, 5, 6 /)
ELSE
jnf(1:8) = (/ 1, 2, 3, 4, 5, 6, 7, 8 /)
ENDIF
ENDIF
-
+ !
+ idx = 0
DO jn = 1, 8
- ishti = ishtRi(jnf(jn))
- ishtj = ishtRj(jnf(jn))
- SELECT CASE ( ifill(jnf(jn)) )
- CASE ( jpfillnothing ) ! no filling
- CASE ( jpfillmpi ) ! fill with data received by MPI
- DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jnf(jn)) ; DO ji = 1,isizei(jnf(jn))
- ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = BUFFRCV(idx)
- idx = idx + 1
- END DO ; END DO ; END DO ; END DO ; END DO
- CASE ( jpfillperio ) ! use periodicity
- ishti2 = ishtPi(jnf(jn))
- ishtj2 = ishtPj(jnf(jn))
- DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jnf(jn)) ; DO ji = 1,isizei(jnf(jn))
- ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = ptab(jf)%pt4d(ishti2+ji,ishtj2+jj,jk,jl)
- END DO ; END DO ; END DO ; END DO ; END DO
- CASE ( jpfillcopy ) ! filling with inner domain values
- ishti2 = ishtSi(jnf(jn))
- ishtj2 = ishtSj(jnf(jn))
- DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jnf(jn)) ; DO ji = 1,isizei(jnf(jn))
- ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = ptab(jf)%pt4d(ishti2+ji,ishtj2+jj,jk,jl)
- END DO ; END DO ; END DO ; END DO ; END DO
- CASE ( jpfillcst ) ! filling with constant value
- DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jnf(jn)) ; DO ji = 1,isizei(jnf(jn))
- ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = zland
- END DO ; END DO ; END DO ; END DO ; END DO
- END SELECT
+ DO jf = 1, kfld
+ IF( ifill(jnf(jn),jf) == jpfillmpi ) THEN ! fill with data received by MPI
+ ishti = ishtRi(jnf(jn),jf)
+ ishtj = ishtRj(jnf(jn),jf)
+ DO jl = 1, ipl(jf) ; DO jk = 1, ipk(jf) ; DO jj = 1,isizej(jnf(jn),jf) ; DO ji = 1,isizei(jnf(jn),jf)
+ idx = idx + 1
+ ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = BUFFRCV(idx)
+ END DO; END DO ; END DO ; END DO
+ ENDIF
+ END DO
END DO
DEALLOCATE( iScnt, iRcnt, iSdpl, iRdpl )
IF( iszS > jpi*jpj ) DEALLOCATE(BUFFSND) ! blocking Send -> can directly deallocate
IF( iszR > jpi*jpj ) DEALLOCATE(BUFFRCV) ! blocking Recv -> can directly deallocate
-
- ! potential "indirect self-periodicity" for the corners
+ !
+ ! ---------------------------------------------------------------- !
+ ! 6. Potential "indirect self-periodicity" for the corners !
+ ! ---------------------------------------------------------------- !
+ !
DO jn = 5, 8
IF( .NOT. l_SelfPerio(jn) .AND. l_SelfPerio(jpwe) ) THEN ! no bi-perio but ew-perio: corners indirect definition
- ishti = ishtRi(jn)
- ishtj = ishtRj(jn)
- ishti2 = ishtPi(jn) ! use i- shift periodicity
- ishtj2 = ishtRj(jn) ! use j- shift recv location: use ew-perio -> ok as filling of the south and north halos now done
- DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn)
- ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = ptab(jf)%pt4d(ishti2+ji,ishtj2+jj,jk,jl)
- END DO ; END DO ; END DO ; END DO ; END DO
+ DO jf = 1, kfld
+ ishti = ishtRi(jn,jf)
+ ishtj = ishtRj(jn,jf)
+ ishti2 = ishtPi(jn,jf) ! use i- shift periodicity
+ ishtj2 = ishtRj(jn,jf) ! use j- shift recv location: use ew-perio -> ok as filling of the so and no halos now done
+ DO jl = 1, ipl(jf) ; DO jk = 1, ipk(jf) ; DO jj = 1,isizej(jn,jf) ; DO ji = 1,isizei(jn,jf)
+ ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = ptab(jf)%pt4d(ishti2+ji,ishtj2+jj,jk,jl)
+ END DO ; END DO ; END DO ; END DO
+ END DO
ENDIF
IF( .NOT. l_SelfPerio(jn) .AND. l_SelfPerio(jpso) ) THEN ! no bi-perio but ns-perio: corners indirect definition
- ishti = ishtRi(jn)
- ishtj = ishtRj(jn)
- ishti2 = ishtRi(jn) ! use i- shift recv location: use ns-perio -> ok as filling of the west and east halos now done
- ishtj2 = ishtPj(jn) ! use j- shift periodicity
- DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn)
- ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = ptab(jf)%pt4d(ishti2+ji,ishtj2+jj,jk,jl)
- END DO ; END DO ; END DO ; END DO ; END DO
+ DO jf = 1, kfld
+ ishti = ishtRi(jn,jf)
+ ishtj = ishtRj(jn,jf)
+ ishti2 = ishtRi(jn,jf) ! use i- shift recv location: use ns-perio -> ok as filling of the we and ea halos now done
+ ishtj2 = ishtPj(jn,jf) ! use j- shift periodicity
+ DO jl = 1, ipl(jf) ; DO jk = 1, ipk(jf) ; DO jj = 1,isizej(jn,jf) ; DO ji = 1,isizei(jn,jf)
+ ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = ptab(jf)%pt4d(ishti2+ji,ishtj2+jj,jk,jl)
+ END DO ; END DO ; END DO ; END DO
+ END DO
ENDIF
END DO
!
! ------------------------------- !
- ! 5. north fold treatment !
+ ! 7. north fold treatment !
! ------------------------------- !
!
IF( l_IdoNFold ) THEN
- IF( jpni == 1 ) THEN ; CALL lbc_nfd( ptab, cd_nat, psgn , ihls, ipf ) ! self NFold
- ELSE ; CALL mpp_nfd( ptab, cd_nat, psgn, ifill_nfd, zland, ihls, ipf ) ! mpi NFold
+ IF( jpni == 1 ) THEN ; CALL lbc_nfd( ptab, cd_nat, psgn , kfld ) ! self NFold
+ ELSE ; CALL mpp_nfd( ptab, cd_nat, psgn, ifill_nfd, zland, kfld, ldfull ) ! mpi NFold
ENDIF
ENDIF
!
diff --git a/src/OCE/LBC/lbc_lnk_pt2pt_generic.h90 b/src/OCE/LBC/lbc_lnk_pt2pt_generic.h90
index 395a3e93c037cf53ac82eb911726c24926168d3b..118aa5c54198b7cc56a307f87edd439f8486279d 100644
--- a/src/OCE/LBC/lbc_lnk_pt2pt_generic.h90
+++ b/src/OCE/LBC/lbc_lnk_pt2pt_generic.h90
@@ -1,6 +1,6 @@
-#if ! defined BLOCK_ISEND && ! defined BLOCK_FILL
- SUBROUTINE lbc_lnk_pt2pt_/**/PRECISION( cdname, ptab, cd_nat, psgn, kfld, kfillmode, pfillval, khls, lsend, lrecv, ld4only )
+#if ! defined BLOCK_ISEND && ! defined BLOCK_FILL_nonMPI && ! defined BLOCK_FILL_MPI_RECV
+ SUBROUTINE lbc_lnk_pt2pt_/**/PRECISION( cdname, ptab, cd_nat, psgn, kfld, kfillmode, pfillval, lsend, lrecv, ld4only, ldfull )
CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine
TYPE(PTR_4d_/**/PRECISION), DIMENSION(:), INTENT(inout) :: ptab ! pointer of arrays on which apply the b.c.
CHARACTER(len=1), DIMENSION(:), INTENT(in ) :: cd_nat ! nature of array grid-points
@@ -8,161 +8,186 @@
INTEGER , INTENT(in ) :: kfld ! number of pt3d arrays
INTEGER , OPTIONAL, INTENT(in ) :: kfillmode ! filling method for halo over land (default = constant)
REAL(PRECISION), OPTIONAL, INTENT(in ) :: pfillval ! background value (used at closed boundaries)
- INTEGER , OPTIONAL, INTENT(in ) :: khls ! halo size, default = nn_hls
LOGICAL, DIMENSION(8),OPTIONAL, INTENT(in ) :: lsend, lrecv ! communication with other 4 proc
LOGICAL, OPTIONAL, INTENT(in ) :: ld4only ! if .T., do only 4-neighbour comm (ignore corners)
+ LOGICAL , OPTIONAL, INTENT(in ) :: ldfull ! .true. if we also update the last line of the inner domain
!
INTEGER :: ji, jj, jk, jl, jf, jn ! dummy loop indices
- INTEGER :: ipi, ipj, ipk, ipl, ipf ! dimension of the input array
INTEGER :: ip0i, ip1i, im0i, im1i
INTEGER :: ip0j, ip1j, im0j, im1j
- INTEGER :: ishti, ishtj, ishti2, ishtj2
+ INTEGER :: ishti, ishtj, ishti1, ishtj1, ishti2, ishtj2
+ INTEGER :: isgni1, isgni2, isgnj1, isgnj2
+ INTEGER :: ii1, ii2, ij1, ij2
INTEGER :: ifill_nfd, icomm, ierr
- INTEGER :: ihls, idxs, idxr, iszS, iszR
+ INTEGER :: ihls, iisz
+ INTEGER :: idxs, idxr, iszS, iszR
INTEGER, DIMENSION(4) :: iwewe, issnn
- INTEGER, DIMENSION(8) :: isizei, ishtSi, ishtRi, ishtPi
- INTEGER, DIMENSION(8) :: isizej, ishtSj, ishtRj, ishtPj
- INTEGER, DIMENSION(8) :: ifill, iszall, ishtS, ishtR
- INTEGER, DIMENSION(8) :: ireq ! mpi_request id
+ INTEGER, DIMENSION(8) :: ibufszS, ibufszR, ishtS, ishtR
INTEGER, DIMENSION(8) :: iStag, iRtag ! Send and Recv mpi_tag id
- REAL(PRECISION) :: zland
- LOGICAL, DIMENSION(8) :: llsend, llrecv
+ INTEGER, DIMENSION( kfld) :: ipi, ipj, ipk, ipl ! dimension of the input array
+ INTEGER, DIMENSION(8,kfld) :: ifill
+ INTEGER, DIMENSION(8,kfld) :: isizei, ishtSi, ishtRi
+ INTEGER, DIMENSION(8,kfld) :: isizej, ishtSj, ishtRj
+ LOGICAL, DIMENSION(8,kfld) :: llsend, llrecv
LOGICAL :: ll4only ! default: 8 neighbourgs
+ REAL(PRECISION) :: zland
!!----------------------------------------------------------------------
!
! ----------------------------------------- !
! 1. local variables initialization !
! ----------------------------------------- !
!
- ipi = SIZE(ptab(1)%pt4d,1)
- ipj = SIZE(ptab(1)%pt4d,2)
- ipk = SIZE(ptab(1)%pt4d,3)
- ipl = SIZE(ptab(1)%pt4d,4)
- ipf = kfld
- !
- IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, ipk, ipl, ipf, ld_lbc = .TRUE. )
- !
idxs = 1 ! initalize index for send buffer
idxr = 1 ! initalize index for recv buffer
icomm = mpi_comm_oce ! shorter name
!
! take care of optional parameters
!
- ihls = nn_hls ! default definition
- IF( PRESENT( khls ) ) ihls = khls
- IF( ihls > n_hlsmax ) THEN
- WRITE(ctmp1,*) TRIM(cdname), ' is calling lbc_lnk with khls > n_hlsmax : ', khls, '>', n_hlsmax
- CALL ctl_stop( 'STOP', ctmp1 )
- ENDIF
- IF( ipi /= Ni_0+2*ihls ) THEN
- WRITE(ctmp1,*) TRIM(cdname), ' is calling lbc_lnk with an input array which does not match ihls along i: ', ipi, ihls, Ni_0
- CALL ctl_stop( 'STOP', ctmp1 )
- ENDIF
- IF( ipj /= Nj_0+2*ihls ) THEN
- WRITE(ctmp1,*) TRIM(cdname), ' is calling lbc_lnk with an input array which does not match ihls along j:', ipj, ihls , Nj_0
- CALL ctl_stop( 'STOP', ctmp1 )
- ENDIF
- !
- ll4only = .FALSE. ! default definition
- IF( PRESENT(ld4only) ) ll4only = ld4only
+ ll4only = .FALSE. ! default definition
+ IF( PRESENT( ld4only ) ) ll4only = ld4only
!
zland = 0._wp ! land filling value: zero by default
- IF( PRESENT( pfillval ) ) zland = pfillval ! set land value
+ IF( PRESENT( pfillval) ) zland = pfillval ! set land value
!
- ! define llsend and llrecv: logicals which say if mpi-neibourgs for send or receive exist or not.
- IF ( PRESENT(lsend) .AND. PRESENT(lrecv) ) THEN ! localy defined neighbourgs
- llsend(:) = lsend(:) ; llrecv(:) = lrecv(:)
- ELSE IF( PRESENT(lsend) .OR. PRESENT(lrecv) ) THEN
- WRITE(ctmp1,*) TRIM(cdname), ' is calling lbc_lnk with only one of the two arguments lsend or lrecv'
- CALL ctl_stop( 'STOP', ctmp1 )
- ELSE ! default neighbours
- llsend(:) = mpiSnei(ihls,:) >= 0
- IF( ll4only ) llsend(5:8) = .FALSE. ! exclude corners
- llrecv(:) = mpiRnei(ihls,:) >= 0
- IF( ll4only ) llrecv(5:8) = .FALSE. ! exclude corners
- ENDIF
+ ifill_nfd = jpfillcst ! default definition
+ IF( PRESENT(kfillmode) ) ifill_nfd = kfillmode
!
- ! define ifill: which method should be used to fill each parts (sides+corners) of the halos
- ! default definition
- DO jn = 1, 4
- IF( llrecv(jn) ) THEN ; ifill(jn) = jpfillmpi ! with an mpi communication
- ELSEIF( l_SelfPerio(jn) ) THEN ; ifill(jn) = jpfillperio ! with self-periodicity
- ELSEIF( PRESENT(kfillmode) ) THEN ; ifill(jn) = kfillmode ! localy defined
- ELSE ; ifill(jn) = jpfillcst ! constant value (zland)
+ DO jf = 1, kfld
+ !
+ ipi(jf) = SIZE(ptab(jf)%pt4d,1)
+ ipj(jf) = SIZE(ptab(jf)%pt4d,2)
+ ipk(jf) = SIZE(ptab(jf)%pt4d,3)
+ ipl(jf) = SIZE(ptab(jf)%pt4d,4)
+ ihls = ( ipi(jf) - Ni_0 ) / 2
+ !
+ IF( numcom == -1 ) THEN ! test input array shape. Use numcom to do these tests only at the beginning of the run
+ IF( MOD( ipi(jf) - Ni_0, 2 ) /= 0 ) THEN
+ WRITE(ctmp1,*) TRIM(cdname), ' is calling lbc_lnk but the ', jf,'th input array has wong i-size: ', ipi(jf), Ni_0
+ CALL ctl_stop( 'STOP', ctmp1 )
+ ENDIF
+ IF( MOD( ipj(jf) - Nj_0, 2 ) /= 0 ) THEN
+ WRITE(ctmp1,*) TRIM(cdname), ' is calling lbc_lnk but the ', jf,'th input array has wong j-size: ', ipj(jf), Nj_0
+ CALL ctl_stop( 'STOP', ctmp1 )
+ ENDIF
+ IF( ( ipj(jf) - Nj_0 ) / 2 /= ihls ) THEN
+ WRITE(ctmp1,*) TRIM(cdname), ' is calling lbc_lnk but the ', jf,'th input array as wong i and j-size: ', &
+ & ipi(jf), Ni_0, ipj(jf), Nj_0
+ CALL ctl_stop( 'STOP', ctmp1 )
+ ENDIF
+ IF( ihls > n_hlsmax ) THEN
+ WRITE(ctmp1,*) TRIM(cdname), ' is calling lbc_lnk but for the ', jf,'th input array, ', ihls, ' > n_hlsmax = ', &
+ & n_hlsmax
+ CALL ctl_stop( 'STOP', ctmp1 )
+ ENDIF
ENDIF
- END DO
- DO jn = 5, 8
- IF( llrecv(jn) ) THEN ; ifill(jn) = jpfillmpi ! with an mpi communication
- ELSE ; ifill(jn) = jpfillnothing! do nothing
+ !
+ ! define llsend and llrecv: logicals which say if mpi-neibourgs for send or receive exist or not.
+ IF ( PRESENT(lsend) .AND. PRESENT(lrecv) ) THEN ! localy defined neighbourgs
+ llsend(:,jf) = lsend(:) ; llrecv(:,jf) = lrecv(:)
+ ELSE IF( PRESENT(lsend) .OR. PRESENT(lrecv) ) THEN
+ WRITE(ctmp1,*) TRIM(cdname), ' is calling lbc_lnk with only one of the two arguments lsend or lrecv'
+ CALL ctl_stop( 'STOP', ctmp1 )
+ ELSE ! default neighbours
+ llsend(:,jf) = mpiSnei(ihls,:) >= 0
+ IF( ll4only ) llsend(5:8,jf) = .FALSE. ! exclude corners
+ llrecv(:,jf) = mpiRnei(ihls,:) >= 0
+ IF( ll4only ) llrecv(5:8,jf) = .FALSE. ! exclude corners
ENDIF
- END DO
!
- ! north fold treatment
- IF( l_IdoNFold ) THEN
- ifill_nfd = ifill(jpno) ! if we are here, this means llrecv(jpno) = .false. and l_SelfPerio(jpno) = .false.
- ifill( (/jpno/) ) = jpfillnothing ! we do north fold -> do nothing for northern halo
- ENDIF
-
- ! We first define the localization and size of the parts of the array that will be sent (s), received (r)
- ! or used for periodocity (p). The localization is defined as "the bottom left corner - 1" in i and j directions.
- ! This is a shift that will be applied later in the do loops to pick-up the appropriate part of the array
- !
- ! all definitions bellow do not refer to N[ij][se]0 so we can use it with any local value of ihls
- ! ! ________________________
- ip0i = 0 ! im0j = inner |__|__|__________|__|__|
- ip1i = ihls ! im1j = inner - halo |__|__|__________|__|__|
- im1i = ipi-2*ihls ! | | | | | |
- im0i = ipi - ihls ! | | | | | |
- ip0j = 0 ! | | | | | |
- ip1j = ihls ! |__|__|__________|__|__|
- im1j = ipj-2*ihls ! ip1j = halo |__|__|__________|__|__|
- im0j = ipj - ihls ! ip0j = 0 |__|__|__________|__|__|
- ! ! ip0i ip1i im1i im0i
+ ! define ifill: which method should be used to fill each parts (sides+corners) of the halos
+ ! default definition
+ DO jn = 1, 4 ! 4 sides
+ IF( llrecv(jn,jf) ) THEN ; ifill(jn,jf) = jpfillmpi ! with an mpi communication
+ ELSEIF( l_SelfPerio(jn) ) THEN ; ifill(jn,jf) = jpfillperio ! with self-periodicity
+ ELSEIF( PRESENT(kfillmode) ) THEN ; ifill(jn,jf) = kfillmode ! localy defined
+ ELSEIF( ihls == 0 ) THEN ; ifill(jn,jf) = jpfillnothing ! do nothing
+ ELSE ; ifill(jn,jf) = jpfillcst ! constant value (zland)
+ ENDIF
+ END DO
+ DO jn = 5, 8 ! 4 corners
+ IF( llrecv(jn,jf) ) THEN ; ifill(jn,jf) = jpfillmpi ! with an mpi communication
+ ELSE ; ifill(jn,jf) = jpfillnothing ! do nothing
+ ENDIF
+ END DO
+ !
+ ! north fold treatment
+ IF( l_IdoNFold ) ifill(jpno,jf) = jpfillnothing ! we do north fold -> do nothing for northern halo
+
+ ! We first define the localization and size of the parts of the array that will be sent (s), received (r)
+ ! or used for periodocity (p). The localization is defined as "the bottom left corner - 1" in i and j directions.
+ ! This is a shift that will be applied later in the do loops to pick-up the appropriate part of the array
+ !
+ ! all definitions bellow do not refer to N[ij][se]0 so we can use it with any local value of ihls
+ !
+ ! ! ________________________
+ ip0i = 0 ! im0j = inner |__|__|__________|__|__|
+ ip1i = ihls ! im1j = inner - halo |__|__|__________|__|__|
+ im1i = ipi(jf)-2*ihls ! | | | | | |
+ im0i = ipi(jf) - ihls ! | | | | | |
+ ip0j = 0 ! | | | | | |
+ ip1j = ihls ! |__|__|__________|__|__|
+ im1j = ipj(jf)-2*ihls ! ip1j = halo |__|__|__________|__|__|
+ im0j = ipj(jf) - ihls ! ip0j = 0 |__|__|__________|__|__|
+ ! ! ip0i ip1i im1i im0i
+ !
+ ! define shorter names...
+ iwewe(:) = (/ jpwe,jpea,jpwe,jpea /) ; issnn(:) = (/ jpso,jpso,jpno,jpno /)
+ iisz = ipi(jf)
+ ! sides: west east south north ; corners: so-we, so-ea, no-we, no-ea
+ isizei(1:4,jf) = (/ ihls, ihls, iisz, iisz /) ; isizei(5:8,jf) = ihls ! i- count
+ isizej(1:4,jf) = (/ Nj_0, Nj_0, ihls, ihls /) ; isizej(5:8,jf) = ihls ! j- count
+ ishtSi(1:4,jf) = (/ ip1i, im1i, ip0i, ip0i /) ; ishtSi(5:8,jf) = ishtSi( iwewe,jf ) ! i- shift send data
+ ishtSj(1:4,jf) = (/ ip1j, ip1j, ip1j, im1j /) ; ishtSj(5:8,jf) = ishtSj( issnn,jf ) ! j- shift send data
+ ishtRi(1:4,jf) = (/ ip0i, im0i, ip0i, ip0i /) ; ishtRi(5:8,jf) = ishtRi( iwewe,jf ) ! i- shift recv data
+ ishtRj(1:4,jf) = (/ ip1j, ip1j, ip0j, im0j /) ; ishtRj(5:8,jf) = ishtRj( issnn,jf ) ! j- shift recv data
+ !
+ END DO ! jf
!
- iwewe(:) = (/ jpwe,jpea,jpwe,jpea /) ; issnn(:) = (/ jpso,jpso,jpno,jpno /)
- ! sides: west east south north ; corners: so-we, so-ea, no-we, no-ea
- isizei(1:4) = (/ ihls, ihls, ipi, ipi /) ; isizei(5:8) = ihls ! i- count
- isizej(1:4) = (/ Nj_0, Nj_0, ihls, ihls /) ; isizej(5:8) = ihls ! j- count
- ishtSi(1:4) = (/ ip1i, im1i, ip0i, ip0i /) ; ishtSi(5:8) = ishtSi( iwewe ) ! i- shift send data
- ishtSj(1:4) = (/ ip1j, ip1j, ip1j, im1j /) ; ishtSj(5:8) = ishtSj( issnn ) ! j- shift send data
- ishtRi(1:4) = (/ ip0i, im0i, ip0i, ip0i /) ; ishtRi(5:8) = ishtRi( iwewe ) ! i- shift received data location
- ishtRj(1:4) = (/ ip1j, ip1j, ip0j, im0j /) ; ishtRj(5:8) = ishtRj( issnn ) ! j- shift received data location
- ishtPi(1:4) = (/ im1i, ip1i, ip0i, ip0i /) ; ishtPi(5:8) = ishtPi( iwewe ) ! i- shift data used for periodicity
- ishtPj(1:4) = (/ ip1j, ip1j, im1j, ip1j /) ; ishtPj(5:8) = ishtPj( issnn ) ! j- shift data used for periodicity
+ IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, SUM(ipk(:))/kfld, SUM(ipl(:))/kfld, kfld, ld_lbc = .TRUE. )
!
! -------------------------------- !
! 2. Prepare MPI exchanges !
! -------------------------------- !
!
- iStag = (/ 1, 2, 3, 4, 5, 6, 7, 8 /) ! any value but each one must be different
+ iStag = (/ 1, 2, 3, 4, 5, 6, 7, 8 /) ! can be any value but each value must be unique
! define iRtag with the corresponding iStag, e.g. data received at west where sent at east.
iRtag(jpwe) = iStag(jpea) ; iRtag(jpea) = iStag(jpwe) ; iRtag(jpso) = iStag(jpno) ; iRtag(jpno) = iStag(jpso)
iRtag(jpsw) = iStag(jpne) ; iRtag(jpse) = iStag(jpnw) ; iRtag(jpnw) = iStag(jpse) ; iRtag(jpne) = iStag(jpsw)
!
- iszall(:) = isizei(:) * isizej(:) * ipk * ipl * ipf
+ ! size of the buffer to be sent/recv in each direction
+ ibufszS(:) = 0 ! defaut definition
+ ibufszR(:) = 0
+ DO jf = 1, kfld
+ DO jn = 1, 8
+ IF( llsend(jn,jf) ) ibufszS(jn) = ibufszS(jn) + isizei(jn,jf) * isizej(jn,jf) * ipk(jf) * ipl(jf)
+ IF( llrecv(jn,jf) ) ibufszR(jn) = ibufszR(jn) + isizei(jn,jf) * isizej(jn,jf) * ipk(jf) * ipl(jf)
+ END DO
+ END DO
+ !
+ ! offset to apply to find the position of the sent/recv data within the buffer
ishtS(1) = 0
DO jn = 2, 8
- ishtS(jn) = ishtS(jn-1) + iszall(jn-1) * COUNT( (/llsend(jn-1)/) )
+ ishtS(jn) = ishtS(jn-1) + ibufszS(jn-1)
END DO
ishtR(1) = 0
DO jn = 2, 8
- ishtR(jn) = ishtR(jn-1) + iszall(jn-1) * COUNT( (/llrecv(jn-1)/) )
+ ishtR(jn) = ishtR(jn-1) + ibufszR(jn-1)
END DO
-
+ !
! Allocate buffer arrays to be sent/received if needed
- iszS = SUM(iszall, mask = llsend) ! send buffer size
+ iszS = SUM(ibufszS) ! send buffer size
IF( ALLOCATED(BUFFSND) ) THEN
CALL mpi_waitall(8, nreq_p2p, MPI_STATUSES_IGNORE, ierr) ! wait for Isend from the PREVIOUS call
IF( SIZE(BUFFSND) < iszS ) DEALLOCATE(BUFFSND) ! send buffer is too small
ENDIF
IF( .NOT. ALLOCATED(BUFFSND) ) ALLOCATE( BUFFSND(iszS) )
- iszR = SUM(iszall, mask = llrecv) ! recv buffer size
+ iszR = SUM(ibufszR) ! recv buffer size
IF( ALLOCATED(BUFFRCV) ) THEN
IF( SIZE(BUFFRCV) < iszR ) DEALLOCATE(BUFFRCV) ! recv buffer is too small
ENDIF
IF( .NOT. ALLOCATED(BUFFRCV) ) ALLOCATE( BUFFRCV(iszR) )
!
- ! default definition when no communication is done. understood by mpi_waitall
+ ! Default definition when no communication is done. Understood by mpi_waitall
nreq_p2p(:) = MPI_REQUEST_NULL ! WARNING: Must be done after the call to mpi_waitall just above
!
! ----------------------------------------------- !
@@ -177,19 +202,28 @@
!
! ----------------------------------- !
! 4. Fill east and west halos !
+ ! Must be done before sending data !
+ ! data to south/north/corners !
! ----------------------------------- !
!
- DO jn = 1, 2
-#define BLOCK_FILL
+ DO jn = 1, 2 ! first: do all the non-MPI filling to give more time to MPI_RECV
+#define BLOCK_FILL_nonMPI
# include "lbc_lnk_pt2pt_generic.h90"
-#undef BLOCK_FILL
+#undef BLOCK_FILL_nonMPI
+ END DO
+ DO jn = 1, 2 ! next: do the MPI_RECV part
+#define BLOCK_FILL_MPI_RECV
+# include "lbc_lnk_pt2pt_generic.h90"
+#undef BLOCK_FILL_MPI_RECV
END DO
!
! ------------------------------------------------- !
! 5. Do north and south MPI_Isend if needed !
+ ! and Specific problem in corner treatment !
+ ! ( very rate case... ) !
! ------------------------------------------------- !
!
- DO jn = 3, 4
+ DO jn = 3, 8
#define BLOCK_ISEND
# include "lbc_lnk_pt2pt_generic.h90"
#undef BLOCK_ISEND
@@ -199,44 +233,34 @@
! 6. north fold treatment !
! ------------------------------- !
!
- ! Must be done after receiving data from East/West neighbourgs (as it is coded in mpp_nfd, to be changed one day...)
- ! Do it after MPI_iSend to south/north neighbourgs so they won't wait (too much) to receive their data
- ! Do if before MPI_Recv from south/north neighbourgs so we have more time to receive data
+ ! Do it after MPI_iSend to south/north/corners neighbourgs so they won't wait (too much) to receive their data
+ ! Do if before MPI_Recv from south/north/corners neighbourgs so we will have more time to receive data
!
IF( l_IdoNFold ) THEN
- IF( jpni == 1 ) THEN ; CALL lbc_nfd( ptab, cd_nat, psgn , ihls, ipf ) ! self NFold
- ELSE ; CALL mpp_nfd( ptab, cd_nat, psgn, ifill_nfd, zland, ihls, ipf ) ! mpi NFold
+ IF( jpni == 1 ) THEN ; CALL lbc_nfd( ptab, cd_nat, psgn , kfld ) ! self NFold
+ ELSE ; CALL mpp_nfd( ptab, cd_nat, psgn, ifill_nfd, zland, kfld, ldfull ) ! mpi NFold
ENDIF
ENDIF
!
- ! ------------------------------------- !
- ! 7. Fill south and north halos !
- ! ------------------------------------- !
- !
- DO jn = 3, 4
-#define BLOCK_FILL
-# include "lbc_lnk_pt2pt_generic.h90"
-#undef BLOCK_FILL
- END DO
- !
- ! ----------------------------------------------- !
- ! 8. Specific problem in corner treatment !
- ! ( very rate case... ) !
- ! ----------------------------------------------- !
+ ! ------------------------------------------------ !
+ ! 7. Fill south and north halos !
+ ! and specific problem in corner treatment !
+ ! ( very rate case... ) !
+ ! ------------------------------------------------ !
!
- DO jn = 5, 8
-#define BLOCK_ISEND
+ DO jn = 3, 8 ! first: do all the non-MPI filling to give more time to MPI_RECV
+#define BLOCK_FILL_nonMPI
# include "lbc_lnk_pt2pt_generic.h90"
-#undef BLOCK_ISEND
+#undef BLOCK_FILL_nonMPI
END DO
- DO jn = 5, 8
-#define BLOCK_FILL
+ DO jn = 3, 8 ! next: do the MPI_RECV part
+#define BLOCK_FILL_MPI_RECV
# include "lbc_lnk_pt2pt_generic.h90"
-#undef BLOCK_FILL
+#undef BLOCK_FILL_MPI_RECV
END DO
!
! -------------------------------------------- !
- ! 9. deallocate local temporary arrays !
+ ! 8. deallocate local temporary arrays !
! if they areg larger than jpi*jpj ! <- arbitrary max size...
! -------------------------------------------- !
!
@@ -250,53 +274,104 @@
#endif
#if defined BLOCK_ISEND
- IF( llsend(jn) ) THEN
- ishti = ishtSi(jn)
- ishtj = ishtSj(jn)
- DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn)
- BUFFSND(idxs) = ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl)
- idxs = idxs + 1
- END DO ; END DO ; END DO ; END DO ; END DO
+ IF( ibufszS(jn) > 0 ) THEN ! we must send some data
+ DO jf = 1, kfld ! first: fill the buffer to be sent
+ IF( llsend(jn,jf) ) THEN
+ ishti = ishtSi(jn,jf)
+ ishtj = ishtSj(jn,jf)
+ DO jl = 1, ipl(jf) ; DO jk = 1, ipk(jf) ; DO jj = 1,isizej(jn,jf) ; DO ji = 1,isizei(jn,jf)
+ BUFFSND(idxs) = ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl)
+ idxs = idxs + 1
+ END DO ; END DO ; END DO ; END DO
+ ENDIF
+ END DO
#if ! defined key_mpi_off
IF( ln_timing ) CALL tic_tac(.TRUE.)
- ! non-blocking send of the west/east side using local buffer
- CALL MPI_ISEND( BUFFSND(ishtS(jn)+1), iszall(jn), MPI_TYPE, mpiSnei(ihls,jn), iStag(jn), icomm, nreq_p2p(jn), ierr )
+ ! next: non-blocking send using local buffer. use mpiSnei(n_hlsmax,jn), see mppini
+ CALL MPI_ISEND( BUFFSND(ishtS(jn)+1), ibufszS(jn), MPI_TYPE, mpiSnei(n_hlsmax,jn), iStag(jn), icomm, nreq_p2p(jn), ierr )
IF( ln_timing ) CALL tic_tac(.FALSE.)
#endif
ENDIF
+
#endif
-#if defined BLOCK_FILL
- ishti = ishtRi(jn)
- ishtj = ishtRj(jn)
- SELECT CASE ( ifill(jn) )
- CASE ( jpfillnothing ) ! no filling
- CASE ( jpfillmpi ) ! fill with data received by MPI
+#if defined BLOCK_FILL_nonMPI
+
+ DO jf = 1, kfld
+ !
+ IF( ifill(jn,jf) == jpfillcst ) THEN
+ !
+ ishti = ishtRi(jn,jf)
+ ishtj = ishtRj(jn,jf)
+ DO jl = 1, ipl(jf) ; DO jk = 1, ipk(jf) ; DO jj = 1,isizej(jn,jf) ; DO ji = 1,isizei(jn,jf)
+ ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = zland
+ END DO ; END DO ; END DO ; END DO
+ !
+ ELSEIF( ifill(jn,jf) == jpfillperio .OR. ifill(jn,jf) == jpfillcopy ) THEN
+ !
+ IF( jn == jpwe .OR. jn == jpsw .OR. jn == jpnw ) THEN ! western side
+ ishti1 = ishtSi(jpwe,jf) + 1 ; isgni1 = -1
+ IF( ifill(jn,jf) == jpfillperio ) THEN ; ishti2 = ishtRi(jpea,jf) + 1 ; isgni2 = -1
+ ELSE ; ishti2 = ishtSi(jpwe,jf) ; isgni2 = 1
+ ENDIF
+ iisz = Ni_0
+ ELSEIF( jn == jpea .OR. jn == jpse .OR. jn == jpne ) THEN ! eastern side
+ ishti1 = ishtRi(jpea,jf) ; isgni1 = 1
+ IF( ifill(jn,jf) == jpfillperio ) THEN ; ishti2 = ishtSi(jpwe,jf) ; isgni2 = 1
+ ELSE ; ishti2 = ishtRi(jpea,jf) + 1 ; isgni2 = -1
+ ENDIF
+ iisz = Ni_0
+ ELSE ! southern/northern side
+ ishti1 = ishtRi(jn,jf) ; isgni1 = 1
+ ishti2 = ishtSi(jn,jf) ; isgni2 = 1
+ iisz = isizei(jn,jf)
+ ENDIF
+ IF( jn == jpso .OR. jn == jpsw .OR. jn == jpse ) THEN ! southern side
+ ishtj1 = ishtSj(jpso,jf) + 1 ; isgnj1 = -1
+ IF( ifill(jn,jf) == jpfillperio ) THEN ; ishtj2 = ishtRj(jpno,jf) + 1 ; isgnj2 = -1
+ ELSE ; ishtj2 = ishtSj(jpso,jf) ; isgnj2 = 1
+ ENDIF
+ ELSEIF( jn == jpno .OR. jn == jpnw .OR. jn == jpne ) THEN ! northern side
+ ishtj1 = ishtRj(jpno,jf) ; isgnj1 = 1
+ IF( ifill(jn,jf) == jpfillperio ) THEN ; ishtj2 = ishtSj(jpso,jf) ; isgnj2 = 1
+ ELSE ; ishtj2 = ishtRj(jpno,jf) + 1 ; isgnj2 = -1
+ ENDIF
+ ELSE ! western/eastern side
+ ishtj1 = ishtRj(jn,jf) ; isgnj1 = 1
+ ishtj2 = ishtSj(jn,jf) ; isgnj2 = 1
+ ENDIF
+ !
+ DO jl = 1, ipl(jf) ; DO jk = 1, ipk(jf) ; DO jj = 1,isizej(jn,jf) ; DO ji = 1,isizei(jn,jf)
+ ii1 = ishti1 + ji * isgni1
+ ij1 = ishtj1 + jj * isgnj1
+ ii2 = ishti2 + ( MOD(ji-1, iisz) + 1 ) * isgni2 ! warning: iisz my be smaller than isizei(jn,jf)
+ ij2 = ishtj2 + ( MOD(jj-1, Nj_0) + 1 ) * isgnj2 ! warning: Nj_0 my be smaller than isizej(jn,jf)
+ ptab(jf)%pt4d(ii1,ij1,jk,jl) = ptab(jf)%pt4d(ii2,ij2,jk,jl)
+ END DO ; END DO ; END DO ; END DO
+ !
+!!$ ELSEIF( ifill(jn,jf) == jpfillnothing ) THEN ! no filling
+!!$ ELSEIF( ifill(jn,jf) == jpfillmpi ) THEN ! do it later
+ ENDIF
+ END DO ! jf
+#endif
+
+#if defined BLOCK_FILL_MPI_RECV
+ IF( ibufszR(jn) > 0 ) THEN ! we must receive some data
#if ! defined key_mpi_off
IF( ln_timing ) CALL tic_tac(.TRUE.)
- ! ! blocking receive of the west/east halo in local temporary arrays
- CALL MPI_RECV( BUFFRCV(ishtR(jn)+1), iszall(jn), MPI_TYPE, mpiRnei(ihls,jn), iRtag(jn), icomm, MPI_STATUS_IGNORE, ierr )
+ ! blocking receive in local buffer. use mpiRnei(n_hlsmax,jn), see mppini
+ CALL MPI_RECV( BUFFRCV(ishtR(jn)+1), ibufszR(jn), MPI_TYPE, mpiRnei(n_hlsmax,jn), iRtag(jn), icomm, MPI_STATUS_IGNORE, ierr )
IF( ln_timing ) CALL tic_tac(.FALSE.)
#endif
- DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn)
- ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = BUFFRCV(idxr)
- idxr = idxr + 1
- END DO ; END DO ; END DO ; END DO ; END DO
- CASE ( jpfillperio ) ! use periodicity
- ishti2 = ishtPi(jn)
- ishtj2 = ishtPj(jn)
- DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn)
- ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = ptab(jf)%pt4d(ishti2+ji,ishtj2+jj,jk,jl)
- END DO ; END DO ; END DO ; END DO ; END DO
- CASE ( jpfillcopy ) ! filling with inner domain values
- ishti2 = ishtSi(jn)
- ishtj2 = ishtSj(jn)
- DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn)
- ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = ptab(jf)%pt4d(ishti2+ji,ishtj2+jj,jk,jl)
- END DO ; END DO ; END DO ; END DO ; END DO
- CASE ( jpfillcst ) ! filling with constant value
- DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn)
- ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = zland
- END DO ; END DO ; END DO ; END DO ; END DO
- END SELECT
+ DO jf = 1, kfld
+ IF( ifill(jn,jf) == jpfillmpi ) THEN ! Use MPI-received data
+ ishti = ishtRi(jn,jf)
+ ishtj = ishtRj(jn,jf)
+ DO jl = 1, ipl(jf) ; DO jk = 1, ipk(jf) ; DO jj = 1,isizej(jn,jf) ; DO ji = 1,isizei(jn,jf)
+ ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = BUFFRCV(idxr)
+ idxr = idxr + 1
+ END DO ; END DO ; END DO ; END DO
+ ENDIF
+ END DO
+ ENDIF
#endif
diff --git a/src/OCE/LBC/lbc_nfd_generic.h90 b/src/OCE/LBC/lbc_nfd_generic.h90
index 18ae89738204699f95b59a2dd15ad27419865f7b..fa20805f5944259e7349dbdc40ae49d54e695d9f 100644
--- a/src/OCE/LBC/lbc_nfd_generic.h90
+++ b/src/OCE/LBC/lbc_nfd_generic.h90
@@ -1,28 +1,23 @@
- SUBROUTINE lbc_nfd_/**/PRECISION( ptab, cd_nat, psgn, khls, kfld )
+ SUBROUTINE lbc_nfd_/**/PRECISION( ptab, cd_nat, psgn, kfld )
TYPE(PTR_4d_/**/PRECISION), DIMENSION(:), INTENT(inout) :: ptab ! pointer of arrays on which apply the b.c.
CHARACTER(len=1), DIMENSION(:), INTENT(in ) :: cd_nat ! nature of array grid-points
REAL(PRECISION), DIMENSION(:), INTENT(in ) :: psgn ! sign used across the north fold boundary
- INTEGER , INTENT(in ) :: khls ! halo size, default = nn_hls
INTEGER , INTENT(in ) :: kfld ! number of pt3d arrays
!
INTEGER :: ji, jj, jk, jl, jf ! dummy loop indices
- INTEGER :: ipi, ipj, ipk, ipl, ipf ! dimension of the input array
+ INTEGER :: ipi, ipj, ipk, ipl, ihls ! dimension of the input array
INTEGER :: ii1, ii2, ij1, ij2
!!----------------------------------------------------------------------
!
- ipi = SIZE(ptab(1)%pt4d,1)
- ipj = SIZE(ptab(1)%pt4d,2)
- ipk = SIZE(ptab(1)%pt4d,3)
- ipl = SIZE(ptab(1)%pt4d,4)
- ipf = kfld
+ DO jf = 1, kfld ! Loop on the number of arrays to be treated
!
- IF( ipi /= Ni0glo+2*khls ) THEN
- WRITE(ctmp1,*) 'lbc_nfd input array does not match khls', ipi, khls, Ni0glo
- CALL ctl_stop( 'STOP', ctmp1 )
- ENDIF
- !
- DO jf = 1, ipf ! Loop on the number of arrays to be treated
+ ipi = SIZE(ptab(jf)%pt4d,1)
+ ipj = SIZE(ptab(jf)%pt4d,2)
+ ipk = SIZE(ptab(jf)%pt4d,3)
+ ipl = SIZE(ptab(jf)%pt4d,4)
+ !
+ ihls = ( ipi - Ni0glo ) / 2
!
IF( c_NFtype == 'T' ) THEN ! * North fold T-point pivot
!
@@ -30,160 +25,162 @@
CASE ( 'T' , 'W' ) ! T-, W-point
DO jl = 1, ipl ; DO jk = 1, ipk
!
- ! last khls lines (from ipj to ipj-khls+1) : full
- DO jj = 1, khls
- ij1 = ipj - jj + 1 ! ends at: ipj - khls + 1
- ij2 = ipj - 2*khls + jj - 1 ! ends at: ipj - 2*khls + khls - 1 = ipj - khls - 1
+ ! last ihls lines (from ipj to ipj-ihls+1) : full
+ DO jj = 1, ihls
+ ij1 = ipj - jj + 1 ! ends at: ipj - ihls + 1
+ ij2 = ipj - 2*ihls + jj - 1 ! ends at: ipj - 2*ihls + ihls - 1 = ipj - ihls - 1
!
- DO ji = 1, khls ! first khls points
- ii1 = ji ! ends at: khls
- ii2 = 2*khls + 2 - ji ! ends at: 2*khls + 2 - khls = khls + 2
+ DO ji = 1, ihls ! first ihls points
+ ii1 = ji ! ends at: ihls
+ ii2 = 2*ihls + 2 - ji ! ends at: 2*ihls + 2 - ihls = ihls + 2
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
- DO ji = 1, 1 ! point khls+1
- ii1 = khls + ji
+ DO ji = 1, 1 ! point ihls+1
+ ii1 = ihls + ji
ii2 = ii1
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
- DO ji = 1, Ni0glo - 1 ! points from khls+2 to ipi - khls (note: Ni0glo = ipi - 2*khls)
- ii1 = 2 + khls + ji - 1 ! ends at: 2 + khls + ipi - 2*khls - 1 - 1 = ipi - khls
- ii2 = ipi - khls - ji + 1 ! ends at: ipi - khls - ( ipi - 2*khls - 1 ) + 1 = khls + 2
+ DO ji = 1, Ni0glo - 1 ! points from ihls+2 to ipi - ihls (note: Ni0glo = ipi - 2*ihls)
+ ii1 = 2 + ihls + ji - 1 ! ends at: 2 + ihls + ipi - 2*ihls - 1 - 1 = ipi - ihls
+ ii2 = ipi - ihls - ji + 1 ! ends at: ipi - ihls - ( ipi - 2*ihls - 1 ) + 1 = ihls + 2
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
- DO ji = 1, 1 ! point ipi - khls + 1
- ii1 = ipi - khls + ji
- ii2 = khls + ji
+ DO ji = 1, COUNT( (/ihls > 0/) ) ! point ipi - ihls + 1
+ ii1 = ipi - ihls + ji
+ ii2 = ihls + ji
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
- DO ji = 1, khls-1 ! last khls-1 points
- ii1 = ipi - khls + 1 + ji ! ends at: ipi - khls + 1 + khls - 1 = ipi
- ii2 = ipi - khls + 1 - ji ! ends at: ipi - khls + 1 - khls + 1 = ipi - 2*khls + 2
+ DO ji = 1, ihls-1 ! last ihls-1 points
+ ii1 = ipi - ihls + 1 + ji ! ends at: ipi - ihls + 1 + ihls - 1 = ipi
+ ii2 = ipi - ihls + 1 - ji ! ends at: ipi - ihls + 1 - ihls + 1 = ipi - 2*ihls + 2
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
END DO
!
- ! line number ipj-khls : right half
+ ! line number ipj-ihls : right half
DO jj = 1, 1
- ij1 = ipj - khls
+ ij1 = ipj - ihls
ij2 = ij1 ! same line
!
- DO ji = 1, Ni0glo/2-1 ! points from ipi/2+2 to ipi - khls (note: Ni0glo = ipi - 2*khls)
- ii1 = ipi/2 + ji + 1 ! ends at: ipi/2 + (ipi/2 - khls - 1) + 1 = ipi - khls
- ii2 = ipi/2 - ji + 1 ! ends at: ipi/2 - (ipi/2 - khls - 1) + 1 = khls + 2
+ DO ji = 1, Ni0glo/2-1 ! points from ipi/2+2 to ipi - ihls (note: Ni0glo = ipi - 2*ihls)
+ ii1 = ipi/2 + ji + 1 ! ends at: ipi/2 + (ipi/2 - ihls - 1) + 1 = ipi - ihls
+ ii2 = ipi/2 - ji + 1 ! ends at: ipi/2 - (ipi/2 - ihls - 1) + 1 = ihls + 2
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
- DO ji = 1, khls ! first khls points: redo them just in case (if e-w periodocity already done)
- ! ! as we just changed points ipi-2khls+1 to ipi-khls
- ii1 = ji ! ends at: khls
- ii2 = 2*khls + 2 - ji ! ends at: 2*khls + 2 - khls = khls + 2
+ DO ji = 1, ihls ! first ihls points: redo them just in case (if e-w periodocity already done)
+ ! ! as we just changed points ipi-2ihls+1 to ipi-ihls
+ ii1 = ji ! ends at: ihls
+ ii2 = 2*ihls + 2 - ji ! ends at: 2*ihls + 2 - ihls = ihls + 2
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
- ! ! last khls-1 points: have been / will done by e-w periodicity
+ ! ! last ihls-1 points: have been or will be done by e-w periodicity
END DO
!
- END DO; END DO
+ END DO ; END DO
CASE ( 'U' ) ! U-point
DO jl = 1, ipl ; DO jk = 1, ipk
!
- ! last khls lines (from ipj to ipj-khls+1) : full
- DO jj = 1, khls
- ij1 = ipj - jj + 1 ! ends at: ipj - khls + 1
- ij2 = ipj - 2*khls + jj - 1 ! ends at: ipj - 2*khls + khls - 1 = ipj - khls - 1
+ ! last ihls lines (from ipj to ipj-ihls+1) : full
+ DO jj = 1, ihls
+ ij1 = ipj - jj + 1 ! ends at: ipj - ihls + 1
+ ij2 = ipj - 2*ihls + jj - 1 ! ends at: ipj - 2*ihls + ihls - 1 = ipj - ihls - 1
!
- DO ji = 1, khls ! first khls points
- ii1 = ji ! ends at: khls
- ii2 = 2*khls + 1 - ji ! ends at: 2*khls + 1 - khls = khls + 1
+ DO ji = 1, ihls ! first ihls points
+ ii1 = ji ! ends at: ihls
+ ii2 = 2*ihls + 1 - ji ! ends at: 2*ihls + 1 - ihls = ihls + 1
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
- DO ji = 1, Ni0glo ! points from khls to ipi - khls (note: Ni0glo = ipi - 2*khls)
- ii1 = khls + ji ! ends at: khls + ipi - 2*khls = ipi - khls
- ii2 = ipi - khls - ji + 1 ! ends at: ipi - khls - ( ipi - 2*khls ) + 1 = khls + 1
+ DO ji = 1, Ni0glo ! points from ihls to ipi - ihls (note: Ni0glo = ipi - 2*ihls)
+ ii1 = ihls + ji ! ends at: ihls + ipi - 2*ihls = ipi - ihls
+ ii2 = ipi - ihls - ji + 1 ! ends at: ipi - ihls - ( ipi - 2*ihls ) + 1 = ihls + 1
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
- DO ji = 1, khls ! last khls points
- ii1 = ipi - khls + ji ! ends at: ipi - khls + khls = ipi
- ii2 = ipi - khls - ji + 1 ! ends at: ipi - khls + 1 - khls = ipi - 2*khls + 1
+ DO ji = 1, ihls ! last ihls points
+ ii1 = ipi - ihls + ji ! ends at: ipi - ihls + ihls = ipi
+ ii2 = ipi - ihls - ji + 1 ! ends at: ipi - ihls + 1 - ihls = ipi - 2*ihls + 1
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
END DO
!
- ! line number ipj-khls : right half
+ ! line number ipj-ihls : right half
DO jj = 1, 1
- ij1 = ipj - khls
+ ij1 = ipj - ihls
ij2 = ij1 ! same line
!
- DO ji = 1, Ni0glo/2 ! points from ipi/2+1 to ipi - khls (note: Ni0glo = ipi - 2*khls)
- ii1 = ipi/2 + ji ! ends at: ipi/2 + (ipi/2 - khls) = ipi - khls
- ii2 = ipi/2 - ji + 1 ! ends at: ipi/2 - (ipi/2 - khls) + 1 = khls + 1
+ DO ji = 1, Ni0glo/2 ! points from ipi/2+1 to ipi - ihls (note: Ni0glo = ipi - 2*ihls)
+ ii1 = ipi/2 + ji ! ends at: ipi/2 + (ipi/2 - ihls) = ipi - ihls
+ ii2 = ipi/2 - ji + 1 ! ends at: ipi/2 - (ipi/2 - ihls) + 1 = ihls + 1
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
- DO ji = 1, khls ! first khls points: redo them just in case (if e-w periodocity already done)
- ! ! as we just changed points ipi-2khls+1 to ipi-khls
- ii1 = ji ! ends at: khls
- ii2 = 2*khls + 1 - ji ! ends at: 2*khls + 1 - khls = khls + 1
+ DO ji = 1, ihls ! first ihls points: redo them just in case (if e-w periodocity already done)
+ ! ! as we just changed points ipi-2ihls+1 to ipi-ihls
+ ii1 = ji ! ends at: ihls
+ ii2 = 2*ihls + 1 - ji ! ends at: 2*ihls + 1 - ihls = ihls + 1
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
- ! ! last khls-1 points: have been / will done by e-w periodicity
+ ! ! last ihls-1 points: have been or will be done by e-w periodicity
END DO
!
- END DO; END DO
+ END DO ; END DO
CASE ( 'V' ) ! V-point
DO jl = 1, ipl ; DO jk = 1, ipk
!
- ! last khls+1 lines (from ipj to ipj-khls) : full
- DO jj = 1, khls+1
- ij1 = ipj - jj + 1 ! ends at: ipj - ( khls + 1 ) + 1 = ipj - khls
- ij2 = ipj - 2*khls + jj - 2 ! ends at: ipj - 2*khls + khls + 1 - 2 = ipj - khls - 1
+ ! last ihls+1 lines (from ipj to ipj-ihls) : full
+ DO jj = 1, ihls+1
+ ij1 = ipj - jj + 1 ! ends at: ipj - ( ihls + 1 ) + 1 = ipj - ihls
+ ij2 = ipj - 2*ihls + jj - 2 ! ends at: ipj - 2*ihls + ihls + 1 - 2 = ipj - ihls - 1
!
- DO ji = 1, khls ! first khls points
- ii1 = ji ! ends at: khls
- ii2 = 2*khls + 2 - ji ! ends at: 2*khls + 2 - khls = khls + 2
+ DO ji = 1, ihls ! first ihls points
+ ii1 = ji ! ends at: ihls
+ ii2 = 2*ihls + 2 - ji ! ends at: 2*ihls + 2 - ihls = ihls + 2
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
- DO ji = 1, 1 ! point khls+1
- ii1 = khls + ji
+ DO ji = 1, 1 ! point ihls+1
+ ii1 = ihls + ji
ii2 = ii1
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
- DO ji = 1, Ni0glo - 1 ! points from khls+2 to ipi - khls (note: Ni0glo = ipi - 2*khls)
- ii1 = 2 + khls + ji - 1 ! ends at: 2 + khls + ipi - 2*khls - 1 - 1 = ipi - khls
- ii2 = ipi - khls - ji + 1 ! ends at: ipi - khls - ( ipi - 2*khls - 1 ) + 1 = khls + 2
+ DO ji = 1, Ni0glo - 1 ! points from ihls+2 to ipi - ihls (note: Ni0glo = ipi - 2*ihls)
+ ii1 = 2 + ihls + ji - 1 ! ends at: 2 + ihls + ipi - 2*ihls - 1 - 1 = ipi - ihls
+ ii2 = ipi - ihls - ji + 1 ! ends at: ipi - ihls - ( ipi - 2*ihls - 1 ) + 1 = ihls + 2
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
- DO ji = 1, 1 ! point ipi - khls + 1
- ii1 = ipi - khls + ji
- ii2 = khls + ji
+ IF( ihls > 0 ) THEN
+ DO ji = 1, COUNT( (/ihls > 0/) ) ! point ipi - ihls + 1
+ ii1 = ipi - ihls + ji
+ ii2 = ihls + ji
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
- DO ji = 1, khls-1 ! last khls-1 points
- ii1 = ipi - khls + 1 + ji ! ends at: ipi - khls + 1 + khls - 1 = ipi
- ii2 = ipi - khls + 1 - ji ! ends at: ipi - khls + 1 - khls + 1 = ipi - 2*khls + 2
+ ENDIF
+ DO ji = 1, ihls-1 ! last ihls-1 points
+ ii1 = ipi - ihls + 1 + ji ! ends at: ipi - ihls + 1 + ihls - 1 = ipi
+ ii2 = ipi - ihls + 1 - ji ! ends at: ipi - ihls + 1 - ihls + 1 = ipi - 2*ihls + 2
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
END DO
!
- END DO; END DO
+ END DO ; END DO
CASE ( 'F' ) ! F-point
DO jl = 1, ipl ; DO jk = 1, ipk
!
- ! last khls+1 lines (from ipj to ipj-khls) : full
- DO jj = 1, khls+1
- ij1 = ipj - jj + 1 ! ends at: ipj - ( khls + 1 ) + 1 = ipj - khls
- ij2 = ipj - 2*khls + jj - 2 ! ends at: ipj - 2*khls + khls + 1 - 2 = ipj - khls - 1
+ ! last ihls+1 lines (from ipj to ipj-ihls) : full
+ DO jj = 1, ihls+1
+ ij1 = ipj - jj + 1 ! ends at: ipj - ( ihls + 1 ) + 1 = ipj - ihls
+ ij2 = ipj - 2*ihls + jj - 2 ! ends at: ipj - 2*ihls + ihls + 1 - 2 = ipj - ihls - 1
!
- DO ji = 1, khls ! first khls points
- ii1 = ji ! ends at: khls
- ii2 = 2*khls + 1 - ji ! ends at: 2*khls + 1 - khls = khls + 1
+ DO ji = 1, ihls ! first ihls points
+ ii1 = ji ! ends at: ihls
+ ii2 = 2*ihls + 1 - ji ! ends at: 2*ihls + 1 - ihls = ihls + 1
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
- DO ji = 1, Ni0glo ! points from khls to ipi - khls (note: Ni0glo = ipi - 2*khls)
- ii1 = khls + ji ! ends at: khls + ipi - 2*khls = ipi - khls
- ii2 = ipi - khls - ji + 1 ! ends at: ipi - khls - ( ipi - 2*khls ) + 1 = khls + 1
+ DO ji = 1, Ni0glo ! points from ihls to ipi - ihls (note: Ni0glo = ipi - 2*ihls)
+ ii1 = ihls + ji ! ends at: ihls + ipi - 2*ihls = ipi - ihls
+ ii2 = ipi - ihls - ji + 1 ! ends at: ipi - ihls - ( ipi - 2*ihls ) + 1 = ihls + 1
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
- DO ji = 1, khls ! last khls points
- ii1 = ipi - khls + ji ! ends at: ipi - khls + khls = ipi
- ii2 = ipi - khls - ji + 1 ! ends at: ipi - khls + 1 - khls = ipi - 2*khls + 1
+ DO ji = 1, ihls ! last ihls points
+ ii1 = ipi - ihls + ji ! ends at: ipi - ihls + ihls = ipi
+ ii2 = ipi - ihls - ji + 1 ! ends at: ipi - ihls + 1 - ihls = ipi - 2*ihls + 1
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
END DO
@@ -199,47 +196,24 @@
CASE ( 'T' , 'W' ) ! T-, W-point
DO jl = 1, ipl ; DO jk = 1, ipk
!
- ! first: line number ipj-khls : 3 points
- DO jj = 1, 1
- ij1 = ipj - khls
- ij2 = ij1 ! same line
- !
- DO ji = 1, 1 ! points from ipi/2+1
- ii1 = ipi/2 + ji
- ii2 = ipi/2 - ji + 1
- ptab(jf)%pt4d(ii1,ij1,jk,jl) = ptab(jf)%pt4d(ii2,ij2,jk,jl) ! Warning: pb with sign...
- END DO
- DO ji = 1, 1 ! points ipi - khls
- ii1 = ipi - khls + ji - 1
- ii2 = khls + ji
- ptab(jf)%pt4d(ii1,ij1,jk,jl) = ptab(jf)%pt4d(ii2,ij2,jk,jl) ! Warning: pb with sign...
- END DO
- DO ji = 1, 1 ! point khls: redo it just in case (if e-w periodocity already done)
- ! ! as we just changed point ipi - khls
- ii1 = khls + ji - 1
- ii2 = khls + ji
- ptab(jf)%pt4d(ii1,ij1,jk,jl) = ptab(jf)%pt4d(ii2,ij2,jk,jl) ! Warning: pb with sign...
- END DO
- END DO
- !
- ! Second: last khls lines (from ipj to ipj-khls+1) : full
- DO jj = 1, khls
- ij1 = ipj + 1 - jj ! ends at: ipj + 1 - khls
- ij2 = ipj - 2*khls + jj ! ends at: ipj - 2*khls + khls = ipj - khls
+ ! last ihls lines (from ipj to ipj-ihls+1) : full
+ DO jj = 1, ihls
+ ij1 = ipj + 1 - jj ! ends at: ipj + 1 - ihls
+ ij2 = ipj - 2*ihls + jj ! ends at: ipj - 2*ihls + ihls = ipj - ihls
!
- DO ji = 1, khls ! first khls points
- ii1 = ji ! ends at: khls
- ii2 = 2*khls + 1 - ji ! ends at: 2*khls + 1 - khls = khls + 1
+ DO ji = 1, ihls ! first ihls points
+ ii1 = ji ! ends at: ihls
+ ii2 = 2*ihls + 1 - ji ! ends at: 2*ihls + 1 - ihls = ihls + 1
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
- DO ji = 1, Ni0glo ! points from khls to ipi - khls (note: Ni0glo = ipi - 2*khls)
- ii1 = khls + ji ! ends at: khls + ipi - 2*khls = ipi - khls
- ii2 = ipi - khls - ji + 1 ! ends at: ipi - khls - ( ipi - 2*khls ) + 1 = khls + 1
+ DO ji = 1, Ni0glo ! points from ihls to ipi - ihls (note: Ni0glo = ipi - 2*ihls)
+ ii1 = ihls + ji ! ends at: ihls + ipi - 2*ihls = ipi - ihls
+ ii2 = ipi - ihls - ji + 1 ! ends at: ipi - ihls - ( ipi - 2*ihls ) + 1 = ihls + 1
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
- DO ji = 1, khls ! last khls points
- ii1 = ipi - khls + ji ! ends at: ipi - khls + khls = ipi
- ii2 = ipi - khls - ji + 1 ! ends at: ipi - khls + 1 - khls = ipi - 2*khls + 1
+ DO ji = 1, ihls ! last ihls points
+ ii1 = ipi - ihls + ji ! ends at: ipi - ihls + ihls = ipi
+ ii2 = ipi - ihls - ji + 1 ! ends at: ipi - ihls + 1 - ihls = ipi - 2*ihls + 1
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
END DO
@@ -248,34 +222,34 @@
CASE ( 'U' ) ! U-point
DO jl = 1, ipl ; DO jk = 1, ipk
!
- ! last khls lines (from ipj to ipj-khls+1) : full
- DO jj = 1, khls
- ij1 = ipj + 1 - jj ! ends at: ipj + 1 - khls
- ij2 = ipj - 2*khls + jj ! ends at: ipj - 2*khls + khls = ipj - khls
+ ! last ihls lines (from ipj to ipj-ihls+1) : full
+ DO jj = 1, ihls
+ ij1 = ipj + 1 - jj ! ends at: ipj + 1 - ihls
+ ij2 = ipj - 2*ihls + jj ! ends at: ipj - 2*ihls + ihls = ipj - ihls
!
- DO ji = 1, khls-1 ! first khls-1 points
- ii1 = ji ! ends at: khls-1
- ii2 = 2*khls - ji ! ends at: 2*khls - ( khls - 1 ) = khls + 1
+ DO ji = 1, ihls-1 ! first ihls-1 points
+ ii1 = ji ! ends at: ihls-1
+ ii2 = 2*ihls - ji ! ends at: 2*ihls - ( ihls - 1 ) = ihls + 1
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
- DO ji = 1, 1 ! point khls
- ii1 = khls + ji - 1
+ DO ji = 1, 1 ! point ihls (here ihls > 0 so it is ok)
+ ii1 = ihls + ji - 1
ii2 = ipi - ii1
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
- DO ji = 1, Ni0glo - 1 ! points from khls+1 to ipi - khls - 1 (note: Ni0glo = ipi - 2*khls)
- ii1 = khls + ji ! ends at: khls + ( ipi - 2*khls - 1 ) = ipi - khls - 1
- ii2 = ipi - khls - ji ! ends at: ipi - khls - ( ipi - 2*khls - 1 ) = khls + 1
+ DO ji = 1, Ni0glo - 1 ! points from ihls+1 to ipi - ihls - 1 (note: Ni0glo = ipi - 2*ihls)
+ ii1 = ihls + ji ! ends at: ihls + ( ipi - 2*ihls - 1 ) = ipi - ihls - 1
+ ii2 = ipi - ihls - ji ! ends at: ipi - ihls - ( ipi - 2*ihls - 1 ) = ihls + 1
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
- DO ji = 1, 1 ! point ipi - khls
- ii1 = ipi - khls + ji - 1
+ DO ji = 1, 1 ! point ipi - ihls
+ ii1 = ipi - ihls + ji - 1
ii2 = ii1
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
- DO ji = 1, khls ! last khls points
- ii1 = ipi - khls + ji ! ends at: ipi - khls + khls = ipi
- ii2 = ipi - khls - ji ! ends at: ipi - khls - khls = ipi - 2*khls
+ DO ji = 1, ihls ! last ihls points
+ ii1 = ipi - ihls + ji ! ends at: ipi - ihls + ihls = ipi
+ ii2 = ipi - ihls - ji ! ends at: ipi - ihls - ihls = ipi - 2*ihls
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
END DO
@@ -284,100 +258,100 @@
CASE ( 'V' ) ! V-point
DO jl = 1, ipl ; DO jk = 1, ipk
!
- ! last khls lines (from ipj to ipj-khls+1) : full
- DO jj = 1, khls
- ij1 = ipj - jj + 1 ! ends at: ipj - khls + 1
- ij2 = ipj - 2*khls + jj - 1 ! ends at: ipj - 2*khls + khls - 1 = ipj - khls - 1
+ ! last ihls lines (from ipj to ipj-ihls+1) : full
+ DO jj = 1, ihls
+ ij1 = ipj - jj + 1 ! ends at: ipj - ihls + 1
+ ij2 = ipj - 2*ihls + jj - 1 ! ends at: ipj - 2*ihls + ihls - 1 = ipj - ihls - 1
!
- DO ji = 1, khls ! first khls points
- ii1 = ji ! ends at: khls
- ii2 = 2*khls + 1 - ji ! ends at: 2*khls + 1 - khls = khls + 1
+ DO ji = 1, ihls ! first ihls points
+ ii1 = ji ! ends at: ihls
+ ii2 = 2*ihls + 1 - ji ! ends at: 2*ihls + 1 - ihls = ihls + 1
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
- DO ji = 1, Ni0glo ! points from khls to ipi - khls (note: Ni0glo = ipi - 2*khls)
- ii1 = khls + ji ! ends at: khls + ipi - 2*khls = ipi - khls
- ii2 = ipi - khls - ji + 1 ! ends at: ipi - khls - ( ipi - 2*khls ) + 1 = khls + 1
+ DO ji = 1, Ni0glo ! points from ihls to ipi - ihls (note: Ni0glo = ipi - 2*ihls)
+ ii1 = ihls + ji ! ends at: ihls + ipi - 2*ihls = ipi - ihls
+ ii2 = ipi - ihls - ji + 1 ! ends at: ipi - ihls - ( ipi - 2*ihls ) + 1 = ihls + 1
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
- DO ji = 1, khls ! last khls points
- ii1 = ipi - khls + ji ! ends at: ipi - khls + khls = ipi
- ii2 = ipi - khls - ji + 1 ! ends at: ipi - khls + 1 - khls = ipi - 2*khls + 1
+ DO ji = 1, ihls ! last ihls points
+ ii1 = ipi - ihls + ji ! ends at: ipi - ihls + ihls = ipi
+ ii2 = ipi - ihls - ji + 1 ! ends at: ipi - ihls + 1 - ihls = ipi - 2*ihls + 1
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
END DO
!
- ! line number ipj-khls : right half
+ ! line number ipj-ihls : right half
DO jj = 1, 1
- ij1 = ipj - khls
+ ij1 = ipj - ihls
ij2 = ij1 ! same line
!
- DO ji = 1, Ni0glo/2 ! points from ipi/2+1 to ipi - khls (note: Ni0glo = ipi - 2*khls)
- ii1 = ipi/2 + ji ! ends at: ipi/2 + (ipi/2 - khls) = ipi - khls
- ii2 = ipi/2 - ji + 1 ! ends at: ipi/2 - (ipi/2 - khls) + 1 = khls + 1
+ DO ji = 1, Ni0glo/2 ! points from ipi/2+1 to ipi - ihls (note: Ni0glo = ipi - 2*ihls)
+ ii1 = ipi/2 + ji ! ends at: ipi/2 + (ipi/2 - ihls) = ipi - ihls
+ ii2 = ipi/2 - ji + 1 ! ends at: ipi/2 - (ipi/2 - ihls) + 1 = ihls + 1
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
- DO ji = 1, khls ! first khls points: redo them just in case (if e-w periodocity already done)
- ! ! as we just changed points ipi-2khls+1 to ipi-khls
- ii1 = ji ! ends at: khls
- ii2 = 2*khls + 1 - ji ! ends at: 2*khls + 1 - khls = khls + 1
+ DO ji = 1, ihls ! first ihls points: redo them just in case (if e-w periodocity already done)
+ ! ! as we just changed points ipi-2ihls+1 to ipi-ihls
+ ii1 = ji ! ends at: ihls
+ ii2 = 2*ihls + 1 - ji ! ends at: 2*ihls + 1 - ihls = ihls + 1
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
- ! ! last khls points: have been / will done by e-w periodicity
+ ! ! last ihls points: have been or will be done by e-w periodicity
END DO
!
END DO; END DO
CASE ( 'F' ) ! F-point
DO jl = 1, ipl ; DO jk = 1, ipk
!
- ! last khls lines (from ipj to ipj-khls+1) : full
- DO jj = 1, khls
- ij1 = ipj - jj + 1 ! ends at: ipj - khls + 1
- ij2 = ipj - 2*khls + jj - 1 ! ends at: ipj - 2*khls + khls - 1 = ipj - khls - 1
+ ! last ihls lines (from ipj to ipj-ihls+1) : full
+ DO jj = 1, ihls
+ ij1 = ipj - jj + 1 ! ends at: ipj - ihls + 1
+ ij2 = ipj - 2*ihls + jj - 1 ! ends at: ipj - 2*ihls + ihls - 1 = ipj - ihls - 1
!
- DO ji = 1, khls-1 ! first khls-1 points
- ii1 = ji ! ends at: khls-1
- ii2 = 2*khls - ji ! ends at: 2*khls - ( khls - 1 ) = khls + 1
+ DO ji = 1, ihls-1 ! first ihls-1 points
+ ii1 = ji ! ends at: ihls-1
+ ii2 = 2*ihls - ji ! ends at: 2*ihls - ( ihls - 1 ) = ihls + 1
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
- DO ji = 1, 1 ! point khls
- ii1 = khls + ji - 1
+ DO ji = 1, 1 ! point ihls (here ihls > 0 so it is ok)
+ ii1 = ihls + ji - 1
ii2 = ipi - ii1
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
- DO ji = 1, Ni0glo - 1 ! points from khls+1 to ipi - khls - 1 (note: Ni0glo = ipi - 2*khls)
- ii1 = khls + ji ! ends at: khls + ( ipi - 2*khls - 1 ) = ipi - khls - 1
- ii2 = ipi - khls - ji ! ends at: ipi - khls - ( ipi - 2*khls - 1 ) = khls + 1
+ DO ji = 1, Ni0glo - 1 ! points from ihls+1 to ipi - ihls - 1 (note: Ni0glo = ipi - 2*ihls)
+ ii1 = ihls + ji ! ends at: ihls + ( ipi - 2*ihls - 1 ) = ipi - ihls - 1
+ ii2 = ipi - ihls - ji ! ends at: ipi - ihls - ( ipi - 2*ihls - 1 ) = ihls + 1
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
- DO ji = 1, 1 ! point ipi - khls
- ii1 = ipi - khls + ji - 1
+ DO ji = 1, 1 ! point ipi - ihls
+ ii1 = ipi - ihls + ji - 1
ii2 = ii1
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
- DO ji = 1, khls ! last khls points
- ii1 = ipi - khls + ji ! ends at: ipi - khls + khls = ipi
- ii2 = ipi - khls - ji ! ends at: ipi - khls - khls = ipi - 2*khls
+ DO ji = 1, ihls ! last ihls points
+ ii1 = ipi - ihls + ji ! ends at: ipi - ihls + ihls = ipi
+ ii2 = ipi - ihls - ji ! ends at: ipi - ihls - ihls = ipi - 2*ihls
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
END DO
!
- ! line number ipj-khls : right half
+ ! line number ipj-ihls : right half
DO jj = 1, 1
- ij1 = ipj - khls
+ ij1 = ipj - ihls
ij2 = ij1 ! same line
!
- DO ji = 1, Ni0glo/2-1 ! points from ipi/2+1 to ipi - khls-1 (note: Ni0glo = ipi - 2*khls)
- ii1 = ipi/2 + ji ! ends at: ipi/2 + (ipi/2 - khls) = ipi - khls
- ii2 = ipi/2 - ji ! ends at: ipi/2 - (ipi/2 - khls - 1 ) = khls + 1
+ DO ji = 1, Ni0glo/2-1 ! points from ipi/2+1 to ipi - ihls-1 (note: Ni0glo = ipi - 2*ihls)
+ ii1 = ipi/2 + ji ! ends at: ipi/2 + (ipi/2 - ihls) = ipi - ihls
+ ii2 = ipi/2 - ji ! ends at: ipi/2 - (ipi/2 - ihls - 1 ) = ihls + 1
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
- DO ji = 1, khls-1 ! first khls-1 points: redo them just in case (if e-w periodocity already done)
- ! ! as we just changed points ipi-2khls+1 to ipi-nn_hl-1
- ii1 = ji ! ends at: khls
- ii2 = 2*khls - ji ! ends at: 2*khls - ( khls - 1 ) = khls + 1
+ DO ji = 1, ihls-1 ! first ihls-1 points: redo them just in case (if e-w periodocity already done)
+ ! ! as we just changed points ipi-2ihls+1 to ipi-nn_hl-1
+ ii1 = ji ! ends at: ihls
+ ii2 = 2*ihls - ji ! ends at: 2*ihls - ( ihls - 1 ) = ihls + 1
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
- ! ! last khls points: have been / will done by e-w periodicity
+ ! ! last ihls points: have been or will be done by e-w periodicity
END DO
!
END DO; END DO
@@ -385,7 +359,7 @@
!
ENDIF ! c_NFtype == 'F'
!
- END DO ! ipf
+ END DO ! kfld
!
END SUBROUTINE lbc_nfd_/**/PRECISION
diff --git a/src/OCE/LBC/lbclnk.F90 b/src/OCE/LBC/lbclnk.F90
index be65cdc13349f614798522689f68b9c2ea63ecf1..3776b59538df9b08daf415881be2757b3f4b2919 100644
--- a/src/OCE/LBC/lbclnk.F90
+++ b/src/OCE/LBC/lbclnk.F90
@@ -38,11 +38,9 @@ MODULE lbclnk
MODULE PROCEDURE lbc_lnk_pt2pt_sp, lbc_lnk_pt2pt_dp
END INTERFACE
-#if ! defined key_mpi2
INTERFACE lbc_lnk_neicoll
MODULE PROCEDURE lbc_lnk_neicoll_sp ,lbc_lnk_neicoll_dp
END INTERFACE
-#endif
!
INTERFACE lbc_lnk_icb
MODULE PROCEDURE mpp_lnk_2d_icb_dp, mpp_lnk_2d_icb_sp
@@ -51,10 +49,10 @@ MODULE lbclnk
PUBLIC lbc_lnk ! ocean/ice lateral boundary conditions
PUBLIC lbc_lnk_icb ! iceberg lateral boundary conditions
- REAL(dp), DIMENSION(:), ALLOCATABLE :: buffsnd_dp, buffrcv_dp ! MPI send/recv buffers
- REAL(sp), DIMENSION(:), ALLOCATABLE :: buffsnd_sp, buffrcv_sp !
- INTEGER, DIMENSION(8) :: nreq_p2p ! request id for MPI_Isend in point-2-point communication
-
+ REAL(dp), DIMENSION(:), ALLOCATABLE :: buffsnd_dp, buffrcv_dp ! MPI send/recv buffers
+ REAL(sp), DIMENSION(:), ALLOCATABLE :: buffsnd_sp, buffrcv_sp !
+ INTEGER, DIMENSION(8) :: nreq_p2p = MPI_REQUEST_NULL ! request id for MPI_Isend in point-2-point communication
+ INTEGER :: nreq_nei = MPI_REQUEST_NULL ! request id for mpi_neighbor_ialltoallv
!! * Substitutions
!!# include "do_loop_substitute.h90"
!!----------------------------------------------------------------------
@@ -134,9 +132,7 @@ CONTAINS
# define BUFFSND buffsnd_sp
# define BUFFRCV buffrcv_sp
# include "lbc_lnk_pt2pt_generic.h90"
-#if ! defined key_mpi2
# include "lbc_lnk_neicoll_generic.h90"
-#endif
# undef MPI_TYPE
# undef BUFFSND
# undef BUFFRCV
@@ -149,9 +145,7 @@ CONTAINS
# define BUFFSND buffsnd_dp
# define BUFFRCV buffrcv_dp
# include "lbc_lnk_pt2pt_generic.h90"
-#if ! defined key_mpi2
# include "lbc_lnk_neicoll_generic.h90"
-#endif
# undef MPI_TYPE
# undef BUFFSND
# undef BUFFRCV
diff --git a/src/OCE/LBC/lbcnfd.F90 b/src/OCE/LBC/lbcnfd.F90
index dc784b868f7c4316feb95af709f6d68afe437d82..c6be460c98335017113ac2028edb02b098ca20cd 100644
--- a/src/OCE/LBC/lbcnfd.F90
+++ b/src/OCE/LBC/lbcnfd.F90
@@ -23,8 +23,11 @@ MODULE lbcnfd
PRIVATE
INTERFACE lbc_nfd ! called by mpp_nfd, lbc_lnk_pt2pt or lbc_lnk_neicoll
- MODULE PROCEDURE lbc_nfd_sp, lbc_nfd_ext_sp
- MODULE PROCEDURE lbc_nfd_dp, lbc_nfd_ext_dp
+ MODULE PROCEDURE lbc_nfd_sp, lbc_nfd_dp
+ END INTERFACE
+
+ INTERFACE lbc_nfd_ext ! called by mpp_lnk_2d_icb
+ MODULE PROCEDURE lbc_nfd_ext_sp, lbc_nfd_ext_dp
END INTERFACE
INTERFACE mpp_nfd ! called by lbc_lnk_pt2pt or lbc_lnk_neicoll
@@ -33,11 +36,13 @@ MODULE lbcnfd
PUBLIC mpp_nfd ! mpi north fold conditions
PUBLIC lbc_nfd ! north fold conditions
+ PUBLIC lbc_nfd_ext ! north fold conditions, called by mpp_lnk_2d_icb
- INTEGER, PUBLIC :: nfd_nbnei
- INTEGER, PUBLIC, ALLOCATABLE, DIMENSION (: ) :: nfd_rknei
- INTEGER, PUBLIC, ALLOCATABLE, DIMENSION (:,:) :: nfd_rksnd
- INTEGER, PUBLIC, ALLOCATABLE, DIMENSION (:,:) :: nfd_jisnd
+ INTEGER, PUBLIC :: nfd_nbnei
+ INTEGER, PUBLIC, ALLOCATABLE, DIMENSION (: ) :: nfd_rknei
+ INTEGER, PUBLIC, ALLOCATABLE, DIMENSION (:,:,:) :: nfd_rksnd
+ INTEGER, PUBLIC, ALLOCATABLE, DIMENSION (:,:,:) :: nfd_jisnd
+ LOGICAL, PUBLIC, ALLOCATABLE, DIMENSION (:,: ) :: lnfd_same
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
diff --git a/src/OCE/LBC/lib_mpp.F90 b/src/OCE/LBC/lib_mpp.F90
index bf839de5ac0f224d52f6194f47efa110fd8ff1f8..eeec13051a35c3131a0ef17f8caa1201a488fc1f 100644
--- a/src/OCE/LBC/lib_mpp.F90
+++ b/src/OCE/LBC/lib_mpp.F90
@@ -140,10 +140,10 @@ MODULE lib_mpp
INTEGER :: MPI_SUMDD
! Neighbourgs informations
- INTEGER, PARAMETER, PUBLIC :: n_hlsmax = 3
- INTEGER, DIMENSION( 8), PUBLIC :: mpinei !: 8-neighbourg MPI indexes (starting at 0, -1 if no neighbourg)
- INTEGER, DIMENSION(n_hlsmax,8), PUBLIC :: mpiSnei !: 8-neighbourg Send MPI indexes (starting at 0, -1 if no neighbourg)
- INTEGER, DIMENSION(n_hlsmax,8), PUBLIC :: mpiRnei !: 8-neighbourg Recv MPI indexes (starting at 0, -1 if no neighbourg)
+ INTEGER, PARAMETER, PUBLIC :: n_hlsmax = 2
+ INTEGER, DIMENSION( 8), PUBLIC :: mpinei !: 8-neighbourg MPI indexes (starting at 0, -1 if no neighbourg)
+ INTEGER, DIMENSION(0:n_hlsmax,8), PUBLIC :: mpiSnei !: 8-neighbourg Send MPI indexes (starting at 0, -1 if no neighbourg)
+ INTEGER, DIMENSION(0:n_hlsmax,8), PUBLIC :: mpiRnei !: 8-neighbourg Recv MPI indexes (starting at 0, -1 if no neighbourg)
INTEGER, PARAMETER, PUBLIC :: jpwe = 1 !: WEst
INTEGER, PARAMETER, PUBLIC :: jpea = 2 !: EAst
INTEGER, PARAMETER, PUBLIC :: jpso = 3 !: SOuth
@@ -190,7 +190,6 @@ MODULE lib_mpp
INTEGER, PUBLIC :: n_sequence_glb = 0 !: # of global communications
INTEGER, PUBLIC :: n_sequence_dlg = 0 !: # of delayed global communications
INTEGER, PUBLIC :: numcom = -1 !: logical unit for communicaton report
- LOGICAL, PUBLIC :: l_full_nf_update = .TRUE. !: logical for a full (2lines) update of bc at North fold report
INTEGER, PARAMETER, PUBLIC :: nbdelay = 2 !: number of delayed operations
!: name (used as id) of allreduce-delayed operations
! Warning: we must use the same character length in an array constructor (at least for gcc compiler)
@@ -1125,7 +1124,7 @@ CONTAINS
INTEGER :: ierr
LOGICAL, PARAMETER :: ireord = .FALSE.
!!----------------------------------------------------------------------
-#if ! defined key_mpi_off && ! defined key_mpi2
+#if ! defined key_mpi_off
iScnt4 = COUNT( mpiSnei(khls,1:4) >= 0 )
iRcnt4 = COUNT( mpiRnei(khls,1:4) >= 0 )
@@ -1139,10 +1138,19 @@ CONTAINS
iSnei8 = PACK( mpiSnei(khls,1:8), mask = mpiSnei(khls,1:8) >= 0 )
iRnei8 = PACK( mpiRnei(khls,1:8), mask = mpiRnei(khls,1:8) >= 0 )
+ ! Isolated processes (i.e., processes WITH no outgoing or incoming edges, that is, processes that have specied
+ ! indegree and outdegree as zero and thus DO not occur as source or destination rank in the graph specication)
+ ! are allowed.
+
+# if ! defined key_mpi2
CALL MPI_Dist_graph_create_adjacent( mpi_comm_oce, iScnt4, iSnei4, MPI_UNWEIGHTED, iRcnt4, iRnei4, MPI_UNWEIGHTED, &
& MPI_INFO_NULL, ireord, mpi_nc_com4(khls), ierr )
CALL MPI_Dist_graph_create_adjacent( mpi_comm_oce, iScnt8, iSnei8, MPI_UNWEIGHTED, iRcnt8, iRnei8, MPI_UNWEIGHTED, &
& MPI_INFO_NULL, ireord, mpi_nc_com8(khls), ierr)
+# else
+ mpi_nc_com4(khls) = -1
+ mpi_nc_com8(khls) = -1
+# endif
DEALLOCATE( iSnei4, iRnei4, iSnei8, iRnei8 )
#endif
@@ -1305,7 +1313,7 @@ CONTAINS
IF ( ncomm_sequence(ji,1) .GT. 1 .AND. ncomm_sequence(ji,2) .GT. 1 ) jj = jj + 1
jh = MAX (jh, ncomm_sequence(ji,1)*ncomm_sequence(ji,2))
END DO
- WRITE(numcom,'(A,I3)') ' 3D Exchanged halos : ', jk
+ WRITE(numcom,'(A,I3)') ' 3D or 4D Exchanged halos : ', jk
WRITE(numcom,'(A,I3)') ' Multi arrays exchanged halos : ', jf
WRITE(numcom,'(A,I3)') ' from which 3D : ', jj
WRITE(numcom,'(A,I10)') ' Array max size : ', jh*jpi*jpj
diff --git a/src/OCE/LBC/mpp_lbc_north_icb_generic.h90 b/src/OCE/LBC/mpp_lbc_north_icb_generic.h90
index 3c8382eacadfb023929f88836e36813d7c40fd69..63cef9abf5ac54ddbe6c93833406f944896dd141 100644
--- a/src/OCE/LBC/mpp_lbc_north_icb_generic.h90
+++ b/src/OCE/LBC/mpp_lbc_north_icb_generic.h90
@@ -92,7 +92,7 @@
! 2. North-Fold boundary conditions
! ----------------------------------
- CALL lbc_nfd( ztab_e(:,1-kextj:ipj+kextj), cd_type, psgn, kextj )
+ CALL lbc_nfd_ext( ztab_e(:,1-kextj:ipj+kextj), cd_type, psgn, kextj )
ij = 1 - kextj
!! Scatter back to pt2d
diff --git a/src/OCE/LBC/mpp_lnk_icb_generic.h90 b/src/OCE/LBC/mpp_lnk_icb_generic.h90
index 8798f3e0c3e71217ced192fbb3c1f1879c0640fd..b0cb70d46cbcc3e5876ccca62d48b1a3b90ea222 100644
--- a/src/OCE/LBC/mpp_lnk_icb_generic.h90
+++ b/src/OCE/LBC/mpp_lnk_icb_generic.h90
@@ -87,7 +87,7 @@
IF( l_IdoNFold ) THEN
!
SELECT CASE ( jpni )
- CASE ( 1 ) ; CALL lbc_nfd ( pt2d(1:jpi,1:jpj+kextj), cd_type, psgn, kextj )
+ CASE ( 1 ) ; CALL lbc_nfd_ext ( pt2d(1:jpi,1:jpj+kextj), cd_type, psgn, kextj )
CASE DEFAULT ; CALL LBCNORTH ( pt2d(1:jpi,1:jpj+kextj), cd_type, psgn, kextj )
END SELECT
!
diff --git a/src/OCE/LBC/mpp_loc_generic.h90 b/src/OCE/LBC/mpp_loc_generic.h90
index 1bce8df2d3c2fb7e677f68185a5309346e764450..fe5697630506ef9afaeea3461ded79ec048db8c1 100644
--- a/src/OCE/LBC/mpp_loc_generic.h90
+++ b/src/OCE/LBC/mpp_loc_generic.h90
@@ -47,6 +47,7 @@
!
INTEGER :: ierror, ii, idim
INTEGER :: index0
+ INTEGER :: ihls, ipiglo, ipjglo
INTEGER , DIMENSION(:), ALLOCATABLE :: ilocs
REAL(PRECISION) :: zmin ! local minimum
REAL(PRECISION), DIMENSION(2,1) :: zain, zaout
@@ -60,6 +61,9 @@
ENDIF
!
idim = SIZE(kindex)
+ ihls = ( SIZE(ARRAY_IN(:,:,:), 1) - Ni_0 ) / 2
+ ipiglo = Ni0glo + 2*ihls
+ ipjglo = Nj0glo + 2*ihls
!
IF ( ANY( MASK_IN(:,:,:) ) ) THEN ! there is at least 1 valid point...
!
@@ -68,9 +72,9 @@
ilocs = LOC_OPERATION( ARRAY_IN(:,:,:) , mask= MASK_IN(:,:,:) )
zmin = ARRAY_IN(ilocs(1),ilocs(2),ilocs(3))
!
- kindex(1) = mig( ilocs(1) )
+ kindex(1) = mig( ilocs(1), ihls )
#if defined DIM_2d || defined DIM_3d /* avoid warning when kindex has 1 element */
- kindex(2) = mjg( ilocs(2) )
+ kindex(2) = mjg( ilocs(2), ihls )
#endif
#if defined DIM_3d /* avoid warning when kindex has 2 elements */
kindex(3) = ilocs(3)
@@ -80,10 +84,10 @@
!
index0 = kindex(1)-1 ! 1d index starting at 0
#if defined DIM_2d || defined DIM_3d /* avoid warning when kindex has 1 element */
- index0 = index0 + jpiglo * (kindex(2)-1)
+ index0 = index0 + ipiglo * (kindex(2)-1)
#endif
#if defined DIM_3d /* avoid warning when kindex has 2 elements */
- index0 = index0 + jpiglo * jpjglo * (kindex(3)-1)
+ index0 = index0 + ipiglo * ipjglo * (kindex(3)-1)
#endif
ELSE
! special case for land processors
@@ -105,20 +109,20 @@
pmin = zaout(1,1)
index0 = NINT( zaout(2,1) )
#if defined DIM_3d /* avoid warning when kindex has 2 elements */
- kindex(3) = index0 / (jpiglo*jpjglo)
- index0 = index0 - kindex(3) * (jpiglo*jpjglo)
+ kindex(3) = index0 / (ipiglo*ipjglo)
+ index0 = index0 - kindex(3) * (ipiglo*ipjglo)
#endif
#if defined DIM_2d || defined DIM_3d /* avoid warning when kindex has 1 element */
- kindex(2) = index0 / jpiglo
- index0 = index0 - kindex(2) * jpiglo
+ kindex(2) = index0 / ipiglo
+ index0 = index0 - kindex(2) * ipiglo
#endif
kindex(1) = index0
kindex(:) = kindex(:) + 1 ! start indices at 1
IF( .NOT. llhalo ) THEN
- kindex(1) = kindex(1) - nn_hls
+ kindex(1) = kindex(1) - ihls
#if defined DIM_2d || defined DIM_3d /* avoid warning when kindex has 1 element */
- kindex(2) = kindex(2) - nn_hls
+ kindex(2) = kindex(2) - ihls
#endif
ENDIF
diff --git a/src/OCE/LBC/mpp_nfd_generic.h90 b/src/OCE/LBC/mpp_nfd_generic.h90
index fd45035fe4f651ae275d26a3c83f08f2bd192911..20ecf8ac22f8e4395fb246073a65a7a807affa76 100644
--- a/src/OCE/LBC/mpp_nfd_generic.h90
+++ b/src/OCE/LBC/mpp_nfd_generic.h90
@@ -1,38 +1,40 @@
- SUBROUTINE mpp_nfd_/**/PRECISION( ptab, cd_nat, psgn, kfillmode, pfillval, khls, kfld )
+ SUBROUTINE mpp_nfd_/**/PRECISION( ptab, cd_nat, psgn, kfillmode, pfillval, kfld, ldfull )
TYPE(PTR_4d_/**/PRECISION), DIMENSION(:), INTENT(inout) :: ptab ! pointer of arrays on which apply the b.c.
- CHARACTER(len=1), DIMENSION(:), INTENT(in ) :: cd_nat ! nature of array grid-points
- REAL(PRECISION), DIMENSION(:), INTENT(in ) :: psgn ! sign used across the north fold boundary
- INTEGER , INTENT(in ) :: kfillmode ! filling method for halo over land
- REAL(PRECISION) , INTENT(in ) :: pfillval ! background value (used at closed boundaries)
- INTEGER , INTENT(in ) :: khls ! halo size, default = nn_hls
- INTEGER , INTENT(in ) :: kfld ! number of pt3d arrays
+ CHARACTER(len=1), DIMENSION(kfld), INTENT(in ) :: cd_nat ! nature of array grid-points
+ REAL(PRECISION), DIMENSION(kfld), INTENT(in ) :: psgn ! sign used across the north fold boundary
+ INTEGER , INTENT(in ) :: kfillmode ! filling method for halo over land
+ REAL(PRECISION) , INTENT(in ) :: pfillval ! background value (used at closed boundaries)
+ INTEGER , INTENT(in ) :: kfld ! number of pt3d arrays
+ LOGICAL , OPTIONAL, INTENT(in ) :: ldfull ! .true. if we also update the last line of the inner domain
!
- LOGICAL :: ll_add_line
+ LOGICAL :: llfull
INTEGER :: ji, jj, jk, jl, jf, jr, jg, jn ! dummy loop indices
- INTEGER :: ipi, ipj, ipj2, ipk, ipl, ipf ! dimension of the input array
- INTEGER :: ierr, ibuffsize, iis0, iie0, impp
- INTEGER :: ii1, ii2, ij1, ij2, iis, iie, iib, iig, iin
- INTEGER :: i0max
- INTEGER :: ij, iproc, ipni, ijnr
- INTEGER, DIMENSION (:), ALLOCATABLE :: ireq_s, ireq_r ! for mpi_isend when avoiding mpi_allgather
- INTEGER :: ipjtot ! sum of lines for all multi fields
- INTEGER :: i012 ! 0, 1 or 2
- INTEGER , DIMENSION(:,:) , ALLOCATABLE :: ijsnd ! j-position of sent lines for each field
- INTEGER , DIMENSION(:,:) , ALLOCATABLE :: ijbuf ! j-position of send buffer lines for each field
- INTEGER , DIMENSION(:,:) , ALLOCATABLE :: ijrcv ! j-position of recv buffer lines for each field
- INTEGER , DIMENSION(:,:) , ALLOCATABLE :: ii1st, iiend
- INTEGER , DIMENSION(:) , ALLOCATABLE :: ipjfld ! number of sent lines for each field
- REAL(PRECISION), DIMENSION(:,:,:,:) , ALLOCATABLE :: zbufs ! buffer, receive and work arrays
- REAL(PRECISION), DIMENSION(:,:,:,:,:) , ALLOCATABLE :: zbufr ! buffer, receive and work arrays
- REAL(PRECISION), DIMENSION(:,:,:,:,:) , ALLOCATABLE :: znorthloc
- REAL(PRECISION), DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: znorthglo
- TYPE(PTR_4D_/**/PRECISION), DIMENSION(:), ALLOCATABLE :: ztabglo ! array or pointer of arrays on which apply the b.c.
+ INTEGER :: ierr, ibuffsize, impp, ipi0
+ INTEGER :: ii1, ii2, ij1, ij2, ij3, iig, inei
+ INTEGER :: i0max, ilntot, iisht, ijsht, ihsz
+ INTEGER :: iproc, ijnr, ipjtot, iF_TU, i012
+ INTEGER, DIMENSION(kfld) :: ipi, ipj, ipj1, ipj2, ipk, ipl ! dimension of the input array
+ INTEGER, DIMENSION(kfld) :: ihls ! halo size
+ INTEGER, DIMENSION(:) , ALLOCATABLE :: ireq_s, ireq_r ! for mpi_isend when avoiding mpi_allgather
+ INTEGER, DIMENSION(:) , ALLOCATABLE :: ipjfld ! number of sent lines for each field
+ REAL(PRECISION) :: zhuge, zztmp
+ REAL(PRECISION), DIMENSION(:,:) , ALLOCATABLE :: zbufs ! buffer, receive and work arrays
+ REAL(PRECISION), DIMENSION(:,:,:), ALLOCATABLE :: zbufr ! buffer, receive and work arrays
+ REAL(PRECISION), DIMENSION(:,:) , ALLOCATABLE :: znorthloc
+ REAL(PRECISION), DIMENSION(:,:,:), ALLOCATABLE :: znorthall
+ TYPE(PTR_4D_/**/PRECISION), DIMENSION(1) :: ztabglo ! array or pointer of arrays on which apply the b.c.
!!----------------------------------------------------------------------
!
- ipk = SIZE(ptab(1)%pt4d,3)
- ipl = SIZE(ptab(1)%pt4d,4)
- ipf = kfld
+ zhuge = HUGE(0._/**/PRECISION) ! avoid to call the huge function inside do loops
+ !
+ DO jf = 1, kfld
+ ipi(jf) = SIZE(ptab(jf)%pt4d,1)
+ ipj(jf) = SIZE(ptab(jf)%pt4d,2)
+ ipk(jf) = SIZE(ptab(jf)%pt4d,3)
+ ipl(jf) = SIZE(ptab(jf)%pt4d,4)
+ ihls(jf) = ( ipi(jf) - Ni_0 ) / 2
+ END DO
!
IF( ln_nnogather ) THEN !== no allgather exchanges ==!
@@ -45,7 +47,6 @@
! - c_NFtype='T', grid=U : half of the last line (jpiglo/2+1:jpiglo-nn_hls)
! - c_NFtype='T', grid=V : all the last line nn_hls+1 and (nn_hls+2:jpiglo-nn_hls)
! - c_NFtype='T', grid=F : all the last line (nn_hls+1:jpiglo-nn_hls)
- ! - c_NFtype='F', grid=T : 2 points of the last line (jpiglo/2+1 and jpglo-nn_hls)
! - c_NFtype='F', grid=U : no points are duplicated
! - c_NFtype='F', grid=V : half of the last line (jpiglo/2+1:jpiglo-nn_hls)
! - c_NFtype='F', grid=F : half of the last line (jpiglo/2+1:jpiglo-nn_hls-1)
@@ -54,81 +55,46 @@
! In consequence, we may want to force the folding on these points by setting l_full_nf_update = .TRUE.
! This is slightly slower but necessary to avoid different values on identical grid points!!
!
- !!!!!!!!! temporary switch off this optimisation ==> force TRUE !!!!!!!!
- !!!!!!!!! needed to get the same results without agrif and with agrif and no zoom !!!!!!!!
- !!!!!!!!! I don't know why we must do that... !!!!!!!!
- l_full_nf_update = .TRUE.
- ! also force it if not restart during the first 2 steps (leap frog?)
- ll_add_line = l_full_nf_update .OR. ( ncom_stp <= nit000+1 .AND. .NOT. ln_rstart )
+ llfull = .FALSE.
+ IF ( PRESENT(ldfull) ) llfull = ldfull
+ ! also force during the first step to make sure all the init are ok
+ llfull = llfull .OR. ncom_stp <= nit000
- ALLOCATE(ipjfld(ipf)) ! how many lines do we exchange for each field?
- IF( ll_add_line ) THEN
- DO jf = 1, ipf ! Loop over the number of arrays to be processed
- ipjfld(jf) = khls + COUNT( (/ c_NFtype == 'T' .OR. cd_nat(jf) == 'V' .OR. cd_nat(jf) == 'F' /) )
+ ALLOCATE(ipjfld(kfld)) ! how many lines do we send for each field?
+ IF( llfull ) THEN
+ DO jf = 1, kfld ! Loop over the number of arrays to be processed
+ ipjfld(jf) = ihls(jf) + COUNT( (/ c_NFtype == 'T' .OR. cd_nat(jf) == 'V' .OR. cd_nat(jf) == 'F' /) )
END DO
ELSE
- ipjfld(:) = khls
+ ipjfld(:) = ihls(:)
ENDIF
-
- ipj = MAXVAL(ipjfld(:)) ! Max 2nd dimension of message transfers
- ipjtot = SUM( ipjfld(:)) ! Total number of lines to be exchanged
-
- ! Index of modifying lines in input
- ALLOCATE( ijsnd(ipj, ipf), ijbuf(ipj, ipf), ijrcv(ipj, ipf), ii1st(ipj, ipf), iiend(ipj, ipf) )
-
- ij1 = 0
- DO jf = 1, ipf ! Loop over the number of arrays to be processed
- !
- DO jj = 1, khls ! first khls lines (starting from top) must be fully defined
- ii1st(jj, jf) = 1
- iiend(jj, jf) = jpi
- END DO
- !
- ! what do we do with line khls+1 (starting from top)
- IF( c_NFtype == 'T' ) THEN ! * North fold T-point pivot
- SELECT CASE ( cd_nat(jf) )
- CASE ('T','W') ; i012 = 1 ; ii1st(khls+1, jf) = mi0(jpiglo/2+2) ; iiend(khls+1, jf) = mi1(jpiglo-khls)
- CASE ('U' ) ; i012 = 1 ; ii1st(khls+1, jf) = mi0(jpiglo/2+1) ; iiend(khls+1, jf) = mi1(jpiglo-khls)
- CASE ('V' ) ; i012 = 2 ; ii1st(khls+1, jf) = 1 ; iiend(khls+1, jf) = jpi
- CASE ('F' ) ; i012 = 2 ; ii1st(khls+1, jf) = 1 ; iiend(khls+1, jf) = jpi
- END SELECT
- ENDIF
- IF( c_NFtype == 'F' ) THEN ! * North fold F-point pivot
- SELECT CASE ( cd_nat(jf) )
- CASE ('T','W') ; i012 = 0 ! we don't touch line khls+1
- CASE ('U' ) ; i012 = 0 ! we don't touch line khls+1
- CASE ('V' ) ; i012 = 1 ; ii1st(khls+1, jf) = mi0(jpiglo/2+1) ; iiend(khls+1, jf) = mi1(jpiglo-khls )
- CASE ('F' ) ; i012 = 1 ; ii1st(khls+1, jf) = mi0(jpiglo/2+1) ; iiend(khls+1, jf) = mi1(jpiglo-khls-1)
- END SELECT
- ENDIF
- !
- DO jj = 1, ipjfld(jf)
- ij1 = ij1 + 1
- ijsnd(jj,jf) = jpj - 2*khls + jj - i012 ! sent lines (from bottom of sent lines)
- ijbuf(jj,jf) = ij1 ! gather all lines in the snd/rcv buffers
- ijrcv(jj,jf) = jpj - jj + 1 ! recv lines (from the top -> reverse order for jj)
- END DO
- !
- END DO
!
- i0max = jpimax - 2 * khls ! we are not sending the halos
- ALLOCATE( zbufs(i0max,ipjtot,ipk,ipl), ireq_s(nfd_nbnei) ) ! store all the data to be sent in a buffer array
- ibuffsize = i0max * ipjtot * ipk * ipl
+ i0max = MAXVAL( nfni_0, mask = nfproc /= -1 ) ! largest value of Ni_0 among processors (we are not sending halos)
+ ilntot = SUM( ipjfld(:) * ipk(:) * ipl(:) )
+ ALLOCATE( zbufs(i0max,ilntot), ireq_s(nfd_nbnei) ) ! store all the data to be sent in a buffer array
+ ibuffsize = i0max * ilntot ! must be the same for all processors -> use i0max
!
! fill the send buffer with all the lines
- DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk
- DO jj = 1, ipjfld(jf)
- ij1 = ijbuf(jj,jf)
- ij2 = ijsnd(jj,jf)
- DO ji = Nis0, Nie0 ! should not use any other value
- iib = ji - Nis0 + 1
- zbufs(iib,ij1,jk,jl) = ptab(jf)%pt4d(ji,ij2,jk,jl)
- END DO
- DO ji = Ni_0+1, i0max ! avoid sending uninitialized values (make sure we don't use it)
- zbufs(ji,ij1,jk,jl) = HUGE(0._/**/PRECISION) ! make sure we don't use it...
+ ij1 = 0
+ DO jf = 1, kfld
+ !
+ i012 = COUNT( (/ c_NFtype == 'T' /) ) + COUNT( (/ cd_nat(jf) == 'V' .OR. cd_nat(jf) == 'F' /) ) ! 0, 1 OR 2
+ ijsht = ipj(jf) - 2*ihls(jf) - i012 ! j-position of the sent lines (from bottom of sent lines)
+ !
+ DO jl = 1, ipl(jf) ; DO jk = 1, ipk(jf)
+ DO jj = 1, ipjfld(jf)
+ ij1 = ij1 + 1
+ ij2 = jj + ijsht
+ DO ji = 1, Ni_0 ! use only inner domain
+ ii2 = ji + ihls(jf)
+ zbufs(ji,ij1) = ptab(jf)%pt4d(ii2,ij2,jk,jl)
+ END DO
+ DO ji = Ni_0+1, i0max ! avoid sending uninitialized values and make sure we don't use it
+ zbufs(ji,ij1) = zhuge
+ END DO
END DO
- END DO
- END DO ; END DO ; END DO
+ END DO ; END DO
+ END DO ! jf
!
! start waiting time measurement
IF( ln_timing ) CALL tic_tac(.TRUE.)
@@ -136,68 +102,62 @@
! send the same buffer data to all neighbourgs as soon as possible
DO jn = 1, nfd_nbnei
iproc = nfd_rknei(jn)
- IF( iproc /= narea-1 .AND. iproc /= -1 ) THEN
+ IF( iproc /= narea-1 .AND. iproc /= -1 ) THEN ! it is neither me nor a land-only neighbourg
#if ! defined key_mpi_off
CALL MPI_Isend( zbufs, ibuffsize, MPI_TYPE, iproc, 5, mpi_comm_oce, ireq_s(jn), ierr )
#endif
ELSE
- ireq_s(jn) = MPI_REQUEST_NULL
+ ireq_s(jn) = MPI_REQUEST_NULL ! must be defined for mpi_waitall
ENDIF
END DO
!
- ALLOCATE( zbufr(i0max,ipjtot,ipk,ipl,nfd_nbnei), ireq_r(nfd_nbnei) )
+ ALLOCATE( zbufr(i0max,ilntot,nfd_nbnei), ireq_r(nfd_nbnei) )
!
- DO jn = 1, nfd_nbnei
- !
+ DO jn = 1, nfd_nbnei ! 1st loop: first get data which does not need any communication
+ ! ! -> this gives more time to receive the communications
iproc = nfd_rknei(jn)
!
- IF( iproc == -1 ) THEN ! No neighbour (land proc that was suppressed)
+ IF( iproc == -1 ) THEN ! No neighbour (land-only neighbourg that was suppressed)
!
- ireq_r(jn) = MPI_REQUEST_NULL ! no message to be received
- zbufr(:,:,:,:,jn) = HUGE(0._/**/PRECISION) ! default: define it and make sure we don't use it...
+ ireq_r(jn) = MPI_REQUEST_NULL ! no message to be received, must be defined for mpi_waitall
SELECT CASE ( kfillmode )
CASE ( jpfillnothing ) ! no filling
- CASE ( jpfillcopy ) ! filling with inner domain values
- DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk
- DO jj = 1, ipjfld(jf)
- ij1 = ijbuf(jj,jf)
- ij2 = ijsnd(jj,jf) ! we will use only the first value, see init_nfdcom
- zbufr(1,ij1,jk,jl,jn) = ptab(jf)%pt4d(Nis0,ij2,jk,jl) ! chose to take the 1st inner domain point
- END DO
- END DO ; END DO ; END DO
+ CASE ( jpfillcopy ) ! filling with my inner domain values
+ ! ! trick: we use only the 1st value, see init_nfdcom
+ zbufr(1,:,jn) = zbufs(1,:) ! chose to take the 1st inner domain point
CASE ( jpfillcst ) ! filling with constant value
- zbufr(1,:,:,:,jn) = pfillval ! we will use only the first value, see init_nfdcom
+ zbufr(1,:,jn) = pfillval ! trick: we use only the 1st value, see init_nfdcom
END SELECT
!
- ELSE IF( iproc == narea-1 ) THEN ! get data from myself!
+ ELSE IF( iproc == narea-1 ) THEN ! I get data from myself!
!
- ireq_r(jn) = MPI_REQUEST_NULL ! no message to be received
- DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk
- DO jj = 1, ipjfld(jf)
- ij1 = ijbuf(jj,jf)
- ij2 = ijsnd(jj,jf)
- DO ji = Nis0, Nie0 ! should not use any other value
- iib = ji - Nis0 + 1
- zbufr(iib,ij1,jk,jl,jn) = ptab(jf)%pt4d(ji,ij2,jk,jl)
- END DO
- END DO
- END DO ; END DO ; END DO
+ ireq_r(jn) = MPI_REQUEST_NULL ! no message to be received, must be defined for mpi_waitall
+ zbufr(:,:,jn) = zbufs(:,:) ! we can directly do: received buffer = sent buffer!
!
- ELSE ! get data from a neighbour trough communication
+ ENDIF
+ !
+ END DO ! nfd_nbnei
+ !
+ DO jn = 1, nfd_nbnei ! 2nd loop: now get data from a neighbour trough communication
+ !
+ iproc = nfd_rknei(jn)
+ IF( iproc /= narea-1 .AND. iproc /= -1 ) THEN ! it is neither me nor a land-only neighbourg
#if ! defined key_mpi_off
- CALL MPI_Irecv( zbufr(:,:,:,:,jn), ibuffsize, MPI_TYPE, iproc, 5, mpi_comm_oce, ireq_r(jn), ierr )
+ CALL MPI_Irecv( zbufr(:,:,jn), ibuffsize, MPI_TYPE, iproc, 5, mpi_comm_oce, ireq_r(jn), ierr )
#endif
ENDIF
- !
END DO ! nfd_nbnei
!
+#if ! defined key_mpi_off
CALL mpi_waitall(nfd_nbnei, ireq_r, MPI_STATUSES_IGNORE, ierr) ! wait for all Irecv
+#endif
!
IF( ln_timing ) CALL tic_tac(.FALSE.)
!
- ! North fold boundary condition
+ ! Apply the North pole folding
!
- DO jf = 1, ipf
+ ij2 = 0
+ DO jf = 1, kfld
!
SELECT CASE ( cd_nat(jf) ) ! which grid number?
CASE ('T','W') ; iig = 1 ! T-, W-point
@@ -206,76 +166,42 @@
CASE ('F') ; iig = 4 ! F-point
END SELECT
!
- DO jl = 1, ipl ; DO jk = 1, ipk
- !
- ! if T point with F-point pivot : must be done first
- ! --> specific correction of 3 points near the 2 pivots (to be clean, usually masked -> so useless)
- IF( c_NFtype == 'F' .AND. iig == 1 ) THEN
- ij1 = jpj - khls ! j-index in the receiving array
- ij2 = 1 ! only 1 line in the buffer
- DO ji = mi0(khls), mi1(khls) ! change because of EW periodicity as we also change jpiglo-khls
- iib = nfd_jisnd(mi0( khls),iig) ! i-index in the buffer
- iin = nfd_rksnd(mi0( khls),iig) ! neigbhour-index in the buffer
- IF( nfd_rknei(iin) == -1 .AND. kfillmode == jpfillnothing ) CYCLE
- ptab(jf)%pt4d(ji,ij1,jk,jl) = zbufr(iib,ij2,jk,jl,iin) ! no psgn(jf)
- END DO
- DO ji = mi0(jpiglo/2+1), mi1(jpiglo/2+1)
- iib = nfd_jisnd(mi0( jpiglo/2+1),iig) ! i-index in the buffer
- iin = nfd_rksnd(mi0( jpiglo/2+1),iig) ! neigbhour-index in the buffer
- IF( nfd_rknei(iin) == -1 .AND. kfillmode == jpfillnothing ) CYCLE
- ptab(jf)%pt4d(ji,ij1,jk,jl) = zbufr(iib,ij2,jk,jl,iin) ! no psgn(jf)
- END DO
- DO ji = mi0(jpiglo-khls), mi1(jpiglo-khls)
- iib = nfd_jisnd(mi0(jpiglo-khls),iig) ! i-index in the buffer
- iin = nfd_rksnd(mi0(jpiglo-khls),iig) ! neigbhour-index in the buffer
- IF( nfd_rknei(iin) == -1 .AND. kfillmode == jpfillnothing ) CYCLE
- ptab(jf)%pt4d(ji,ij1,jk,jl) = zbufr(iib,ij2,jk,jl,iin) ! no psgn(jf)
- END DO
- ENDIF
+ ihsz = ihls(jf) ! shorter name
+ iisht = nn_hls - ihsz
+ !
+ DO jl = 1, ipl(jf) ; DO jk = 1, ipk(jf)
!
- ! Apply the North pole folding.
- DO jj = 1, ipjfld(jf) ! for all lines to be exchanged for this field
- ij1 = ijrcv(jj,jf) ! j-index in the receiving array
- ij2 = ijbuf(jj,jf) ! j-index in the buffer
- iis = ii1st(jj,jf) ! stating i-index in the receiving array
- iie = iiend(jj,jf) ! ending i-index in the receiving array
- DO ji = iis, iie
- iib = nfd_jisnd(ji,iig) ! i-index in the buffer
- iin = nfd_rksnd(ji,iig) ! neigbhour-index in the buffer
- IF( nfd_rknei(iin) == -1 .AND. kfillmode == jpfillnothing ) CYCLE
- ptab(jf)%pt4d(ji,ij1,jk,jl) = psgn(jf) * zbufr(iib,ij2,jk,jl,iin)
+ DO jj = 1,ihsz ! NP folding for the last ihls(jf) lines of this field
+ ij1 = ipj(jf) - jj + 1 ! j-index in the receiving array (from the top -> reverse order for jj)
+ ij2 = ij2 + 1
+ ij3 = ihsz+1 - jj + 1
+ DO ji = 1, ipi(jf)
+ ii1 = ji + iisht
+ inei = nfd_rksnd(ii1,ij3,iig) ! neigbhour-index in the buffer
+ IF( nfd_rknei(inei) == -1 .AND. kfillmode == jpfillnothing ) CYCLE ! no neighbourg and do nothing to fill
+ ii2 = nfd_jisnd(ii1,ij3,iig) ! i-index in the buffer, starts at 1 in the inner domain
+ ptab(jf)%pt4d(ji,ij1,jk,jl) = psgn(jf) * zbufr(ii2,ij2,inei)
END DO
END DO
- !
- ! re-apply periodocity when we modified the eastern side of the inner domain (and not the full line)
- IF( c_NFtype == 'T' ) THEN ! * North fold T-point pivot
- IF( iig <= 2 ) THEN ; iis = mi0(1) ; iie = mi1(khls) ! 'T','W','U': update west halo
- ELSE ; iis = 1 ; iie = 0 ! 'V','F' : full line already exchanged
- ENDIF
- ENDIF
- IF( c_NFtype == 'F' ) THEN ! * North fold F-point pivot
- IF( iig <= 2 ) THEN ; iis = 1 ; iie = 0 ! 'T','W','U': nothing to do
- ELSEIF( iig == 3 ) THEN ; iis = mi0(1) ; iie = mi1(khls) ! 'V' : update west halo
- ELSEIF( khls > 1 ) THEN ; iis = mi0(1) ; iie = mi1(khls-1) ! 'F' and khls > 1
- ELSE ; iis = 1 ; iie = 0 ! 'F' and khls == 1 : nothing to do
- ENDIF
- ENDIF
- jj = ipjfld(jf) ! only for the last line of this field
- ij1 = ijrcv(jj,jf) ! j-index in the receiving array
- ij2 = ijbuf(jj,jf) ! j-index in the buffer
- DO ji = iis, iie
- iib = nfd_jisnd(ji,iig) ! i-index in the buffer
- iin = nfd_rksnd(ji,iig) ! neigbhour-index in the buffer
- IF( nfd_rknei(iin) == -1 .AND. kfillmode == jpfillnothing ) CYCLE
- ptab(jf)%pt4d(ji,ij1,jk,jl) = psgn(jf) * zbufr(iib,ij2,jk,jl,iin)
+ DO jj = ihsz+1, ipjfld(jf) ! NP folding for line ipj-ihsz that can be partially modified
+ ij1 = ipj(jf) - jj + 1 ! j-index in the receiving array (from the top -> reverse order for jj)
+ ij2 = ij2 + 1
+ ij3 = 1
+ DO ji = 1, ipi(jf)
+ ii1 = ji + iisht
+ IF( lnfd_same(ii1,iig) ) CYCLE ! do nothing if should not be modified
+ inei = nfd_rksnd(ii1,ij3,iig) ! neigbhour-index in the buffer
+ IF( nfd_rknei(inei) == -1 .AND. kfillmode == jpfillnothing ) CYCLE ! no neighbourg and do nothing to fill
+ ii2 = nfd_jisnd(ii1,ij3,iig) ! i-index in the buffer, starts at 1 in the inner domain
+ ptab(jf)%pt4d(ji,ij1,jk,jl) = psgn(jf) * zbufr(ii2,ij2,inei)
+ END DO
END DO
!
- END DO ; END DO ! ipl ; ipk
+ END DO ; END DO ! jk ; jl
!
- END DO ! ipf
-
+ END DO ! jf
!
- DEALLOCATE( zbufr, ireq_r, ijsnd, ijbuf, ijrcv, ii1st, iiend, ipjfld )
+ DEALLOCATE( zbufr, ireq_r, ipjfld )
!
CALL mpi_waitall(nfd_nbnei, ireq_s, MPI_STATUSES_IGNORE, ierr) ! wait for all Isend
!
@@ -283,114 +209,126 @@
!
ELSE !== allgather exchanges ==!
!
- ! how many lines do we exchange at max? -> ipj (no further optimizations in this case...)
- ipj = khls + 2
- ! how many lines do we need at max? -> ipj2 (no further optimizations in this case...)
- ipj2 = 2 * khls + 2
+ DO jf = 1, kfld
+ ! how many lines do we send for each field?
+ ipj1(jf) = ihls(jf) + COUNT( (/ c_NFtype == 'T' .OR. cd_nat(jf) == 'V' .OR. cd_nat(jf) == 'F' /) )
+ ! how many lines do we need for each field?
+ ipj2(jf) = 2 * ihls(jf) + COUNT( (/ c_NFtype == 'T' /) ) + COUNT( (/ cd_nat(jf) == 'V' .OR. cd_nat(jf) == 'F' /) )
+ END DO
!
- i0max = jpimax - 2 * khls
- ibuffsize = i0max * ipj * ipk * ipl * ipf
- ALLOCATE( znorthloc(i0max,ipj,ipk,ipl,ipf), znorthglo(i0max,ipj,ipk,ipl,ipf,ndim_rank_north) )
+ i0max = MAXVAL( nfni_0, mask = nfproc /= -1 ) ! largest value of Ni_0 among processors (we are not sending halos)
+ ibuffsize = i0max * SUM( ipj1(:) * ipk(:) * ipl(:) ) ! use i0max because each proc must have the same buffer size
+ ALLOCATE( znorthloc(i0max, ibuffsize/i0max), znorthall(i0max, ibuffsize/i0max, ndim_rank_north) )
!
- DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ! put in znorthloc ipj j-lines of ptab
- DO jj = 1, ipj
- ij2 = jpj - ipj2 + jj ! the first ipj lines of the last ipj2 lines
+ ij1 = 0 ! initalize line index
+ DO jf = 1, kfld ; DO jl = 1, ipl(jf) ; DO jk = 1, ipk(jf)
+ DO jj = 1, ipj1(jf) ! put in znorthloc ipj1(jf) j-lines of ptab
+ ij2 = ipj(jf) - ipj2(jf) + jj ! the first ipj1 lines of the last ipj2 lines
+ ij1 = ij1 + 1
DO ji = 1, Ni_0
- ii2 = Nis0 - 1 + ji ! inner domain: Nis0 to Nie0
- znorthloc(ji,jj,jk,jl,jf) = ptab(jf)%pt4d(ii2,ij2,jk,jl)
+ ii2 = ihls(jf) + ji ! copy only the inner domain
+ znorthloc(ji,ij1) = ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
- DO ji = Ni_0+1, i0max
- znorthloc(ji,jj,jk,jl,jf) = HUGE(0._/**/PRECISION) ! avoid sending uninitialized values (make sure we don't use it)
+ DO ji = Ni_0+1, i0max ! avoid to send uninitialized values
+ znorthloc(ji,ij1) = zhuge ! and make sure we don't use it
END DO
END DO
END DO ; END DO ; END DO
!
! start waiting time measurement
- IF( ln_timing ) CALL tic_tac(.TRUE.)
#if ! defined key_mpi_off
- CALL MPI_ALLGATHER( znorthloc, ibuffsize, MPI_TYPE, znorthglo, ibuffsize, MPI_TYPE, ncomm_north, ierr )
+ IF( ln_timing ) CALL tic_tac( .TRUE.) ! start waiting time measurement
+ ! fill znorthall with the znorthloc of each northern process
+ CALL MPI_ALLGATHER( znorthloc, ibuffsize, MPI_TYPE, znorthall, ibuffsize, MPI_TYPE, ncomm_north, ierr )
+ IF( ln_timing ) CALL tic_tac(.FALSE.) ! stop waiting time measurement
#endif
- ! stop waiting time measurement
- IF( ln_timing ) CALL tic_tac(.FALSE.)
- DEALLOCATE( znorthloc )
- ALLOCATE( ztabglo(ipf) )
- DO jf = 1, ipf
- ALLOCATE( ztabglo(jf)%pt4d(jpiglo,ipj2,ipk,ipl) )
- END DO
+ DEALLOCATE( znorthloc ) ! no more need of znorthloc
!
- ! need to fill only the first ipj lines of ztabglo as lbc_nfd don't use the last khls lines
- ijnr = 0
- DO jr = 1, jpni ! recover the global north array
- iproc = nfproc(jr)
- impp = nfimpp(jr)
- ipi = nfjpi( jr) - 2 * khls ! corresponds to Ni_0 but for subdomain iproc
- IF( iproc == -1 ) THEN ! No neighbour (land proc that was suppressed)
- !
- SELECT CASE ( kfillmode )
- CASE ( jpfillnothing ) ! no filling
- CALL ctl_stop( 'STOP', 'mpp_nfd_generic : cannot use jpfillnothing with ln_nnogather = F')
- CASE ( jpfillcopy ) ! filling with inner domain values
- DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk
- DO jj = 1, ipj
- ij2 = jpj - ipj2 + jj ! the first ipj lines of the last ipj2 lines
- DO ji = 1, ipi
- ii1 = impp + khls + ji - 1 ! corresponds to mig(khls + ji) but for subdomain iproc
- ztabglo(jf)%pt4d(ii1,jj,jk,jl) = ptab(jf)%pt4d(Nis0,ij2,jk,jl) ! chose to take the 1st inner domain point
+ DO jf = 1, kfld
+ !
+ ihsz = ihls(jf) ! shorter name
+ iisht = nn_hls - ihsz
+ ALLOCATE( ztabglo(1)%pt4d(Ni0glo+2*ihsz,ipj2(jf),ipk(jf),ipl(jf)) )
+ !
+ iF_TU = COUNT( (/ c_NFtype == 'F' .AND. ( cd_nat(jf) == 'U' .OR. cd_nat(jf) == 'T' ) /) ) ! F-folding and T or U grid
+ IF( iF_TU == 0 ) ztabglo(1)%pt4d(:,ipj2(jf)-ihsz,:,:) = zhuge ! flag off the line that is not fully modified
+ !
+ ! need to fill only the first ipj1(j) lines of ztabglo as lbc_nfd don't use the last ihsz lines
+ ijnr = 0
+ DO jr = 1, jpni ! recover the global north array using each northern process
+ iproc = nfproc(jr) ! process number
+ impp = nfimpp(jr) + ihsz ! ( = +nn_hls-iisht) ! inner domain position (without halos) of subdomain iproc
+ ipi0 = nfni_0(jr) ! Ni_0 but for subdomain iproc
+ !
+ IF( iproc == -1 ) THEN ! No neighbour (land proc that was suppressed)
+ !
+ SELECT CASE ( kfillmode )
+ CASE ( jpfillnothing ) ! no filling
+ CALL ctl_stop( 'STOP', 'mpp_nfd_generic : cannot use jpfillnothing with ln_nnogather = F')
+ CASE ( jpfillcopy ) ! filling with inner domain values
+ DO jl = 1, ipl(jf) ; DO jk = 1, ipk(jf)
+ DO jj = 1, ipj1(jf)
+ ij2 = ipj(jf) - ipj2(jf) + jj ! the first ipj1(jf) lines of the last ipj2(jf) lines
+ DO ji = 1, ipi0
+ ii1 = impp + ji - 1 ! inner iproc-subdomain in the global domain with ihsz halos
+ ztabglo(1)%pt4d(ii1,jj,jk,jl) = ptab(jf)%pt4d(ihsz+1,ij2,jk,jl) ! take the 1st inner domain point
+ END DO
END DO
- END DO
- END DO ; END DO ; END DO
- CASE ( jpfillcst ) ! filling with constant value
- DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk
- DO jj = 1, ipj
- DO ji = 1, ipi
- ii1 = impp + khls + ji - 1 ! corresponds to mig(khls + ji) but for subdomain iproc
- ztabglo(jf)%pt4d(ii1,jj,jk,jl) = pfillval
+ END DO ; END DO
+ CASE ( jpfillcst ) ! filling with constant value
+ DO jl = 1, ipl(jf) ; DO jk = 1, ipk(jf)
+ DO jj = 1, ipj1(jf)
+ DO ji = 1, ipi0
+ ii1 = impp + ji - 1 ! inner iproc-subdomain in the global domain with ihsz halos
+ ztabglo(1)%pt4d(ii1,jj,jk,jl) = pfillval
+ END DO
+ END DO
+ END DO ; END DO
+ END SELECT
+ !
+ ELSE ! use neighbour values
+ ijnr = ijnr + 1
+ ij1 = SUM( ipj1(1:jf-1) * ipk(1:jf-1) * ipl(1:jf-1) ) ! reset line offset, return 0 if jf = 1
+ DO jl = 1, ipl(jf) ; DO jk = 1, ipk(jf)
+ DO jj = 1, ipj1(jf)
+ ij1 = ij1 + 1
+ DO ji = 1, ipi0
+ ii1 = impp + ji - 1 ! inner iproc-subdomain in the global domain with ihsz halos
+ ztabglo(1)%pt4d(ii1,jj,jk,jl) = znorthall(ji, ij1, ijnr)
END DO
END DO
- END DO ; END DO ; END DO
- END SELECT
+ END DO ; END DO
+ ENDIF
!
- ELSE
- ijnr = ijnr + 1
- DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk
- DO jj = 1, ipj
- DO ji = 1, ipi
- ii1 = impp + khls + ji - 1 ! corresponds to mig(khls + ji) but for subdomain iproc
- ztabglo(jf)%pt4d(ii1,jj,jk,jl) = znorthglo(ji,jj,jk,jl,jf,ijnr)
- END DO
- END DO
- END DO ; END DO ; END DO
- ENDIF
+ END DO ! jpni
!
- END DO ! jpni
- DEALLOCATE( znorthglo )
- !
- DO jf = 1, ipf
- CALL lbc_nfd( ztabglo(jf:jf), cd_nat(jf:jf), psgn(jf:jf), khls, 1 ) ! North fold boundary condition
- DO jl = 1, ipl ; DO jk = 1, ipk ! e-w periodicity
- DO jj = 1, khls + 1
- ij1 = ipj2 - (khls + 1) + jj ! need only the last khls + 1 lines until ipj2
- ztabglo(jf)%pt4d( 1: khls,ij1,jk,jl) = ztabglo(jf)%pt4d(jpiglo-2*khls+1:jpiglo-khls,ij1,jk,jl)
- ztabglo(jf)%pt4d(jpiglo-khls+1:jpiglo,ij1,jk,jl) = ztabglo(jf)%pt4d( khls+1: 2*khls,ij1,jk,jl)
+ CALL lbc_nfd( ztabglo, cd_nat(jf:jf), psgn(jf:jf), 1 ) ! North fold boundary condition
+ !
+ DO jl = 1, ipl(jf) ; DO jk = 1, ipk(jf) ! Scatter back to ARRAY_IN
+ DO jj = 0, ihsz-1
+ ij1 = ipj( jf) - jj ! last ihsz lines
+ ij2 = ipj2(jf) - jj ! last ihsz lines
+ DO ji= 1, ipi(jf)
+ ii2 = mig(ji+iisht,ihsz) ! warning, mig is expecting local domain indices related to nn_hls
+ ptab(jf)%pt4d(ji,ij1,jk,jl) = ztabglo(1)%pt4d(ii2,ij2,jk,jl)
+ END DO
END DO
- END DO ; END DO
- END DO
- !
- DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ! Scatter back to ARRAY_IN
- DO jj = 1, khls + 1
- ij1 = jpj - (khls + 1) + jj ! last khls + 1 lines until jpj
- ij2 = ipj2 - (khls + 1) + jj ! last khls + 1 lines until ipj2
- DO ji= 1, jpi
- ii2 = mig(ji)
- ptab(jf)%pt4d(ji,ij1,jk,jl) = ztabglo(jf)%pt4d(ii2,ij2,jk,jl)
+ DO jj = ihsz, ihsz - iF_TU
+ ij1 = ipj( jf) - jj ! last ihsz+1 line
+ ij2 = ipj2(jf) - jj ! last ihsz+1 line
+ DO ji= 1, ipi(jf)
+ ii2 = mig(ji+iisht,ihsz) ! warning, mig is expecting local domain indices related to nn_hls
+ zztmp = ztabglo(1)%pt4d(ii2,ij2,jk,jl)
+ IF( zztmp /= zhuge ) ptab(jf)%pt4d(ji,ij1,jk,jl) = zztmp ! apply it only if it was modified by lbc_nfd
+ END DO
END DO
- END DO
- END DO ; END DO ; END DO
+ END DO ; END DO
+ !
+ DEALLOCATE( ztabglo(1)%pt4d )
+ !
+ END DO ! jf
!
- DO jf = 1, ipf
- DEALLOCATE( ztabglo(jf)%pt4d )
- END DO
- DEALLOCATE( ztabglo )
+ DEALLOCATE( znorthall )
!
ENDIF ! ln_nnogather
!
diff --git a/src/OCE/LBC/mppini.F90 b/src/OCE/LBC/mppini.F90
index 7af3c0fe8fbf7cc329dc63a64fe8bbf606538340..3e335b8fc71219f4f8f545fab873d42bccb62e18 100644
--- a/src/OCE/LBC/mppini.F90
+++ b/src/OCE/LBC/mppini.F90
@@ -73,7 +73,8 @@ CONTAINS
jpi = jpiglo
jpj = jpjglo
jpk = MAX( 2, jpkglo )
- jpij = jpi*jpj
+ !jpij = jpi*jpj
+ jpij = Ni0glo*Nj0glo
jpni = 1
jpnj = 1
jpnij = jpni*jpnj
@@ -169,6 +170,10 @@ CONTAINS
902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nammpp in configuration namelist' )
!
nn_hls = MAX(1, nn_hls) ! nn_hls must be > 0
+# if defined key_mpi2
+ WRITE(numout,*) ' use key_mpi2, we force nn_comm = 1'
+ nn_comm = 1
+# endif
IF(lwp) THEN
WRITE(numout,*) ' Namelist nammpp'
IF( jpni < 1 .OR. jpnj < 1 ) THEN
@@ -307,7 +312,7 @@ CONTAINS
9002 FORMAT (a, i4, a)
9003 FORMAT (a, i5)
- ALLOCATE( nfimpp(jpni), nfproc(jpni), nfjpi(jpni), &
+ ALLOCATE( nfimpp(jpni), nfproc(jpni), nfjpi(jpni), nfni_0(jpni), &
& iin(jpnij), ijn(jpnij), &
& iimppt(jpni,jpnj), ijmppt(jpni,jpnj), ijpi(jpni,jpnj), ijpj(jpni,jpnj), ipproc(jpni,jpnj), &
& inei(8,jpni,jpnj), llnei(8,jpni,jpnj), &
@@ -331,7 +336,8 @@ CONTAINS
jpi = ijpi(ii,ij)
jpj = ijpj(ii,ij)
jpk = MAX( 2, jpkglo )
- jpij = jpi*jpj
+ !jpij = jpi*jpj
+ jpij = (jpi-2*nn_hls)*(jpj-2*nn_hls)
nimpp = iimppt(ii,ij)
njmpp = ijmppt(ii,ij)
!
@@ -379,7 +385,8 @@ CONTAINS
! Store informations for the north pole folding communications
nfproc(:) = ipproc(:,jpnj)
nfimpp(:) = iimppt(:,jpnj)
- nfjpi (:) = ijpi(:,jpnj)
+ nfjpi (:) = ijpi(:,jpnj) ! needed only for mpp_lbc_north_icb_generic.h90
+ nfni_0(:) = ijpi(:,jpnj) - 2 * nn_hls
!
! 3. Define Western, Eastern, Southern and Northern neighbors + corners in the subdomain grid reference
! ------------------------------------------------------------------------------------------------------
@@ -493,7 +500,9 @@ CONTAINS
! -----------------------------------------
!
! set default neighbours
- mpinei(:) = impi(:,narea)
+ mpinei(:) = impi(:,narea) ! should be just local but is still used in icblbc and mpp_lnk_icb_generic.h90...
+ mpiSnei(0,:) = -1 ! no comm if no halo (but still need to call the NP Folding that may modify the last line)
+ mpiRnei(0,:) = -1
DO jh = 1, n_hlsmax
mpiSnei(jh,:) = impi(:,narea) ! default definition
mpiRnei(jh,:) = impi(:,narea)
@@ -520,6 +529,7 @@ CONTAINS
!
! ! Prepare mpp north fold
!
+ l_NFold = l_NFold .AND. ANY( nfproc /= -1 ) ! make sure that we kept at least 1 proc along the last line
llmpiNFold = jpni > 1 .AND. l_NFold ! is the North fold done with an MPI communication?
l_IdoNFold = ijn(narea) == jpnj .AND. l_NFold ! is this process doing North fold?
!
@@ -1203,7 +1213,7 @@ CONTAINS
!
ALLOCATE( zmsk0(ipi,ipj), zmsk(ipi,ipj) )
zmsk0(jh+1:jh+Ni_0,jh+1:jh+Nj_0) = REAL(COUNT(lloce, dim = 3), wp) ! define inner domain -> need REAL to use lbclnk
- CALL lbc_lnk('mppini', zmsk0, 'T', 1._wp, khls = jh) ! fill halos
+ CALL lbc_lnk( ' mppini', zmsk0, 'T', 1._wp ) ! fill halos
! Beware about the mask we must use here :
DO jj = jh+1, jh+Nj_0
DO ji = jh+1, jh+Ni_0
@@ -1216,7 +1226,7 @@ CONTAINS
& + zmsk0(ji+1,jj) + zmsk0(ji,jj+1) + zmsk0(ji+1,jj+1)
END DO
END DO
- CALL lbc_lnk('mppini', zmsk, 'T', 1._wp, khls = jh) ! fill halos again!
+ CALL lbc_lnk( 'mppini', zmsk, 'T', 1._wp ) ! fill halos again!
!
iiwe = jh ; iiea = Ni_0 ! bottom-left corner - 1 of the sent data
ijso = jh ; ijno = Nj_0
@@ -1289,7 +1299,7 @@ ENDIF
! used in IOM. This works even if jpnij .ne. jpni*jpnj.
iglo( :) = (/ Ni0glo, Nj0glo /)
iloc( :) = (/ Ni_0 , Nj_0 /)
- iabsf(:) = (/ Nis0 , Njs0 /) + (/ nimpp, njmpp /) - 1 - nn_hls ! corresponds to mig0(Nis0) but mig0 is not yet defined!
+ iabsf(:) = (/ Nis0 , Njs0 /) + (/ nimpp, njmpp /) - 1 - nn_hls ! corresponds to mig(Nis0,0) but mig is not yet defined!
iabsl(:) = iabsf(:) + iloc(:) - 1
ihals(:) = (/ 0 , 0 /)
ihale(:) = (/ 0 , 0 /)
@@ -1324,10 +1334,10 @@ ENDIF
INTEGER, INTENT(in ) :: knum ! layout.dat unit
!
REAL(wp), DIMENSION(jpi,jpj,2,4) :: zinfo
- INTEGER , DIMENSION(10) :: irknei ! too many elements but safe...
+ INTEGER , DIMENSION(0:10) :: irknei ! too many elements but safe...
INTEGER :: ji, jj, jg, jn ! dummy loop indices
INTEGER :: iitmp
- LOGICAL :: lnew
+ LOGICAL :: llnew
!!----------------------------------------------------------------------
!
IF (lwp) THEN
@@ -1341,29 +1351,28 @@ ENDIF
WRITE(knum,*)
WRITE(knum,*)
WRITE(knum,*) 'Number of subdomains located along the north fold : ', ndim_rank_north
- WRITE(knum,*) 'Rank of the subdomains located along the north fold : ', ndim_rank_north
+ WRITE(knum,*) 'Rank of the subdomains located along the north fold : '
DO jn = 1, ndim_rank_north, 5
WRITE(knum,*) nrank_north( jn:MINVAL( (/jn+4,ndim_rank_north/) ) )
END DO
ENDIF
- nfd_nbnei = 0 ! defaul def (useless?)
+ nfd_nbnei = 0 ! default def (useless?)
IF( ln_nnogather ) THEN
!
! Use the "gather nfd" to know how to do the nfd: for ji point, which process send data from which of its ji-index?
! Note that nfd is perfectly symetric: I receive data from X <=> I send data to X (-> no deadlock)
!
- zinfo(:,:,:,:) = HUGE(0._wp) ! default def to make sure we don't use the halos
- DO jg = 1, 4 ! grid type: T, U, V, F
+ DO jg = 1, 4 ! grid type: T, U, V, F
DO jj = nn_hls+1, jpj-nn_hls ! inner domain (warning do_loop_substitute not yet defined)
DO ji = nn_hls+1, jpi-nn_hls ! inner domain (warning do_loop_substitute not yet defined)
- zinfo(ji,jj,1,jg) = REAL(narea, wp) ! mpi_rank + 1 (as default lbc_lnk fill is 0
+ zinfo(ji,jj,1,jg) = REAL(narea, wp) ! mpi_rank + 1 (note: lbc_lnk will put 0 if no neighbour)
zinfo(ji,jj,2,jg) = REAL(ji, wp) ! ji of this proc
END DO
END DO
END DO
!
- ln_nnogather = .FALSE. ! force "classical" North pole folding to fill all halos -> should be no more HUGE values...
+ ln_nnogather = .FALSE. ! force "classical" North pole folding to fill all halos
CALL lbc_lnk( 'mppini', zinfo(:,:,:,1), 'T', 1._wp ) ! Do 4 calls instead of 1 to save memory as the nogather version
CALL lbc_lnk( 'mppini', zinfo(:,:,:,2), 'U', 1._wp ) ! creates buffer arrays with jpiglo as the first dimension
CALL lbc_lnk( 'mppini', zinfo(:,:,:,3), 'V', 1._wp ) !
@@ -1372,24 +1381,52 @@ ENDIF
IF( l_IdoNFold ) THEN ! only the procs involed in the NFD must take care of this
- ALLOCATE( nfd_rksnd(jpi,4), nfd_jisnd(jpi,4) ) ! neighbour rand and remote ji-index for each grid (T, U, V, F)
- nfd_rksnd(:,:) = NINT( zinfo(:, jpj, 1, :) ) - 1 ! neighbour MPI rank
- nfd_jisnd(:,:) = NINT( zinfo(:, jpj, 2, :) ) - nn_hls ! neighbour ji index (shifted as we don't send the halos)
- WHERE( nfd_rksnd == -1 ) nfd_jisnd = 1 ! use ji=1 if no neighbour, see mpp_nfd_generic.h90
-
- nfd_nbnei = 1 ! Number of neighbour sending data for the nfd. We have at least 1 neighbour!
- irknei(1) = nfd_rksnd(1,1) ! which is the 1st one (I can be neighbour of myself, exclude land-proc are also ok)
+ ALLOCATE( nfd_rksnd(jpi,nn_hls+1,4), nfd_jisnd(jpi,nn_hls+1,4), lnfd_same(jpi,4) )
+ nfd_rksnd(:,:,:) = NINT( zinfo(:,jpj-nn_hls:jpj,1,:) ) - 1 ! neighbour MPI rank (-1 means no neighbour)
+ ! Use some tricks for mpp_nfd_generic.h90:
+ ! 1) neighbour ji index (shifted as we don't send the halos)
+ nfd_jisnd(:,:,:) = NINT( zinfo(:,jpj-nn_hls:jpj,2,:) ) - nn_hls
+ ! 2) use ji=1 if no neighbour
+ WHERE( nfd_rksnd == -1 ) nfd_jisnd = 1
+ ! 3) control which points must be modified by the NP folding on line jpjglo-nn_hls
+ lnfd_same(:,:) = .TRUE.
+ IF( c_NFtype == 'T' ) THEN
+ lnfd_same(mi0(jpiglo/2+2,nn_hls):mi1(jpiglo-nn_hls,nn_hls), 1) = .FALSE.
+ lnfd_same(mi0(jpiglo/2+1,nn_hls):mi1(jpiglo-nn_hls,nn_hls), 2) = .FALSE.
+ lnfd_same(mi0( nn_hls+1,nn_hls):mi1(jpiglo-nn_hls,nn_hls),3:4) = .FALSE.
+ IF( l_Iperio ) THEN ! in case the ew-periodicity was done before calling the NP folding
+ lnfd_same(mi0( 1,nn_hls):mi1(nn_hls,nn_hls),1:4) = .FALSE.
+ lnfd_same(mi0(jpiglo-nn_hls+1,nn_hls):mi1(jpiglo,nn_hls),3:4) = .FALSE.
+ ENDIF
+ ELSEIF( c_NFtype == 'F' ) THEN
+ lnfd_same(mi0(jpiglo/2+1 ,nn_hls):mi1(jpiglo/2+1 ,nn_hls),1) = .FALSE.
+ lnfd_same(mi0(jpiglo-nn_hls,nn_hls):mi1(jpiglo-nn_hls ,nn_hls),1) = .FALSE.
+ lnfd_same(mi0(jpiglo/2+1 ,nn_hls):mi1(jpiglo-nn_hls ,nn_hls),3) = .FALSE.
+ lnfd_same(mi0(jpiglo/2+1 ,nn_hls):mi1(jpiglo-nn_hls-1,nn_hls),4) = .FALSE.
+ IF( l_Iperio ) THEN ! in case the ew-periodicity was done before calling the NP folding
+ lnfd_same(mi0(nn_hls,nn_hls):mi1(nn_hls ,nn_hls),1) = .FALSE.
+ lnfd_same(mi0( 1,nn_hls):mi1(nn_hls ,nn_hls),3) = .FALSE.
+ IF( nn_hls > 1 ) lnfd_same(mi0( 1,nn_hls):mi1(nn_hls-1,nn_hls),4) = .FALSE.
+ ENDIF
+ ENDIF
+ WHERE( lnfd_same ) nfd_jisnd(:,1,:) = HUGE(0) ! make sure we dont use it
+
+ nfd_nbnei = 0
+ irknei(0) = HUGE(0)
DO jg = 1, 4
- DO ji = 1, jpi ! we must be able to fill the full line including halos
- lnew = .TRUE. ! new neighbour?
- DO jn = 1, nfd_nbnei
- IF( irknei(jn) == nfd_rksnd(ji,jg) ) lnew = .FALSE. ! already found
+ DO jj = 1, nn_hls+1
+ DO ji = 1, jpi ! we must be able to fill the full line including halos
+ IF( jj == 1 .AND. lnfd_same(ji,jg) ) CYCLE
+ llnew = .TRUE. ! new neighbour?
+ DO jn = 0, nfd_nbnei
+ IF( irknei(jn) == nfd_rksnd(ji,jj,jg) ) llnew = .FALSE. ! already found
+ END DO
+ IF( llnew ) THEN
+ jn = nfd_nbnei + 1
+ nfd_nbnei = jn
+ irknei(jn) = nfd_rksnd(ji,jj,jg)
+ ENDIF
END DO
- IF( lnew ) THEN
- jn = nfd_nbnei + 1
- nfd_nbnei = jn
- irknei(jn) = nfd_rksnd(ji,jg)
- ENDIF
END DO
END DO
@@ -1397,14 +1434,20 @@ ENDIF
nfd_rknei(:) = irknei(1:nfd_nbnei)
! re-number nfd_rksnd according to the indexes of nfd_rknei
DO jg = 1, 4
- DO ji = 1, jpi
- iitmp = nfd_rksnd(ji,jg) ! must store a copy of nfd_rksnd(ji,jg) to make sure we don't change it twice
- DO jn = 1, nfd_nbnei
- IF( iitmp == nfd_rknei(jn) ) nfd_rksnd(ji,jg) = jn
+ DO jj = 1, nn_hls+1
+ DO ji = 1, jpi
+ IF( jj == 1 .AND. lnfd_same(ji,jg) ) THEN
+ nfd_rksnd(ji,jj,jg) = HUGE(0) ! make sure we don't use it
+ ELSE
+ iitmp = nfd_rksnd(ji,jj,jg) ! must store a copy of nfd_rksnd(ji,jj,jg) so we don't change it twice
+ DO jn = 1, nfd_nbnei
+ IF( iitmp == nfd_rknei(jn) ) nfd_rksnd(ji,jj,jg) = jn
+ END DO
+ ENDIF
END DO
END DO
END DO
-
+
IF( ldwrtlay ) THEN
WRITE(knum,*)
WRITE(knum,*) 'north fold exchanges with explicit point-to-point messaging :'
@@ -1435,7 +1478,18 @@ ENDIF
Ni_0 = Nie0 - Nis0 + 1
Nj_0 = Nje0 - Njs0 + 1
!
- jpkm1 = jpk-1 ! " "
+ jpkm1 = jpk-1
+ !
+ ntile = 0 ! Initialise "no tile" by default
+ nijtile = 1
+ ntsi = Nis0
+ ntsj = Njs0
+ ntei = Nie0
+ ntej = Nje0
+ nthl = 0
+ nthr = 0
+ nthb = 0
+ ntht = 0
!
END SUBROUTINE init_doloop
@@ -1448,38 +1502,74 @@ ENDIF
!!
!! ** Method :
!!
- !! ** Action : - mig , mjg : local domain indices ==> global domain, including halos, indices
- !! - mig0, mjg0: local domain indices ==> global domain, excluding halos, indices
+ !! Local domain indices: Same values for the same point, different upper/lower bounds
+ !! e.g. with nn_hls = 2
+ !! jh = 0 x,x,3,...,jpi-2, x, x
+ !! jh = 1 x,2,3,...,jpi-2,jpi-1, x
+ !! jh = 2 1,2,3,...,jpi-2,jpi-1,jpi
+ !!
+ !! or jh = 0 x,x,3,...,Ni_0+2, x, x
+ !! jh = 1 x,2,3,...,Ni_0+2,Ni_0+3, x
+ !! jh = 2 1,2,3,...,Ni_0+2,Ni_0+3,Ni_0+4
+ !!
+ !! Global domain indices: different values for the same point, all starts at 1
+ !! e.g. with nn_hls = 2
+ !! jh = 0 1,2,3, ...,jpiglo-4, x, x,x,x
+ !! jh = 1 1,2,3, ...,jpiglo-4,jpiglo-3,jpiglo-2, x,x
+ !! jh = 2 1,2,3,...,jpiglo-4,jpiglo-3,jpiglo-2,jpiglo-1,jpiglo
+ !!
+ !! or jh = 0 1,2,3, ...,Ni0glo , x, x,x,x
+ !! jh = 1 1,2,3, ...,Ni0glo ,Ni0glo+1,Ni0glo+2, x,x
+ !! jh = 2 1,2,3,...,Ni0glo,Ni0glo+1,Ni0glo+2,Ni0glo+3,Ni0glo+4
+ !! ^
+ !! |
+ !! |
+ !! iimpp
+ !!
+ !! ** Action : - mig , mjg : local domain indices ==> global domain indices
!! - mi0 , mi1 : global domain indices ==> local domain indices
!! - mj0 , mj1 (if global point not in the local domain ==> mi0>mi1 and/or mj0>mj1)
!!----------------------------------------------------------------------
- INTEGER :: ji, jj ! dummy loop argument
+ INTEGER :: ji, jj, jh ! dummy loop argument
+ INTEGER :: ipi, ipj, ipiglo, ipjglo, iimpp, ijmpp, ishft
!!----------------------------------------------------------------------
!
- ALLOCATE( mig(jpi), mjg(jpj), mig0(jpi), mjg0(jpj) )
- ALLOCATE( mi0(jpiglo), mi1(jpiglo), mj0(jpjglo), mj1(jpjglo) )
+ ALLOCATE( mig(jpi , 0:nn_hls), mjg(jpj , 0:nn_hls) )
+ ALLOCATE( mi0(jpiglo, 0:nn_hls), mi1(jpiglo, 0:nn_hls), mj0(jpjglo, 0:nn_hls), mj1(jpjglo, 0:nn_hls) )
!
- DO ji = 1, jpi ! local domain indices ==> global domain indices, including halos
- mig(ji) = ji + nimpp - 1
- END DO
- DO jj = 1, jpj
- mjg(jj) = jj + njmpp - 1
- END DO
- ! ! local domain indices ==> global domain indices, excluding halos
- !
- mig0(:) = mig(:) - nn_hls
- mjg0(:) = mjg(:) - nn_hls
- ! ! global domain, including halos, indices ==> local domain indices
- ! ! (return (m.0,m.1)=(1,0) if data domain gridpoint is to the west/south of the
- ! ! local domain, or (m.0,m.1)=(jp.+1,jp.) to the east/north of local domain.
- DO ji = 1, jpiglo
- mi0(ji) = MAX( 1 , MIN( ji - nimpp + 1, jpi+1 ) )
- mi1(ji) = MAX( 0 , MIN( ji - nimpp + 1, jpi ) )
- END DO
- DO jj = 1, jpjglo
- mj0(jj) = MAX( 1 , MIN( jj - njmpp + 1, jpj+1 ) )
- mj1(jj) = MAX( 0 , MIN( jj - njmpp + 1, jpj ) )
- END DO
+ DO jh = 0, nn_hls
+ !
+ ishft = nn_hls - jh
+ !
+ ipi = Ni_0 + 2*jh ; ipj = Nj_0 + 2*jh
+ ipiglo = Ni0glo + 2*jh ; ipjglo = Nj0glo + 2*jh
+ iimpp = nimpp - ishft ; ijmpp = njmpp - ishft
+ !
+ ! local domain indices ==> global domain indices, including jh halos
+ !
+ DO ji = ishft + 1, ishft + ipi
+ mig(ji,jh) = ji + iimpp - 1
+ END DO
+ !
+ DO jj = ishft + 1, ishft + ipj
+ mjg(jj,jh) = jj + ijmpp - 1
+ END DO
+ !
+ ! global domain, including jh halos, indices ==> local domain indices
+ ! return (m.0,m.1)=(1,0) if data domain gridpoint is to the west/south of the
+ ! local domain, or (m.0,m.1)=(jp.+1,jp.) to the east/north of local domain.
+ !
+ DO ji = 1, ipiglo
+ mi0(ji,jh) = MAX( 1 , MIN( ji - iimpp + 1, ipi+ishft+1 ) )
+ mi1(ji,jh) = MAX( 0 , MIN( ji - iimpp + 1, ipi+ishft ) )
+ END DO
+ !
+ DO jj = 1, ipjglo
+ mj0(jj,jh) = MAX( 1 , MIN( jj - ijmpp + 1, ipj+ishft+1 ) )
+ mj1(jj,jh) = MAX( 0 , MIN( jj - ijmpp + 1, ipj+ishft ) )
+ END DO
+ !
+ END DO ! jh
!
END SUBROUTINE init_locglo
diff --git a/src/OCE/LDF/ldfc1d_c2d.F90 b/src/OCE/LDF/ldfc1d_c2d.F90
index efe9c3ade67439ac2d1804c950c096941b6b458d..c81bb36d5d5da54972a9a9f8d748da7c992291fc 100644
--- a/src/OCE/LDF/ldfc1d_c2d.F90
+++ b/src/OCE/LDF/ldfc1d_c2d.F90
@@ -31,6 +31,7 @@ MODULE ldfc1d_c2d
!! * Substitutions
# include "do_loop_substitute.h90"
+# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
!! $Id: ldfc1d_c2d.F90 15014 2021-06-17 17:02:04Z smasson $
@@ -80,8 +81,8 @@ CONTAINS
pah1(:,:,jk) = pahs1(:,:) * ( zratio + zc * ( 1._wp + TANH( - ( gdept_0(:,:,jk) - zh ) * zw) ) )
END DO
DO_3DS( 0, 0, 0, 0, jpkm1, 1, -1 ) ! pah2 at F-point (zdep2 is an approximation in zps-coord.)
- zdep2 = ( gdept_0(ji,jj+1,jk) + gdept_0(ji+1,jj+1,jk) &
- & + gdept_0(ji,jj ,jk) + gdept_0(ji+1,jj ,jk) ) * r1_4
+ zdep2 = ( ( gdept_0(ji,jj+1,jk) + gdept_0(ji+1,jj+1,jk) ) & ! add () for NP repro
+ & + ( gdept_0(ji,jj ,jk) + gdept_0(ji+1,jj ,jk) ) ) * r1_4
pah2(ji,jj,jk) = pahs2(ji,jj) * ( zratio + zc * ( 1._wp + TANH( - ( zdep2 - zh ) * zw) ) )
END_3D
CALL lbc_lnk( 'ldfc1d_c2d', pah2, 'F', 1.0_wp ) ! Lateral boundary conditions
diff --git a/src/OCE/LDF/ldfdyn.F90 b/src/OCE/LDF/ldfdyn.F90
index 92623ba08b2e2271515a09c0a65ee12dd7ce2111..9f9bf1871b9037642627ab4d61c89bf87db8fd9e 100644
--- a/src/OCE/LDF/ldfdyn.F90
+++ b/src/OCE/LDF/ldfdyn.F90
@@ -185,35 +185,25 @@ CONTAINS
! ! Set nldf_dyn, the type of lateral diffusion, from ln_dynldf_... logicals
ierr = 0
IF( ln_dynldf_lap ) THEN ! laplacian operator
- IF( ln_zco ) THEN ! z-coordinate
- IF ( ln_dynldf_lev ) nldf_dyn = np_lap ! iso-level = horizontal (no rotation)
- IF ( ln_dynldf_hor ) nldf_dyn = np_lap ! iso-level = horizontal (no rotation)
- IF ( ln_dynldf_iso ) nldf_dyn = np_lap_i ! iso-neutral ( rotation)
+ IF( l_zco .OR. l_zps ) THEN ! z-coordinate with or without partial step
+ IF( ln_dynldf_lev ) nldf_dyn = np_lap ! iso-level = horizontal (no rotation)
+ IF( ln_dynldf_hor ) nldf_dyn = np_lap ! iso-level = horizontal (no rotation)
+ IF( ln_dynldf_iso ) nldf_dyn = np_lap_i ! iso-neutral ( rotation)
ENDIF
- IF( ln_zps ) THEN ! z-coordinate with partial step
- IF ( ln_dynldf_lev ) nldf_dyn = np_lap ! iso-level (no rotation)
- IF ( ln_dynldf_hor ) nldf_dyn = np_lap ! iso-level (no rotation)
- IF ( ln_dynldf_iso ) nldf_dyn = np_lap_i ! iso-neutral ( rotation)
- ENDIF
- IF( ln_sco ) THEN ! s-coordinate
- IF ( ln_dynldf_lev ) nldf_dyn = np_lap ! iso-level = horizontal (no rotation)
- IF ( ln_dynldf_hor ) nldf_dyn = np_lap_i ! horizontal ( rotation)
- IF ( ln_dynldf_iso ) nldf_dyn = np_lap_i ! iso-neutral ( rotation)
+ IF( l_sco ) THEN ! s-coordinate
+ IF( ln_dynldf_lev ) nldf_dyn = np_lap ! iso-level = horizontal (no rotation)
+ IF( ln_dynldf_hor ) nldf_dyn = np_lap_i ! horizontal ( rotation)
+ IF( ln_dynldf_iso ) nldf_dyn = np_lap_i ! iso-neutral ( rotation)
ENDIF
ENDIF
!
IF( ln_dynldf_blp ) THEN ! bilaplacian operator
- IF( ln_zco ) THEN ! z-coordinate
+ IF( l_zco .OR. l_zps ) THEN ! z-coordinate with or without partial step
IF( ln_dynldf_lev ) nldf_dyn = np_blp ! iso-level = horizontal (no rotation)
IF( ln_dynldf_hor ) nldf_dyn = np_blp ! iso-level = horizontal (no rotation)
IF( ln_dynldf_iso ) ierr = 2 ! iso-neutral ( rotation)
ENDIF
- IF( ln_zps ) THEN ! z-coordinate with partial step
- IF( ln_dynldf_lev ) nldf_dyn = np_blp ! iso-level (no rotation)
- IF( ln_dynldf_hor ) nldf_dyn = np_blp ! iso-level (no rotation)
- IF( ln_dynldf_iso ) ierr = 2 ! iso-neutral ( rotation)
- ENDIF
- IF( ln_sco ) THEN ! s-coordinate
+ IF( l_sco ) THEN ! s-coordinate
IF( ln_dynldf_lev ) nldf_dyn = np_blp ! iso-level (no rotation)
IF( ln_dynldf_hor ) ierr = 2 ! horizontal ( rotation)
IF( ln_dynldf_iso ) ierr = 2 ! iso-neutral ( rotation)
@@ -321,10 +311,10 @@ CONTAINS
l_ldfdyn_time = .TRUE. ! will be calculated by call to ldf_dyn routine in step.F90
!
! ! allocate arrays used in ldf_dyn.
- ALLOCATE( dtensq(jpi,jpj,jpk) , dshesq(jpi,jpj,jpk) , esqt(jpi,jpj) , esqf(jpi,jpj) , STAT=ierr )
+ ALLOCATE( dtensq(A2D(1),jpk) , dshesq(A2D(1),jpk) , esqt(A2D(0)) , esqf(A2D(0)) , STAT=ierr )
IF( ierr /= 0 ) CALL ctl_stop( 'STOP', 'ldf_dyn_init: failed to allocate Smagorinsky arrays')
!
- DO_2D( 1, 1, 1, 1 ) ! Set local gridscale values
+ DO_2D( 0, 0, 0, 0 ) ! Set local gridscale values
esqt(ji,jj) = ( 2._wp * e1e2t(ji,jj) / ( e1t(ji,jj) + e2t(ji,jj) ) )**2
esqf(ji,jj) = ( 2._wp * e1e2f(ji,jj) / ( e1f(ji,jj) + e2f(ji,jj) ) )**2
END_2D
@@ -419,26 +409,20 @@ CONTAINS
! ! of |U|L^3/16 in blp case
DO jk = 1, jpkm1
!
- DO_2D( 0, 0, 0, 0 )
- zdb = ( uu(ji,jj,jk,Kbb) * r1_e2u(ji,jj) - uu(ji-1,jj,jk,Kbb) * r1_e2u(ji-1,jj) ) &
- & * r1_e1t(ji,jj) * e2t(ji,jj) &
- & - ( vv(ji,jj,jk,Kbb) * r1_e1v(ji,jj) - vv(ji,jj-1,jk,Kbb) * r1_e1v(ji,jj-1) ) &
- & * r1_e2t(ji,jj) * e1t(ji,jj)
+ DO_2D( 0, 1, 0, 1 )
+ zdb = ( uu(ji,jj,jk,Kbb) * r1_e2u(ji,jj) - uu(ji-1,jj,jk,Kbb) * r1_e2u(ji-1,jj) ) * r1_e1t(ji,jj) * e2t(ji,jj) &
+ & - ( vv(ji,jj,jk,Kbb) * r1_e1v(ji,jj) - vv(ji,jj-1,jk,Kbb) * r1_e1v(ji,jj-1) ) * r1_e2t(ji,jj) * e1t(ji,jj)
dtensq(ji,jj,jk) = zdb * zdb * tmask(ji,jj,jk)
END_2D
!
DO_2D( 1, 0, 1, 0 )
- zdb = ( uu(ji,jj+1,jk,Kbb) * r1_e1u(ji,jj+1) - uu(ji,jj,jk,Kbb) * r1_e1u(ji,jj) ) &
- & * r1_e2f(ji,jj) * e1f(ji,jj) &
- & + ( vv(ji+1,jj,jk,Kbb) * r1_e2v(ji+1,jj) - vv(ji,jj,jk,Kbb) * r1_e2v(ji,jj) ) &
- & * r1_e1f(ji,jj) * e2f(ji,jj)
+ zdb = ( uu(ji,jj+1,jk,Kbb) * r1_e1u(ji,jj+1) - uu(ji,jj,jk,Kbb) * r1_e1u(ji,jj) ) * r1_e2f(ji,jj) * e1f(ji,jj) &
+ & + ( vv(ji+1,jj,jk,Kbb) * r1_e2v(ji+1,jj) - vv(ji,jj,jk,Kbb) * r1_e2v(ji,jj) ) * r1_e1f(ji,jj) * e2f(ji,jj)
dshesq(ji,jj,jk) = zdb * zdb * fmask(ji,jj,jk)
END_2D
!
END DO
!
- CALL lbc_lnk( 'ldfdyn', dtensq, 'T', 1.0_wp ) ! lbc_lnk on dshesq not needed
- !
DO jk = 1, jpkm1
!
DO_2D( 0, 0, 0, 0 ) ! T-point value
@@ -447,23 +431,23 @@ CONTAINS
zu2pv2_ij_m1 = uu(ji-1,jj ,jk,Kbb) * uu(ji-1,jj ,jk,Kbb) + vv(ji ,jj-1,jk,Kbb) * vv(ji ,jj-1,jk,Kbb)
!
zdelta = zcmsmag * esqt(ji,jj) ! L^2 * (C_smag/pi)^2
- ahmt(ji,jj,jk) = zdelta * SQRT( dtensq(ji ,jj,jk) + &
- & r1_4 * ( dshesq(ji ,jj,jk) + dshesq(ji ,jj-1,jk) + &
- & dshesq(ji-1,jj,jk) + dshesq(ji-1,jj-1,jk) ) )
+ ahmt(ji,jj,jk) = zdelta * SQRT( dtensq(ji ,jj,jk) + &
+ & r1_4 * ( ( dshesq(ji ,jj,jk) + dshesq(ji ,jj-1,jk) ) + & ! add () for NP repro
+ & ( dshesq(ji-1,jj,jk) + dshesq(ji-1,jj-1,jk) ) ) )
ahmt(ji,jj,jk) = MAX( ahmt(ji,jj,jk), SQRT( (zu2pv2_ij + zu2pv2_ij_m1) * zdelta * zstabf_lo ) ) ! Impose lower limit == minfac * |U|L/2
ahmt(ji,jj,jk) = MIN( ahmt(ji,jj,jk), zdelta * zstabf_up ) ! Impose upper limit == maxfac * L^2/(4*2dt)
!
END_2D
!
- DO_2D( 1, 0, 1, 0 ) ! F-point value
+ DO_2D( 0, 0, 0, 0 ) ! F-point value
!
- zu2pv2_ij_p1 = uu(ji ,jj+1,jk, kbb) * uu(ji ,jj+1,jk, kbb) + vv(ji+1,jj ,jk, kbb) * vv(ji+1,jj ,jk, kbb)
- zu2pv2_ij = uu(ji ,jj ,jk, kbb) * uu(ji ,jj ,jk, kbb) + vv(ji ,jj ,jk, kbb) * vv(ji ,jj ,jk, kbb)
+ zu2pv2_ij_p1 = uu(ji ,jj+1,jk,kbb) * uu(ji ,jj+1,jk,kbb) + vv(ji+1,jj ,jk,kbb) * vv(ji+1,jj ,jk,kbb)
+ zu2pv2_ij = uu(ji ,jj ,jk,kbb) * uu(ji ,jj ,jk,kbb) + vv(ji ,jj ,jk,kbb) * vv(ji ,jj ,jk,kbb)
!
zdelta = zcmsmag * esqf(ji,jj) ! L^2 * (C_smag/pi)^2
- ahmf(ji,jj,jk) = zdelta * SQRT( dshesq(ji ,jj,jk) + &
- & r1_4 * ( dtensq(ji ,jj,jk) + dtensq(ji ,jj+1,jk) + &
- & dtensq(ji+1,jj,jk) + dtensq(ji+1,jj+1,jk) ) )
+ ahmf(ji,jj,jk) = zdelta * SQRT( dshesq(ji ,jj,jk) + &
+ & r1_4 * ( ( dtensq(ji ,jj,jk) + dtensq(ji ,jj+1,jk) ) + & ! add () for NP repro
+ & ( dtensq(ji+1,jj,jk) + dtensq(ji+1,jj+1,jk) ) ) )
ahmf(ji,jj,jk) = MAX( ahmf(ji,jj,jk), SQRT( (zu2pv2_ij + zu2pv2_ij_p1) * zdelta * zstabf_lo ) ) ! Impose lower limit == minfac * |U|L/2
ahmf(ji,jj,jk) = MIN( ahmf(ji,jj,jk), zdelta * zstabf_up ) ! Impose upper limit == maxfac * L^2/(4*2dt)
!
diff --git a/src/OCE/LDF/ldfslp.F90 b/src/OCE/LDF/ldfslp.F90
index d4804673554de52a04ebd0b8dd6de52161314407..5a1fcf8ef324ef5d7cad1832d1df74cd7368b349 100644
--- a/src/OCE/LDF/ldfslp.F90
+++ b/src/OCE/LDF/ldfslp.F90
@@ -11,12 +11,12 @@ MODULE ldfslp
!! 3.3 ! 2010-10 (G. Nurser, C. Harris, G. Madec) add Griffies operator
!! - ! 2010-11 (F. Dupond, G. Madec) bug correction in slopes just below the ML
!! 3.7 ! 2013-12 (F. Lemarie, G. Madec) add limiter on triad slopes
+ !! 4.x ! 2022-12 (S. Techene, G. Madec) optmise memory and correct discrepancy wrt eos evolution
!!----------------------------------------------------------------------
!!----------------------------------------------------------------------
!! ldf_slp : calculates the slopes of neutral surface (Madec operator)
!! ldf_slp_triad : calculates the triads of isoneutral slopes (Griffies operator)
- !! ldf_slp_mxl : calculates the slopes at the base of the mixed layer (Madec operator)
!! ldf_slp_init : initialization of the slopes computation
!!----------------------------------------------------------------------
USE oce ! ocean dynamics and tracers
@@ -64,11 +64,7 @@ MODULE ldfslp
! !! both operators
REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: ah_wslp2 !: ah * slope^2 at w-point
REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: akz !: stabilizing vertical diffusivity
-
- ! !! Madec operator
- REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: omlmask ! mask of the surface mixed layer at T-pt
- REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: uslpml, wslpiml ! i_slope at U- and W-points just below the mixed layer
- REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: vslpml, wslpjml ! j_slope at V- and W-points just below the mixed layer
+
REAL(wp) :: repsln = 1.e-25_wp ! tiny value used as minium of di(rho), dj(rho) and dk(rho)
@@ -98,11 +94,11 @@ CONTAINS
!! diffusion (here, aht=2000m2/s ==> l=20km with a typical velocity
!! of 10cm/s)
!! A horizontal shapiro filter is applied to the slopes
- !! ln_sco=T, s-coordinate, add to the previously computed slopes
+ !! l_sco=T, s-coordinate, add to the previously computed slopes
!! the slope of the model level surface.
!! macro-tasked on horizontal slab (jk-loop) (2, jpk-1)
!! [slopes already set to zero at level 1, and to zero or the ocean
- !! bottom slope (ln_sco=T) at level jpk in inildf]
+ !! bottom slope (l_sco=T) at level jpk in inildf]
!!
!! ** Action : - uslp, wslpi, and vslp, wslpj, the i- and j-slopes
!! of now neutral surfaces at u-, w- and v- w-points, resp.
@@ -112,17 +108,20 @@ CONTAINS
REAL(wp), INTENT(in), DIMENSION(:,:,:) :: prd ! in situ density
REAL(wp), INTENT(in), DIMENSION(:,:,:) :: pn2 ! Brunt-Vaisala frequency (locally ref.)
!!
- INTEGER :: ji , jj , jk ! dummy loop indices
- INTEGER :: ii0, ii1 ! temporary integer
- INTEGER :: ij0, ij1 ! temporary integer
+ INTEGER :: ji , jj , jk ! dummy loop indices
+ INTEGER :: iik, iikm1, itmp, iku, ikv ! local integer
REAL(wp) :: zeps, zm1_g, zm1_2g, z1_16, zcofw, z1_slpmax ! local scalars
- REAL(wp) :: zci, zfi, zau, zbu, zai, zbi ! - -
- REAL(wp) :: zcj, zfj, zav, zbv, zaj, zbj ! - -
- REAL(wp) :: zck, zfk, zbw ! - -
- REAL(wp) :: zdepu, zdepv ! - -
- REAL(wp), DIMENSION(jpi,jpj) :: zslpml_hmlpu, zslpml_hmlpv
- REAL(wp), DIMENSION(jpi,jpj,jpk) :: zgru, zwz, zdzr
- REAL(wp), DIMENSION(jpi,jpj,jpk) :: zgrv, zww
+ REAL(wp) :: zci, zfi, zau, zbu, zai, zbi, zmli ! - -
+ REAL(wp) :: zcj, zfj, zav, zbv, zaj, zbj, zmlj ! - -
+ REAL(wp) :: zck, zfk, zbw , zmlk ! - -
+ REAL(wp) :: zdepu, zdepv ! - -
+ REAL(wp), DIMENSION(A2D(2)) :: zwz, zdzr
+ REAL(wp), DIMENSION(A2D(2)) :: zww
+ REAL(wp), DIMENSION(A2D(2)) :: zhmlpt
+ REAL(wp), DIMENSION(A2D(1)) :: zuslp_hml, zwslpi_hml, r1_hmlu
+ REAL(wp), DIMENSION(A2D(1)) :: zvslp_hml, zwslpj_hml, r1_hmlv
+ REAL(wp), DIMENSION(A2D(1)) :: r1_hmlw
+ REAL(wp), DIMENSION(A2D(2),2) :: zgru, zgrv
!!----------------------------------------------------------------------
!
IF( ln_timing ) CALL timing_start('ldf_slp')
@@ -133,192 +132,185 @@ CONTAINS
zm1_2g = -0.5_wp / grav
z1_slpmax = 1._wp / rn_slpmax
!
- zww(:,:,:) = 0._wp
- zwz(:,:,:) = 0._wp
+ zuslp_hml(:,:) = 0._wp ; zwslpi_hml(:,:) = 0._wp
+ zvslp_hml(:,:) = 0._wp ; zwslpj_hml(:,:) = 0._wp
!
- DO_3D( 1, 0, 1, 0, 1, jpk ) !== i- & j-gradient of density ==!
- zgru(ji,jj,jk) = umask(ji,jj,jk) * ( prd(ji+1,jj ,jk) - prd(ji,jj,jk) )
- zgrv(ji,jj,jk) = vmask(ji,jj,jk) * ( prd(ji ,jj+1,jk) - prd(ji,jj,jk) )
- END_3D
- IF( ln_zps ) THEN ! partial steps correction at the bottom ocean level
- DO_2D( 1, 0, 1, 0 )
- zgru(ji,jj,mbku(ji,jj)) = gru(ji,jj)
- zgrv(ji,jj,mbkv(ji,jj)) = grv(ji,jj)
+ ! nmln calculation in zdfmxl is only on internal points
+ DO_2D( 0, 0, 0, 0 )
+ zhmlpt(ji,jj) = REAL( nmln(ji,jj), wp )
+ END_2D
+ CALL lbc_lnk( 'ldfslp', zhmlpt, 'T', 1.0_wp, hmlp, 'W', 1.0_wp, kfillmode=jpfillcopy ) ! No 0 over closed boundaries
+ DO_2D( 1, 2, 1, 2 )
+ nmln(ji,jj) = NINT( zhmlpt(ji,jj) )
+ END_2D
+ !
+ DO_2D( 1, 2, 1, 2 ) ! depth of the last T-point inside the mixed layer
+ zhmlpt(ji,jj) = gdept(ji,jj,nmln(ji,jj)-1,Kmm) * ssmask(ji,jj)
+ END_2D
+ ! !== Mixed layer height at u-, v- and w-points ==!
+ IF( ln_isfcav ) THEN
+ DO_2D( 1, 1, 1, 1 )
+ r1_hmlu(ji,jj) = 1._wp / ( MAX(zhmlpt (ji,jj), zhmlpt (ji+1,jj ), 5._wp) &
+ & - MAX(risfdep(ji,jj), risfdep(ji+1,jj ) ) )
+ r1_hmlv(ji,jj) = 1._wp / ( MAX(zhmlpt (ji,jj), zhmlpt (ji ,jj+1), 5._wp) &
+ & - MAX(risfdep(ji,jj), risfdep(ji ,jj+1) ) )
END_2D
- ENDIF
- IF( ln_zps .AND. ln_isfcav ) THEN ! partial steps correction at the bottom ocean level
- DO_2D( 1, 0, 1, 0 )
- IF( miku(ji,jj) > 1 ) zgru(ji,jj,miku(ji,jj)) = grui(ji,jj)
- IF( mikv(ji,jj) > 1 ) zgrv(ji,jj,mikv(ji,jj)) = grvi(ji,jj)
+ ELSE
+ DO_2D( 1, 1, 1, 1 )
+ r1_hmlu(ji,jj) = 1._wp / MAX(zhmlpt(ji,jj), zhmlpt(ji+1,jj ), 5._wp)
+ r1_hmlv(ji,jj) = 1._wp / MAX(zhmlpt(ji,jj), zhmlpt(ji ,jj+1), 5._wp)
END_2D
ENDIF
!
- zdzr(:,:,1) = 0._wp !== Local vertical density gradient at T-point == ! (evaluated from N^2)
- DO jk = 2, jpkm1
- ! ! zdzr = d/dz(prd)= - ( prd ) / grav * mk(pn2) -- at t point
- ! ! trick: tmask(ik ) = 0 => all pn2 = 0 => zdzr = 0
- ! ! else tmask(ik+1) = 0 => pn2(ik+1) = 0 => zdzr divides by 1
- ! ! umask(ik+1) /= 0 => all pn2 /= 0 => zdzr divides by 2
- ! ! NB: 1/(tmask+1) = (1-.5*tmask) substitute a / by a * ==> faster
- zdzr(:,:,jk) = zm1_g * ( prd(:,:,jk) + 1._wp ) &
- & * ( pn2(:,:,jk) + pn2(:,:,jk+1) ) * ( 1._wp - 0.5_wp * tmask(:,:,jk+1) )
- END DO
+ DO_2D( 1, 1, 1, 1 )
+ r1_hmlw(ji,jj) = 1._wp / MAX( hmlp(ji,jj) - gdepw(ji,jj,mikt(ji,jj),Kmm), 10._wp )
+ END_2D
!
- ! !== Slopes just below the mixed layer ==!
- CALL ldf_slp_mxl( prd, pn2, zgru, zgrv, zdzr, Kmm ) ! output: uslpml, vslpml, wslpiml, wslpjml
-
-
- ! I. slopes at u and v point | uslp = d/di( prd ) / d/dz( prd )
- ! =========================== | vslp = d/dj( prd ) / d/dz( prd )
+ iikm1 = 1 ; iik = 2 ! iik-index initialisation
!
- IF ( ln_isfcav ) THEN
- DO_2D( 0, 0, 0, 0 )
- zslpml_hmlpu(ji,jj) = uslpml(ji,jj) / ( MAX(hmlpt (ji,jj), hmlpt (ji+1,jj ), 5._wp) &
- & - MAX(risfdep(ji,jj), risfdep(ji+1,jj ) ) )
- zslpml_hmlpv(ji,jj) = vslpml(ji,jj) / ( MAX(hmlpt (ji,jj), hmlpt (ji ,jj+1), 5._wp) &
- & - MAX(risfdep(ji,jj), risfdep(ji ,jj+1) ) )
+ DO_2D( 2, 1, 2, 1 ) !== bottom i- & j-gradient of density at u- and v-points ==!
+ zgru(ji,jj,iikm1) = umask(ji,jj,jpkm1) * ( prd(ji+1,jj ,jpkm1) - prd(ji,jj,jpkm1) )
+ zgrv(ji,jj,iikm1) = vmask(ji,jj,jpkm1) * ( prd(ji ,jj+1,jpkm1) - prd(ji,jj,jpkm1) )
+ END_2D
+ !
+ zdzr(:,:) = 0._wp !== bottom local vertical density gradient at T-point == !
+ !
+ ! !----------------------!
+ DO jk = jpkm1, 2, -1 !- Horizontal slice -!
+ ! !----------------------!
+ !
+ itmp = iik ; iik = iikm1 ; iikm1 = itmp ! swap iik-index
+ !
+ DO_2D( 2, 1, 2, 1 )
+ ! !== jk: i- & j-gradient of density ==!
+ zgru(ji,jj,iikm1) = umask(ji,jj,jk-1) * ( prd(ji+1,jj ,jk-1) - prd(ji,jj,jk-1) )
+ zgrv(ji,jj,iikm1) = vmask(ji,jj,jk-1) * ( prd(ji ,jj+1,jk-1) - prd(ji,jj,jk-1) )
+ !
END_2D
- ELSE
- DO_2D( 0, 0, 0, 0 )
- zslpml_hmlpu(ji,jj) = uslpml(ji,jj) / MAX(hmlpt(ji,jj), hmlpt(ji+1,jj ), 5._wp)
- zslpml_hmlpv(ji,jj) = vslpml(ji,jj) / MAX(hmlpt(ji,jj), hmlpt(ji ,jj+1), 5._wp)
+ ! !== jk: Local vertical density gradient at T-point == !
+ DO_2D( 1, 2, 1, 2 )
+ ! ! zdzr = d/dz(prd)= - ( prd ) / grav * mk(pn2) -- at t point
+ ! ! trick: tmask(ik ) = 0 => all pn2 = 0 => zdzr = 0
+ ! ! else tmask(ik+1) = 0 => pn2(ik+1) = 0 => zdzr divides by 1
+ ! ! umask(ik+1) /= 0 => all pn2 /= 0 => zdzr divides by 2
+ ! ! NB: 1/(tmask+1) = (1-.5*tmask) substitute a / by a * ==> faster
+ zdzr(ji,jj) = zm1_g * ( prd(ji,jj,jk) + 1._wp ) &
+ & * ( pn2(ji,jj,jk) + pn2(ji,jj,jk+1) ) * ( 1._wp - 0.5_wp * tmask(ji,jj,jk+1) )
END_2D
- END IF
-
- DO_3D( 0, 0, 0, 0, 2, jpkm1 ) !* Slopes at u and v points
- ! ! horizontal and vertical density gradient at u- and v-points
- zau = zgru(ji,jj,jk) * r1_e1u(ji,jj)
- zav = zgrv(ji,jj,jk) * r1_e2v(ji,jj)
- zbu = 0.5_wp * ( zdzr(ji,jj,jk) + zdzr(ji+1,jj ,jk) )
- zbv = 0.5_wp * ( zdzr(ji,jj,jk) + zdzr(ji ,jj+1,jk) )
- ! ! bound the slopes: abs(zw.)<= 1/100 and zb..<0
- ! ! + kxz max= ah slope max =< e1 e3 /(pi**2 2 dt)
- zbu = MIN( zbu, - z1_slpmax * ABS( zau ) , -7.e+3_wp/e3u(ji,jj,jk,Kmm)* ABS( zau ) )
- zbv = MIN( zbv, - z1_slpmax * ABS( zav ) , -7.e+3_wp/e3v(ji,jj,jk,Kmm)* ABS( zav ) )
- ! ! Fred Dupont: add a correction for bottom partial steps:
- ! ! max slope = 1/2 * e3 / e1
- IF (ln_zps .AND. jk==mbku(ji,jj)) &
- zbu = MIN( zbu, - z1_slpmax * ABS( zau ) , &
- & - 2._wp * e1u(ji,jj) / e3u(ji,jj,jk,Kmm)* ABS( zau ) )
- IF (ln_zps .AND. jk==mbkv(ji,jj)) &
- zbv = MIN( zbv, - z1_slpmax * ABS( zav ) , &
- & - 2._wp * e2v(ji,jj) / e3v(ji,jj,jk,Kmm)* ABS( zav ) )
- ! ! uslp and vslp output in zwz and zww, resp.
- zfi = MAX( omlmask(ji,jj,jk), omlmask(ji+1,jj,jk) )
- zfj = MAX( omlmask(ji,jj,jk), omlmask(ji,jj+1,jk) )
- ! thickness of water column between surface and level k at u/v point
- zdepu = 0.5_wp * ( ( gdept(ji,jj,jk,Kmm) + gdept(ji+1,jj,jk,Kmm) ) &
- & - 2 * MAX( risfdep(ji,jj), risfdep(ji+1,jj) ) &
- & - e3u(ji,jj,miku(ji,jj),Kmm) )
- zdepv = 0.5_wp * ( ( gdept(ji,jj,jk,Kmm) + gdept(ji,jj+1,jk,Kmm) ) &
- & - 2 * MAX( risfdep(ji,jj), risfdep(ji,jj+1) ) &
- & - e3v(ji,jj,mikv(ji,jj),Kmm) )
!
- zwz(ji,jj,jk) = ( ( 1._wp - zfi) * zau / ( zbu - zeps ) &
- & + zfi * zdepu * zslpml_hmlpu(ji,jj) ) * umask(ji,jj,jk)
- zww(ji,jj,jk) = ( ( 1._wp - zfj) * zav / ( zbv - zeps ) &
- & + zfj * zdepv * zslpml_hmlpv(ji,jj) ) * vmask(ji,jj,jk)
-!!gm modif to suppress omlmask.... (as in Griffies case)
-! ! ! jk must be >= ML level for zf=1. otherwise zf=0.
-! zfi = REAL( 1 - 1/(1 + jk / MAX( nmln(ji+1,jj), nmln(ji,jj) ) ), wp )
-! zfj = REAL( 1 - 1/(1 + jk / MAX( nmln(ji,jj+1), nmln(ji,jj) ) ), wp )
-! zci = 0.5 * ( gdept(ji+1,jj,jk,Kmm)+gdept(ji,jj,jk,Kmm) ) / MAX( hmlpt(ji,jj), hmlpt(ji+1,jj), 10. ) )
-! zcj = 0.5 * ( gdept(ji,jj+1,jk,Kmm)+gdept(ji,jj,jk,Kmm) ) / MAX( hmlpt(ji,jj), hmlpt(ji,jj+1), 10. ) )
-! zwz(ji,jj,jk) = ( zfi * zai / ( zbi - zeps ) + ( 1._wp - zfi ) * wslpiml(ji,jj) * zci ) * tmask(ji,jj,jk)
-! zww(ji,jj,jk) = ( zfj * zaj / ( zbj - zeps ) + ( 1._wp - zfj ) * wslpjml(ji,jj) * zcj ) * tmask(ji,jj,jk)
-!!gm end modif
- END_3D
- CALL lbc_lnk( 'ldfslp', zwz, 'U', -1.0_wp, zww, 'V', -1.0_wp ) ! lateral boundary conditions
- !
- ! !* horizontal Shapiro filter
- DO jk = 2, jpkm1
+ !
+ ! !==================================!
+ DO_2D( 1, 1, 1, 1 ) !== Slopes at u and v points ==!
+ ! !==================================!
+ ! ! horizontal and vertical density gradient at u- and v-points
+ zau = zgru(ji,jj,iik) * r1_e1u(ji,jj)
+ zav = zgrv(ji,jj,iik) * r1_e2v(ji,jj)
+ zbu = 0.5_wp * ( zdzr(ji,jj) + zdzr(ji+1,jj ) )
+ zbv = 0.5_wp * ( zdzr(ji,jj) + zdzr(ji ,jj+1) )
+ ! ! bound the slopes: abs(zw.)<= 1/100 and zb..<0
+ ! ! + kxz max= ah slope max =< e1 e3 /(pi**2 2 dt)
+ zbu = MIN( zbu, - z1_slpmax * ABS( zau ) , -7.e+3_wp/e3u(ji,jj,jk,Kmm)* ABS( zau ) )
+ zbv = MIN( zbv, - z1_slpmax * ABS( zav ) , -7.e+3_wp/e3v(ji,jj,jk,Kmm)* ABS( zav ) )
+ !
+ ! !== slp=dxR(jk)/dzR(jk) under ml slp=dep(jk)/hml*(dxR/dzR)_ml in ml ==!
+ iku = MAX( nmln(ji+1,jj), nmln(ji,jj) ) ! mix-layer index
+ ikv = MAX( nmln(ji,jj+1), nmln(ji,jj) )
+ ! ! zfi/j=0 in the mix-layer otherwise zfi/j=1
+ zfi = REAL( 1 - 1/(1 + jk / iku ), wp )
+ zfj = REAL( 1 - 1/(1 + jk / ikv ), wp )
+ ! ! zmi/j=1 when jk=nmln otherwise zmi/j=0
+ zmli = REAL( 1/( 1 + jk / (iku + 1) ) - 1/( 1 + jk / iku ), wp )
+ zmlj = REAL( 1/( 1 + jk / (ikv + 1) ) - 1/( 1 + jk / ikv ), wp )
+ !
+ ! ! thickness of water column between surface and level k at u/v point
+ zdepu = 0.5_wp * ( ( gdept(ji,jj,jk,Kmm) + gdept(ji+1,jj,jk,Kmm) ) &
+ & - 2 * MAX( risfdep(ji,jj), risfdep(ji+1,jj) ) &
+ & - e3u(ji,jj,miku(ji,jj),Kmm) )
+ zdepv = 0.5_wp * ( ( gdept(ji,jj,jk,Kmm) + gdept(ji,jj+1,jk,Kmm) ) &
+ & - 2 * MAX( risfdep(ji,jj), risfdep(ji,jj+1) ) &
+ & - e3v(ji,jj,mikv(ji,jj),Kmm) )
+ ! ! slp at jk level
+ zwz(ji,jj) = ( zfi * zau / ( zbu - zeps ) + ( 1._wp - zfi ) * zdepu * zuslp_hml(ji,jj) ) * umask(ji,jj,jk)
+ zww(ji,jj) = ( zfj * zav / ( zbv - zeps ) + ( 1._wp - zfj ) * zdepv * zvslp_hml(ji,jj) ) * vmask(ji,jj,jk)
+ ! ! store 1/hml*(dxR/dzR)_ml at nmln level
+ zuslp_hml(ji,jj) = zmli * zwz(ji,jj) * r1_hmlu(ji,jj) + ( 1._wp - zmli ) * zuslp_hml(ji,jj)
+ zvslp_hml(ji,jj) = zmlj * zww(ji,jj) * r1_hmlv(ji,jj) + ( 1._wp - zmlj ) * zvslp_hml(ji,jj)
+ END_2D
+ !
+ ! !== horizontal Shapiro filter + decrease along coastal boundaries ==!
DO_2D( 0, 0, 0, 0 ) ! rows jj=2 and =jpjm1 only
- uslp(ji,jj,jk) = z1_16 * ( zwz(ji-1,jj-1,jk) + zwz(ji+1,jj-1,jk) &
- & + zwz(ji-1,jj+1,jk) + zwz(ji+1,jj+1,jk) &
- & + 2.*( zwz(ji ,jj-1,jk) + zwz(ji-1,jj ,jk) &
- & + zwz(ji+1,jj ,jk) + zwz(ji ,jj+1,jk) ) &
- & + 4.* zwz(ji ,jj ,jk) )
- vslp(ji,jj,jk) = z1_16 * ( zww(ji-1,jj-1,jk) + zww(ji+1,jj-1,jk) &
- & + zww(ji-1,jj+1,jk) + zww(ji+1,jj+1,jk) &
- & + 2.*( zww(ji ,jj-1,jk) + zww(ji-1,jj ,jk) &
- & + zww(ji+1,jj ,jk) + zww(ji ,jj+1,jk) ) &
- & + 4.* zww(ji,jj ,jk) )
+ uslp(ji,jj,jk) = z1_16 * ( ( ( zwz(ji-1,jj-1) + zwz(ji+1,jj-1) ) & ! need additional () for
+ & + ( zwz(ji-1,jj+1) + zwz(ji+1,jj+1) ) ) & ! reproducibility around NP
+ & + 2.*( ( zwz(ji ,jj-1) + zwz(ji-1,jj ) ) &
+ & + ( zwz(ji+1,jj ) + zwz(ji ,jj+1) ) ) &
+ & + 4.* zwz(ji ,jj ) ) &
+ & * ( umask(ji,jj+1,jk) + umask(ji,jj-1,jk ) ) * 0.5_wp &
+ & * ( umask(ji,jj ,jk) + umask(ji,jj ,jk+1) ) * 0.5_wp
+ vslp(ji,jj,jk) = z1_16 * ( ( ( zww(ji-1,jj-1) + zww(ji+1,jj-1) ) &
+ & + ( zww(ji-1,jj+1) + zww(ji+1,jj+1) ) ) &
+ & + 2.*( ( zww(ji ,jj-1) + zww(ji-1,jj ) ) &
+ & + ( zww(ji+1,jj ) + zww(ji ,jj+1) ) ) &
+ & + 4.* zww(ji,jj ) ) &
+ & * ( vmask(ji+1,jj,jk) + vmask(ji-1,jj,jk ) ) * 0.5_wp &
+ & * ( vmask(ji ,jj,jk) + vmask(ji ,jj,jk+1) ) * 0.5_wp
END_2D
- ! !* decrease along coastal boundaries
- DO_2D( 0, 0, 0, 0 )
- uslp(ji,jj,jk) = uslp(ji,jj,jk) * ( umask(ji,jj+1,jk) + umask(ji,jj-1,jk ) ) * 0.5_wp &
- & * ( umask(ji,jj ,jk) + umask(ji,jj ,jk+1) ) * 0.5_wp
- vslp(ji,jj,jk) = vslp(ji,jj,jk) * ( vmask(ji+1,jj,jk) + vmask(ji-1,jj,jk ) ) * 0.5_wp &
- & * ( vmask(ji ,jj,jk) + vmask(ji ,jj,jk+1) ) * 0.5_wp
+ !
+ ! !============================!
+ DO_2D( 1, 1, 1, 1 ) !== Slopes at w points ==!
+ ! !============================!
+ ! !== Local vertical density gradient evaluated from N^2 ==!
+ zbw = zm1_2g * pn2 (ji,jj,jk) * ( prd (ji,jj,jk) + prd (ji,jj,jk-1) + 2. )
+ ! !== Slopes at w point
+ ! ! i- & j-gradient of density at w-points ==!
+ zci = MAX( umask(ji-1,jj,jk ) + umask(ji,jj,jk ) &
+ & + umask(ji-1,jj,jk-1 ) + umask(ji,jj,jk-1 ) , zeps ) * e1t(ji,jj)
+ zcj = MAX( vmask(ji,jj-1,jk ) + vmask(ji,jj,jk-1 ) &
+ & + vmask(ji,jj-1,jk-1 ) + vmask(ji,jj,jk ) , zeps ) * e2t(ji,jj)
+ zai = ( ( zgru (ji-1,jj,iik ) + zgru (ji,jj,iik ) ) & ! need additional () for reproducibility around NP
+ & + ( zgru (ji-1,jj,iikm1) + zgru (ji,jj,iikm1) ) ) / zci * wmask (ji,jj,jk)
+ zaj = ( ( zgrv (ji,jj-1,iik ) + zgrv (ji,jj,iikm1) ) &
+ & + ( zgrv (ji,jj-1,iikm1) + zgrv (ji,jj,iik ) ) ) / zcj * wmask (ji,jj,jk)
+ ! ! bound the slopes: abs(zw.)<= 1/100 and zb..<0.
+ ! ! + kxz max= ah slope max =< e1 e3 /(pi**2 2 dt)
+ zbi = MIN( zbw ,- 100._wp* ABS( zai ) , -7.e+3_wp/e3w(ji,jj,jk,Kmm)* ABS( zai ) )
+ zbj = MIN( zbw , -100._wp* ABS( zaj ) , -7.e+3_wp/e3w(ji,jj,jk,Kmm)* ABS( zaj ) )
+ !
+ ! ! zfk=0 in the mix-layer otherwise zfk=1
+ zfk = REAL( 1 - 1/( 1 + jk / ( nmln(ji,jj) + 1 ) ) , wp )
+ ! ! zmlk=1 when jk=nmln+1 otherwise zmlk=0
+ zmlk = REAL( 1/( 1 + jk / ( nmln(ji,jj) + 2 ) ) - 1/( 1 + jk / ( nmln(ji,jj) + 1 ) ), wp )
+ !
+ ! ! thickness of water column between surface and level k at w point
+ zck = ( gdepw(ji,jj,jk,Kmm) - gdepw(ji,jj,mikt(ji,jj),Kmm) )
+ ! ! wslpi and wslpj with ML flattening (output in zwz and zww, resp.)
+ zwz(ji,jj) = ( zfk * zai / ( zbi - zeps ) + ( 1._wp - zfk ) * zck * zwslpi_hml(ji,jj) ) * wmask(ji,jj,jk)
+ zww(ji,jj) = ( zfk * zaj / ( zbj - zeps ) + ( 1._wp - zfk ) * zck * zwslpj_hml(ji,jj) ) * wmask(ji,jj,jk)
+ !
+ ! ! store 1/hml*(dxR/dzR)_ml at nmln+1 level (1st level above lower T-point in ML)
+ zwslpi_hml(ji,jj) = zmlk * zwz(ji,jj) * r1_hmlw(ji,jj) + ( 1._wp - zmlk ) * zwslpi_hml(ji,jj)
+ zwslpj_hml(ji,jj) = zmlk * zww(ji,jj) * r1_hmlw(ji,jj) + ( 1._wp - zmlk ) * zwslpj_hml(ji,jj)
END_2D
- END DO
-
-
- ! II. slopes at w point | wslpi = mij( d/di( prd ) / d/dz( prd )
- ! =========================== | wslpj = mij( d/dj( prd ) / d/dz( prd )
- !
- DO_3D( 0, 0, 0, 0, 2, jpkm1 )
- ! !* Local vertical density gradient evaluated from N^2
- zbw = zm1_2g * pn2 (ji,jj,jk) * ( prd (ji,jj,jk) + prd (ji,jj,jk-1) + 2. )
- ! !* Slopes at w point
- ! ! i- & j-gradient of density at w-points
- zci = MAX( umask(ji-1,jj,jk ) + umask(ji,jj,jk ) &
- & + umask(ji-1,jj,jk-1) + umask(ji,jj,jk-1) , zeps ) * e1t(ji,jj)
- zcj = MAX( vmask(ji,jj-1,jk ) + vmask(ji,jj,jk-1) &
- & + vmask(ji,jj-1,jk-1) + vmask(ji,jj,jk ) , zeps ) * e2t(ji,jj)
- zai = ( zgru (ji-1,jj,jk ) + zgru (ji,jj,jk-1) &
- & + zgru (ji-1,jj,jk-1) + zgru (ji,jj,jk ) ) / zci * wmask (ji,jj,jk)
- zaj = ( zgrv (ji,jj-1,jk ) + zgrv (ji,jj,jk-1) &
- & + zgrv (ji,jj-1,jk-1) + zgrv (ji,jj,jk ) ) / zcj * wmask (ji,jj,jk)
- ! ! bound the slopes: abs(zw.)<= 1/100 and zb..<0.
- ! ! + kxz max= ah slope max =< e1 e3 /(pi**2 2 dt)
- zbi = MIN( zbw ,- 100._wp* ABS( zai ) , -7.e+3_wp/e3w(ji,jj,jk,Kmm)* ABS( zai ) )
- zbj = MIN( zbw , -100._wp* ABS( zaj ) , -7.e+3_wp/e3w(ji,jj,jk,Kmm)* ABS( zaj ) )
- ! ! wslpi and wslpj with ML flattening (output in zwz and zww, resp.)
- zfk = MAX( omlmask(ji,jj,jk), omlmask(ji,jj,jk-1) ) ! zfk=1 in the ML otherwise zfk=0
- zck = ( gdepw(ji,jj,jk,Kmm) - gdepw(ji,jj,mikt(ji,jj),Kmm) ) / MAX( hmlp(ji,jj) - gdepw(ji,jj,mikt(ji,jj),Kmm), 10._wp )
- zwz(ji,jj,jk) = ( zai / ( zbi - zeps ) * ( 1._wp - zfk ) + zck * wslpiml(ji,jj) * zfk ) * wmask(ji,jj,jk)
- zww(ji,jj,jk) = ( zaj / ( zbj - zeps ) * ( 1._wp - zfk ) + zck * wslpjml(ji,jj) * zfk ) * wmask(ji,jj,jk)
-
-!!gm modif to suppress omlmask.... (as in Griffies operator)
-! ! ! jk must be >= ML level for zfk=1. otherwise zfk=0.
-! zfk = REAL( 1 - 1/(1 + jk / nmln(ji+1,jj)), wp )
-! zck = gdepw(ji,jj,jk,Kmm) / MAX( hmlp(ji,jj), 10. )
-! zwz(ji,jj,jk) = ( zfk * zai / ( zbi - zeps ) + ( 1._wp - zfk ) * wslpiml(ji,jj) * zck ) * tmask(ji,jj,jk)
-! zww(ji,jj,jk) = ( zfk * zaj / ( zbj - zeps ) + ( 1._wp - zfk ) * wslpjml(ji,jj) * zck ) * tmask(ji,jj,jk)
-!!gm end modif
- END_3D
- CALL lbc_lnk( 'ldfslp', zwz, 'T', -1.0_wp, zww, 'T', -1.0_wp ) ! lateral boundary conditions
- !
- ! !* horizontal Shapiro filter
- DO jk = 2, jpkm1
+ ! !== horizontal Shapiro filter + decrease in vicinity of topography ==!
DO_2D( 0, 0, 0, 0 ) ! rows jj=2 and =jpjm1 only
- zcofw = wmask(ji,jj,jk) * z1_16
- wslpi(ji,jj,jk) = ( zwz(ji-1,jj-1,jk) + zwz(ji+1,jj-1,jk) &
- & + zwz(ji-1,jj+1,jk) + zwz(ji+1,jj+1,jk) &
- & + 2.*( zwz(ji ,jj-1,jk) + zwz(ji-1,jj ,jk) &
- & + zwz(ji+1,jj ,jk) + zwz(ji ,jj+1,jk) ) &
- & + 4.* zwz(ji ,jj ,jk) ) * zcofw
-
- wslpj(ji,jj,jk) = ( zww(ji-1,jj-1,jk) + zww(ji+1,jj-1,jk) &
- & + zww(ji-1,jj+1,jk) + zww(ji+1,jj+1,jk) &
- & + 2.*( zww(ji ,jj-1,jk) + zww(ji-1,jj ,jk) &
- & + zww(ji+1,jj ,jk) + zww(ji ,jj+1,jk) ) &
- & + 4.* zww(ji ,jj ,jk) ) * zcofw
- END_2D
- ! !* decrease in vicinity of topography
- DO_2D( 0, 0, 0, 0 )
- zck = ( umask(ji,jj,jk) + umask(ji-1,jj,jk) ) &
- & * ( vmask(ji,jj,jk) + vmask(ji,jj-1,jk) ) * 0.25
- wslpi(ji,jj,jk) = wslpi(ji,jj,jk) * zck
- wslpj(ji,jj,jk) = wslpj(ji,jj,jk) * zck
+ zcofw = wmask(ji,jj,jk) * z1_16 * ( umask(ji,jj,jk) + umask(ji-1,jj,jk) ) &
+ & * ( vmask(ji,jj,jk) + vmask(ji,jj-1,jk) ) * 0.25
+ wslpi(ji,jj,jk) = ( ( ( zwz(ji-1,jj-1) + zwz(ji+1,jj-1) ) & ! need additional () for
+ & + ( zwz(ji-1,jj+1) + zwz(ji+1,jj+1) ) ) & ! reproducibility around NP
+ & + 2.*( ( zwz(ji ,jj-1) + zwz(ji-1,jj ) ) &
+ & + ( zwz(ji+1,jj ) + zwz(ji ,jj+1) ) ) &
+ & + 4.* zwz(ji ,jj ) ) * zcofw
+
+ wslpj(ji,jj,jk) = ( ( ( zww(ji-1,jj-1) + zww(ji+1,jj-1) ) &
+ & + ( zww(ji-1,jj+1) + zww(ji+1,jj+1) ) ) &
+ & + 2.*( ( zww(ji ,jj-1) + zww(ji-1,jj ) ) &
+ & + ( zww(ji+1,jj ) + zww(ji ,jj+1) ) ) &
+ & + 4.* zww(ji ,jj ) ) * zcofw
END_2D
- END DO
-
- ! IV. Lateral boundary conditions
- ! ===============================
+ !
+ END DO ! end jk
+ ! !== Lateral boundary conditions ==!
CALL lbc_lnk( 'ldfslp', uslp , 'U', -1.0_wp , vslp , 'V', -1.0_wp , wslpi, 'W', -1.0_wp, wslpj, 'W', -1.0_wp )
-
+ !
IF(sn_cfctl%l_prtctl) THEN
CALL prt_ctl(tab3d_1=uslp , clinfo1=' slp - u : ', tab3d_2=vslp, clinfo2=' v : ')
CALL prt_ctl(tab3d_1=wslpi, clinfo1=' slp - wi: ', tab3d_2=wslpj, clinfo2=' wj: ')
@@ -381,18 +373,6 @@ CONTAINS
zdyrho(ji ,jj+jp,jk,1-jp) = SIGN( MAX( repsln, ABS( zdyrho_raw ) ), zdyrho_raw )
END_3D
!
- IF( ln_zps .AND. l_grad_zps ) THEN ! partial steps: correction of i- & j-grad on bottom
- DO_2D( nn_hls, nn_hls-1, nn_hls, nn_hls-1 )
- iku = mbku(ji,jj) ; ikv = mbkv(ji,jj) ! last ocean level (u- & v-points)
- zdit = gtsu(ji,jj,jp_tem) ; zdjt = gtsv(ji,jj,jp_tem) ! i- & j-gradient of Temperature
- zdis = gtsu(ji,jj,jp_sal) ; zdjs = gtsv(ji,jj,jp_sal) ! i- & j-gradient of Salinity
- zdxrho_raw = ( - rab_b(ji+ip,jj ,iku,jp_tem) * zdit + rab_b(ji+ip,jj ,iku,jp_sal) * zdis ) * r1_e1u(ji,jj)
- zdyrho_raw = ( - rab_b(ji ,jj+jp,ikv,jp_tem) * zdjt + rab_b(ji ,jj+jp,ikv,jp_sal) * zdjs ) * r1_e2v(ji,jj)
- zdxrho(ji+ip,jj ,iku,1-ip) = SIGN( MAX( repsln, ABS( zdxrho_raw ) ), zdxrho_raw ) ! keep the sign
- zdyrho(ji ,jj+jp,ikv,1-jp) = SIGN( MAX( repsln, ABS( zdyrho_raw ) ), zdyrho_raw )
- END_2D
- ENDIF
- !
END DO
DO kp = 0, 1 !== unmasked before density i- j-, k-gradients ==!
@@ -410,6 +390,13 @@ CONTAINS
zdzrho(ji,jj,jk,kp) = - MIN( - repsln , zdzrho_raw ) ! force zdzrho >= repsln
END_3D
END DO
+
+ ! nmln calculation in zdfmxl is only on internal points
+ DO_2D( 0, 0, 0, 0 )
+ z1_mlbw(ji,jj) = REAL( nmln(ji,jj), wp )
+ END_2D
+ CALL lbc_lnk( 'ldfslp', z1_mlbw, 'T', 1.0_wp, kfillmode=jpfillcopy ) ! No 0 over closed boundaries
+ nmln(:,:) = NINT( z1_mlbw(:,:) )
!
DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) !== Reciprocal depth of the w-point below ML base ==!
jk = MIN( nmln(ji,jj), mbkt(ji,jj) ) + 1 ! MIN in case ML depth is the ocean depth
@@ -556,113 +543,6 @@ CONTAINS
END SUBROUTINE ldf_slp_triad
- SUBROUTINE ldf_slp_mxl( prd, pn2, p_gru, p_grv, p_dzr, Kmm )
- !!----------------------------------------------------------------------
- !! *** ROUTINE ldf_slp_mxl ***
- !!
- !! ** Purpose : Compute the slopes of iso-neutral surface just below
- !! the mixed layer.
- !!
- !! ** Method : The slope in the i-direction is computed at u- & w-points
- !! (uslpml, wslpiml) and the slope in the j-direction is computed
- !! at v- and w-points (vslpml, wslpjml) with the same bounds as
- !! in ldf_slp.
- !!
- !! ** Action : uslpml, wslpiml : i- & j-slopes of neutral surfaces
- !! vslpml, wslpjml just below the mixed layer
- !! omlmask : mixed layer mask
- !!----------------------------------------------------------------------
- REAL(wp), DIMENSION(:,:,:), INTENT(in) :: prd ! in situ density
- REAL(wp), DIMENSION(:,:,:), INTENT(in) :: pn2 ! Brunt-Vaisala frequency (locally ref.)
- REAL(wp), DIMENSION(:,:,:), INTENT(in) :: p_gru, p_grv ! i- & j-gradient of density (u- & v-pts)
- REAL(wp), DIMENSION(:,:,:), INTENT(in) :: p_dzr ! z-gradient of density (T-point)
- INTEGER , INTENT(in) :: Kmm ! ocean time level indices
- !!
- INTEGER :: ji , jj , jk ! dummy loop indices
- INTEGER :: iku, ikv, ik, ikm1 ! local integers
- REAL(wp) :: zeps, zm1_g, zm1_2g, z1_slpmax ! local scalars
- REAL(wp) :: zci, zfi, zau, zbu, zai, zbi ! - -
- REAL(wp) :: zcj, zfj, zav, zbv, zaj, zbj ! - -
- REAL(wp) :: zck, zfk, zbw ! - -
- !!----------------------------------------------------------------------
- !
- zeps = 1.e-20_wp !== Local constant initialization ==!
- zm1_g = -1.0_wp / grav
- zm1_2g = -0.5_wp / grav
- z1_slpmax = 1._wp / rn_slpmax
- !
- uslpml (1,:) = 0._wp ; uslpml (jpi,:) = 0._wp
- vslpml (1,:) = 0._wp ; vslpml (jpi,:) = 0._wp
- wslpiml(1,:) = 0._wp ; wslpiml(jpi,:) = 0._wp
- wslpjml(1,:) = 0._wp ; wslpjml(jpi,:) = 0._wp
- !
- ! !== surface mixed layer mask !
- DO_3D( 1, 1, 1, 1, 1, jpk ) ! =1 inside the mixed layer, =0 otherwise
- ik = nmln(ji,jj) - 1
- IF( jk <= ik ) THEN ; omlmask(ji,jj,jk) = 1._wp
- ELSE ; omlmask(ji,jj,jk) = 0._wp
- ENDIF
- END_3D
-
-
- ! Slopes of isopycnal surfaces just before bottom of mixed layer
- ! --------------------------------------------------------------
- ! The slope are computed as in the 3D case.
- ! A key point here is the definition of the mixed layer at u- and v-points.
- ! It is assumed to be the maximum of the two neighbouring T-point mixed layer depth.
- ! Otherwise, a n2 value inside the mixed layer can be involved in the computation
- ! of the slope, resulting in a too steep diagnosed slope and thus a spurious eddy
- ! induce velocity field near the base of the mixed layer.
- !-----------------------------------------------------------------------
- !
- DO_2D( 0, 0, 0, 0 )
- ! !== Slope at u- & v-points just below the Mixed Layer ==!
- !
- ! !- vertical density gradient for u- and v-slopes (from dzr at T-point)
- iku = MIN( MAX( 1, nmln(ji,jj) , nmln(ji+1,jj) ) , jpkm1 ) ! ML (MAX of T-pts, bound by jpkm1)
- ikv = MIN( MAX( 1, nmln(ji,jj) , nmln(ji,jj+1) ) , jpkm1 ) !
- zbu = 0.5_wp * ( p_dzr(ji,jj,iku) + p_dzr(ji+1,jj ,iku) )
- zbv = 0.5_wp * ( p_dzr(ji,jj,ikv) + p_dzr(ji ,jj+1,ikv) )
- ! !- horizontal density gradient at u- & v-points
- zau = p_gru(ji,jj,iku) * r1_e1u(ji,jj)
- zav = p_grv(ji,jj,ikv) * r1_e2v(ji,jj)
- ! !- bound the slopes: abs(zw.)<= 1/100 and zb..<0
- ! kxz max= ah slope max =< e1 e3 /(pi**2 2 dt)
- zbu = MIN( zbu , - z1_slpmax * ABS( zau ) , -7.e+3_wp/e3u(ji,jj,iku,Kmm)* ABS( zau ) )
- zbv = MIN( zbv , - z1_slpmax * ABS( zav ) , -7.e+3_wp/e3v(ji,jj,ikv,Kmm)* ABS( zav ) )
- ! !- Slope at u- & v-points (uslpml, vslpml)
- uslpml(ji,jj) = zau / ( zbu - zeps ) * umask(ji,jj,iku)
- vslpml(ji,jj) = zav / ( zbv - zeps ) * vmask(ji,jj,ikv)
- !
- ! !== i- & j-slopes at w-points just below the Mixed Layer ==!
- !
- ik = MIN( nmln(ji,jj) + 1, jpk )
- ikm1 = MAX( 1, ik-1 )
- ! !- vertical density gradient for w-slope (from N^2)
- zbw = zm1_2g * pn2 (ji,jj,ik) * ( prd (ji,jj,ik) + prd (ji,jj,ikm1) + 2. )
- ! !- horizontal density i- & j-gradient at w-points
- zci = MAX( umask(ji-1,jj,ik ) + umask(ji,jj,ik ) &
- & + umask(ji-1,jj,ikm1) + umask(ji,jj,ikm1) , zeps ) * e1t(ji,jj)
- zcj = MAX( vmask(ji,jj-1,ik ) + vmask(ji,jj,ik ) &
- & + vmask(ji,jj-1,ikm1) + vmask(ji,jj,ikm1) , zeps ) * e2t(ji,jj)
- zai = ( p_gru(ji-1,jj,ik ) + p_gru(ji,jj,ik) &
- & + p_gru(ji-1,jj,ikm1) + p_gru(ji,jj,ikm1 ) ) / zci * tmask(ji,jj,ik)
- zaj = ( p_grv(ji,jj-1,ik ) + p_grv(ji,jj,ik ) &
- & + p_grv(ji,jj-1,ikm1) + p_grv(ji,jj,ikm1) ) / zcj * tmask(ji,jj,ik)
- ! !- bound the slopes: abs(zw.)<= 1/100 and zb..<0.
- ! kxz max= ah slope max =< e1 e3 /(pi**2 2 dt)
- zbi = MIN( zbw , -100._wp* ABS( zai ) , -7.e+3_wp/e3w(ji,jj,ik,Kmm)* ABS( zai ) )
- zbj = MIN( zbw , -100._wp* ABS( zaj ) , -7.e+3_wp/e3w(ji,jj,ik,Kmm)* ABS( zaj ) )
- ! !- i- & j-slope at w-points (wslpiml, wslpjml)
- wslpiml(ji,jj) = zai / ( zbi - zeps ) * tmask (ji,jj,ik)
- wslpjml(ji,jj) = zaj / ( zbj - zeps ) * tmask (ji,jj,ik)
- END_2D
- !!gm this lbc_lnk should be useless....
- CALL lbc_lnk( 'ldfslp', uslpml , 'U', -1.0_wp , vslpml , 'V', -1.0_wp , wslpiml, 'W', -1.0_wp , wslpjml, 'W', -1.0_wp )
- !
- END SUBROUTINE ldf_slp_mxl
-
-
SUBROUTINE ldf_slp_init
!!----------------------------------------------------------------------
!! *** ROUTINE ldf_slp_init ***
@@ -699,17 +579,16 @@ CONTAINS
!
ELSE ! Madec operator : slopes at u-, v-, and w-points
IF(lwp) WRITE(numout,*) ' ==>>> iso operator (Madec)'
- ALLOCATE( omlmask(jpi,jpj,jpk) , &
- & uslp(jpi,jpj,jpk) , uslpml(jpi,jpj) , wslpi(jpi,jpj,jpk) , wslpiml(jpi,jpj) , &
- & vslp(jpi,jpj,jpk) , vslpml(jpi,jpj) , wslpj(jpi,jpj,jpk) , wslpjml(jpi,jpj) , STAT=ierr )
+ ALLOCATE( uslp(jpi,jpj,jpk) , wslpi(jpi,jpj,jpk) , &
+ & vslp(jpi,jpj,jpk) , wslpj(jpi,jpj,jpk) , STAT=ierr )
IF( ierr > 0 ) CALL ctl_stop( 'STOP', 'ldf_slp_init : unable to allocate Madec operator slope ' )
! Direction of lateral diffusion (tracers and/or momentum)
! ------------------------------
- uslp (:,:,:) = 0._wp ; uslpml (:,:) = 0._wp ! set the slope to zero (even in s-coordinates)
- vslp (:,:,:) = 0._wp ; vslpml (:,:) = 0._wp
- wslpi(:,:,:) = 0._wp ; wslpiml(:,:) = 0._wp
- wslpj(:,:,:) = 0._wp ; wslpjml(:,:) = 0._wp
+ uslp (:,:,:) = 0._wp ! set the slope to zero (even in s-coordinates)
+ vslp (:,:,:) = 0._wp
+ wslpi(:,:,:) = 0._wp
+ wslpj(:,:,:) = 0._wp
!!gm I no longer understand this.....
!!gm IF( (ln_traldf_hor .OR. ln_dynldf_hor) .AND. .NOT. (.NOT.ln_linssh .AND. ln_rstart) ) THEN
diff --git a/src/OCE/LDF/ldftra.F90 b/src/OCE/LDF/ldftra.F90
index 87e1d746557589acb22e01749b03156bbc5172cb..7304aabdce41935afdc209f2fc0a7bdb698f7c3c 100644
--- a/src/OCE/LDF/ldftra.F90
+++ b/src/OCE/LDF/ldftra.F90
@@ -204,19 +204,13 @@ CONTAINS
! ! defined the type of lateral diffusion from ln_traldf_... logicals
ierr = 0
IF ( ln_traldf_lap ) THEN ! laplacian operator
- IF ( ln_zco ) THEN ! z-coordinate
+ IF ( l_zco .OR. l_zps ) THEN ! z-coordinate with or without partial step
IF ( ln_traldf_lev ) nldf_tra = np_lap ! iso-level = horizontal (no rotation)
IF ( ln_traldf_hor ) nldf_tra = np_lap ! iso-level = horizontal (no rotation)
IF ( ln_traldf_iso ) nldf_tra = np_lap_i ! iso-neutral: standard ( rotation)
IF ( ln_traldf_triad ) nldf_tra = np_lap_it ! iso-neutral: triad ( rotation)
ENDIF
- IF ( ln_zps ) THEN ! z-coordinate with partial step
- IF ( ln_traldf_lev ) ierr = 1 ! iso-level not allowed
- IF ( ln_traldf_hor ) nldf_tra = np_lap ! horizontal (no rotation)
- IF ( ln_traldf_iso ) nldf_tra = np_lap_i ! iso-neutral: standard (rotation)
- IF ( ln_traldf_triad ) nldf_tra = np_lap_it ! iso-neutral: triad (rotation)
- ENDIF
- IF ( ln_sco ) THEN ! s-coordinate
+ IF ( l_sco ) THEN ! s-coordinate
IF ( ln_traldf_lev ) nldf_tra = np_lap ! iso-level (no rotation)
IF ( ln_traldf_hor ) nldf_tra = np_lap_i ! horizontal ( rotation)
IF ( ln_traldf_iso ) nldf_tra = np_lap_i ! iso-neutral: standard ( rotation)
@@ -225,19 +219,13 @@ CONTAINS
ENDIF
!
IF( ln_traldf_blp ) THEN ! bilaplacian operator
- IF ( ln_zco ) THEN ! z-coordinate
+ IF ( l_zco .OR. l_zps ) THEN ! z-coordinate with or without partial step
IF ( ln_traldf_lev ) nldf_tra = np_blp ! iso-level = horizontal (no rotation)
IF ( ln_traldf_hor ) nldf_tra = np_blp ! iso-level = horizontal (no rotation)
IF ( ln_traldf_iso ) nldf_tra = np_blp_i ! iso-neutral: standard ( rotation)
IF ( ln_traldf_triad ) nldf_tra = np_blp_it ! iso-neutral: triad ( rotation)
ENDIF
- IF ( ln_zps ) THEN ! z-coordinate with partial step
- IF ( ln_traldf_lev ) ierr = 1 ! iso-level not allowed
- IF ( ln_traldf_hor ) nldf_tra = np_blp ! horizontal (no rotation)
- IF ( ln_traldf_iso ) nldf_tra = np_blp_i ! iso-neutral: standard ( rotation)
- IF ( ln_traldf_triad ) nldf_tra = np_blp_it ! iso-neutral: triad ( rotation)
- ENDIF
- IF ( ln_sco ) THEN ! s-coordinate
+ IF ( l_sco ) THEN ! s-coordinate
IF ( ln_traldf_lev ) nldf_tra = np_blp ! iso-level (no rotation)
IF ( ln_traldf_hor ) nldf_tra = np_blp_it ! horizontal ( rotation)
IF ( ln_traldf_iso ) nldf_tra = np_blp_i ! iso-neutral: standard ( rotation)
@@ -726,19 +714,18 @@ CONTAINS
!!
!! ** Action : pu, pv increased by the eiv transport
!!----------------------------------------------------------------------
- INTEGER , INTENT(in ) :: kt ! ocean time-step index
- INTEGER , INTENT(in ) :: kit000 ! first time step index
- INTEGER , INTENT(in ) :: Kmm, Krhs ! ocean time level indices
- CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator)
- ! TEMP: [tiling] Can be A2D(nn_hls) after all lbc_lnks removed in the nn_hls = 2 case in tra_adv_fct
- REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pu ! in : 3 ocean transport components [m3/s]
- REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pv ! out: 3 ocean transport components [m3/s]
- REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pw ! increased by the eiv [m3/s]
+ INTEGER , INTENT(in ) :: kt ! ocean time-step index
+ INTEGER , INTENT(in ) :: kit000 ! first time step index
+ INTEGER , INTENT(in ) :: Kmm, Krhs ! ocean time level indices
+ CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator)
+ REAL(wp), DIMENSION(T2D(nn_hls),jpk), INTENT(inout) :: pu ! in : 3 ocean transport components [m3/s]
+ REAL(wp), DIMENSION(T2D(nn_hls),jpk), INTENT(inout) :: pv ! out: 3 ocean transport components [m3/s]
+ REAL(wp), DIMENSION(T2D(nn_hls),jpk), INTENT(inout) :: pw ! increased by the eiv [m3/s]
!!
INTEGER :: ji, jj, jk ! dummy loop indices
REAL(wp) :: zuwk, zuwk1, zuwi, zuwi1 ! local scalars
REAL(wp) :: zvwk, zvwk1, zvwj, zvwj1 ! - -
- REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zpsi_uw, zpsi_vw
+ REAL(wp), DIMENSION(T2D(nn_hls),jpk) :: zpsi_uw, zpsi_vw
!!----------------------------------------------------------------------
!
IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile
@@ -765,8 +752,8 @@ CONTAINS
pv(ji,jj,jk) = pv(ji,jj,jk) - ( zpsi_vw(ji,jj,jk) - zpsi_vw(ji,jj,jk+1) )
END_3D
DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpkm1 )
- pw(ji,jj,jk) = pw(ji,jj,jk) + ( zpsi_uw(ji,jj,jk) - zpsi_uw(ji-1,jj ,jk) &
- & + zpsi_vw(ji,jj,jk) - zpsi_vw(ji ,jj-1,jk) )
+ pw(ji,jj,jk) = pw(ji,jj,jk) + ( ( zpsi_uw(ji,jj,jk) - zpsi_uw(ji-1,jj ,jk) ) & ! add () for NP repro
+ & + ( zpsi_vw(ji,jj,jk) - zpsi_vw(ji ,jj-1,jk) ) )
END_3D
!
! ! diagnose the eddy induced velocity and associated heat transport
@@ -789,13 +776,13 @@ CONTAINS
!! ** Method :
!!
!!----------------------------------------------------------------------
- REAL(wp), DIMENSION(A2D(nn_hls),jpk), INTENT(in) :: psi_uw, psi_vw ! streamfunction [m3/s]
+ REAL(wp), DIMENSION(T2D(nn_hls),jpk), INTENT(in) :: psi_uw, psi_vw ! streamfunction [m3/s]
INTEGER , INTENT(in) :: Kmm ! ocean time level indices
!
INTEGER :: ji, jj, jk ! dummy loop indices
REAL(wp) :: zztmp ! local scalar
- REAL(wp), DIMENSION(A2D(nn_hls)) :: zw2d ! 2D workspace
- REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zw3d ! 3D workspace
+ REAL(wp), DIMENSION(T2D(0)) :: zw2d ! 2D workspace
+ REAL(wp), DIMENSION(T2D(0),jpk) :: zw3d ! 3D workspace
!!----------------------------------------------------------------------
!
!!gm I don't like this routine.... Crazy way of doing things, not optimal at all...
@@ -806,42 +793,53 @@ CONTAINS
!
! !== eiv velocities: calculate and output ==!
!
- zw3d(:,:,jpk) = 0._wp ! bottom value always 0
+ zw3d(:,:,jpk) = 0._wp ! bottom value always 0
!
- DO_3D( 0, 0, 0, 0, 1, jpkm1 ) ! e2u e3u u_eiv = -dk[psi_uw]
- zw3d(ji,jj,jk) = ( psi_uw(ji,jj,jk+1) - psi_uw(ji,jj,jk) ) / ( e2u(ji,jj) * e3u(ji,jj,jk,Kmm) )
- END_3D
- CALL iom_put( "uoce_eiv", zw3d )
+ IF( iom_use('uoce_eiv') ) THEN
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 ) ! e2u e3u u_eiv = -dk[psi_uw]
+ zw3d(ji,jj,jk) = ( psi_uw(ji,jj,jk+1) - psi_uw(ji,jj,jk) ) / ( e2u(ji,jj) * e3u(ji,jj,jk,Kmm) )
+ END_3D
+ CALL iom_put( "uoce_eiv", zw3d )
+ ENDIF
!
- DO_3D( 0, 0, 0, 0, 1, jpkm1 ) ! e1v e3v v_eiv = -dk[psi_vw]
- zw3d(ji,jj,jk) = ( psi_vw(ji,jj,jk+1) - psi_vw(ji,jj,jk) ) / ( e1v(ji,jj) * e3v(ji,jj,jk,Kmm) )
- END_3D
- CALL iom_put( "voce_eiv", zw3d )
+ IF( iom_use('ueiv_masstr') ) THEN
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
+ zw3d(ji,jj,jk) = rho0 * ( psi_uw(ji,jj,jk+1) - psi_uw(ji,jj,jk) )
+ END_3D
+ CALL iom_put( "ueiv_masstr", zw3d ) ! mass transport in i-direction
+ ENDIF
!
- DO_3D( 0, 0, 0, 0, 1, jpkm1 ) ! e1 e2 w_eiv = dk[psix] + dk[psix]
- zw3d(ji,jj,jk) = ( psi_vw(ji,jj,jk) - psi_vw(ji ,jj-1,jk) &
- & + psi_uw(ji,jj,jk) - psi_uw(ji-1,jj ,jk) ) / e1e2t(ji,jj)
- END_3D
- CALL iom_put( "woce_eiv", zw3d )
+ IF( iom_use('voce_eiv') ) THEN
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 ) ! e1v e3v v_eiv = -dk[psi_vw]
+ zw3d(ji,jj,jk) = ( psi_vw(ji,jj,jk+1) - psi_vw(ji,jj,jk) ) / ( e1v(ji,jj) * e3v(ji,jj,jk,Kmm) )
+ END_3D
+ CALL iom_put( "voce_eiv", zw3d )
+ ENDIF
!
- IF( iom_use('weiv_masstr') ) THEN ! vertical mass transport & its square value
- DO_2D( 0, 0, 0, 0 )
- zw2d(ji,jj) = rho0 * e1e2t(ji,jj)
- END_2D
- DO jk = 1, jpk
- zw3d(:,:,jk) = zw3d(:,:,jk) * zw2d(:,:)
- END DO
- CALL iom_put( "weiv_masstr" , zw3d )
+ IF( iom_use('veiv_masstr') ) THEN
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
+ zw3d(ji,jj,jk) = rho0 * ( psi_vw(ji,jj,jk+1) - psi_vw(ji,jj,jk) )
+ END_3D
+ CALL iom_put( "veiv_masstr", zw3d ) ! mass transport in j-direction
+ ENDIF
+ !
+ IF( iom_use('woce_eiv') ) THEN
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 ) ! e1 e2 w_eiv = dk[psix] + dk[psix]
+ zw3d(ji,jj,jk) = ( ( psi_vw(ji,jj,jk) - psi_vw(ji ,jj-1,jk) ) & ! add () for NP repro
+ & + ( psi_uw(ji,jj,jk) - psi_uw(ji-1,jj ,jk) ) ) / e1e2t(ji,jj)
+ END_3D
+ CALL iom_put( "woce_eiv", zw3d )
ENDIF
!
- IF( iom_use('ueiv_masstr') ) THEN
- zw3d(:,:,:) = 0.e0
- DO jk = 1, jpkm1
- zw3d(:,:,jk) = rho0 * ( psi_uw(:,:,jk+1) - psi_uw(:,:,jk) )
- END DO
- CALL iom_put( "ueiv_masstr", zw3d ) ! mass transport in i-direction
+ IF( iom_use('weiv_masstr') ) THEN
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
+ zw3d(ji,jj,jk) = rho0 * ( ( psi_vw(ji,jj,jk) - psi_vw(ji ,jj-1,jk) ) & ! add () for NP repro
+ & + ( psi_uw(ji,jj,jk) - psi_uw(ji-1,jj ,jk) ) )
+ END_3D
+ CALL iom_put( "weiv_masstr" , zw3d ) ! mass transport in z-direction
ENDIF
!
+ !
zztmp = 0.5_wp * rho0 * rcp
IF( iom_use('ueiv_heattr') .OR. iom_use('ueiv_heattr3d') ) THEN
zw2d(:,:) = 0._wp
@@ -855,49 +853,47 @@ CONTAINS
CALL iom_put( "ueiv_heattr3d", zztmp * zw3d ) ! heat transport in i-direction
ENDIF
!
- IF( iom_use('veiv_masstr') ) THEN
- zw3d(:,:,:) = 0.e0
- DO jk = 1, jpkm1
- zw3d(:,:,jk) = rho0 * ( psi_vw(:,:,jk+1) - psi_vw(:,:,jk) )
- END DO
- CALL iom_put( "veiv_masstr", zw3d ) ! mass transport in i-direction
+ IF( iom_use('veiv_heattr') .OR. iom_use('veiv_heattr3d') .OR. iom_use('sophteiv') ) THEN
+ zw2d(:,:) = 0._wp
+ zw3d(:,:,:) = 0._wp
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
+ zw3d(ji,jj,jk) = zw3d(ji,jj,jk) + ( psi_vw(ji,jj,jk+1) - psi_vw(ji,jj ,jk) ) &
+ & * ( ts (ji,jj,jk,jp_tem,Kmm) + ts (ji,jj+1,jk,jp_tem,Kmm) )
+ zw2d(ji,jj) = zw2d(ji,jj) + zw3d(ji,jj,jk)
+ END_3D
+ CALL iom_put( "veiv_heattr" , zztmp * zw2d ) ! heat transport in j-direction
+ CALL iom_put( "veiv_heattr3d", zztmp * zw3d ) ! heat transport in j-direction
+ !
+ IF( iom_use( 'sophteiv' ) .AND. l_diaptr ) CALL dia_ptr_hst( jp_tem, 'eiv', 0.5 * zw3d )
ENDIF
!
- zw2d(:,:) = 0._wp
- zw3d(:,:,:) = 0._wp
- DO_3D( 0, 0, 0, 0, 1, jpkm1 )
- zw3d(ji,jj,jk) = zw3d(ji,jj,jk) + ( psi_vw(ji,jj,jk+1) - psi_vw(ji,jj ,jk) ) &
- & * ( ts (ji,jj,jk,jp_tem,Kmm) + ts (ji,jj+1,jk,jp_tem,Kmm) )
- zw2d(ji,jj) = zw2d(ji,jj) + zw3d(ji,jj,jk)
- END_3D
- CALL iom_put( "veiv_heattr" , zztmp * zw2d ) ! heat transport in j-direction
- CALL iom_put( "veiv_heattr3d", zztmp * zw3d ) ! heat transport in j-direction
- !
- IF( iom_use( 'sophteiv' ) .AND. l_diaptr ) CALL dia_ptr_hst( jp_tem, 'eiv', 0.5 * zw3d )
!
zztmp = 0.5_wp * 0.5
- IF( iom_use('ueiv_salttr') .OR. iom_use('ueiv_salttr3d')) THEN
- zw2d(:,:) = 0._wp
- zw3d(:,:,:) = 0._wp
- DO_3D( 0, 0, 0, 0, 1, jpkm1 )
- zw3d(ji,jj,jk) = zw3d(ji,jj,jk) * ( psi_uw(ji,jj,jk+1) - psi_uw(ji ,jj,jk) ) &
- & * ( ts (ji,jj,jk,jp_sal,Kmm) + ts (ji+1,jj,jk,jp_sal,Kmm) )
- zw2d(ji,jj) = zw2d(ji,jj) + zw3d(ji,jj,jk)
- END_3D
- CALL iom_put( "ueiv_salttr", zztmp * zw2d ) ! salt transport in i-direction
- CALL iom_put( "ueiv_salttr3d", zztmp * zw3d ) ! salt transport in i-direction
+ IF( iom_use('ueiv_salttr') .OR. iom_use('ueiv_salttr3d') ) THEN
+ zw2d(:,:) = 0._wp
+ zw3d(:,:,:) = 0._wp
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
+ zw3d(ji,jj,jk) = zw3d(ji,jj,jk) * ( psi_uw(ji,jj,jk+1) - psi_uw(ji ,jj,jk) ) &
+ & * ( ts (ji,jj,jk,jp_sal,Kmm) + ts (ji+1,jj,jk,jp_sal,Kmm) )
+ zw2d(ji,jj) = zw2d(ji,jj) + zw3d(ji,jj,jk)
+ END_3D
+ CALL iom_put( "ueiv_salttr", zztmp * zw2d ) ! salt transport in i-direction
+ CALL iom_put( "ueiv_salttr3d", zztmp * zw3d ) ! salt transport in i-direction
ENDIF
- zw2d(:,:) = 0._wp
- zw3d(:,:,:) = 0._wp
- DO_3D( 0, 0, 0, 0, 1, jpkm1 )
- zw3d(ji,jj,jk) = zw3d(ji,jj,jk) + ( psi_vw(ji,jj,jk+1) - psi_vw(ji,jj ,jk) ) &
- & * ( ts (ji,jj,jk,jp_sal,Kmm) + ts (ji,jj+1,jk,jp_sal,Kmm) )
- zw2d(ji,jj) = zw2d(ji,jj) + zw3d(ji,jj,jk)
- END_3D
- CALL iom_put( "veiv_salttr" , zztmp * zw2d ) ! salt transport in j-direction
- CALL iom_put( "veiv_salttr3d", zztmp * zw3d ) ! salt transport in j-direction
!
- IF( iom_use( 'sopsteiv' ) .AND. l_diaptr ) CALL dia_ptr_hst( jp_sal, 'eiv', 0.5 * zw3d )
+ IF( iom_use('veiv_salttr') .OR. iom_use('veiv_salttr3d') .OR. iom_use('sopsteiv') ) THEN
+ zw2d(:,:) = 0._wp
+ zw3d(:,:,:) = 0._wp
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
+ zw3d(ji,jj,jk) = zw3d(ji,jj,jk) + ( psi_vw(ji,jj,jk+1) - psi_vw(ji,jj ,jk) ) &
+ & * ( ts (ji,jj,jk,jp_sal,Kmm) + ts (ji,jj+1,jk,jp_sal,Kmm) )
+ zw2d(ji,jj) = zw2d(ji,jj) + zw3d(ji,jj,jk)
+ END_3D
+ CALL iom_put( "veiv_salttr" , zztmp * zw2d ) ! salt transport in j-direction
+ CALL iom_put( "veiv_salttr3d", zztmp * zw3d ) ! salt transport in j-direction
+ !
+ IF( iom_use( 'sopsteiv' ) .AND. l_diaptr ) CALL dia_ptr_hst( jp_sal, 'eiv', 0.5 * zw3d )
+ ENDIF
!
!
END SUBROUTINE ldf_eiv_dia
diff --git a/src/OCE/OBS/mpp_map.F90 b/src/OCE/OBS/mpp_map.F90
index 5a4007df1a3718f1affda3f4152baad7beaa11ad..553a36446ad51a5153b540de49820ef2b473705d 100644
--- a/src/OCE/OBS/mpp_map.F90
+++ b/src/OCE/OBS/mpp_map.F90
@@ -10,8 +10,8 @@ MODULE mpp_map
!! mppmap_init : Initialize mppmap.
!!----------------------------------------------------------------------
USE par_kind, ONLY : wp ! Precision variables
- USE par_oce , ONLY : jpi, jpj, Nis0, Nie0, Njs0, Nje0 ! Ocean parameters
- USE dom_oce , ONLY : mig, mjg, narea ! Ocean space and time domain variables
+ USE par_oce , ONLY : jpi, jpj, Nis0, Nie0, Njs0, Nje0, nn_hls ! Ocean parameters
+ USE dom_oce , ONLY : mig, mjg, narea ! Ocean space and time domain variables
#if ! defined key_mpi_off
USE lib_mpp , ONLY : mpi_comm_oce ! MPP library
#endif
@@ -64,7 +64,7 @@ INCLUDE 'mpif.h'
imppmap(:,:) = 0
! ! Setup local grid points
- imppmap(mig(1):mig(jpi),mjg(1):mjg(jpj)) = narea
+ imppmap(mig(1,nn_hls):mig(jpi,nn_hls),mjg(1,nn_hls):mjg(jpj,nn_hls)) = narea
! Get global data
diff --git a/src/OCE/OBS/obs_grd_bruteforce.h90 b/src/OCE/OBS/obs_grd_bruteforce.h90
index 5a41fa312c864dc2245e8f3a519f6a6de84fa55e..5df8b26c7d1cee1ec27c9cc33fc8cbc8e556519c 100644
--- a/src/OCE/OBS/obs_grd_bruteforce.h90
+++ b/src/OCE/OBS/obs_grd_bruteforce.h90
@@ -111,9 +111,9 @@
zmskg(:,:) = -1.e+10
DO jj = kldj, klej
DO ji = kldi, klei
- zlamg(mig(ji),mjg(jj)) = pglam(ji,jj)
- zphig(mig(ji),mjg(jj)) = pgphi(ji,jj)
- zmskg(mig(ji),mjg(jj)) = pmask(ji,jj)
+ zlamg(mig(ji,nn_hls),mjg(jj,nn_hls)) = pglam(ji,jj)
+ zphig(mig(ji,nn_hls),mjg(jj,nn_hls)) = pgphi(ji,jj)
+ zmskg(mig(ji,nn_hls),mjg(jj,nn_hls)) = pmask(ji,jj)
END DO
END DO
CALL mpp_global_max( zlamg )
diff --git a/src/OCE/OBS/obs_grid.F90 b/src/OCE/OBS/obs_grid.F90
index 7157416234e257342c5fd610b1c5a0023fc4a57b..b9c7554c4691682bab3bde84fe0cd24351c60187 100644
--- a/src/OCE/OBS/obs_grid.F90
+++ b/src/OCE/OBS/obs_grid.F90
@@ -280,9 +280,9 @@ CONTAINS
! Add various grids here.
DO jj = 1, jpj
DO ji = 1, jpi
- zlamg(mig(ji),mjg(jj)) = glamt(ji,jj)
- zphig(mig(ji),mjg(jj)) = gphit(ji,jj)
- zmskg(mig(ji),mjg(jj)) = tmask(ji,jj,1)
+ zlamg(mig(ji,nn_hls),mjg(jj,nn_hls)) = glamt(ji,jj)
+ zphig(mig(ji,nn_hls),mjg(jj,nn_hls)) = gphit(ji,jj)
+ zmskg(mig(ji,nn_hls),mjg(jj,nn_hls)) = tmask(ji,jj,1)
END DO
END DO
CALL mpp_global_max( zlamg )
diff --git a/src/OCE/OBS/obs_inter_sup.F90 b/src/OCE/OBS/obs_inter_sup.F90
index d8116276d3a5bcbf7cb2b5ebb187e1b2a427a575..084830e1d1aad62a3db3dde36d22a067cb71c330 100644
--- a/src/OCE/OBS/obs_inter_sup.F90
+++ b/src/OCE/OBS/obs_inter_sup.F90
@@ -279,8 +279,8 @@ CONTAINS
! Pack interpolation data to be sent
DO ji = 1, itot
- ii = mi1(igrdij_recv(2*ji-1))
- ij = mj1(igrdij_recv(2*ji))
+ ii = mi1(igrdij_recv(2*ji-1),nn_hls)
+ ij = mj1(igrdij_recv(2*ji ),nn_hls)
DO jk = 1, kpk
zsend(jk,ji) = pval(ii,ij,jk)
END DO
diff --git a/src/OCE/OBS/obs_write.F90 b/src/OCE/OBS/obs_write.F90
index 1b44338d0b4ce03546ae8d9676b40a10bcb79b39..d0c0eda8c673fd7950817519ed1065a2d2dfc8eb 100644
--- a/src/OCE/OBS/obs_write.F90
+++ b/src/OCE/OBS/obs_write.F90
@@ -245,8 +245,8 @@ CONTAINS
fbdata%iobsi(jo,jvar) = profdata%mi(jo,jvar)
fbdata%iobsj(jo,jvar) = profdata%mj(jo,jvar)
ELSE
- fbdata%iobsi(jo,jvar) = mig(profdata%mi(jo,jvar))
- fbdata%iobsj(jo,jvar) = mjg(profdata%mj(jo,jvar))
+ fbdata%iobsi(jo,jvar) = mig(profdata%mi(jo,jvar),nn_hls)
+ fbdata%iobsj(jo,jvar) = mjg(profdata%mj(jo,jvar),nn_hls)
ENDIF
END DO
CALL greg2jul( 0, &
@@ -511,8 +511,8 @@ CONTAINS
fbdata%iobsi(jo,1) = surfdata%mi(jo)
fbdata%iobsj(jo,1) = surfdata%mj(jo)
ELSE
- fbdata%iobsi(jo,1) = mig(surfdata%mi(jo))
- fbdata%iobsj(jo,1) = mjg(surfdata%mj(jo))
+ fbdata%iobsi(jo,1) = mig(surfdata%mi(jo),nn_hls)
+ fbdata%iobsj(jo,1) = mjg(surfdata%mj(jo),nn_hls)
ENDIF
CALL greg2jul( 0, &
& surfdata%nmin(jo), &
diff --git a/src/OCE/SBC/cpl_oasis3.F90 b/src/OCE/SBC/cpl_oasis3.F90
index 111343f970676e1324dc282eda037b93c202c8de..c64bfd2d5ef7492ddfbef4fb4a8d066c2611d3d8 100644
--- a/src/OCE/SBC/cpl_oasis3.F90
+++ b/src/OCE/SBC/cpl_oasis3.F90
@@ -67,7 +67,6 @@ MODULE cpl_oasis3
INTEGER :: nrcv ! total number of fields received
INTEGER :: nsnd ! total number of fields sent
INTEGER :: ncplmodel ! Maximum number of models to/from which NEMO is potentialy sending/receiving data
- INTEGER, PUBLIC, PARAMETER :: nmaxfld=62 ! Maximum number of coupling fields
INTEGER, PUBLIC, PARAMETER :: nmaxcat=5 ! Maximum number of coupling fields
INTEGER, PUBLIC, PARAMETER :: nmaxcpl=5 ! Maximum number of coupling fields
@@ -81,7 +80,7 @@ MODULE cpl_oasis3
INTEGER :: ncplmodel ! Maximum number of models to/from which this variable may be sent/received
END TYPE FLD_CPL
- TYPE(FLD_CPL), DIMENSION(nmaxfld), PUBLIC :: srcv, ssnd !: Coupling fields
+ TYPE(FLD_CPL), DIMENSION(:), ALLOCATABLE, PUBLIC :: srcv, ssnd !: Coupling fields
REAL(wp), DIMENSION(:,:), ALLOCATABLE :: exfld ! Temporary buffer for receiving
@@ -157,15 +156,6 @@ CONTAINS
CALL oasis_abort ( ncomp_id, 'cpl_define', 'ncplmodel is larger than nmaxcpl, increase nmaxcpl') ; RETURN
ENDIF
- nrcv = krcv
- IF( nrcv > nmaxfld ) THEN
- CALL oasis_abort ( ncomp_id, 'cpl_define', 'nrcv is larger than nmaxfld, increase nmaxfld') ; RETURN
- ENDIF
-
- nsnd = ksnd
- IF( nsnd > nmaxfld ) THEN
- CALL oasis_abort ( ncomp_id, 'cpl_define', 'nsnd is larger than nmaxfld, increase nmaxfld') ; RETURN
- ENDIF
!
! ... Define the shape for the area that excludes the halo as we don't want them to be "seen" by oasis
!
@@ -185,11 +175,11 @@ CONTAINS
! ... Define the partition, excluding halos as we don't want them to be "seen" by oasis
! -----------------------------------------------------------------
- paral(1) = 2 ! box partitioning
- paral(2) = Ni0glo * mjg0(nn_hls) + mig0(nn_hls) ! NEMO lower left corner global offset, without halos
- paral(3) = Ni_0 ! local extent in i, excluding halos
- paral(4) = Nj_0 ! local extent in j, excluding halos
- paral(5) = Ni0glo ! global extent in x, excluding halos
+ paral(1) = 2 ! box partitioning
+ paral(2) = Ni0glo * mjg(nn_hls,0) + mig(nn_hls,0) ! NEMO lower left corner global offset, without halos
+ paral(3) = Ni_0 ! local extent in i, excluding halos
+ paral(4) = Nj_0 ! local extent in j, excluding halos
+ paral(5) = Ni0glo ! global extent in x, excluding halos
IF( sn_cfctl%l_oasout ) THEN
WRITE(numout,*) ' multiexchg: paral (1:5)', paral
@@ -428,8 +418,9 @@ CONTAINS
!--- we must call lbc_lnk to fill the halos that where not received.
IF( .NOT. ll_1st ) THEN
- CALL lbc_lnk( 'cpl_oasis3', pdata(:,:,jc), srcv(kid)%clgrid, srcv(kid)%nsgn )
+ CALL lbc_lnk( 'cpl_oasis3', pdata(:,:,jc), srcv(kid)%clgrid, srcv(kid)%nsgn, ldfull = .TRUE. )
ENDIF
+ !!clem: mettre T instead of clgrid
ENDDO
!
diff --git a/src/OCE/SBC/cyclone.F90 b/src/OCE/SBC/cyclone.F90
index 6a66bb02e39f0a709c6e15493114da229b3adb39..175a36633aa4cf80f5b06de59d696619e46a9e4d 100644
--- a/src/OCE/SBC/cyclone.F90
+++ b/src/OCE/SBC/cyclone.F90
@@ -54,9 +54,9 @@ CONTAINS
!! ** Action : - open TC data, find TCs for the current timestep
!! - for each potential TC, add the winds on the grid
!!----------------------------------------------------------------------
- INTEGER , INTENT(in) :: kt ! time step index
- REAL(wp), INTENT(out), DIMENSION(jpi,jpj) :: pwnd_i ! wind speed i-components at T-point ORCA direction
- REAL(wp), INTENT(out), DIMENSION(jpi,jpj) :: pwnd_j ! wind speed j-components at T-point ORCA direction
+ INTEGER , INTENT(in) :: kt ! time step index
+ REAL(wp), INTENT(out), DIMENSION(A2D(0)) :: pwnd_i ! wind speed i-components at T-point ORCA direction
+ REAL(wp), INTENT(out), DIMENSION(A2D(0)) :: pwnd_j ! wind speed j-components at T-point ORCA direction
!
!!
INTEGER :: ji, jj , jtc ! loop arguments
@@ -79,7 +79,7 @@ CONTAINS
REAL(wp) :: zwnd_r, zwnd_t ! radial and tangential components of the wind
REAL(wp) :: zvmax ! timestep interpolated vmax
REAL(wp) :: zrlon, zrlat ! temporary
- REAL(wp), DIMENSION(jpi,jpj) :: zwnd_x, zwnd_y ! zonal and meridional components of the wind
+ REAL(wp), DIMENSION(A2D(0)) :: zwnd_x, zwnd_y ! zonal and meridional components of the wind
REAL(wp), DIMENSION(14,5) :: ztct ! tropical cyclone track data at kt
!
CHARACTER(len=100) :: cn_dir ! Root directory for location of files
@@ -146,7 +146,7 @@ CONTAINS
! fitted B parameter (Willoughby 2004)
zb = 2.
- DO_2D( 1, 1, 1, 1 )
+ DO_2D( 0, 0, 0, 0 )
! calc distance between TC center and any point following great circle
! source : http://www.movable-type.co.uk/scripts/latlong.html
@@ -207,7 +207,7 @@ CONTAINS
zA=0
ENDIF
- DO_2D( 1, 1, 1, 1 )
+ DO_2D( 0, 0, 0, 0 )
zzrglam = rad * glamt(ji,jj) - zrlon
zzrgphi = rad * gphit(ji,jj)
diff --git a/src/OCE/SBC/fldread.F90 b/src/OCE/SBC/fldread.F90
index f7a6d90fa6949a2144e762b1a8634f939fcaf8a3..dd25b66e448d037099b4350b8ca89f83ed6a6670 100644
--- a/src/OCE/SBC/fldread.F90
+++ b/src/OCE/SBC/fldread.F90
@@ -274,7 +274,7 @@ CONTAINS
!!----------------------------------------------------------------------
INTEGER , INTENT(in ) :: ksecsbc !
TYPE(FLD), INTENT(inout) :: sdjf ! input field related variables
- INTEGER , OPTIONAL, INTENT(in ) :: Kmm ! ocean time level index
+ INTEGER , OPTIONAL, INTENT(in ) :: Kmm ! ocean time level index
!
INTEGER :: ja ! end of this record (in seconds)
INTEGER :: ibb, iaa ! shorter name for sdjf%nbb and sdjf%naa
@@ -288,7 +288,7 @@ CONTAINS
DO WHILE ( ksecsbc >= sdjf%nrecsec(ja) .AND. ja < sdjf%nreclast ) ! Warning: make sure ja <= sdjf%nreclast in this test
ja = ja + 1
END DO
- IF( ksecsbc > sdjf%nrecsec(ja) ) ja = ja + 1 ! in case ksecsbc > sdjf%nrecsec(sdjf%nreclast)
+ IF( ksecsbc > sdjf%nrecsec(ja) ) ja = ja + 1 ! in case ksecsbc > sdjf%nrecsec(sdjf%nreclast)
! if ln_tint and if the new after is not ja+1, we need also to update after data before the swap
! so, after the swap, sdjf%nrec(2,ibb) will still be the closest value located just before ksecsbc
@@ -699,9 +699,10 @@ CONTAINS
INTEGER :: imf ! size of the structure sd
INTEGER :: ill ! character length
INTEGER :: iv ! indice of V component
+ INTEGER :: ipi, ipj
CHARACTER (LEN=100) :: clcomp ! dummy weight name
- REAL(wp), DIMENSION(jpi,jpj) :: utmp, vtmp ! temporary arrays for vector rotation
- REAL(wp), DIMENSION(:,:,:), POINTER :: dta_u, dta_v ! short cut
+ REAL(wp), DIMENSION(:,:), ALLOCATABLE :: utmp, vtmp ! temporary arrays for vector rotation
+ REAL(wp), DIMENSION(:,:,:), POINTER :: dta_u, dta_v ! short cut
!!---------------------------------------------------------------------
!
!! (sga: following code should be modified so that pairs arent searched for each time
@@ -724,11 +725,14 @@ CONTAINS
IF( sd(ju)%ln_tint ) THEN ; dta_u => sd(ju)%fdta(:,:,:,jn) ; dta_v => sd(iv)%fdta(:,:,:,jn)
ELSE ; dta_u => sd(ju)%fnow(:,:,: ) ; dta_v => sd(iv)%fnow(:,:,: )
ENDIF
+ ipi = SIZE(dta_u,1) ; ipj = SIZE(dta_u,2)
+ ALLOCATE( utmp(ipi,ipj), vtmp(ipi,ipj) )
DO jk = 1, SIZE( sd(ju)%fnow, 3 )
CALL rot_rep( dta_u(:,:,jk), dta_v(:,:,jk), 'T', 'en->i', utmp(:,:) )
CALL rot_rep( dta_u(:,:,jk), dta_v(:,:,jk), 'T', 'en->j', vtmp(:,:) )
dta_u(:,:,jk) = utmp(:,:) ; dta_v(:,:,jk) = vtmp(:,:)
END DO
+ DEALLOCATE( utmp, vtmp )
sd(ju)%rotn(jn) = .TRUE. ! vector was rotated
IF( lwp .AND. kt == nit000 ) WRITE(numout,*) &
& 'fld_read: vector pair ('//TRIM(sd(ju)%clvar)//', '//TRIM(sd(iv)%clvar)//') rotated on to model grid'
@@ -745,11 +749,18 @@ CONTAINS
!!---------------------------------------------------------------------
!! *** ROUTINE fld_def ***
!!
- !! ** Purpose : define the record(s) of the file and its name
+ !! ** Purpose : Compute the record(s) of the file and define its name.
+ !! By default, the current file is defined according to the current time step calendar
+ !! variables (nyear, month, day, nsec_month, nsec_year... see daymod.F90)
+ !! Records time (seconds since Jan. 1st 00h of nit000 year) is stored in sdjf%nrecsec
+ !! if sdjf%ln_tint = .TRUE.
+ !! sdjf%nrecsec(1:sdjf%nreclast) = middle of each record
+ !! if sdjf%ln_tint = .FALSE.
+ !! sdjf%nrecsec(0:sdjf%nreclast) = beginning/end of each record
!!----------------------------------------------------------------------
TYPE(FLD) , INTENT(inout) :: sdjf ! input field related variables
- LOGICAL, OPTIONAL, INTENT(in ) :: ldprev !
- LOGICAL, OPTIONAL, INTENT(in ) :: ldnext !
+ LOGICAL, OPTIONAL, INTENT(in ) :: ldprev ! True if sdjf must be defined for the previous file
+ LOGICAL, OPTIONAL, INTENT(in ) :: ldnext ! True if sdjf must be defined for the next file
!
INTEGER :: jt
INTEGER :: idaysec ! number of seconds in 1 day = NINT(rday)
@@ -1100,7 +1111,7 @@ CONTAINS
CHARACTER (len=5) :: clname !
INTEGER , DIMENSION(4) :: ddims
INTEGER :: isrc
- REAL(wp), DIMENSION(jpi,jpj) :: data_tmp
+ REAL(wp), DIMENSION(A2D(0)) :: data_tmp
!!----------------------------------------------------------------------
!
IF( nxt_wgt > tot_wgts ) THEN
@@ -1155,9 +1166,9 @@ CONTAINS
ELSE ; ref_wgts(nxt_wgt)%numwgt = 16
ENDIF
- ALLOCATE( ref_wgts(nxt_wgt)%data_jpi(Nis0:Nie0,Njs0:Nje0,4) )
- ALLOCATE( ref_wgts(nxt_wgt)%data_jpj(Nis0:Nie0,Njs0:Nje0,4) )
- ALLOCATE( ref_wgts(nxt_wgt)%data_wgt(Nis0:Nie0,Njs0:Nje0,ref_wgts(nxt_wgt)%numwgt) )
+ ALLOCATE( ref_wgts(nxt_wgt)%data_jpi(A2D(0),4) )
+ ALLOCATE( ref_wgts(nxt_wgt)%data_jpj(A2D(0),4) )
+ ALLOCATE( ref_wgts(nxt_wgt)%data_wgt(A2D(0),ref_wgts(nxt_wgt)%numwgt) )
DO jn = 1,4
WRITE(clname,'(a3,i2.2)') 'src',jn
@@ -1332,7 +1343,9 @@ CONTAINS
INTEGER, DIMENSION(3) :: rec1_lsm, recn_lsm ! temporary arrays for start and length in case of seaoverland
INTEGER :: ii_lsm1,ii_lsm2,ij_lsm1,ij_lsm2 ! temporary indices
INTEGER :: ji, jj, jk, jn, jir, jjr ! loop counters
- INTEGER :: ipk
+ INTEGER :: ipi, ipj, ipk
+ INTEGER :: iisht, ijsht
+ INTEGER :: ii, ij
INTEGER :: ni, nj ! lengths
INTEGER :: jpimin,jpiwid ! temporary indices
INTEGER :: jpimin_lsm,jpiwid_lsm ! temporary indices
@@ -1343,7 +1356,11 @@ CONTAINS
INTEGER :: itmpi,itmpj,itmpz ! lengths
REAL(wp),DIMENSION(:,:,:), ALLOCATABLE :: ztmp_fly_dta ! local array of values on input grid
!!----------------------------------------------------------------------
+ ipi = SIZE(dta, 1)
+ ipj = SIZE(dta, 2)
ipk = SIZE(dta, 3)
+ iisht = ( jpi - ipi ) / 2
+ ijsht = ( jpj - ipj ) / 2
!
!! for weighted interpolation we have weights at four corners of a box surrounding
!! a model grid point, each weight is multiplied by a grid value (bilinear case)
@@ -1438,7 +1455,9 @@ CONTAINS
DO_3D( 0, 0, 0, 0, 1,ipk )
ni = ref_wgts(kw)%data_jpi(ji,jj,jn) + 1
nj = ref_wgts(kw)%data_jpj(ji,jj,jn) + 1
- dta(ji,jj,jk) = dta(ji,jj,jk) + ref_wgts(kw)%data_wgt(ji,jj,jn) * ref_wgts(kw)%fly_dta(ni,nj,jk)
+ ii = ji - iisht
+ ij = jj - ijsht
+ dta(ii,ij,jk) = dta(ii,ij,jk) + ref_wgts(kw)%data_wgt(ji,jj,jn) * ref_wgts(kw)%fly_dta(ni,nj,jk)
END_3D
END DO
@@ -1482,7 +1501,9 @@ CONTAINS
!!$ DO_3D( 0, 0, 0, 0, 1,ipk )
!!$ ni = ref_wgts(kw)%data_jpi(ji,jj,jn) + 1
!!$ nj = ref_wgts(kw)%data_jpj(ji,jj,jn) + 1
-!!$ dta(ji,jj,jk) = dta(ji,jj,jk) &
+!!$ ii = ji - iisht
+!!$ ij = jj - ijsht
+!!$ dta(ii,ij,jk) = dta(ii,ij,jk) &
!!$ ! gradient in the i direction
!!$ & + ref_wgts(kw)%data_wgt(ji,jj,jn+4) * 0.5_wp * &
!!$ & (ref_wgts(kw)%fly_dta(ni+1,nj ,jk) - ref_wgts(kw)%fly_dta(ni-1,nj ,jk)) &
@@ -1500,8 +1521,10 @@ CONTAINS
DO_3D( 0, 0, 0, 0, 1,ipk )
ni = ref_wgts(kw)%data_jpi(ji,jj,jn)
nj = ref_wgts(kw)%data_jpj(ji,jj,jn)
+ ii = ji - iisht
+ ij = jj - ijsht
! gradient in the i direction
- dta(ji,jj,jk) = dta(ji,jj,jk) + ref_wgts(kw)%data_wgt(ji,jj,jn+4) * 0.5_wp * &
+ dta(ii,ij,jk) = dta(ii,ij,jk) + ref_wgts(kw)%data_wgt(ji,jj,jn+4) * 0.5_wp * &
& (ref_wgts(kw)%fly_dta(ni+2,nj+1,jk) - ref_wgts(kw)%fly_dta(ni ,nj+1,jk))
END_3D
END DO
@@ -1509,8 +1532,10 @@ CONTAINS
DO_3D( 0, 0, 0, 0, 1,ipk )
ni = ref_wgts(kw)%data_jpi(ji,jj,jn)
nj = ref_wgts(kw)%data_jpj(ji,jj,jn)
+ ii = ji - iisht
+ ij = jj - ijsht
! gradient in the j direction
- dta(ji,jj,jk) = dta(ji,jj,jk) + ref_wgts(kw)%data_wgt(ji,jj,jn+8) * 0.5_wp * &
+ dta(ii,ij,jk) = dta(ii,ij,jk) + ref_wgts(kw)%data_wgt(ji,jj,jn+8) * 0.5_wp * &
& (ref_wgts(kw)%fly_dta(ni+1,nj+2,jk) - ref_wgts(kw)%fly_dta(ni+1,nj ,jk))
END_3D
END DO
@@ -1518,8 +1543,10 @@ CONTAINS
DO_3D( 0, 0, 0, 0, 1,ipk )
ni = ref_wgts(kw)%data_jpi(ji,jj,jn)
nj = ref_wgts(kw)%data_jpj(ji,jj,jn)
+ ii = ji - iisht
+ ij = jj - ijsht
! gradient in the ij direction
- dta(ji,jj,jk) = dta(ji,jj,jk) + ref_wgts(kw)%data_wgt(ji,jj,jn+12) * 0.25_wp * ( &
+ dta(ii,ij,jk) = dta(ii,ij,jk) + ref_wgts(kw)%data_wgt(ji,jj,jn+12) * 0.25_wp * ( &
& (ref_wgts(kw)%fly_dta(ni+2,nj+2,jk) - ref_wgts(kw)%fly_dta(ni ,nj+2,jk)) - &
& (ref_wgts(kw)%fly_dta(ni+2,nj ,jk) - ref_wgts(kw)%fly_dta(ni ,nj ,jk)))
END_3D
diff --git a/src/OCE/SBC/geo2ocean.F90 b/src/OCE/SBC/geo2ocean.F90
index 182e5e03073cc458a418e34b745b0fef8f355368..734ce4ef961dcfc0b8041111924a29765de48796 100644
--- a/src/OCE/SBC/geo2ocean.F90
+++ b/src/OCE/SBC/geo2ocean.F90
@@ -57,15 +57,23 @@ CONTAINS
!! ** Purpose : Rotate the Repere: Change vector componantes between
!! geographic grid <--> stretched coordinates grid.
!!----------------------------------------------------------------------
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pxin, pyin ! vector componantes
- CHARACTER(len=1), INTENT(in ) :: cd_type ! define the nature of pt2d array grid-points
- CHARACTER(len=5), INTENT(in ) :: cdtodo ! type of transpormation:
- ! ! 'en->i' = east-north to i-component
- ! ! 'en->j' = east-north to j-component
- ! ! 'ij->e' = (i,j) components to east
- ! ! 'ij->n' = (i,j) components to north
- REAL(wp), DIMENSION(jpi,jpj), INTENT( out) :: prot
+ REAL(wp), DIMENSION(:,:), INTENT(in ) :: pxin, pyin ! vector componantes
+ CHARACTER(len=1), INTENT(in ) :: cd_type ! define the nature of pt2d array grid-points
+ CHARACTER(len=5), INTENT(in ) :: cdtodo ! type of transpormation:
+ ! ! 'en->i' = east-north to i-component
+ ! ! 'en->j' = east-north to j-component
+ ! ! 'ij->e' = (i,j) components to east
+ ! ! 'ij->n' = (i,j) components to north
+ REAL(wp), DIMENSION(:,:), INTENT( out) :: prot
+ !
+ INTEGER :: ipi, ipj, iipi, ijpj
+ INTEGER :: iisht, ijsht
+ INTEGER :: ii, ij, ii1, ij1
!!----------------------------------------------------------------------
+ ipi = SIZE(pxin, 1) ; ipj = SIZE(pxin, 2)
+ iisht = ( jpi - ipi ) / 2 ; ijsht = ( jpj - ipj ) / 2
+ ii1 = 1 + iisht ; ij1 = 1 + iisht
+ iipi = ipi + iisht ; ijpj = ipj + ijsht
!
IF( lmust_init ) THEN ! at 1st call only: set gsin. & gcos.
IF(lwp) WRITE(numout,*)
@@ -80,34 +88,50 @@ CONTAINS
!
CASE( 'en->i' ) ! east-north to i-component
SELECT CASE (cd_type)
- CASE ('T') ; prot(:,:) = pxin(:,:) * gcost(:,:) + pyin(:,:) * gsint(:,:)
- CASE ('U') ; prot(:,:) = pxin(:,:) * gcosu(:,:) + pyin(:,:) * gsinu(:,:)
- CASE ('V') ; prot(:,:) = pxin(:,:) * gcosv(:,:) + pyin(:,:) * gsinv(:,:)
- CASE ('F') ; prot(:,:) = pxin(:,:) * gcosf(:,:) + pyin(:,:) * gsinf(:,:)
+ CASE ('T') ; prot(1:ipi,1:ipj) = pxin(1:ipi,1:ipj) * gcost(ii1:iipi,ij1:ijpj) &
+ & + pyin(1:ipi,1:ipj) * gsint(ii1:iipi,ij1:ijpj)
+ CASE ('U') ; prot(1:ipi,1:ipj) = pxin(1:ipi,1:ipj) * gcosu(ii1:iipi,ij1:ijpj) &
+ & + pyin(1:ipi,1:ipj) * gsinu(ii1:iipi,ij1:ijpj)
+ CASE ('V') ; prot(1:ipi,1:ipj) = pxin(1:ipi,1:ipj) * gcosv(ii1:iipi,ij1:ijpj) &
+ & + pyin(1:ipi,1:ipj) * gsinv(ii1:iipi,ij1:ijpj)
+ CASE ('F') ; prot(1:ipi,1:ipj) = pxin(1:ipi,1:ipj) * gcosf(ii1:iipi,ij1:ijpj) &
+ & + pyin(1:ipi,1:ipj) * gsinf(ii1:iipi,ij1:ijpj)
CASE DEFAULT ; CALL ctl_stop( 'Only T, U, V and F grid points are coded' )
END SELECT
CASE ('en->j') ! east-north to j-component
SELECT CASE (cd_type)
- CASE ('T') ; prot(:,:) = pyin(:,:) * gcost(:,:) - pxin(:,:) * gsint(:,:)
- CASE ('U') ; prot(:,:) = pyin(:,:) * gcosu(:,:) - pxin(:,:) * gsinu(:,:)
- CASE ('V') ; prot(:,:) = pyin(:,:) * gcosv(:,:) - pxin(:,:) * gsinv(:,:)
- CASE ('F') ; prot(:,:) = pyin(:,:) * gcosf(:,:) - pxin(:,:) * gsinf(:,:)
+ CASE ('T') ; prot(1:ipi,1:ipj) = pyin(1:ipi,1:ipj) * gcost(ii1:iipi,ij1:ijpj) &
+ & - pxin(1:ipi,1:ipj) * gsint(ii1:iipi,ij1:ijpj)
+ CASE ('U') ; prot(1:ipi,1:ipj) = pyin(1:ipi,1:ipj) * gcosu(ii1:iipi,ij1:ijpj) &
+ & - pxin(1:ipi,1:ipj) * gsinu(ii1:iipi,ij1:ijpj)
+ CASE ('V') ; prot(1:ipi,1:ipj) = pyin(1:ipi,1:ipj) * gcosv(ii1:iipi,ij1:ijpj) &
+ & - pxin(1:ipi,1:ipj) * gsinv(ii1:iipi,ij1:ijpj)
+ CASE ('F') ; prot(1:ipi,1:ipj) = pyin(1:ipi,1:ipj) * gcosf(ii1:iipi,ij1:ijpj) &
+ & - pxin(1:ipi,1:ipj) * gsinf(ii1:iipi,ij1:ijpj)
CASE DEFAULT ; CALL ctl_stop( 'Only T, U, V and F grid points are coded' )
END SELECT
CASE ('ij->e') ! (i,j)-components to east
SELECT CASE (cd_type)
- CASE ('T') ; prot(:,:) = pxin(:,:) * gcost(:,:) - pyin(:,:) * gsint(:,:)
- CASE ('U') ; prot(:,:) = pxin(:,:) * gcosu(:,:) - pyin(:,:) * gsinu(:,:)
- CASE ('V') ; prot(:,:) = pxin(:,:) * gcosv(:,:) - pyin(:,:) * gsinv(:,:)
- CASE ('F') ; prot(:,:) = pxin(:,:) * gcosf(:,:) - pyin(:,:) * gsinf(:,:)
+ CASE ('T') ; prot(1:ipi,1:ipj) = pxin(1:ipi,1:ipj) * gcost(ii1:iipi,ij1:ijpj) &
+ & - pyin(1:ipi,1:ipj) * gsint(ii1:iipi,ij1:ijpj)
+ CASE ('U') ; prot(1:ipi,1:ipj) = pxin(1:ipi,1:ipj) * gcosu(ii1:iipi,ij1:ijpj) &
+ & - pyin(1:ipi,1:ipj) * gsinu(ii1:iipi,ij1:ijpj)
+ CASE ('V') ; prot(1:ipi,1:ipj) = pxin(1:ipi,1:ipj) * gcosv(ii1:iipi,ij1:ijpj) &
+ & - pyin(1:ipi,1:ipj) * gsinv(ii1:iipi,ij1:ijpj)
+ CASE ('F') ; prot(1:ipi,1:ipj) = pxin(1:ipi,1:ipj) * gcosf(ii1:iipi,ij1:ijpj) &
+ & - pyin(1:ipi,1:ipj) * gsinf(ii1:iipi,ij1:ijpj)
CASE DEFAULT ; CALL ctl_stop( 'Only T, U, V and F grid points are coded' )
END SELECT
CASE ('ij->n') ! (i,j)-components to north
SELECT CASE (cd_type)
- CASE ('T') ; prot(:,:) = pyin(:,:) * gcost(:,:) + pxin(:,:) * gsint(:,:)
- CASE ('U') ; prot(:,:) = pyin(:,:) * gcosu(:,:) + pxin(:,:) * gsinu(:,:)
- CASE ('V') ; prot(:,:) = pyin(:,:) * gcosv(:,:) + pxin(:,:) * gsinv(:,:)
- CASE ('F') ; prot(:,:) = pyin(:,:) * gcosf(:,:) + pxin(:,:) * gsinf(:,:)
+ CASE ('T') ; prot(1:ipi,1:ipj) = pyin(1:ipi,1:ipj) * gcost(ii1:iipi,ij1:ijpj) &
+ & + pxin(1:ipi,1:ipj) * gsint(ii1:iipi,ij1:ijpj)
+ CASE ('U') ; prot(1:ipi,1:ipj) = pyin(1:ipi,1:ipj) * gcosu(ii1:iipi,ij1:ijpj) &
+ & + pxin(1:ipi,1:ipj) * gsinu(ii1:iipi,ij1:ijpj)
+ CASE ('V') ; prot(1:ipi,1:ipj) = pyin(1:ipi,1:ipj) * gcosv(ii1:iipi,ij1:ijpj) &
+ & + pxin(1:ipi,1:ipj) * gsinv(ii1:iipi,ij1:ijpj)
+ CASE ('F') ; prot(1:ipi,1:ipj) = pyin(1:ipi,1:ipj) * gcosf(ii1:iipi,ij1:ijpj) &
+ & + pxin(1:ipi,1:ipj) * gsinf(ii1:iipi,ij1:ijpj)
CASE DEFAULT ; CALL ctl_stop( 'Only T, U, V and F grid points are coded' )
END SELECT
CASE DEFAULT ; CALL ctl_stop( 'rot_rep: Syntax Error in the definition of cdtodo' )
@@ -286,14 +310,17 @@ CONTAINS
!! ** Method : Change a vector from geocentric to east/north
!!
!!----------------------------------------------------------------------
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pxx, pyy, pzz
- CHARACTER(len=1) , INTENT(in ) :: cgrid
- REAL(wp), DIMENSION(jpi,jpj), INTENT( out) :: pte, ptn
+ REAL(wp), DIMENSION(:,:), INTENT(in ) :: pxx, pyy, pzz
+ CHARACTER(len=1) , INTENT(in ) :: cgrid
+ REAL(wp), DIMENSION(:,:), INTENT( out) :: pte, ptn
!
REAL(wp), PARAMETER :: rpi = 3.141592653e0
REAL(wp), PARAMETER :: rad = rpi / 180.e0
INTEGER :: ig !
INTEGER :: ierr ! local integer
+ INTEGER :: ipi, ipj, iipi, ijpj
+ INTEGER :: iisht, ijsht
+ INTEGER :: ii, ij, ii1, ij1
!!----------------------------------------------------------------------
!
IF( .NOT. ALLOCATED( gsinlon ) ) THEN
@@ -345,10 +372,16 @@ CONTAINS
CALL ctl_stop( ctmp1 )
END SELECT
!
- pte = - gsinlon(:,:,ig) * pxx + gcoslon(:,:,ig) * pyy
- ptn = - gcoslon(:,:,ig) * gsinlat(:,:,ig) * pxx &
- & - gsinlon(:,:,ig) * gsinlat(:,:,ig) * pyy &
- & + gcoslat(:,:,ig) * pzz
+ ipi = SIZE(pxx, 1) ; ipj = SIZE(pxx, 2)
+ iisht = ( jpi - ipi ) / 2 ; ijsht = ( jpj - ipj ) / 2
+ ii1 = 1 + iisht ; ij1 = 1 + iisht
+ iipi = ipi + iisht ; ijpj = ipj + ijsht
+ !
+ pte(1:ipi,1:ipj) = - gsinlon(ii1:iipi,ij1:ijpj,ig) * pxx(1:ipi,1:ipj) &
+ & + gcoslon(ii1:iipi,ij1:ijpj,ig) * pyy(1:ipi,1:ipj)
+ ptn(1:ipi,1:ipj) = - gcoslon(ii1:iipi,ij1:ijpj,ig) * gsinlat(ii1:iipi,ij1:ijpj,ig) * pxx(1:ipi,1:ipj) &
+ & - gsinlon(ii1:iipi,ij1:ijpj,ig) * gsinlat(ii1:iipi,ij1:ijpj,ig) * pyy(1:ipi,1:ipj) &
+ & + gcoslat(ii1:iipi,ij1:ijpj,ig) * pzz(1:ipi,1:ipj)
!
END SUBROUTINE geo2oce
@@ -371,6 +404,9 @@ CONTAINS
REAL(wp), PARAMETER :: rad = rpi / 180.e0_wp
INTEGER :: ig !
INTEGER :: ierr ! local integer
+ INTEGER :: ipi, ipj, iipi, ijpj
+ INTEGER :: iisht, ijsht
+ INTEGER :: ii, ij, ii1, ij1
!!----------------------------------------------------------------------
IF( .NOT. ALLOCATED( gsinlon ) ) THEN
@@ -422,9 +458,16 @@ CONTAINS
CALL ctl_stop( ctmp1 )
END SELECT
!
- pxx = - gsinlon(:,:,ig) * pte - gcoslon(:,:,ig) * gsinlat(:,:,ig) * ptn
- pyy = gcoslon(:,:,ig) * pte - gsinlon(:,:,ig) * gsinlat(:,:,ig) * ptn
- pzz = gcoslat(:,:,ig) * ptn
+ ipi = SIZE(pte, 1) ; ipj = SIZE(pte, 2)
+ iisht = ( jpi - ipi ) / 2 ; ijsht = ( jpj - ipj ) / 2
+ ii1 = 1 + iisht ; ij1 = 1 + iisht
+ iipi = ipi + iisht ; ijpj = ipj + ijsht
+ !
+ pxx(1:ipi,1:ipj) = - gsinlon(ii1:iipi,ij1:ijpj,ig) * pte(1:ipi,1:ipj) &
+ & - gcoslon(ii1:iipi,ij1:ijpj,ig) * gsinlat(ii1:iipi,ij1:ijpj,ig) * ptn(1:ipi,1:ipj)
+ pyy(1:ipi,1:ipj) = gcoslon(ii1:iipi,ij1:ijpj,ig) * pte(1:ipi,1:ipj) &
+ & - gsinlon(ii1:iipi,ij1:ijpj,ig) * gsinlat(ii1:iipi,ij1:ijpj,ig) * ptn(1:ipi,1:ipj)
+ pzz(1:ipi,1:ipj) = gcoslat(ii1:iipi,ij1:ijpj,ig) * ptn(1:ipi,1:ipj)
!
END SUBROUTINE oce2geo
diff --git a/src/OCE/SBC/ocealb.F90 b/src/OCE/SBC/ocealb.F90
index e40f6f20144ed9754fd2e3a61eb01c28fc6e2367..6ea068681eea63ff75e3e8eece2284e94b676c9e 100644
--- a/src/OCE/SBC/ocealb.F90
+++ b/src/OCE/SBC/ocealb.F90
@@ -17,7 +17,9 @@ MODULE ocealb
PRIVATE
PUBLIC oce_alb ! routine called by sbccpl
-
+
+ !! Substitution
+# include "do_loop_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
!! $Id: ocealb.F90 10069 2018-08-28 14:12:24Z nicolasmartin $
@@ -31,8 +33,8 @@ CONTAINS
!!
!! ** Purpose : Computation of the albedo of the ocean
!!----------------------------------------------------------------------
- REAL(wp), DIMENSION(:,:), INTENT(out) :: palb_os ! albedo of ocean under overcast sky
- REAL(wp), DIMENSION(:,:), INTENT(out) :: palb_cs ! albedo of ocean under clear sky
+ REAL(wp), DIMENSION(A2D(0)), INTENT(out) :: palb_os ! albedo of ocean under overcast sky
+ REAL(wp), DIMENSION(A2D(0)), INTENT(out) :: palb_cs ! albedo of ocean under clear sky
!!
REAL(wp) :: zcoef
REAL(wp) :: rmue = 0.40 ! cosine of local solar altitude
diff --git a/src/OCE/SBC/sbc_ice.F90 b/src/OCE/SBC/sbc_ice.F90
index acc6adf1fd10939f9a8e0b742f951b1330fbe844..7cde0d4cbfa8195835e2ec1ce1d8b5b3e544ca41 100644
--- a/src/OCE/SBC/sbc_ice.F90
+++ b/src/OCE/SBC/sbc_ice.F90
@@ -50,8 +50,8 @@ MODULE sbc_ice
REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: qcn_ice !: heat conduction flux in the layer below surface [W/m2]
REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: qtr_ice_top !: solar flux transmitted below the ice surface [W/m2]
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: utau_ice !: atmos-ice u-stress. VP: I-pt ; EVP: U,V-pts [N/m2]
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: vtau_ice !: atmos-ice v-stress. VP: I-pt ; EVP: U,V-pts [N/m2]
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: utau_ice !: atmos-ice u-stress. T-pts [N/m2]
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: vtau_ice !: atmos-ice v-stress. T-pts [N/m2]
REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: emp_ice !: sublimation - precip over sea ice [kg/m2/s]
REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: topmelt !: category topmelt
@@ -103,6 +103,8 @@ MODULE sbc_ice
REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: snwice_mass_b !: mass of snow and ice at previous ice time step [Kg/m2]
REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: snwice_fmass !: time evolution of mass of snow+ice [Kg/m2/s]
+ !! * Substitutions
+# include "do_loop_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
!! $Id: sbc_ice.F90 14072 2020-12-04 07:48:38Z laurent $
@@ -114,36 +116,49 @@ CONTAINS
!!----------------------------------------------------------------------
!! *** FUNCTION sbc_ice_alloc ***
!!----------------------------------------------------------------------
- INTEGER :: ierr(4)
+ INTEGER :: ierr(5), ii
!!----------------------------------------------------------------------
ierr(:) = 0
+ ii = 0
- ALLOCATE( snwice_mass(jpi,jpj) , snwice_mass_b(jpi,jpj), snwice_fmass(jpi,jpj) , STAT=ierr(1) )
+ ii = ii + 1
+ ALLOCATE( snwice_mass(jpi,jpj) , snwice_mass_b(jpi,jpj), snwice_fmass(jpi,jpj) , STAT=ierr(ii) )
#if defined key_si3
- ALLOCATE( qns_ice (jpi,jpj,jpl) , qsr_ice (jpi,jpj,jpl) , &
- & qla_ice (jpi,jpj,jpl) , dqla_ice (jpi,jpj,jpl) , &
- & dqns_ice(jpi,jpj,jpl) , tn_ice (jpi,jpj,jpl) , alb_ice (jpi,jpj,jpl) , &
- & qml_ice (jpi,jpj,jpl) , qcn_ice (jpi,jpj,jpl) , qtr_ice_top(jpi,jpj,jpl) , &
- & utau_ice(jpi,jpj) , vtau_ice (jpi,jpj) , wndm_ice (jpi,jpj) , &
- & evap_ice(jpi,jpj,jpl) , devap_ice(jpi,jpj,jpl) , qprec_ice (jpi,jpj) , &
- & qemp_ice(jpi,jpj) , qevap_ice(jpi,jpj,jpl) , qemp_oce (jpi,jpj) , &
- & qns_oce (jpi,jpj) , qsr_oce (jpi,jpj) , emp_oce (jpi,jpj) , &
- & emp_ice (jpi,jpj) , sstfrz (jpi,jpj) , rCdU_ice (jpi,jpj) , STAT= ierr(2) )
+ ! ----------------- !
+ ! == FULL ARRAYS == !
+ ! ----------------- !
+ ii = ii + 1
+ ALLOCATE( utau_ice(jpi,jpj) , vtau_ice(jpi,jpj) , &
+ & rCdU_ice(A2D(1)) , STAT= ierr(ii) )
+ ! -------------------- !
+ ! == REDUCED ARRAYS == !
+ ! -------------------- !
+ ii = ii + 1
+ ALLOCATE( wndm_ice(A2D(0)) , &
+ & qns_ice (A2D(0),jpl) , qsr_ice (A2D(0),jpl) , &
+ & qla_ice (A2D(0),jpl) , dqla_ice (A2D(0),jpl) , &
+ & dqns_ice(A2D(0),jpl) , tn_ice (A2D(0),jpl) , alb_ice (A2D(0),jpl) , &
+ & qml_ice (A2D(0),jpl) , qcn_ice (A2D(0),jpl) , qtr_ice_top(A2D(0),jpl) , &
+ & evap_ice(A2D(0),jpl) , devap_ice(A2D(0),jpl) , qprec_ice (A2D(0)) , &
+ & qemp_ice(A2D(0)) , qevap_ice(A2D(0),jpl) , qemp_oce (A2D(0)) , &
+ & qns_oce (A2D(0)) , qsr_oce (A2D(0)) , emp_oce (A2D(0)) , &
+ & emp_ice (A2D(0)) , sstfrz (A2D(0)) , STAT= ierr(ii) )
#endif
#if defined key_cice
+ ii = ii + 1
ALLOCATE( qla_ice(jpi,jpj,1) , qlw_ice(jpi,jpj,1) , qsr_ice(jpi,jpj,1) , &
wndi_ice(jpi,jpj) , tatm_ice(jpi,jpj) , qatm_ice(jpi,jpj) , &
wndj_ice(jpi,jpj) , nfrzmlt(jpi,jpj) , ss_iou(jpi,jpj) , &
ss_iov(jpi,jpj) , fr_iu(jpi,jpj) , fr_iv(jpi,jpj) , &
a_i(jpi,jpj,ncat) , topmelt(jpi,jpj,ncat) , botmelt(jpi,jpj,ncat) , &
- STAT= ierr(2) )
+ STAT= ierr(ii) )
+ ii = ii + 1
IF( ln_cpl ) ALLOCATE( u_ice(jpi,jpj) , tn_ice (jpi,jpj,1) , &
& v_ice(jpi,jpj) , alb_ice(jpi,jpj,1) , &
& emp_ice(jpi,jpj) , qns_ice(jpi,jpj,1) , dqns_ice(jpi,jpj,1) , &
- & STAT= ierr(3) )
- IF( ln_cpl ) ALLOCATE( h_i(jpi,jpj,jpl) , h_s(jpi,jpj,jpl) , STAT=ierr(4) )
+ & h_i(jpi,jpj,jpl) , h_s(jpi,jpj,jpl) ,STAT= ierr(ii) )
#endif
sbc_ice_alloc = MAXVAL( ierr )
diff --git a/src/OCE/SBC/sbc_oce.F90 b/src/OCE/SBC/sbc_oce.F90
index 3098b5865b6719eb5250180257f7d9e1ab143c75..d4eea48910fd30a7eba454c5bf6fcba1c69b6d46 100644
--- a/src/OCE/SBC/sbc_oce.F90
+++ b/src/OCE/SBC/sbc_oce.F90
@@ -103,34 +103,36 @@ MODULE sbc_oce
INTEGER , PUBLIC :: ncpl_qsr_freq = 0 !: qsr coupling frequency per days from atmosphere (used by top)
!
!! !! now ! before !!
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: utau , utau_b !: sea surface i-stress (ocean referential) [N/m2]
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: vtau , vtau_b !: sea surface j-stress (ocean referential) [N/m2]
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: utau_icb, vtau_icb !: sea surface (i,j)-stress used by icebergs [N/m2]
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: taum !: module of sea surface stress (at T-point) [N/m2]
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: utau !: sea surface i-stress (ocean referential) T-pt [N/m2]
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: vtau !: sea surface j-stress (ocean referential) T-pt [N/m2]
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: utauU , utau_b !: sea surface i-stress (ocean referential) U-pt [N/m2]
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: vtauV , vtau_b !: sea surface j-stress (ocean referential) V-pt [N/m2]
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: utau_icb, vtau_icb !: sea surface (i,j)-stress used by icebergs [N/m2]
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: taum !: module of sea surface stress (at T-point) [N/m2]
!! wndm is used compute surface gases exchanges in ice-free ocean or leads
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wndm !: wind speed module at T-point (=|U10m-Uoce|) [m/s]
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: rhoa !: air density at "rn_zu" m above the sea [kg/m3]
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: qsr !: sea heat flux: solar [W/m2]
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: qns , qns_b !: sea heat flux: non solar [W/m2]
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: qsr_tot !: total solar heat flux (over sea and ice) [W/m2]
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: qns_tot !: total non solar heat flux (over sea and ice) [W/m2]
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: emp , emp_b !: freshwater budget: volume flux [Kg/m2/s]
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sfx , sfx_b !: salt flux [PSS.kg/m2/s]
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: emp_tot !: total E-P over ocean and ice [Kg/m2/s]
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fmmflx !: freshwater budget: freezing/melting [Kg/m2/s]
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: rnf , rnf_b !: river runoff [Kg/m2/s]
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fwficb , fwficb_b !: iceberg melting [Kg/m2/s]
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wndm !: wind speed module at T-point (=|U10m-Uoce|) [m/s]
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: rhoa !: air density at "rn_zu" m above the sea [kg/m3]
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: qsr !: sea heat flux: solar [W/m2]
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: qns , qns_b !: sea heat flux: non solar [W/m2]
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: qsr_tot !: total solar heat flux (over sea and ice) [W/m2]
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: qns_tot !: total non solar heat flux (over sea and ice) [W/m2]
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: emp , emp_b !: freshwater budget: volume flux [Kg/m2/s]
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sfx , sfx_b !: salt flux [PSS.kg/m2/s]
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: emp_tot !: total E-P over ocean and ice [Kg/m2/s]
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fwfice !: ice-ocean freshwater budget (>0 to the ocean) [Kg/m2/s]
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: rnf , rnf_b !: river runoff [Kg/m2/s]
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fwficb !: iceberg melting [Kg/m2/s]
!!
REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: sbc_tsc, sbc_tsc_b !: sbc content trend [K.m/s] jpi,jpj,jpts
REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: qsr_hc , qsr_hc_b !: heat content trend due to qsr flux [K.m/s] jpi,jpj,jpk
!!
!!
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: tprecip !: total precipitation [Kg/m2/s]
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sprecip !: solid precipitation [Kg/m2/s]
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fr_i !: ice fraction = 1 - lead fraction (between 0 to 1)
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: atm_co2 !: atmospheric pCO2 [ppm]
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: xcplmask !: coupling mask for ln_mixcpl (warning: allocated in sbccpl)
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: cloud_fra !: cloud cover (fraction of cloud in a gridcell) [-]
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: tprecip !: total precipitation [Kg/m2/s]
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sprecip !: solid precipitation [Kg/m2/s]
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fr_i !: ice fraction = 1 - lead fraction (between 0 to 1)
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: atm_co2 !: atmospheric pCO2 [ppm]
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: xcplmask !: coupling mask for ln_mixcpl (warning: allocated in sbccpl)
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: cloud_fra !: cloud cover (fraction of cloud in a gridcell) [-]
!!---------------------------------------------------------------------
!! ABL Vertical Domain size
@@ -173,30 +175,40 @@ CONTAINS
!!---------------------------------------------------------------------
!! *** FUNCTION sbc_oce_alloc ***
!!---------------------------------------------------------------------
- INTEGER :: ierr(6)
+ INTEGER :: ierr(8)
!!---------------------------------------------------------------------
ierr(:) = 0
!
- ALLOCATE( utau(jpi,jpj) , utau_b(jpi,jpj) , taum(jpi,jpj) , &
- & vtau(jpi,jpj) , vtau_b(jpi,jpj) , wndm(jpi,jpj) , rhoa(jpi,jpj) , STAT=ierr(1) )
+ ! ----------------- !
+ ! == FULL ARRAYS == !
+ ! ----------------- !
+ ALLOCATE( utau(jpi,jpj) , utau_b(jpi,jpj) , utauU(jpi,jpj) , &
+ & vtau(jpi,jpj) , vtau_b(jpi,jpj) , vtauV(jpi,jpj) , STAT=ierr(1) )
!
- ALLOCATE( qns_tot(jpi,jpj) , qns (jpi,jpj) , qns_b(jpi,jpj), &
- & qsr_tot(jpi,jpj) , qsr (jpi,jpj) , &
- & emp (jpi,jpj) , emp_b(jpi,jpj) , &
- & sfx (jpi,jpj) , sfx_b(jpi,jpj) , emp_tot(jpi,jpj), fmmflx(jpi,jpj), STAT=ierr(2) )
+ ALLOCATE( emp(jpi,jpj) , emp_b(jpi,jpj) , &
+ & STAT=ierr(2) )
!
- ALLOCATE( rnf (jpi,jpj) , sbc_tsc (jpi,jpj,jpts) , qsr_hc (jpi,jpj,jpk) , &
- & rnf_b(jpi,jpj) , sbc_tsc_b(jpi,jpj,jpts) , qsr_hc_b(jpi,jpj,jpk) , &
- & fwficb (jpi,jpj), fwficb_b(jpi,jpj), STAT=ierr(3) )
+ ALLOCATE( rnf(jpi,jpj), rnf_b(jpi,jpj), STAT=ierr(3) )
!
- ALLOCATE( tprecip(jpi,jpj) , sprecip(jpi,jpj) , fr_i(jpi,jpj) , &
- & atm_co2(jpi,jpj) , tsk_m(jpi,jpj) , cloud_fra(jpi,jpj), &
+ ALLOCATE( fr_i(jpi,jpj) , &
& ssu_m (jpi,jpj) , sst_m(jpi,jpj) , frq_m(jpi,jpj) , &
- & ssv_m (jpi,jpj) , sss_m(jpi,jpj) , ssh_m(jpi,jpj) , STAT=ierr(4) )
+ & ssv_m (jpi,jpj) , sss_m(jpi,jpj) , ssh_m(jpi,jpj) , e3t_m(jpi,jpj) , STAT=ierr(4) )
!
- ALLOCATE( e3t_m(jpi,jpj) , STAT=ierr(5) )
+ ! -------------------- !
+ ! == REDUCED ARRAYS == !
+ ! -------------------- !
+ ALLOCATE( qns (A2D(0)) , qns_b (A2D(0)) , qsr (A2D(0)) , &
+ & qns_tot(A2D(0)) , qsr_tot(A2D(0)) , qsr_hc(A2D(0),jpk) , qsr_hc_b(A2D(0),jpk) , STAT=ierr(5) )
+ !
+ ALLOCATE( sbc_tsc(A2D(0),jpts) , sbc_tsc_b(A2D(0),jpts) , &
+ & sfx (A2D(0)) , sfx_b(A2D(0)) , emp_tot(A2D(0)), fwfice(A2D(0)), fwficb(A2D(0)), &
+ & wndm(A2D(0)) , taum (A2D(0)) , STAT=ierr(6) )
+ !
+ ALLOCATE( tprecip(A2D(0)) , sprecip(A2D(0)) , &
+ & atm_co2(A2D(0)) , tsk_m (A2D(0)) , cloud_fra(A2D(0)), STAT=ierr(7) )
+
+ ALLOCATE( rhoa(A2D(0)) , q_air_zt(A2D(0)) , theta_air_zt(A2D(0)) , STAT=ierr(8) )
!
- ALLOCATE( q_air_zt(jpi,jpj) , theta_air_zt(jpi,jpj) , STAT=ierr(6) ) !#LB
!
sbc_oce_alloc = MAXVAL( ierr )
CALL mpp_sum ( 'sbc_oce', sbc_oce_alloc )
@@ -205,9 +217,10 @@ CONTAINS
END FUNCTION sbc_oce_alloc
+ !!clem => this subroutine is never used in nemo
SUBROUTINE sbc_tau2wnd
!!---------------------------------------------------------------------
- !! *** ROUTINE sbc_tau2wnd ***
+ !! *** ROUTINE ***
!!
!! ** Purpose : Estimation of wind speed as a function of wind stress
!!
@@ -217,17 +230,14 @@ CONTAINS
USE lbclnk ! ocean lateral boundary conditions (or mpp link)
REAL(wp) :: zrhoa = 1.22 ! Air density kg/m3
REAL(wp) :: zcdrag = 1.5e-3 ! drag coefficient
- REAL(wp) :: ztx, zty, ztau, zcoef ! temporary variables
+ REAL(wp) :: ztau, zcoef ! temporary variables
INTEGER :: ji, jj ! dummy indices
!!---------------------------------------------------------------------
zcoef = 0.5 / ( zrhoa * zcdrag )
DO_2D( 0, 0, 0, 0 )
- ztx = utau(ji-1,jj ) + utau(ji,jj)
- zty = vtau(ji ,jj-1) + vtau(ji,jj)
- ztau = SQRT( ztx * ztx + zty * zty )
- wndm(ji,jj) = SQRT ( ztau * zcoef ) * tmask(ji,jj,1)
+ ztau = SQRT( utau(ji,jj)*utau(ji,jj) + vtau(ji,jj)*vtau(ji,jj) )
+ wndm(ji,jj) = SQRT ( ztau * zcoef ) * smask0(ji,jj)
END_2D
- CALL lbc_lnk( 'sbc_oce', wndm(:,:) , 'T', 1.0_wp )
!
END SUBROUTINE sbc_tau2wnd
diff --git a/src/OCE/SBC/sbc_phy.F90 b/src/OCE/SBC/sbc_phy.F90
index cabec70fcfda4a096d045c62979b86cb029f02a8..2a845e3a54f0850b3457f4ddee4e039fd1ac4d27 100644
--- a/src/OCE/SBC/sbc_phy.F90
+++ b/src/OCE/SBC/sbc_phy.F90
@@ -223,9 +223,9 @@ CONTAINS
FUNCTION virt_temp_vctr( pta, pqa )
- REAL(wp), DIMENSION(jpi,jpj) :: virt_temp_vctr !: virtual temperature [K]
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pta !: absolute or potential air temperature [K]
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pqa !: specific humidity of air [kg/kg]
+ REAL(wp), DIMENSION(A2D(0)) :: virt_temp_vctr !: virtual temperature [K]
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pta !: absolute or potential air temperature [K]
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pqa !: specific humidity of air [kg/kg]
virt_temp_vctr(:,:) = pta(:,:) * (1._wp + rctv0*pqa(:,:))
@@ -290,25 +290,25 @@ CONTAINS
!! ** Author: G. Samson, Feb 2021
!!-------------------------------------------------------------------------------
- REAL(wp), DIMENSION(jpi,jpj) :: pres_temp_vctr ! air pressure [Pa]
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pqspe ! air specific humidity [kg/kg]
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pslp ! sea-level pressure [Pa]
- REAL(wp), INTENT(in ) :: pz ! height above surface [m]
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) , OPTIONAL :: ptpot ! air potential temperature [K]
- REAL(wp), DIMENSION(jpi,jpj), INTENT(inout), OPTIONAL :: pta ! air absolute temperature [K]
- INTEGER :: ji, jj ! loop indices
- LOGICAL , INTENT(in) , OPTIONAL :: l_ice ! sea-ice presence
- LOGICAL :: lice ! sea-ice presence
+ REAL(wp), DIMENSION(A2D(0)) :: pres_temp_vctr ! air pressure [Pa]
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in ) :: pqspe ! air specific humidity [kg/kg]
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in ) :: pslp ! sea-level pressure [Pa]
+ REAL(wp), INTENT(in ) :: pz ! height above surface [m]
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in ) , OPTIONAL :: ptpot ! air potential temperature [K]
+ REAL(wp), DIMENSION(A2D(0)), INTENT(inout), OPTIONAL :: pta ! air absolute temperature [K]
+ INTEGER :: ji, jj ! loop indices
+ LOGICAL , INTENT(in) , OPTIONAL :: l_ice ! sea-ice presence
+ LOGICAL :: lice ! sea-ice presence
lice = .FALSE.
IF( PRESENT(l_ice) ) lice = l_ice
IF( PRESENT(ptpot) ) THEN
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
pres_temp_vctr(ji,jj) = pres_temp_sclr( pqspe(ji,jj), pslp(ji,jj), pz, ptpot=ptpot(ji,jj), pta=pta(ji,jj), l_ice=lice )
END_2D
ELSE
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
pres_temp_vctr(ji,jj) = pres_temp_sclr( pqspe(ji,jj), pslp(ji,jj), pz, pta=pta(ji,jj), l_ice=lice )
END_2D
ENDIF
@@ -344,12 +344,12 @@ CONTAINS
!! ** Author: G. Samson, Feb 2021
!!-------------------------------------------------------------------------------
- REAL(wp), DIMENSION(jpi,jpj) :: theta_exner_vctr ! air/surface potential temperature [K]
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pta ! air/surface absolute temperature [K]
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ppa ! air/surface pressure [Pa]
- INTEGER :: ji, jj ! loop indices
+ REAL(wp), DIMENSION(A2D(0)) :: theta_exner_vctr ! air/surface potential temperature [K]
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pta ! air/surface absolute temperature [K]
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: ppa ! air/surface pressure [Pa]
+ INTEGER :: ji, jj ! loop indices
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
theta_exner_vctr(ji,jj) = theta_exner_sclr( pta(ji,jj), ppa(ji,jj) )
END_2D
@@ -364,10 +364,10 @@ CONTAINS
!!
!! ** Author: L. Brodeau, June 2016 / AeroBulk (https://github.com/brodeau/aerobulk/)
!!-------------------------------------------------------------------------------
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ptak ! air temperature [K]
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pqa ! air specific humidity [kg/kg]
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ppa ! pressure in [Pa]
- REAL(wp), DIMENSION(jpi,jpj) :: rho_air_vctr ! density of moist air [kg/m^3]
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: ptak ! air temperature [K]
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pqa ! air specific humidity [kg/kg]
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: ppa ! pressure in [Pa]
+ REAL(wp), DIMENSION(A2D(0)) :: rho_air_vctr ! density of moist air [kg/m^3]
!!-------------------------------------------------------------------------------
rho_air_vctr = MAX( ppa / (R_dry*ptak * ( 1._wp + rctv0*pqa )) , 0.8_wp )
@@ -412,11 +412,11 @@ CONTAINS
FUNCTION visc_air_vctr(ptak)
- REAL(wp), DIMENSION(jpi,jpj) :: visc_air_vctr ! kinetic viscosity (m^2/s)
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ptak ! air temperature in (K)
+ REAL(wp), DIMENSION(A2D(0)) :: visc_air_vctr ! kinetic viscosity (m^2/s)
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: ptak ! air temperature in (K)
INTEGER :: ji, jj ! dummy loop indices
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
visc_air_vctr(ji,jj) = visc_air_sclr( ptak(ji,jj) )
END_2D
@@ -431,8 +431,8 @@ CONTAINS
!!
!! ** Author: L. Brodeau, june 2016 / AeroBulk (https://github.com/brodeau/aerobulk/)
!!----------------------------------------------------------------------------------
- REAL(wp), DIMENSION(jpi,jpj) :: L_vap_vctr ! latent heat of vaporization [J/kg]
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: psst ! water temperature [K]
+ REAL(wp), DIMENSION(A2D(0)) :: L_vap_vctr ! latent heat of vaporization [J/kg]
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: psst ! water temperature [K]
!!----------------------------------------------------------------------------------
!
L_vap_vctr = ( 2.501_wp - 0.00237_wp * ( psst(:,:) - rt0) ) * 1.e6_wp
@@ -464,8 +464,8 @@ CONTAINS
!!
!! ** Author: L. Brodeau, june 2016 / AeroBulk (https://github.com/brodeau/aerobulk/)
!!-------------------------------------------------------------------------------
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pqa ! air specific humidity [kg/kg]
- REAL(wp), DIMENSION(jpi,jpj) :: cp_air_vctr ! specific heat of moist air [J/K/kg]
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pqa ! air specific humidity [kg/kg]
+ REAL(wp), DIMENSION(A2D(0)) :: cp_air_vctr ! specific heat of moist air [J/K/kg]
!!-------------------------------------------------------------------------------
cp_air_vctr = rCp_dry + rCp_vap * pqa
@@ -516,12 +516,12 @@ CONTAINS
FUNCTION gamma_moist_vctr( ptak, pqa )
- REAL(wp), DIMENSION(jpi,jpj) :: gamma_moist_vctr
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ptak
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pqa
+ REAL(wp), DIMENSION(A2D(0)) :: gamma_moist_vctr
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: ptak
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pqa
INTEGER :: ji, jj
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
gamma_moist_vctr(ji,jj) = gamma_moist_sclr( ptak(ji,jj), pqa(ji,jj) )
END_2D
@@ -537,17 +537,17 @@ CONTAINS
!! Author: L. Brodeau, June 2019 / AeroBulk
!! (https://github.com/brodeau/aerobulk/)
!!------------------------------------------------------------------------
- REAL(wp), DIMENSION(jpi,jpj) :: One_on_L !: 1./(Obukhov length) [m^-1]
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ptha !: reference potential temperature of air [K]
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pqa !: reference specific humidity of air [kg/kg]
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pus !: u*: friction velocity [m/s]
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pts, pqs !: \theta* and q* friction aka turb. scales for temp. and spec. hum.
+ REAL(wp), DIMENSION(A2D(0)) :: One_on_L !: 1./(Obukhov length) [m^-1]
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: ptha !: reference potential temperature of air [K]
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pqa !: reference specific humidity of air [kg/kg]
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pus !: u*: friction velocity [m/s]
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pts, pqs !: \theta* and q* friction aka turb. scales for temp. and spec. hum.
!
INTEGER :: ji, jj ! dummy loop indices
REAL(wp) :: zqa ! local scalar
!!-------------------------------------------------------------------
!
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
zqa = (1._wp + rctv0*pqa(ji,jj))
!
! The main concern is to know whether, the vertical turbulent flux of virtual temperature, < u' theta_v' > is estimated with:
@@ -598,27 +598,27 @@ CONTAINS
FUNCTION Ri_bulk_vctr( pz, psst, ptha, pssq, pqa, pub, pta_layer, pqa_layer )
- REAL(wp), DIMENSION(jpi,jpj) :: Ri_bulk_vctr
- REAL(wp) , INTENT(in) :: pz ! height above the sea (aka "delta z") [m]
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: psst ! SST [K]
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ptha ! pot. air temp. at height "pz" [K]
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pssq ! 0.98*q_sat(SST) [kg/kg]
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pqa ! air spec. hum. at height "pz" [kg/kg]
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pub ! bulk wind speed [m/s]
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in), OPTIONAL :: pta_layer ! when possible, a better guess of absolute temperature WITHIN the layer [K]
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in), OPTIONAL :: pqa_layer ! when possible, a better guess of specific humidity WITHIN the layer [kg/kg]
+ REAL(wp), DIMENSION(A2D(0)) :: Ri_bulk_vctr
+ REAL(wp) , INTENT(in) :: pz ! height above the sea (aka "delta z") [m]
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: psst ! SST [K]
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: ptha ! pot. air temp. at height "pz" [K]
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pssq ! 0.98*q_sat(SST) [kg/kg]
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pqa ! air spec. hum. at height "pz" [kg/kg]
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pub ! bulk wind speed [m/s]
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in), OPTIONAL :: pta_layer ! when possible, a better guess of absolute temperature WITHIN the layer [K]
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in), OPTIONAL :: pqa_layer ! when possible, a better guess of specific humidity WITHIN the layer [kg/kg]
!!
LOGICAL :: l_ptqa_l_prvd = .FALSE.
INTEGER :: ji, jj
IF( PRESENT(pta_layer) .AND. PRESENT(pqa_layer) ) l_ptqa_l_prvd = .TRUE.
IF( l_ptqa_l_prvd ) THEN
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
Ri_bulk_vctr(ji,jj) = Ri_bulk_sclr( pz, psst(ji,jj), ptha(ji,jj), pssq(ji,jj), pqa(ji,jj), pub(ji,jj), &
& pta_layer=pta_layer(ji,jj ), pqa_layer=pqa_layer(ji,jj ) )
END_2D
ELSE
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
Ri_bulk_vctr(ji,jj) = Ri_bulk_sclr( pz, psst(ji,jj), ptha(ji,jj), pssq(ji,jj), pqa(ji,jj), pub(ji,jj) )
END_2D
END IF
@@ -652,10 +652,10 @@ CONTAINS
END FUNCTION e_sat_sclr
FUNCTION e_sat_vctr(ptak)
- REAL(wp), DIMENSION(jpi,jpj) :: e_sat_vctr !: vapour pressure at saturation [Pa]
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ptak !: temperature (K)
+ REAL(wp), DIMENSION(A2D(0)) :: e_sat_vctr !: vapour pressure at saturation [Pa]
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: ptak !: temperature (K)
INTEGER :: ji, jj ! dummy loop indices
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
e_sat_vctr(ji,jj) = e_sat_sclr(ptak(ji,jj))
END_2D
END FUNCTION e_sat_vctr
@@ -681,11 +681,11 @@ CONTAINS
FUNCTION e_sat_ice_vctr(ptak)
!! Same as "e_sat" but over ice rather than water!
- REAL(wp), DIMENSION(jpi,jpj) :: e_sat_ice_vctr !: vapour pressure at saturation in presence of ice [Pa]
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ptak
+ REAL(wp), DIMENSION(A2D(0)) :: e_sat_ice_vctr !: vapour pressure at saturation in presence of ice [Pa]
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: ptak
INTEGER :: ji, jj
!!----------------------------------------------------------------------------------
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
e_sat_ice_vctr(ji,jj) = e_sat_ice_sclr( ptak(ji,jj) )
END_2D
@@ -712,11 +712,11 @@ CONTAINS
FUNCTION de_sat_dt_ice_vctr(ptak)
!! Same as "e_sat" but over ice rather than water!
- REAL(wp), DIMENSION(jpi,jpj) :: de_sat_dt_ice_vctr !: vapour pressure at saturation in presence of ice [Pa]
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ptak
+ REAL(wp), DIMENSION(A2D(0)) :: de_sat_dt_ice_vctr !: vapour pressure at saturation in presence of ice [Pa]
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: ptak
INTEGER :: ji, jj
!!----------------------------------------------------------------------------------
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
de_sat_dt_ice_vctr(ji,jj) = de_sat_dt_ice_sclr( ptak(ji,jj) )
END_2D
@@ -751,16 +751,16 @@ CONTAINS
FUNCTION q_sat_vctr( pta, ppa, l_ice )
- REAL(wp), DIMENSION(jpi,jpj) :: q_sat_vctr
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pta !: absolute temperature of air [K]
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ppa !: atmospheric pressure [Pa]
+ REAL(wp), DIMENSION(A2D(0)) :: q_sat_vctr
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pta !: absolute temperature of air [K]
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: ppa !: atmospheric pressure [Pa]
LOGICAL, INTENT(in), OPTIONAL :: l_ice !: we are above ice
LOGICAL :: lice
INTEGER :: ji, jj
!!----------------------------------------------------------------------------------
lice = .FALSE.
IF( PRESENT(l_ice) ) lice = l_ice
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
q_sat_vctr(ji,jj) = q_sat_sclr( pta(ji,jj) , ppa(ji,jj), l_ice=lice )
END_2D
@@ -790,12 +790,12 @@ CONTAINS
FUNCTION dq_sat_dt_ice_vctr( pta, ppa )
- REAL(wp), DIMENSION(jpi,jpj) :: dq_sat_dt_ice_vctr
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pta !: absolute temperature of air [K]
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ppa !: atmospheric pressure [Pa]
+ REAL(wp), DIMENSION(A2D(0)) :: dq_sat_dt_ice_vctr
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pta !: absolute temperature of air [K]
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: ppa !: atmospheric pressure [Pa]
INTEGER :: ji, jj
!!----------------------------------------------------------------------------------
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
dq_sat_dt_ice_vctr(ji,jj) = dq_sat_dt_ice_sclr( pta(ji,jj) , ppa(ji,jj) )
END_2D
@@ -808,16 +808,16 @@ CONTAINS
!!
!! ** Author: L. Brodeau, june 2016 / AeroBulk (https://github.com/brodeau/aerobulk/)
!!----------------------------------------------------------------------------------
- REAL(wp), DIMENSION(jpi,jpj) :: q_air_rh
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: prha !: relative humidity [fraction, not %!!!]
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ptak !: air temperature [K]
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ppa !: atmospheric pressure [Pa]
+ REAL(wp), DIMENSION(A2D(0)) :: q_air_rh
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: prha !: relative humidity [fraction, not %!!!]
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: ptak !: air temperature [K]
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: ppa !: atmospheric pressure [Pa]
!
INTEGER :: ji, jj ! dummy loop indices
REAL(wp) :: ze ! local scalar
!!----------------------------------------------------------------------------------
!
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
ze = prha(ji,jj)*e_sat_sclr(ptak(ji,jj))
q_air_rh(ji,jj) = ze*reps0/(ppa(ji,jj) - (1. - reps0)*ze)
END_2D
@@ -833,29 +833,29 @@ CONTAINS
!! and the module of the wind stress => pTau = Tau
!! ** Author: L. Brodeau, Sept. 2019 / AeroBulk (https://github.com/brodeau/aerobulk/)
!!----------------------------------------------------------------------------------
- REAL(wp), INTENT(in) :: pzu ! height above the sea-level where all this takes place (normally 10m)
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pTs ! water temperature at the air-sea interface [K]
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pqs ! satur. spec. hum. at T=pTs [kg/kg]
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pTa ! potential air temperature at z=pzu [K]
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pqa ! specific humidity at z=pzu [kg/kg]
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pust ! u*
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ptst ! t*
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pqst ! q*
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pwnd ! wind speed module at z=pzu [m/s]
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pUb ! bulk wind speed at z=pzu (inc. pot. effect of gustiness etc) [m/s]
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ppa ! sea-level atmospheric pressure [Pa]
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: prlw ! downwelling longwave radiative flux [W/m^2]
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: prhoa ! air density [kg/m3]
+ REAL(wp), INTENT(in) :: pzu ! height above the sea-level where all this takes place (normally 10m)
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pTs ! water temperature at the air-sea interface [K]
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pqs ! satur. spec. hum. at T=pTs [kg/kg]
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pTa ! potential air temperature at z=pzu [K]
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pqa ! specific humidity at z=pzu [kg/kg]
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pust ! u*
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: ptst ! t*
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pqst ! q*
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pwnd ! wind speed module at z=pzu [m/s]
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pUb ! bulk wind speed at z=pzu (inc. pot. effect of gustiness etc) [m/s]
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: ppa ! sea-level atmospheric pressure [Pa]
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: prlw ! downwelling longwave radiative flux [W/m^2]
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: prhoa ! air density [kg/m3]
!
- REAL(wp), DIMENSION(jpi,jpj), INTENT(out) :: pQns ! non-solar heat flux to the ocean aka "Qlat + Qsen + Qlw" [W/m^2]]
- REAL(wp), DIMENSION(jpi,jpj), INTENT(out) :: pTau ! module of the wind stress [N/m^2]
+ REAL(wp), DIMENSION(A2D(0)), INTENT(out) :: pQns ! non-solar heat flux to the ocean aka "Qlat + Qsen + Qlw" [W/m^2]]
+ REAL(wp), DIMENSION(A2D(0)), INTENT(out) :: pTau ! module of the wind stress [N/m^2]
!
- REAL(wp), DIMENSION(jpi,jpj), OPTIONAL, INTENT(out) :: Qlat
+ REAL(wp), DIMENSION(A2D(0)), OPTIONAL, INTENT(out) :: Qlat
!
REAL(wp) :: zdt, zdq, zCd, zCh, zCe, zz0, zQlat, zQsen, zQlw
INTEGER :: ji, jj ! dummy loop indices
!!----------------------------------------------------------------------------------
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
zdt = pTa(ji,jj) - pTs(ji,jj) ; zdt = SIGN( MAX(ABS(zdt),1.E-6_wp), zdt )
zdq = pqa(ji,jj) - pqs(ji,jj) ; zdq = SIGN( MAX(ABS(zdq),1.E-9_wp), zdq )
@@ -929,25 +929,25 @@ CONTAINS
& pTau, pQsen, pQlat, &
& pEvap, pfact_evap )
!!----------------------------------------------------------------------------------
- REAL(wp), INTENT(in) :: pzu ! height above the sea-level where all this takes place (normally 10m)
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pTs ! water temperature at the air-sea interface [K]
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pqs ! satur. spec. hum. at T=pTs [kg/kg]
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pTa ! potential air temperature at z=pzu [K]
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pqa ! specific humidity at z=pzu [kg/kg]
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pCd
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pCh
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pCe
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pwnd ! wind speed module at z=pzu [m/s]
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pUb ! bulk wind speed at z=pzu (inc. pot. effect of gustiness etc) [m/s]
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ppa ! sea-level atmospheric pressure [Pa]
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: prhoa ! Air density at z=pzu [kg/m^3]
+ REAL(wp), INTENT(in) :: pzu ! height above the sea-level where all this takes place (normally 10m)
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pTs ! water temperature at the air-sea interface [K]
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pqs ! satur. spec. hum. at T=pTs [kg/kg]
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pTa ! potential air temperature at z=pzu [K]
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pqa ! specific humidity at z=pzu [kg/kg]
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pCd
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pCh
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pCe
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pwnd ! wind speed module at z=pzu [m/s]
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pUb ! bulk wind speed at z=pzu (inc. pot. effect of gustiness etc) [m/s]
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: ppa ! sea-level atmospheric pressure [Pa]
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: prhoa ! Air density at z=pzu [kg/m^3]
!!
- REAL(wp), DIMENSION(jpi,jpj), INTENT(out) :: pTau ! module of the wind stress [N/m^2]
- REAL(wp), DIMENSION(jpi,jpj), INTENT(out) :: pQsen ! [W/m^2]
- REAL(wp), DIMENSION(jpi,jpj), INTENT(out) :: pQlat ! [W/m^2]
+ REAL(wp), DIMENSION(A2D(0)), INTENT(out) :: pTau ! module of the wind stress [N/m^2]
+ REAL(wp), DIMENSION(A2D(0)), INTENT(out) :: pQsen ! [W/m^2]
+ REAL(wp), DIMENSION(A2D(0)), INTENT(out) :: pQlat ! [W/m^2]
!!
- REAL(wp), DIMENSION(jpi,jpj), INTENT(out), OPTIONAL :: pEvap ! Evaporation [kg/m^2/s]
- REAL(wp), INTENT(in) , OPTIONAL :: pfact_evap ! ABOMINATION: corrective factor for evaporation (doing this against my will! /laurent)
+ REAL(wp), DIMENSION(A2D(0)), INTENT(out), OPTIONAL :: pEvap ! Evaporation [kg/m^2/s]
+ REAL(wp), INTENT(in) , OPTIONAL :: pfact_evap ! ABOMINATION: corrective factor for evaporation (doing this against my will! /laurent)
!!
REAL(wp) :: ztaa, zgamma, zrho, zUrho, zevap, zfact_evap
INTEGER :: ji, jj
@@ -955,7 +955,7 @@ CONTAINS
zfact_evap = 1._wp
IF( PRESENT(pfact_evap) ) zfact_evap = pfact_evap
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
CALL BULK_FORMULA_SCLR( pzu, pTs(ji,jj), pqs(ji,jj), pTa(ji,jj), pqa(ji,jj), &
& pCd(ji,jj), pCh(ji,jj), pCe(ji,jj), &
@@ -977,8 +977,8 @@ CONTAINS
!!
!! ** Author: L. Brodeau, june 2016 / AeroBulk (https://github.com/brodeau/aerobulk/)
!!----------------------------------------------------------------------------------
- REAL(wp), DIMENSION(jpi,jpj) :: alpha_sw_vctr ! thermal expansion coefficient of sea-water [1/K]
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: psst ! water temperature [K]
+ REAL(wp), DIMENSION(A2D(0)) :: alpha_sw_vctr ! thermal expansion coefficient of sea-water [1/K]
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: psst ! water temperature [K]
!!----------------------------------------------------------------------------------
alpha_sw_vctr = 2.1e-5_wp * MAX(psst(:,:)-rt0 + 3.2_wp, 0._wp)**0.79
@@ -1027,16 +1027,16 @@ CONTAINS
FUNCTION qlw_net_vctr( pdwlw, pts, l_ice )
- REAL(wp), DIMENSION(jpi,jpj) :: qlw_net_vctr
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pdwlw !: downwelling longwave (aka infrared, aka thermal) radiation [W/m^2]
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pts !: surface temperature [K]
+ REAL(wp), DIMENSION(A2D(0)) :: qlw_net_vctr
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pdwlw !: downwelling longwave (aka infrared, aka thermal) radiation [W/m^2]
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pts !: surface temperature [K]
LOGICAL, INTENT(in), OPTIONAL :: l_ice !: we are above ice
LOGICAL :: lice
INTEGER :: ji, jj
!!----------------------------------------------------------------------------------
lice = .FALSE.
IF( PRESENT(l_ice) ) lice = l_ice
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
qlw_net_vctr(ji,jj) = qlw_net_sclr( pdwlw(ji,jj) , pts(ji,jj), l_ice=lice )
END_2D
@@ -1045,10 +1045,10 @@ CONTAINS
FUNCTION z0_from_Cd( pzu, pCd, ppsi )
- REAL(wp), DIMENSION(jpi,jpj) :: z0_from_Cd !: roughness length [m]
- REAL(wp) , INTENT(in) :: pzu !: reference height zu [m]
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pCd !: (neutral or non-neutral) drag coefficient []
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in), OPTIONAL :: ppsi !: "Psi_m(pzu/L)" stability correction profile for momentum []
+ REAL(wp), DIMENSION(A2D(0)) :: z0_from_Cd !: roughness length [m]
+ REAL(wp) , INTENT(in) :: pzu !: reference height zu [m]
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pCd !: (neutral or non-neutral) drag coefficient []
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in), OPTIONAL :: ppsi !: "Psi_m(pzu/L)" stability correction profile for momentum []
!!
!! If pCd is the NEUTRAL-STABILITY drag coefficient then ppsi must be 0 or not given
!! If pCd is the drag coefficient (in stable or unstable conditions) then pssi must be provided
@@ -1066,10 +1066,10 @@ CONTAINS
FUNCTION Cd_from_z0( pzu, pz0, ppsi )
- REAL(wp), DIMENSION(jpi,jpj) :: Cd_from_z0 !: (neutral or non-neutral) drag coefficient []
- REAL(wp) , INTENT(in) :: pzu !: reference height zu [m]
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pz0 !: roughness length [m]
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in), OPTIONAL :: ppsi !: "Psi_m(pzu/L)" stability correction profile for momentum []
+ REAL(wp), DIMENSION(A2D(0)) :: Cd_from_z0 !: (neutral or non-neutral) drag coefficient []
+ REAL(wp) , INTENT(in) :: pzu !: reference height zu [m]
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pz0 !: roughness length [m]
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in), OPTIONAL :: ppsi !: "Psi_m(pzu/L)" stability correction profile for momentum []
!!
!! If we want to return the NEUTRAL-STABILITY drag coefficient then ppsi must be 0 or not given
!! If we want to return the stability-corrected Cd (i.e. in stable or unstable conditions) then pssi must be provided
@@ -1111,14 +1111,14 @@ CONTAINS
FUNCTION f_m_louis_vctr( pzu, pRib, pCdn, pz0 )
- REAL(wp), DIMENSION(jpi,jpj) :: f_m_louis_vctr
- REAL(wp), INTENT(in) :: pzu
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pRib
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pCdn
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pz0
+ REAL(wp), DIMENSION(A2D(0)) :: f_m_louis_vctr
+ REAL(wp), INTENT(in) :: pzu
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pRib
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pCdn
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pz0
INTEGER :: ji, jj
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
f_m_louis_vctr(ji,jj) = f_m_louis_sclr( pzu, pRib(ji,jj), pCdn(ji,jj), pz0(ji,jj) )
END_2D
@@ -1150,14 +1150,14 @@ CONTAINS
FUNCTION f_h_louis_vctr( pzu, pRib, pChn, pz0 )
- REAL(wp), DIMENSION(jpi,jpj) :: f_h_louis_vctr
- REAL(wp), INTENT(in) :: pzu
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pRib
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pChn
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pz0
+ REAL(wp), DIMENSION(A2D(0)) :: f_h_louis_vctr
+ REAL(wp), INTENT(in) :: pzu
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pRib
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pChn
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pz0
INTEGER :: ji, jj
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
f_h_louis_vctr(ji,jj) = f_h_louis_sclr( pzu, pRib(ji,jj), pChn(ji,jj), pz0(ji,jj) )
END_2D
@@ -1168,11 +1168,11 @@ CONTAINS
!!----------------------------------------------------------------------------------
!! Provides the neutral-stability wind speed at 10 m
!!----------------------------------------------------------------------------------
- REAL(wp), DIMENSION(jpi,jpj) :: UN10_from_ustar !: neutral stability wind speed at 10m [m/s]
- REAL(wp), INTENT(in) :: pzu !: measurement heigh of wind speed [m]
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pUzu !: bulk wind speed at height pzu m [m/s]
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pus !: friction velocity [m/s]
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ppsi !: "Psi_m(pzu/L)" stability correction profile for momentum []
+ REAL(wp), DIMENSION(A2D(0)) :: UN10_from_ustar !: neutral stability wind speed at 10m [m/s]
+ REAL(wp), INTENT(in) :: pzu !: measurement heigh of wind speed [m]
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pUzu !: bulk wind speed at height pzu m [m/s]
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pus !: friction velocity [m/s]
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: ppsi !: "Psi_m(pzu/L)" stability correction profile for momentum []
!!----------------------------------------------------------------------------------
UN10_from_ustar(:,:) = pUzu(:,:) - pus(:,:)/vkarmn * ( LOG(pzu/10._wp) - ppsi(:,:) )
!!
@@ -1183,11 +1183,11 @@ CONTAINS
!!----------------------------------------------------------------------------------
!! Provides the neutral-stability wind speed at 10 m
!!----------------------------------------------------------------------------------
- REAL(wp), DIMENSION(jpi,jpj) :: UN10_from_CD !: [m/s]
- REAL(wp), INTENT(in) :: pzu !: measurement heigh of bulk wind speed
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pUb !: bulk wind speed at height pzu m [m/s]
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pCd !: drag coefficient
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ppsi !: "Psi_m(pzu/L)" stability correction profile for momentum []
+ REAL(wp), DIMENSION(A2D(0)) :: UN10_from_CD !: [m/s]
+ REAL(wp), INTENT(in) :: pzu !: measurement heigh of bulk wind speed
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pUb !: bulk wind speed at height pzu m [m/s]
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pCd !: drag coefficient
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: ppsi !: "Psi_m(pzu/L)" stability correction profile for momentum []
!!----------------------------------------------------------------------------------
!! Reminder: UN10 = u*/vkarmn * log(10/z0)
!! and: u* = sqrt(Cd) * Ub
@@ -1214,10 +1214,10 @@ CONTAINS
!!
!! ** Author: L. Brodeau, April 2020 / AeroBulk (https://github.com/brodeau/aerobulk/)
!!----------------------------------------------------------------------------------
- REAL(wp), DIMENSION(jpi,jpj) :: z0tq_LKB
- INTEGER, INTENT(in) :: iflag !: 1 => dealing with temperature; 2 => dealing with humidity
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pRer !: roughness Reynolds number [z_0 u*]/Nu_{air}
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pz0 !: roughness length (for momentum) [m]
+ REAL(wp), DIMENSION(A2D(0)) :: z0tq_LKB
+ INTEGER, INTENT(in) :: iflag !: 1 => dealing with temperature; 2 => dealing with humidity
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pRer !: roughness Reynolds number [z_0 u*]/Nu_{air}
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pz0 !: roughness length (for momentum) [m]
!-------------------------------------------------------------------
! Scalar Re_r relation from Liu et al.
REAL(wp), DIMENSION(8,2), PARAMETER :: &
@@ -1250,7 +1250,7 @@ CONTAINS
z0tq_LKB(:,:) = -999._wp
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
zrr = pRer(ji,jj)
lfound = .FALSE.
diff --git a/src/OCE/SBC/sbcblk.F90 b/src/OCE/SBC/sbcblk.F90
index aa3668c3300bb8d3a46998a76f2f56014332d540..c6da0220294d2044f221029ceedd134fdbbe8061 100644
--- a/src/OCE/SBC/sbcblk.F90
+++ b/src/OCE/SBC/sbcblk.F90
@@ -124,7 +124,7 @@ MODULE sbcblk
!
INTEGER :: nn_iter_algo ! Number of iterations in bulk param. algo ("stable ABL + weak wind" requires more)
- REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: theta_zu, q_zu ! air temp. and spec. hum. at wind speed height (L15 bulk scheme)
+ REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: theta_zu, q_zu ! air temp. and spec. hum. at wind speed height (L15 bulk scheme)
#if defined key_si3
REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: Cd_ice , Ch_ice , Ce_ice !#LB transfert coefficients over ice
@@ -180,7 +180,7 @@ CONTAINS
!!-------------------------------------------------------------------
!! *** ROUTINE sbc_blk_alloc ***
!!-------------------------------------------------------------------
- ALLOCATE( theta_zu(jpi,jpj), q_zu(jpi,jpj), STAT=sbc_blk_alloc )
+ ALLOCATE( theta_zu(A2D(0)), q_zu(A2D(0)), STAT=sbc_blk_alloc )
CALL mpp_sum ( 'sbcblk', sbc_blk_alloc )
IF( sbc_blk_alloc /= 0 ) CALL ctl_stop( 'STOP', 'sbc_blk_alloc: failed to allocate arrays' )
END FUNCTION sbc_blk_alloc
@@ -190,8 +190,7 @@ CONTAINS
!!-------------------------------------------------------------------
!! *** ROUTINE sbc_blk_ice_alloc ***
!!-------------------------------------------------------------------
- ALLOCATE( Cd_ice (jpi,jpj), Ch_ice (jpi,jpj), Ce_ice (jpi,jpj), &
- & theta_zu_i(jpi,jpj), q_zu_i(jpi,jpj), STAT=sbc_blk_ice_alloc )
+ ALLOCATE( Cd_ice(A2D(0)), Ch_ice(A2D(0)), Ce_ice(A2D(0)), theta_zu_i(A2D(0)), q_zu_i(A2D(0)), STAT=sbc_blk_ice_alloc )
CALL mpp_sum ( 'sbcblk', sbc_blk_ice_alloc )
IF( sbc_blk_ice_alloc /= 0 ) CALL ctl_stop( 'STOP', 'sbc_blk_ice_alloc: failed to allocate arrays' )
END FUNCTION sbc_blk_ice_alloc
@@ -362,7 +361,7 @@ CONTAINS
ipka = 1
ENDIF
!
- ALLOCATE( sf(jfpr)%fnow(jpi,jpj,ipka) )
+ ALLOCATE( sf(jfpr)%fnow(A2D(0),ipka) )
!
IF( TRIM(sf(jfpr)%clrootname) == 'NOT USED' ) THEN !-- not used field --! (only now allocated and set to default)
IF( jfpr == jp_slp ) THEN
@@ -384,7 +383,7 @@ CONTAINS
CALL ctl_stop( ctmp1 )
ENDIF
ELSE !-- used field --!
- IF( sf(jfpr)%ln_tint ) ALLOCATE( sf(jfpr)%fdta(jpi,jpj,ipka,2) ) ! allocate array for temporal interpolation
+ IF( sf(jfpr)%ln_tint ) ALLOCATE( sf(jfpr)%fdta(A2D(0),ipka,2) ) ! allocate array for temporal interpolation
!
IF( sf(jfpr)%freqh > 0. .AND. MOD( NINT(3600. * sf(jfpr)%freqh), nn_fsbc * NINT(rn_Dt) ) /= 0 ) &
& CALL ctl_warn( 'sbc_blk_init: sbcmod timestep rn_Dt*nn_fsbc is NOT a submultiple of atmospheric forcing frequency.', &
@@ -493,7 +492,7 @@ CONTAINS
!! the stress is assumed to be in the (i,j) mesh referential
!!
!! ** Action : defined at each time-step at the air-sea interface
- !! - utau, vtau i- and j-component of the wind stress
+ !! - utau, vtau i- and j-component of the wind stress at T-point
!! - taum wind stress module at T-point
!! - wndm wind speed module at T-point over free ocean or leads in presence of sea-ice
!! - qns, qsr non-solar and solar heat fluxes
@@ -505,9 +504,10 @@ CONTAINS
!!----------------------------------------------------------------------
INTEGER, INTENT(in) :: kt ! ocean time step
!!----------------------------------------------------------------------
- REAL(wp), DIMENSION(jpi,jpj) :: zssq, zcd_du, zsen, zlat, zevp, zpre, ztheta
+ REAL(wp), DIMENSION(A2D(0)) :: zssq, zcd_du, zsen, zlat, zevp, zpre, ztheta
REAL(wp) :: ztst
LOGICAL :: llerr
+ INTEGER :: ji, jj
!!----------------------------------------------------------------------
!
CALL fld_read( kt, nn_fsbc, sf ) ! input fields provided at the current time-step
@@ -515,7 +515,8 @@ CONTAINS
! Sanity/consistence test on humidity at first time step to detect potential screw-up:
IF( kt == nit000 ) THEN
! mean humidity over ocean on proc
- ztst = glob_sum( 'sbcblk', sf(jp_humi)%fnow(:,:,1) * e1e2t(:,:) * tmask(:,:,1) ) / glob_sum( 'sbcblk', e1e2t(:,:) * tmask(:,:,1) )
+ ztst = glob_sum( 'sbcblk', sf(jp_humi)%fnow(:,:,1) * e1e2t(A2D(0)) * smask0(:,:) ) &
+ & / glob_sum( 'sbcblk', e1e2t(A2D(0)) * smask0(:,:) )
llerr = .FALSE.
SELECT CASE( nhumi )
CASE( np_humi_sph ) ! specific humidity => expect: 0. <= something < 0.065 [kg/kg] (0.061 is saturation at 45degC !!!)
@@ -558,6 +559,7 @@ CONTAINS
! Potential temperature of air at z=rn_zqt (most reanalysis products provide absolute temp., not potential temp.)
IF( ln_tair_pot ) THEN
! temperature read into file is already potential temperature, do nothing...
+ IF((kt==nit000).AND.lwp) WRITE(numout,*) ' *** sbc_blk() => air temperature already converted to POTENTIAL!'
theta_air_zt(:,:) = sf(jp_tair )%fnow(:,:,1)
ELSE
! temperature read into file is ABSOLUTE temperature (that's the case for ECMWF products for example...)
@@ -568,7 +570,7 @@ CONTAINS
!
CALL blk_oce_1( kt, sf(jp_wndi )%fnow(:,:,1), sf(jp_wndj )%fnow(:,:,1), & ! <<= in
& theta_air_zt(:,:), q_air_zt(:,:), & ! <<= in
- & sf(jp_slp )%fnow(:,:,1), sst_m, ssu_m, ssv_m, & ! <<= in
+ & sf(jp_slp )%fnow(:,:,1), sst_m(A2D(0)), ssu_m(A2D(0)), ssv_m(A2D(0)), & ! <<= in
& sf(jp_uoatm)%fnow(:,:,1), sf(jp_voatm)%fnow(:,:,1), & ! <<= in
& sf(jp_qsr )%fnow(:,:,1), sf(jp_qlw )%fnow(:,:,1), & ! <<= in (wl/cs)
& tsk_m, zssq, zcd_du, zsen, zlat, zevp ) ! =>> out
@@ -600,7 +602,9 @@ CONTAINS
IF( ln_trcdc2dm ) THEN ! diurnal cycle in TOP
IF( MOD( kt - 1, nn_fsbc ) == 0 ) THEN
IF( ln_dm2dc ) THEN
- qsr_mean(:,:) = ( 1. - albo ) * sf(jp_qsr)%fnow(:,:,1) * tmask(:,:,1)
+ DO_2D( 0, 0, 0, 0 )
+ qsr_mean(ji,jj) = ( 1. - albo ) * sf(jp_qsr)%fnow(ji,jj,1) * smask0(ji,jj)
+ END_2D
ELSE
ncpl_qsr_freq = sf(jp_qsr)%freqh * 3600 ! qsr_mean will be computed in TOP
ENDIF
@@ -611,10 +615,10 @@ CONTAINS
END SUBROUTINE sbc_blk
- SUBROUTINE blk_oce_1( kt, pwndi, pwndj, ptair, pqair, & ! inp
- & pslp , pst , pu , pv, & ! inp
- & puatm, pvatm, pdqsr , pdqlw , & ! inp
- & ptsk , pssq , pcd_du, psen, plat, pevp ) ! out
+ SUBROUTINE blk_oce_1( kt, pwndi, pwndj, ptair, pqair, & ! <<= in
+ & pslp , pst , pu , pv, & ! <<= in
+ & puatm, pvatm, pdqsr , pdqlw , & ! <<= in
+ & ptsk , pssq , pcd_du, psen, plat, pevp ) ! =>> out
!!---------------------------------------------------------------------
!! *** ROUTINE blk_oce_1 ***
!!
@@ -631,40 +635,39 @@ CONTAINS
!! - plat : latent heat flux (W/m^2)
!! - pevp : evaporation (mm/s) #lolo
!!---------------------------------------------------------------------
- INTEGER , INTENT(in ) :: kt ! time step index
- REAL(wp), INTENT(in ), DIMENSION(:,:) :: pwndi ! atmospheric wind at T-point [m/s]
- REAL(wp), INTENT(in ), DIMENSION(:,:) :: pwndj ! atmospheric wind at T-point [m/s]
- REAL(wp), INTENT(in ), DIMENSION(:,:) :: pqair ! specific humidity at T-points [kg/kg]
- REAL(wp), INTENT(in ), DIMENSION(:,:) :: ptair ! potential temperature at T-points [Kelvin]
- REAL(wp), INTENT(in ), DIMENSION(:,:) :: pslp ! sea-level pressure [Pa]
- REAL(wp), INTENT(in ), DIMENSION(:,:) :: pst ! surface temperature [Celsius]
- REAL(wp), INTENT(in ), DIMENSION(:,:) :: pu ! surface current at U-point (i-component) [m/s]
- REAL(wp), INTENT(in ), DIMENSION(:,:) :: pv ! surface current at V-point (j-component) [m/s]
- REAL(wp), INTENT(in ), DIMENSION(:,:) :: puatm ! surface current seen by the atm at T-point (i-component) [m/s]
- REAL(wp), INTENT(in ), DIMENSION(:,:) :: pvatm ! surface current seen by the atm at T-point (j-component) [m/s]
- REAL(wp), INTENT(in ), DIMENSION(:,:) :: pdqsr ! downwelling solar (shortwave) radiation at surface [W/m^2]
- REAL(wp), INTENT(in ), DIMENSION(:,:) :: pdqlw ! downwelling longwave radiation at surface [W/m^2]
- REAL(wp), INTENT( out), DIMENSION(:,:) :: ptsk ! skin temp. (or SST if CS & WL not used) [Celsius]
- REAL(wp), INTENT( out), DIMENSION(:,:) :: pssq ! specific humidity at pst [kg/kg]
- REAL(wp), INTENT( out), DIMENSION(:,:) :: pcd_du
- REAL(wp), INTENT( out), DIMENSION(:,:) :: psen
- REAL(wp), INTENT( out), DIMENSION(:,:) :: plat
- REAL(wp), INTENT( out), DIMENSION(:,:) :: pevp
+ INTEGER , INTENT(in ) :: kt ! time step index
+ REAL(wp), INTENT(in ), DIMENSION(A2D(0)) :: pwndi ! atmospheric wind at T-point [m/s]
+ REAL(wp), INTENT(in ), DIMENSION(A2D(0)) :: pwndj ! atmospheric wind at T-point [m/s]
+ REAL(wp), INTENT(in ), DIMENSION(A2D(0)) :: pqair ! specific humidity at T-points [kg/kg]
+ REAL(wp), INTENT(in ), DIMENSION(A2D(0)) :: ptair ! potential temperature at T-points [Kelvin]
+ REAL(wp), INTENT(in ), DIMENSION(A2D(0)) :: pslp ! sea-level pressure [Pa]
+ REAL(wp), INTENT(in ), DIMENSION(A2D(0)) :: pst ! surface temperature [Celsius]
+ REAL(wp), INTENT(in ), DIMENSION(A2D(0)) :: pu ! surface current at U-point (i-component) [m/s]
+ REAL(wp), INTENT(in ), DIMENSION(A2D(0)) :: pv ! surface current at V-point (j-component) [m/s]
+ REAL(wp), INTENT(in ), DIMENSION(A2D(0)) :: puatm ! surface current seen by the atm at T-point (i-component) [m/s]
+ REAL(wp), INTENT(in ), DIMENSION(A2D(0)) :: pvatm ! surface current seen by the atm at T-point (j-component) [m/s]
+ REAL(wp), INTENT(in ), DIMENSION(A2D(0)) :: pdqsr ! downwelling solar (shortwave) radiation at surface [W/m^2]
+ REAL(wp), INTENT(in ), DIMENSION(A2D(0)) :: pdqlw ! downwelling longwave radiation at surface [W/m^2]
+ REAL(wp), INTENT( out), DIMENSION(A2D(0)) :: ptsk ! skin temp. (or SST if CS & WL not used) [Celsius]
+ REAL(wp), INTENT( out), DIMENSION(A2D(0)) :: pssq ! specific humidity at pst [kg/kg]
+ REAL(wp), INTENT( out), DIMENSION(A2D(0)) :: pcd_du
+ REAL(wp), INTENT( out), DIMENSION(A2D(0)) :: psen
+ REAL(wp), INTENT( out), DIMENSION(A2D(0)) :: plat
+ REAL(wp), INTENT( out), DIMENSION(A2D(0)) :: pevp
!
INTEGER :: ji, jj ! dummy loop indices
REAL(wp) :: zztmp ! local variable
REAL(wp) :: zstmax, zstau
#if defined key_cyclone
- REAL(wp), DIMENSION(jpi,jpj) :: zwnd_i, zwnd_j ! wind speed components at T-point
+ REAL(wp), DIMENSION(A2D(0)) :: zwnd_i, zwnd_j ! wind speed components at T-point
#endif
- REAL(wp), DIMENSION(jpi,jpj) :: ztau_i, ztau_j ! wind stress components at T-point
- REAL(wp), DIMENSION(jpi,jpj) :: zU_zu ! bulk wind speed at height zu [m/s]
- REAL(wp), DIMENSION(jpi,jpj) :: zcd_oce ! momentum transfert coefficient over ocean
- REAL(wp), DIMENSION(jpi,jpj) :: zch_oce ! sensible heat transfert coefficient over ocean
- REAL(wp), DIMENSION(jpi,jpj) :: zce_oce ! latent heat transfert coefficient over ocean
- REAL(wp), DIMENSION(jpi,jpj) :: zsspt ! potential sea-surface temperature [K]
- REAL(wp), DIMENSION(jpi,jpj) :: zpre, ztabs ! air pressure [Pa] & absolute temperature [K]
- REAL(wp), DIMENSION(jpi,jpj) :: zztmp1, zztmp2
+ REAL(wp), DIMENSION(A2D(0)) :: zU_zu ! bulk wind speed at height zu [m/s]
+ REAL(wp), DIMENSION(A2D(0)) :: zcd_oce ! momentum transfert coefficient over ocean
+ REAL(wp), DIMENSION(A2D(0)) :: zch_oce ! sensible heat transfert coefficient over ocean
+ REAL(wp), DIMENSION(A2D(0)) :: zce_oce ! latent heat transfert coefficient over ocean
+ REAL(wp), DIMENSION(A2D(0)) :: zsspt ! potential sea-surface temperature [K]
+ REAL(wp), DIMENSION(A2D(0)) :: zpre, ztabs ! air pressure [Pa] & absolute temperature [K]
+ REAL(wp), DIMENSION(A2D(0)) :: zztmp1, zztmp2
!!---------------------------------------------------------------------
!
! local scalars ( place there for vector optimisation purposes)
@@ -686,7 +689,7 @@ CONTAINS
zwnd_i(:,:) = 0._wp
zwnd_j(:,:) = 0._wp
CALL wnd_cyc( kt, zwnd_i, zwnd_j ) ! add analytical tropical cyclone (Vincent et al. JGR 2012)
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
zwnd_i(ji,jj) = pwndi(ji,jj) + zwnd_i(ji,jj)
zwnd_j(ji,jj) = pwndj(ji,jj) + zwnd_j(ji,jj)
! ... scalar wind at T-point (not masked)
@@ -694,23 +697,21 @@ CONTAINS
END_2D
#else
! ... scalar wind module at T-point (not masked)
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
- wndm(ji,jj) = SQRT( pwndi(ji,jj) * pwndi(ji,jj) + pwndj(ji,jj) * pwndj(ji,jj) )
+ DO_2D( 0, 0, 0, 0 )
+ wndm(ji,jj) = SQRT( pwndi(ji,jj) * pwndi(ji,jj) + pwndj(ji,jj) * pwndj(ji,jj) )
END_2D
#endif
! ----------------------------------------------------------------------------- !
! I Solar FLUX !
! ----------------------------------------------------------------------------- !
- ! ocean albedo assumed to be constant + modify now Qsr to include the diurnal cycle ! Short Wave
- zztmp = 1. - albo
+ ! ocean albedo assumed to be constant + modify now Qsr to include the diurnal cycle
IF( ln_dm2dc ) THEN
- qsr(:,:) = zztmp * sbc_dcy( pdqsr(:,:) ) * tmask(:,:,1)
+ qsr(:,:) = ( 1._wp - albo ) * sbc_dcy( pdqsr(:,:) ) * smask0(:,:)
ELSE
- qsr(:,:) = zztmp * pdqsr(:,:) * tmask(:,:,1)
+ qsr(:,:) = ( 1._wp - albo ) * pdqsr(:,:) * smask0(:,:)
ENDIF
-
! ----------------------------------------------------------------------------- !
! II Turbulent FLUXES !
! ----------------------------------------------------------------------------- !
@@ -718,69 +719,62 @@ CONTAINS
! specific humidity at SST
pssq(:,:) = rdct_qsat_salt * q_sat( ptsk(:,:), pslp(:,:) )
+ ! Backup "bulk SST" and associated spec. hum.
IF( ln_skin_cs .OR. ln_skin_wl ) THEN
- !! Backup "bulk SST" and associated spec. hum.
zztmp1(:,:) = zsspt(:,:)
- zztmp2(:,:) = pssq(:,:)
+ zztmp2(:,:) = pssq (:,:)
ENDIF
- !! Time to call the user-selected bulk parameterization for
- !! == transfer coefficients ==! Cd, Ch, Ce at T-point, and more...
- SELECT CASE( nblk )
-
+ ! transfer coefficients (Cd, Ch, Ce at T-point, and more)
+ SELECT CASE( nblk ) ! user-selected bulk parameterization
+ !
CASE( np_NCAR )
CALL turb_ncar ( rn_zqt, rn_zu, zsspt, ptair, pssq, pqair, wndm, &
- & zcd_oce, zch_oce, zce_oce, theta_zu, q_zu, zU_zu , &
+ & zcd_oce, zch_oce, zce_oce, theta_zu, q_zu, zU_zu , &
& nb_iter=nn_iter_algo )
- !
CASE( np_COARE_3p0 )
CALL turb_coare3p0( kt, rn_zqt, rn_zu, zsspt, ptair, pssq, pqair, wndm, &
- & ln_skin_cs, ln_skin_wl, &
- & zcd_oce, zch_oce, zce_oce, theta_zu, q_zu, zU_zu, &
- & nb_iter=nn_iter_algo, &
+ & ln_skin_cs, ln_skin_wl, &
+ & zcd_oce, zch_oce, zce_oce, theta_zu, q_zu, zU_zu, &
+ & nb_iter=nn_iter_algo, &
& Qsw=qsr(:,:), rad_lw=pdqlw(:,:), slp=pslp(:,:) )
- !
CASE( np_COARE_3p6 )
CALL turb_coare3p6( kt, rn_zqt, rn_zu, zsspt, ptair, pssq, pqair, wndm, &
- & ln_skin_cs, ln_skin_wl, &
- & zcd_oce, zch_oce, zce_oce, theta_zu, q_zu, zU_zu, &
- & nb_iter=nn_iter_algo, &
+ & ln_skin_cs, ln_skin_wl, &
+ & zcd_oce, zch_oce, zce_oce, theta_zu, q_zu, zU_zu, &
+ & nb_iter=nn_iter_algo, &
& Qsw=qsr(:,:), rad_lw=pdqlw(:,:), slp=pslp(:,:) )
- !
CASE( np_ECMWF )
CALL turb_ecmwf ( kt, rn_zqt, rn_zu, zsspt, ptair, pssq, pqair, wndm, &
- & ln_skin_cs, ln_skin_wl, &
- & zcd_oce, zch_oce, zce_oce, theta_zu, q_zu, zU_zu, &
- & nb_iter=nn_iter_algo, &
+ & ln_skin_cs, ln_skin_wl, &
+ & zcd_oce, zch_oce, zce_oce, theta_zu, q_zu, zU_zu, &
+ & nb_iter=nn_iter_algo, &
& Qsw=qsr(:,:), rad_lw=pdqlw(:,:), slp=pslp(:,:) )
- !
CASE( np_ANDREAS )
CALL turb_andreas ( rn_zqt, rn_zu, zsspt, ptair, pssq, pqair, wndm, &
- & zcd_oce, zch_oce, zce_oce, theta_zu, q_zu, zU_zu , &
+ & zcd_oce, zch_oce, zce_oce, theta_zu, q_zu, zU_zu, &
& nb_iter=nn_iter_algo )
- !
CASE DEFAULT
CALL ctl_stop( 'STOP', 'sbc_oce: non-existing bulk parameterizaton selected' )
- !
END SELECT
- IF( iom_use('Cd_oce') ) CALL iom_put("Cd_oce", zcd_oce * tmask(:,:,1))
- IF( iom_use('Ce_oce') ) CALL iom_put("Ce_oce", zce_oce * tmask(:,:,1))
- IF( iom_use('Ch_oce') ) CALL iom_put("Ch_oce", zch_oce * tmask(:,:,1))
+ ! outputs
+ IF( iom_use('Cd_oce') ) CALL iom_put( "Cd_oce", zcd_oce * smask0(:,:) )
+ IF( iom_use('Ce_oce') ) CALL iom_put( "Ce_oce", zce_oce * smask0(:,:) )
+ IF( iom_use('Ch_oce') ) CALL iom_put( "Ch_oce", zch_oce * smask0(:,:) )
!! LB: mainly here for debugging purpose:
- IF( iom_use('theta_zt') ) CALL iom_put("theta_zt", (ptair-rt0) * tmask(:,:,1)) ! potential temperature at z=zt
- IF( iom_use('q_zt') ) CALL iom_put("q_zt", pqair * tmask(:,:,1)) ! specific humidity "
- IF( iom_use('theta_zu') ) CALL iom_put("theta_zu", (theta_zu -rt0) * tmask(:,:,1)) ! potential temperature at z=zu
- IF( iom_use('q_zu') ) CALL iom_put("q_zu", q_zu * tmask(:,:,1)) ! specific humidity "
- IF( iom_use('ssq') ) CALL iom_put("ssq", pssq * tmask(:,:,1)) ! saturation specific humidity at z=0
- IF( iom_use('wspd_blk') ) CALL iom_put("wspd_blk", zU_zu * tmask(:,:,1)) ! bulk wind speed at z=zu
-
+ IF( iom_use('theta_zt') ) CALL iom_put( "theta_zt", (ptair-rt0) * smask0(:,:) ) ! potential temperature at z=zt
+ IF( iom_use('q_zt') ) CALL iom_put( "q_zt", pqair * smask0(:,:) ) ! specific humidity "
+ IF( iom_use('theta_zu') ) CALL iom_put( "theta_zu", (theta_zu -rt0) * smask0(:,:) ) ! potential temperature at z=zu
+ IF( iom_use('q_zu') ) CALL iom_put( "q_zu", q_zu * smask0(:,:) ) ! specific humidity "
+ IF( iom_use('ssq') ) CALL iom_put( "ssq", pssq * smask0(:,:) ) ! saturation specific humidity at z=0
+ IF( iom_use('wspd_blk') ) CALL iom_put( "wspd_blk", zU_zu * smask0(:,:) ) ! bulk wind speed at z=zu
+
+ ! In the presence of sea-ice we do not use the cool-skin/warm-layer update of zsspt, pssq & ptsk from turb_*()
IF( ln_skin_cs .OR. ln_skin_wl ) THEN
- !! In the presence of sea-ice we forget about the cool-skin/warm-layer update of zsspt, pssq & ptsk:
- WHERE ( fr_i(:,:) > 0.001_wp )
- ! sea-ice present, we forget about the update, using what we backed up before call to turb_*()
+ WHERE ( fr_i(A2D(0)) > 0.001_wp )
zsspt(:,:) = zztmp1(:,:)
- pssq(:,:) = zztmp2(:,:)
+ pssq (:,:) = zztmp2(:,:)
END WHERE
! apply potential temperature increment to abolute SST
ptsk(:,:) = ptsk(:,:) + ( zsspt(:,:) - zztmp1(:,:) )
@@ -791,7 +785,7 @@ CONTAINS
IF( ln_abl ) THEN !== ABL formulation ==! multiplication by rho_air and turbulent fluxes computation done in ablstp
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
zztmp = zU_zu(ji,jj)
wndm(ji,jj) = zztmp ! Store zU_zu in wndm to compute ustar2 in ablmod
pcd_du(ji,jj) = zztmp * zcd_oce(ji,jj)
@@ -803,81 +797,66 @@ CONTAINS
ELSE !== BLK formulation ==! turbulent fluxes computation
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
zpre(ji,jj) = pres_temp( q_zu(ji,jj), pslp(ji,jj), rn_zu, ptpot=theta_zu(ji,jj), pta=ztabs(ji,jj) )
rhoa(ji,jj) = rho_air( ztabs(ji,jj), q_zu(ji,jj), zpre(ji,jj) )
END_2D
CALL BULK_FORMULA( rn_zu, zsspt(:,:), pssq(:,:), theta_zu(:,:), q_zu(:,:), &
- & zcd_oce(:,:), zch_oce(:,:), zce_oce(:,:), &
- & wndm(:,:), zU_zu(:,:), pslp(:,:), rhoa(:,:), &
- & taum(:,:), psen(:,:), plat(:,:), &
- & pEvap=pevp(:,:), pfact_evap=rn_efac )
+ & zcd_oce(:,:), zch_oce(:,:), zce_oce(:,:), &
+ & wndm(:,:), zU_zu(:,:), pslp(:,:), rhoa(:,:), &
+ & taum(:,:), psen(:,:), plat(:,:), &
+ & pEvap=pevp(:,:), pfact_evap=rn_efac )
- psen(:,:) = psen(:,:) * tmask(:,:,1)
- plat(:,:) = plat(:,:) * tmask(:,:,1)
- taum(:,:) = taum(:,:) * tmask(:,:,1)
- pevp(:,:) = pevp(:,:) * tmask(:,:,1)
+ psen(:,:) = psen(:,:) * smask0(:,:)
+ plat(:,:) = plat(:,:) * smask0(:,:)
+ taum(:,:) = taum(:,:) * smask0(:,:)
+ pevp(:,:) = pevp(:,:) * smask0(:,:)
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
IF( wndm(ji,jj) > 0._wp ) THEN
- zztmp = taum(ji,jj) / wndm(ji,jj)
+ zztmp = taum(ji,jj) / wndm(ji,jj)
#if defined key_cyclone
- ztau_i(ji,jj) = zztmp * zwnd_i(ji,jj)
- ztau_j(ji,jj) = zztmp * zwnd_j(ji,jj)
+ utau(ji,jj) = zztmp * zwnd_i(ji,jj)
+ vtau(ji,jj) = zztmp * zwnd_j(ji,jj)
#else
- ztau_i(ji,jj) = zztmp * pwndi(ji,jj)
- ztau_j(ji,jj) = zztmp * pwndj(ji,jj)
+ utau(ji,jj) = zztmp * pwndi(ji,jj)
+ vtau(ji,jj) = zztmp * pwndj(ji,jj)
#endif
ELSE
- ztau_i(ji,jj) = 0._wp
- ztau_j(ji,jj) = 0._wp
+ utau(ji,jj) = 0._wp
+ vtau(ji,jj) = 0._wp
ENDIF
END_2D
IF( ln_crt_fbk ) THEN ! aply eq. 10 and 11 of Renault et al. 2020 (doi: 10.1029/2019MS001715)
zstmax = MIN( rn_stau_a * 3._wp + rn_stau_b, 0._wp ) ! set the max value of Stau corresponding to a wind of 3 m/s (<0)
- DO_2D( 0, 1, 0, 1 ) ! end at jpj and jpi, as ztau_j(ji,jj+1) ztau_i(ji+1,jj) used in the next loop
- zstau = MIN( rn_stau_a * wndm(ji,jj) + rn_stau_b, zstmax ) ! stau (<0) must be smaller than zstmax
- ztau_i(ji,jj) = ztau_i(ji,jj) + zstau * ( 0.5_wp * ( pu(ji-1,jj ) + pu(ji,jj) ) - puatm(ji,jj) )
- ztau_j(ji,jj) = ztau_j(ji,jj) + zstau * ( 0.5_wp * ( pv(ji ,jj-1) + pv(ji,jj) ) - pvatm(ji,jj) )
- taum(ji,jj) = SQRT( ztau_i(ji,jj) * ztau_i(ji,jj) + ztau_j(ji,jj) * ztau_j(ji,jj) )
+ DO_2D( 0, 0, 0, 0 )
+ zstau = MIN( rn_stau_a * wndm(ji,jj) + rn_stau_b, zstmax ) * smask0(ji,jj) ! stau (<0) must be smaller than zstmax
+ utau(ji,jj) = utau(ji,jj) + zstau * ( 0.5_wp * ( pu(ji-1,jj ) + pu(ji,jj) ) - puatm(ji,jj) )
+ vtau(ji,jj) = vtau(ji,jj) + zstau * ( 0.5_wp * ( pv(ji ,jj-1) + pv(ji,jj) ) - pvatm(ji,jj) )
+ taum(ji,jj) = SQRT( utau(ji,jj) * utau(ji,jj) + vtau(ji,jj) * vtau(ji,jj) )
END_2D
+ CALL lbc_lnk( 'sbcblk', utau, 'T', -1._wp, vtau, 'T', -1._wp )
ENDIF
- ! ... utau, vtau at U- and V_points, resp.
- ! Note the use of 0.5*(2-umask) in order to unmask the stress along coastlines
- ! Note that coastal wind stress is not used in the code... so this extra care has no effect
- DO_2D( 0, 0, 0, 0 ) ! start loop at 2, in case ln_crt_fbk = T
- utau(ji,jj) = 0.5 * ( 2. - umask(ji,jj,1) ) * ( ztau_i(ji,jj) + ztau_i(ji+1,jj ) ) &
- & * MAX(tmask(ji,jj,1),tmask(ji+1,jj,1))
- vtau(ji,jj) = 0.5 * ( 2. - vmask(ji,jj,1) ) * ( ztau_j(ji,jj) + ztau_j(ji ,jj+1) ) &
- & * MAX(tmask(ji,jj,1),tmask(ji,jj+1,1))
- END_2D
-
- IF( ln_crt_fbk ) THEN
- CALL lbc_lnk( 'sbcblk', utau, 'U', -1._wp, vtau, 'V', -1._wp, taum, 'T', 1._wp )
- ELSE
- CALL lbc_lnk( 'sbcblk', utau, 'U', -1._wp, vtau, 'V', -1._wp )
- ENDIF
-
- ! Saving open-ocean wind-stress (module and components) on T-points:
- CALL iom_put( "taum_oce", taum(:,:)*tmask(:,:,1) ) ! output wind stress module
- !#LB: These 2 lines below mostly here for 'STATION_ASF' test-case, otherwize "utau" (U-grid) and vtau" (V-grid) does the job in: [DYN/dynatf.F90])
- CALL iom_put( "utau_oce", ztau_i(:,:)*tmask(:,:,1) ) ! utau at T-points!
- CALL iom_put( "vtau_oce", ztau_j(:,:)*tmask(:,:,1) ) ! vtau at T-points!
+ ! Saving open-ocean wind-stress (module and components)
+ CALL iom_put( "taum_oce", taum(:,:) ) ! wind stress module
+ ! ! LB: These 2 lines below mostly here for 'STATION_ASF' test-case
+ CALL iom_put( "utau_oce", utau(:,:) ) ! utau
+ CALL iom_put( "vtau_oce", vtau(:,:) ) ! vtau
IF(sn_cfctl%l_prtctl) THEN
CALL prt_ctl( tab2d_1=pssq , clinfo1=' blk_oce_1: pssq : ', mask1=tmask )
CALL prt_ctl( tab2d_1=wndm , clinfo1=' blk_oce_1: wndm : ', mask1=tmask )
- CALL prt_ctl( tab2d_1=utau , clinfo1=' blk_oce_1: utau : ', mask1=umask, &
- & tab2d_2=vtau , clinfo2=' vtau : ', mask2=vmask )
+ CALL prt_ctl( tab2d_1=utau , clinfo1=' blk_oce_1: utau : ', mask1=tmask, &
+ & tab2d_2=vtau , clinfo2=' vtau : ', mask2=tmask )
CALL prt_ctl( tab2d_1=zcd_oce, clinfo1=' blk_oce_1: Cd : ', mask1=tmask )
ENDIF
!
ENDIF ! ln_blk / ln_abl
- ptsk(:,:) = ( ptsk(:,:) - rt0 ) * tmask(:,:,1) ! Back to Celsius
+ ptsk(:,:) = ( ptsk(:,:) - rt0 ) * smask0(:,:) ! Back to Celsius
IF( ln_skin_cs .OR. ln_skin_wl ) THEN
CALL iom_put( "t_skin" , ptsk ) ! T_skin in Celsius
@@ -896,68 +875,74 @@ CONTAINS
!! at the ocean surface at each time step knowing Cd, Ch, Ce and
!! atmospheric variables (from ABL or external data)
!!
- !! ** Outputs : - utau : i-component of the stress at U-point (N/m2)
- !! - vtau : j-component of the stress at V-point (N/m2)
+ !! ** Outputs : - utau : i-component of the stress at T-point (N/m2)
+ !! - vtau : j-component of the stress at T-point (N/m2)
!! - taum : Wind stress module at T-point (N/m2)
!! - wndm : Wind speed module at T-point (m/s)
!! - qsr : Solar heat flux over the ocean (W/m2)
!! - qns : Non Solar heat flux over the ocean (W/m2)
!! - emp : evaporation minus precipitation (kg/m2/s)
!!---------------------------------------------------------------------
- REAL(wp), INTENT(in), DIMENSION(:,:) :: ptair ! potential temperature of air #LB: confirm!
- REAL(wp), INTENT(in), DIMENSION(:,:) :: pdqlw ! downwelling longwave radiation at surface [W/m^2]
- REAL(wp), INTENT(in), DIMENSION(:,:) :: pprec
- REAL(wp), INTENT(in), DIMENSION(:,:) :: psnow
- REAL(wp), INTENT(in), DIMENSION(:,:) :: ptsk ! SKIN surface temperature [Celsius]
- REAL(wp), INTENT(in), DIMENSION(:,:) :: psen
- REAL(wp), INTENT(in), DIMENSION(:,:) :: plat
- REAL(wp), INTENT(in), DIMENSION(:,:) :: pevp
+ REAL(wp), INTENT(in), DIMENSION(A2D(0)) :: ptair ! potential temperature of air #LB: confirm!
+ REAL(wp), INTENT(in), DIMENSION(A2D(0)) :: pdqlw ! downwelling longwave radiation at surface [W/m^2]
+ REAL(wp), INTENT(in), DIMENSION(A2D(0)) :: pprec
+ REAL(wp), INTENT(in), DIMENSION(A2D(0)) :: psnow
+ REAL(wp), INTENT(in), DIMENSION(A2D(0)) :: ptsk ! SKIN surface temperature [Celsius]
+ REAL(wp), INTENT(in), DIMENSION(A2D(0)) :: psen
+ REAL(wp), INTENT(in), DIMENSION(A2D(0)) :: plat
+ REAL(wp), INTENT(in), DIMENSION(A2D(0)) :: pevp
!
INTEGER :: ji, jj ! dummy loop indices
REAL(wp) :: zztmp,zz1,zz2,zz3 ! local variable
- REAL(wp), DIMENSION(jpi,jpj) :: zqlw ! net long wave radiative heat flux
- REAL(wp), DIMENSION(jpi,jpj) :: zcptrain, zcptsnw, zcptn ! Heat content per unit mass (J/kg)
+ REAL(wp), DIMENSION(A2D(0)) :: zqlw ! net long wave radiative heat flux
+ REAL(wp), DIMENSION(A2D(0)) :: zcptrain, zcptsnw, zcptn ! Heat content per unit mass (J/kg)
!!---------------------------------------------------------------------
!
- ! Heat content per unit mass (J/kg)
- zcptrain(:,:) = ( ptair - rt0 ) * rcp * tmask(:,:,1)
- zcptsnw (:,:) = ( MIN( ptair, rt0 ) - rt0 ) * rcpi * tmask(:,:,1)
- zcptn (:,:) = ptsk * rcp * tmask(:,:,1)
- !
+ DO_2D( 0, 0, 0, 0 )
+ ! Heat content per unit mass (J/kg)
+ zcptrain(ji,jj) = ( ptair(ji,jj) - rt0 ) * rcp * smask0(ji,jj)
+ zcptsnw (ji,jj) = ( MIN( ptair(ji,jj), rt0 ) - rt0 ) * rcpi * smask0(ji,jj)
+ zcptn (ji,jj) = ptsk (ji,jj) * rcp * smask0(ji,jj)
+ !
+ END_2D
! ----------------------------------------------------------------------------- !
! III Net longwave radiative FLUX !
! ----------------------------------------------------------------------------- !
!! #LB: now moved after Turbulent fluxes because must use the skin temperature rather than bulk SST
!! (ptsk is skin temperature if ln_skin_cs==.TRUE. .OR. ln_skin_wl==.TRUE.)
zqlw(:,:) = qlw_net( pdqlw(:,:), ptsk(:,:)+rt0 )
-
+
! ----------------------------------------------------------------------------- !
! IV Total FLUXES !
! ----------------------------------------------------------------------------- !
!
- emp (:,:) = ( pevp(:,:) - pprec(:,:) * rn_pfac ) * tmask(:,:,1) ! mass flux (evap. - precip.)
- !
- qns(:,:) = zqlw(:,:) + psen(:,:) + plat(:,:) & ! Downward Non Solar
- & - psnow(:,:) * rn_pfac * rLfus & ! remove latent melting heat for solid precip
- & - pevp(:,:) * zcptn(:,:) & ! remove evap heat content at SST
- & + ( pprec(:,:) - psnow(:,:) ) * rn_pfac * zcptrain(:,:) & ! add liquid precip heat content at Tair
- & + psnow(:,:) * rn_pfac * zcptsnw(:,:) ! add solid precip heat content at min(Tair,Tsnow)
- qns(:,:) = qns(:,:) * tmask(:,:,1)
+ DO_2D( 0, 0, 0, 0 )
+ emp (ji,jj) = ( pevp(ji,jj) - pprec(ji,jj) * rn_pfac ) * smask0(ji,jj) ! mass flux (evap. - precip.)
+ !
+ qns(ji,jj) = zqlw(ji,jj) + psen(ji,jj) + plat(ji,jj) & ! Downward Non Solar
+ & - psnow(ji,jj) * rn_pfac * rLfus & ! remove latent melting heat for solid precip
+ & - pevp(ji,jj) * zcptn(ji,jj) & ! remove evap heat content at SST
+ & + ( pprec(ji,jj) - psnow(ji,jj) ) * rn_pfac * zcptrain(ji,jj) & ! add liquid precip heat content at Tair
+ & + psnow(ji,jj) * rn_pfac * zcptsnw(ji,jj) ! add solid precip heat content at min(Tair,Tsnow)
+ qns(ji,jj) = qns(ji,jj) * smask0(ji,jj)
+ END_2D
!
#if defined key_si3
IF ( nn_ice == 2 ) THEN
- qns_oce(:,:) = zqlw(:,:) + psen(:,:) + plat(:,:) ! non solar without emp (only needed by SI3)
- qsr_oce(:,:) = qsr(:,:)
+ DO_2D( 0, 0, 0, 0 )
+ qns_oce(ji,jj) = zqlw(ji,jj) + psen(ji,jj) + plat(ji,jj) ! non solar without emp (only needed by SI3)
+ qsr_oce(ji,jj) = qsr(ji,jj)
+ END_2D
ENDIF
#endif
!
- CALL iom_put( "rho_air" , rhoa*tmask(:,:,1) ) ! output air density [kg/m^3]
+ CALL iom_put( "rho_air" , rhoa*smask0(:,:) ) ! output air density [kg/m^3]
CALL iom_put( "evap_oce" , pevp ) ! evaporation
CALL iom_put( "qlw_oce" , zqlw ) ! output downward longwave heat over the ocean
CALL iom_put( "qsb_oce" , psen ) ! output downward sensible heat over the ocean
CALL iom_put( "qla_oce" , plat ) ! output downward latent heat over the ocean
- tprecip(:,:) = pprec(:,:) * rn_pfac * tmask(:,:,1) ! output total precipitation [kg/m2/s]
- sprecip(:,:) = psnow(:,:) * rn_pfac * tmask(:,:,1) ! output solid precipitation [kg/m2/s]
+ tprecip(:,:) = pprec(:,:) * rn_pfac * smask0(:,:) ! output total precipitation [kg/m2/s]
+ sprecip(:,:) = psnow(:,:) * rn_pfac * smask0(:,:) ! output solid precipitation [kg/m2/s]
CALL iom_put( 'snowpre', sprecip ) ! Snow
CALL iom_put( 'precip' , tprecip ) ! Total precipitation
!
@@ -988,8 +973,8 @@ CONTAINS
!! blk_ice_qcn : provide ice surface temperature and snow/ice conduction flux (emulating conduction flux)
!!----------------------------------------------------------------------
- SUBROUTINE blk_ice_1( pwndi, pwndj, ptair, pqair, pslp , puice, pvice, ptsui, & ! inputs
- & putaui, pvtaui, pseni, pevpi, pssqi, pcd_dui ) ! optional outputs
+ SUBROUTINE blk_ice_1( pwndi, pwndj, ptair, pqair, pslp, ptsui, & ! inputs
+ & putaui, pvtaui, pseni, pevpi, pssqi, pcd_dui ) ! optional outputs
!!---------------------------------------------------------------------
!! *** ROUTINE blk_ice_1 ***
!!
@@ -999,32 +984,35 @@ CONTAINS
!! formulea, ice variables and read atmospheric fields.
!! NB: ice drag coefficient is assumed to be a constant
!!---------------------------------------------------------------------
- REAL(wp) , INTENT(in ), DIMENSION(:,: ) :: pslp ! sea-level pressure [Pa]
- REAL(wp) , INTENT(in ), DIMENSION(:,: ) :: pwndi ! atmospheric wind at T-point [m/s]
- REAL(wp) , INTENT(in ), DIMENSION(:,: ) :: pwndj ! atmospheric wind at T-point [m/s]
- REAL(wp) , INTENT(in ), DIMENSION(:,: ) :: ptair ! atmospheric potential temperature at T-point [K]
- REAL(wp) , INTENT(in ), DIMENSION(:,: ) :: pqair ! atmospheric specific humidity at T-point [kg/kg]
- REAL(wp) , INTENT(in ), DIMENSION(:,: ) :: puice ! sea-ice velocity on I or C grid [m/s]
- REAL(wp) , INTENT(in ), DIMENSION(:,: ) :: pvice ! "
- REAL(wp) , INTENT(in ), DIMENSION(:,: ) :: ptsui ! sea-ice surface temperature [K]
- REAL(wp) , INTENT( out), DIMENSION(:,: ), OPTIONAL :: putaui ! if ln_blk
- REAL(wp) , INTENT( out), DIMENSION(:,: ), OPTIONAL :: pvtaui ! if ln_blk
- REAL(wp) , INTENT( out), DIMENSION(:,: ), OPTIONAL :: pseni ! if ln_abl
- REAL(wp) , INTENT( out), DIMENSION(:,: ), OPTIONAL :: pevpi ! if ln_abl
- REAL(wp) , INTENT( out), DIMENSION(:,: ), OPTIONAL :: pssqi ! if ln_abl
- REAL(wp) , INTENT( out), DIMENSION(:,: ), OPTIONAL :: pcd_dui ! if ln_abl
+ REAL(wp) , INTENT(in ), DIMENSION(A2D(0) ) :: pslp ! sea-level pressure [Pa]
+ REAL(wp) , INTENT(in ), DIMENSION(A2D(0) ) :: pwndi ! atmospheric wind at T-point [m/s]
+ REAL(wp) , INTENT(in ), DIMENSION(A2D(0) ) :: pwndj ! atmospheric wind at T-point [m/s]
+ REAL(wp) , INTENT(in ), DIMENSION(A2D(0) ) :: ptair ! atmospheric potential temperature at T-point [K]
+ REAL(wp) , INTENT(in ), DIMENSION(A2D(0) ) :: pqair ! atmospheric specific humidity at T-point [kg/kg]
+ REAL(wp) , INTENT(in ), DIMENSION(A2D(0) ) :: ptsui ! sea-ice surface temperature [K]
+ REAL(wp) , INTENT( out), DIMENSION(A2D(0) ), OPTIONAL :: putaui ! if ln_blk
+ REAL(wp) , INTENT( out), DIMENSION(A2D(0) ), OPTIONAL :: pvtaui ! if ln_blk
+ REAL(wp) , INTENT( out), DIMENSION(A2D(0) ), OPTIONAL :: pseni ! if ln_abl
+ REAL(wp) , INTENT( out), DIMENSION(A2D(0) ), OPTIONAL :: pevpi ! if ln_abl
+ REAL(wp) , INTENT( out), DIMENSION(A2D(0) ), OPTIONAL :: pssqi ! if ln_abl
+ REAL(wp) , INTENT( out), DIMENSION(A2D(0) ), OPTIONAL :: pcd_dui ! if ln_abl
!
INTEGER :: ji, jj ! dummy loop indices
- REAL(wp) :: zootm_su ! sea-ice surface mean temperature
- REAL(wp) :: zztmp1, zztmp2 ! temporary scalars
- REAL(wp), DIMENSION(jpi,jpj) :: ztmp, zsipt ! temporary array
+ REAL(wp) :: zztmp ! temporary scalars
+ REAL(wp), DIMENSION(A2D(0)) :: ztmp, zsipt ! temporary array
+ REAL(wp), DIMENSION(A2D(0)) :: zmsk00 ! O% concentration ice mask
!!---------------------------------------------------------------------
!
+ ! treshold for outputs
+ DO_2D( 0, 0, 0, 0 )
+ zmsk00(ji,jj) = MAX( 0._wp , SIGN( 1._wp , fr_i(ji,jj) - 1.e-6_wp ) ) ! 1 if ice, 0 if no ice
+ END_2D
+
! ------------------------------------------------------------ !
! Wind module relative to the moving ice ( U10m - U_ice ) !
! ------------------------------------------------------------ !
! C-grid ice dynamics : U & V-points (same as ocean)
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
wndm_ice(ji,jj) = SQRT( pwndi(ji,jj) * pwndi(ji,jj) + pwndj(ji,jj) * pwndj(ji,jj) )
END_2D
!
@@ -1032,9 +1020,9 @@ CONTAINS
zsipt(:,:) = theta_exner( ptsui(:,:), pslp(:,:) )
! sea-ice <-> atmosphere bulk transfer coefficients
- SELECT CASE( nblk_ice )
-
- CASE( np_ice_cst )
+ SELECT CASE( nblk_ice ) ! user-selected bulk parameterization
+ !
+ CASE( np_ice_cst )
! Constant bulk transfer coefficients over sea-ice:
Cd_ice(:,:) = rn_Cd_i
Ch_ice(:,:) = rn_Ch_i
@@ -1042,73 +1030,61 @@ CONTAINS
! no height adjustment, keeping zt values:
theta_zu_i(:,:) = ptair(:,:)
q_zu_i(:,:) = pqair(:,:)
-
- CASE( np_ice_an05 ) ! calculate new drag from Lupkes(2015) equations
+ !
+ CASE( np_ice_an05 ) ! from Andreas(2005) equations
ztmp(:,:) = q_sat( ptsui(:,:), pslp(:,:), l_ice=.TRUE. ) ! temporary array for SSQ
CALL turb_ice_an05( rn_zqt, rn_zu, zsipt, ptair, ztmp, pqair, wndm_ice, &
& Cd_ice, Ch_ice, Ce_ice, theta_zu_i, q_zu_i )
- !!
- CASE( np_ice_lu12 )
+ !
+ CASE( np_ice_lu12 ) ! from Lupkes(2012) equations
ztmp(:,:) = q_sat( ptsui(:,:), pslp(:,:), l_ice=.TRUE. ) ! temporary array for SSQ
- CALL turb_ice_lu12( rn_zqt, rn_zu, zsipt, ptair, ztmp, pqair, wndm_ice, fr_i, &
+ CALL turb_ice_lu12( rn_zqt, rn_zu, zsipt, ptair, ztmp, pqair, wndm_ice, fr_i(A2D(0)), &
& Cd_ice, Ch_ice, Ce_ice, theta_zu_i, q_zu_i )
- !!
- CASE( np_ice_lg15 ) ! calculate new drag from Lupkes(2015) equations
+ !
+ CASE( np_ice_lg15 ) ! from Lupkes and Gryanik (2015) equations
ztmp(:,:) = q_sat( ptsui(:,:), pslp(:,:), l_ice=.TRUE. ) ! temporary array for SSQ
- CALL turb_ice_lg15( rn_zqt, rn_zu, zsipt, ptair, ztmp, pqair, wndm_ice, fr_i, &
+ CALL turb_ice_lg15( rn_zqt, rn_zu, zsipt, ptair, ztmp, pqair, wndm_ice, fr_i(A2D(0)), &
& Cd_ice, Ch_ice, Ce_ice, theta_zu_i, q_zu_i )
- !!
+ !
END SELECT
- IF( iom_use('Cd_ice').OR.iom_use('Ce_ice').OR.iom_use('Ch_ice').OR.iom_use('taum_ice').OR.iom_use('utau_ice').OR.iom_use('vtau_ice') ) &
- & ztmp(:,:) = ( 1._wp - MAX(0._wp, SIGN( 1._wp, 1.E-6_wp - fr_i )) )*tmask(:,:,1) ! mask for presence of ice !
-
- IF( iom_use('Cd_ice') ) CALL iom_put("Cd_ice", Cd_ice*ztmp)
- IF( iom_use('Ce_ice') ) CALL iom_put("Ce_ice", Ce_ice*ztmp)
- IF( iom_use('Ch_ice') ) CALL iom_put("Ch_ice", Ch_ice*ztmp)
-
IF( ln_blk ) THEN
! ---------------------------------------------------- !
! Wind stress relative to nonmoving ice ( U10m ) !
! ---------------------------------------------------- !
! supress moving ice in wind stress computation as we don't know how to do it properly...
- DO_2D( 0, 1, 0, 1 ) ! at T point
- zztmp1 = rhoa(ji,jj) * Cd_ice(ji,jj) * wndm_ice(ji,jj)
- putaui(ji,jj) = zztmp1 * pwndi(ji,jj)
- pvtaui(ji,jj) = zztmp1 * pwndj(ji,jj)
+ DO_2D( 0, 0, 0, 0 )
+ zztmp = rhoa(ji,jj) * Cd_ice(ji,jj) * wndm_ice(ji,jj)
+ putaui(ji,jj) = zztmp * pwndi(ji,jj)
+ pvtaui(ji,jj) = zztmp * pwndj(ji,jj)
END_2D
- !#LB: saving the module, and x-y components, of the ai wind-stress at T-points: NOT weighted by the ice concentration !!!
- IF(iom_use('taum_ice')) CALL iom_put('taum_ice', SQRT( putaui*putaui + pvtaui*pvtaui )*ztmp )
- !#LB: These 2 lines below mostly here for 'STATION_ASF' test-case, otherwize "utau_oi" (U-grid) and vtau_oi" (V-grid) does the job in: [ICE/icedyn_rhg_evp.F90])
- IF(iom_use('utau_ice')) CALL iom_put("utau_ice", putaui*ztmp) ! utau at T-points!
- IF(iom_use('vtau_ice')) CALL iom_put("vtau_ice", pvtaui*ztmp) ! vtau at T-points!
-
+ ! outputs
+ ! LB: not weighted by the ice concentration
+ IF( iom_use('taum_ice') ) CALL iom_put( 'taum_ice', SQRT( putaui*putaui + pvtaui*pvtaui ) * zmsk00 )
+ ! LB: These 2 lines below mostly here for 'STATION_ASF' test-case
+ IF( iom_use('utau_ice') ) CALL iom_put( "utau_ice", putaui * zmsk00 )
+ IF( iom_use('vtau_ice') ) CALL iom_put( "vtau_ice", pvtaui * zmsk00 )
!
- DO_2D( 0, 0, 0, 0 ) ! U & V-points (same as ocean).
- !#LB: QUESTION?? so SI3 expects wind stress vector to be provided at U & V points? Not at T-points ?
- ! take care of the land-sea mask to avoid "pollution" of coastal stress. p[uv]taui used in frazil and rheology
- zztmp1 = 0.5_wp * ( 2. - umask(ji,jj,1) ) * MAX( tmask(ji,jj,1),tmask(ji+1,jj ,1) )
- zztmp2 = 0.5_wp * ( 2. - vmask(ji,jj,1) ) * MAX( tmask(ji,jj,1),tmask(ji ,jj+1,1) )
- putaui(ji,jj) = zztmp1 * ( putaui(ji,jj) + putaui(ji+1,jj ) )
- pvtaui(ji,jj) = zztmp2 * ( pvtaui(ji,jj) + pvtaui(ji ,jj+1) )
- END_2D
- CALL lbc_lnk( 'sbcblk', putaui, 'U', -1._wp, pvtaui, 'V', -1._wp )
- !
- IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab2d_1=putaui , clinfo1=' blk_ice: putaui : ', mask1=umask &
- & , tab2d_2=pvtaui , clinfo2=' pvtaui : ', mask2=vmask )
+ IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab2d_1=putaui , clinfo1=' blk_ice: putaui : ', mask1=tmask &
+ & , tab2d_2=pvtaui , clinfo2=' pvtaui : ', mask2=tmask )
ELSE ! ln_abl
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
pcd_dui(ji,jj) = wndm_ice(ji,jj) * Cd_ice(ji,jj)
pseni (ji,jj) = wndm_ice(ji,jj) * Ch_ice(ji,jj)
pevpi (ji,jj) = wndm_ice(ji,jj) * Ce_ice(ji,jj)
END_2D
- pssqi(:,:) = q_sat( ptsui(:,:), pslp(:,:), l_ice=.TRUE. ) ; ! more accurate way to obtain ssq !
+ pssqi(:,:) = q_sat( ptsui(:,:), pslp(:,:), l_ice=.TRUE. ) ! more accurate way to obtain ssq
ENDIF ! ln_blk / ln_abl
!
+ ! outputs
+ IF( iom_use('Cd_ice') ) CALL iom_put( "Cd_ice", Cd_ice * zmsk00 )
+ IF( iom_use('Ce_ice') ) CALL iom_put( "Ce_ice", Ce_ice * zmsk00 )
+ IF( iom_use('Ch_ice') ) CALL iom_put( "Ch_ice", Ch_ice * zmsk00 )
+ !
IF(sn_cfctl%l_prtctl) CALL prt_ctl(tab2d_1=wndm_ice , clinfo1=' blk_ice: wndm_ice : ', mask1=tmask )
!
END SUBROUTINE blk_ice_1
@@ -1126,30 +1102,30 @@ CONTAINS
!!
!! caution : the net upward water flux has with mm/day unit
!!---------------------------------------------------------------------
- REAL(wp), DIMENSION(:,:,:), INTENT(in) :: ptsu ! sea ice surface temperature [K]
- REAL(wp), DIMENSION(:,:,:), INTENT(in) :: phs ! snow thickness
- REAL(wp), DIMENSION(:,:,:), INTENT(in) :: phi ! ice thickness
- REAL(wp), DIMENSION(:,:,:), INTENT(in) :: palb ! ice albedo (all skies)
- REAL(wp), DIMENSION(:,: ), INTENT(in) :: ptair ! potential temperature of air #LB: okay ???
- REAL(wp), DIMENSION(:,: ), INTENT(in) :: pqair ! specific humidity of air
- REAL(wp), DIMENSION(:,: ), INTENT(in) :: pslp
- REAL(wp), DIMENSION(:,: ), INTENT(in) :: pdqlw
- REAL(wp), DIMENSION(:,: ), INTENT(in) :: pprec
- REAL(wp), DIMENSION(:,: ), INTENT(in) :: psnow
+ REAL(wp), DIMENSION(A2D(0),jpl), INTENT(in) :: ptsu ! sea ice surface temperature [K]
+ REAL(wp), DIMENSION(A2D(0),jpl), INTENT(in) :: phs ! snow thickness
+ REAL(wp), DIMENSION(A2D(0),jpl), INTENT(in) :: phi ! ice thickness
+ REAL(wp), DIMENSION(A2D(0),jpl), INTENT(in) :: palb ! ice albedo (all skies)
+ REAL(wp), DIMENSION(A2D(0) ), INTENT(in) :: ptair ! potential temperature of air #LB: okay ???
+ REAL(wp), DIMENSION(A2D(0) ), INTENT(in) :: pqair ! specific humidity of air
+ REAL(wp), DIMENSION(A2D(0) ), INTENT(in) :: pslp
+ REAL(wp), DIMENSION(A2D(0) ), INTENT(in) :: pdqlw
+ REAL(wp), DIMENSION(A2D(0) ), INTENT(in) :: pprec
+ REAL(wp), DIMENSION(A2D(0) ), INTENT(in) :: psnow
!!
INTEGER :: ji, jj, jl ! dummy loop indices
REAL(wp) :: zst, zst3, zsq, zsipt ! local variable
REAL(wp) :: zcoef_dqlw, zcoef_dqla ! - -
REAL(wp) :: zztmp, zzblk, zztmp1, z1_rLsub ! - -
REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zmsk ! temporary mask for prt_ctl
- REAL(wp), DIMENSION(jpi,jpj,jpl) :: z_qlw ! long wave heat flux over ice
- REAL(wp), DIMENSION(jpi,jpj,jpl) :: z_qsb ! sensible heat flux over ice
- REAL(wp), DIMENSION(jpi,jpj,jpl) :: z_dqlw ! long wave heat sensitivity over ice
- REAL(wp), DIMENSION(jpi,jpj,jpl) :: z_dqsb ! sensible heat sensitivity over ice
- REAL(wp), DIMENSION(jpi,jpj) :: zevap, zsnw ! evaporation and snw distribution after wind blowing (SI3)
- REAL(wp), DIMENSION(jpi,jpj) :: ztmp, ztmp2
- REAL(wp), DIMENSION(jpi,jpj) :: ztri
- REAL(wp), DIMENSION(jpi,jpj) :: zcptrain, zcptsnw, zcptn ! Heat content per unit mass (J/kg)
+ REAL(wp), DIMENSION(A2D(0),jpl) :: z_qlw ! long wave heat flux over ice
+ REAL(wp), DIMENSION(A2D(0),jpl) :: z_qsb ! sensible heat flux over ice
+ REAL(wp), DIMENSION(A2D(0),jpl) :: z_dqlw ! long wave heat sensitivity over ice
+ REAL(wp), DIMENSION(A2D(0),jpl) :: z_dqsb ! sensible heat sensitivity over ice
+ REAL(wp), DIMENSION(A2D(0)) :: zevap, zsnw ! evaporation and snw distribution after wind blowing (SI3)
+ REAL(wp), DIMENSION(A2D(0)) :: ztmp, ztmp2
+ REAL(wp), DIMENSION(A2D(0)) :: ztri
+ REAL(wp), DIMENSION(A2D(0)) :: zcptrain, zcptsnw, zcptn ! Heat content per unit mass (J/kg)
!!---------------------------------------------------------------------
!
zcoef_dqlw = 4._wp * emiss_i * stefan ! local scalars
@@ -1157,14 +1133,14 @@ CONTAINS
dqla_ice(:,:,:) = 0._wp
! Heat content per unit mass (J/kg)
- zcptrain(:,:) = ( ptair - rt0 ) * rcp * tmask(:,:,1)
- zcptsnw (:,:) = ( MIN( ptair, rt0 ) - rt0 ) * rcpi * tmask(:,:,1)
- zcptn (:,:) = sst_m * rcp * tmask(:,:,1)
+ zcptrain(:,:) = ( ptair(:,:) - rt0 ) * rcp * smask0(:,:)
+ zcptsnw (:,:) = ( MIN( ptair(:,:), rt0 ) - rt0 ) * rcpi * smask0(:,:)
+ zcptn (:,:) = sst_m(A2D(0)) * rcp * smask0(:,:)
!
! ! ========================== !
DO jl = 1, jpl ! Loop over ice categories !
! ! ========================== !
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
zst = ptsu(ji,jj,jl) ! surface temperature of sea-ice [K]
zsq = q_sat( zst, pslp(ji,jj), l_ice=.TRUE. ) ! surface saturation specific humidity when ice present
@@ -1178,7 +1154,7 @@ CONTAINS
! Long Wave (lw)
zst3 = zst * zst * zst
- z_qlw(ji,jj,jl) = emiss_i * ( pdqlw(ji,jj) - stefan * zst * zst3 ) * tmask(ji,jj,1)
+ z_qlw(ji,jj,jl) = emiss_i * ( pdqlw(ji,jj) - stefan * zst * zst3 ) * smask0(ji,jj)
! lw sensitivity
z_dqlw(ji,jj,jl) = zcoef_dqlw * zst3
@@ -1205,7 +1181,6 @@ CONTAINS
!qla_ice( ji,jj,jl) = zztmp1 * (zsq - q_zu_i(ji,jj))
!dqla_ice(ji,jj,jl) = zztmp1 * dq_sat_dt_ice(zst, pslp(ji,jj)) ! ==> Qlat sensitivity (dQlat/dT)
-
! ----------------------------!
! III Total FLUXES !
! ----------------------------!
@@ -1218,43 +1193,48 @@ CONTAINS
!
END DO
!
- tprecip(:,:) = pprec(:,:) * rn_pfac * tmask(:,:,1) ! total precipitation [kg/m2/s]
- sprecip(:,:) = psnow(:,:) * rn_pfac * tmask(:,:,1) ! solid precipitation [kg/m2/s]
- CALL iom_put( 'snowpre', sprecip ) ! Snow precipitation
- CALL iom_put( 'precip' , tprecip ) ! Total precipitation
-
- ! --- evaporation --- !
z1_rLsub = 1._wp / rLsub
- evap_ice (:,:,:) = rn_efac * qla_ice (:,:,:) * z1_rLsub ! sublimation
- devap_ice(:,:,:) = rn_efac * dqla_ice(:,:,:) * z1_rLsub ! d(sublimation)/dT
- zevap (:,:) = emp(:,:) + tprecip(:,:) ! evaporation over ocean !LB: removed rn_efac here, correct???
+ DO_2D( 0, 0, 0, 0 )
+ ! --- precipitation --- !
+ tprecip(ji,jj) = pprec(ji,jj) * rn_pfac * smask0(ji,jj) ! total precipitation [kg/m2/s]
+ sprecip(ji,jj) = psnow(ji,jj) * rn_pfac * smask0(ji,jj) ! solid precipitation [kg/m2/s]
+
+ ! --- evaporation --- !
+ zevap(ji,jj) = emp(ji,jj) + tprecip(ji,jj) ! evaporation over ocean !LB: removed rn_efac here, correct???
+ DO jl = 1, jpl
+ evap_ice (ji,jj,jl) = rn_efac * qla_ice (ji,jj,jl) * z1_rLsub ! sublimation
+ devap_ice(ji,jj,jl) = rn_efac * dqla_ice(ji,jj,jl) * z1_rLsub ! d(sublimation)/dT
+ ENDDO
+ END_2D
- ! --- evaporation minus precipitation --- !
zsnw(:,:) = 0._wp
- CALL ice_var_snwblow( (1.-at_i_b(:,:)), zsnw ) ! snow distribution over ice after wind blowing
- emp_oce(:,:) = ( 1._wp - at_i_b(:,:) ) * zevap(:,:) - ( tprecip(:,:) - sprecip(:,:) ) - sprecip(:,:) * (1._wp - zsnw )
- emp_ice(:,:) = SUM( a_i_b(:,:,:) * evap_ice(:,:,:), dim=3 ) - sprecip(:,:) * zsnw
- emp_tot(:,:) = emp_oce(:,:) + emp_ice(:,:)
-
- ! --- heat flux associated with emp --- !
- qemp_oce(:,:) = - ( 1._wp - at_i_b(:,:) ) * zevap(:,:) * zcptn(:,:) & ! evap at sst
- & + ( tprecip(:,:) - sprecip(:,:) ) * zcptrain(:,:) & ! liquid precip at Tair
- & + sprecip(:,:) * ( 1._wp - zsnw ) * ( zcptsnw (:,:) - rLfus ) ! solid precip at min(Tair,Tsnow)
- qemp_ice(:,:) = sprecip(:,:) * zsnw * ( zcptsnw (:,:) - rLfus ) ! solid precip (only)
-
- ! --- total solar and non solar fluxes --- !
- qns_tot(:,:) = ( 1._wp - at_i_b(:,:) ) * qns_oce(:,:) + SUM( a_i_b(:,:,:) * qns_ice(:,:,:), dim=3 ) &
- & + qemp_ice(:,:) + qemp_oce(:,:)
- qsr_tot(:,:) = ( 1._wp - at_i_b(:,:) ) * qsr_oce(:,:) + SUM( a_i_b(:,:,:) * qsr_ice(:,:,:), dim=3 )
-
- ! --- heat content of precip over ice in J/m3 (to be used in 1D-thermo) --- !
- qprec_ice(:,:) = rhos * ( zcptsnw(:,:) - rLfus )
-
- ! --- heat content of evap over ice in W/m2 (to be used in 1D-thermo) ---
- DO jl = 1, jpl
- qevap_ice(:,:,jl) = 0._wp ! should be -evap_ice(:,:,jl)*( ( Tice - rt0 ) * rcpi * tmask(:,:,1) )
- ! ! But we do not have Tice => consider it at 0degC => evap=0
- END DO
+ CALL ice_var_snwblow( (1.-at_i_b(:,:)), zsnw(:,:) ) ! snow distribution over ice after wind blowing
+ DO_2D( 0, 0, 0, 0 )
+ ! --- evaporation minus precipitation --- !
+ emp_oce(ji,jj) = ( 1._wp - at_i_b(ji,jj) ) * zevap(ji,jj) - ( tprecip(ji,jj) - sprecip(ji,jj) ) - sprecip(ji,jj) * (1._wp - zsnw(ji,jj) )
+ emp_ice(ji,jj) = SUM( a_i_b(ji,jj,:) * evap_ice(ji,jj,:) ) - sprecip(ji,jj) * zsnw(ji,jj)
+ emp_tot(ji,jj) = emp_oce(ji,jj) + emp_ice(ji,jj)
+
+ ! --- heat flux associated with emp --- !
+ qemp_oce(ji,jj) = - ( 1._wp - at_i_b(ji,jj) ) * zevap(ji,jj) * zcptn(ji,jj) & ! evap at sst
+ & + ( tprecip(ji,jj) - sprecip(ji,jj) ) * zcptrain(ji,jj) & ! liquid precip at Tair
+ & + sprecip(ji,jj) * ( 1._wp - zsnw(ji,jj) ) * ( zcptsnw (ji,jj) - rLfus ) ! solid precip at min(Tair,Tsnow)
+ qemp_ice(ji,jj) = sprecip(ji,jj) * zsnw(ji,jj) * ( zcptsnw (ji,jj) - rLfus ) ! solid precip (only)
+
+ ! --- total solar and non solar fluxes --- !
+ qns_tot(ji,jj) = ( 1._wp - at_i_b(ji,jj) ) * qns_oce(ji,jj) + SUM( a_i_b(ji,jj,:) * qns_ice(ji,jj,:) ) &
+ & + qemp_ice(ji,jj) + qemp_oce(ji,jj)
+ qsr_tot(ji,jj) = ( 1._wp - at_i_b(ji,jj) ) * qsr_oce(ji,jj) + SUM( a_i_b(ji,jj,:) * qsr_ice(ji,jj,:) )
+
+ ! --- heat content of precip over ice in J/m3 (to be used in 1D-thermo) --- !
+ qprec_ice(ji,jj) = rhos * ( zcptsnw(ji,jj) - rLfus )
+
+ ! --- heat content of evap over ice in W/m2 (to be used in 1D-thermo) ---
+ DO jl = 1, jpl
+ qevap_ice(ji,jj,jl) = 0._wp ! should be -evap_ice(ji,jj,jl)*( ( Tice - rt0 ) * rcpi * smask0(ji,jj) )
+ ! ! But we do not have Tice => consider it at 0degC => evap=0
+ ENDDO
+ END_2D
! --- shortwave radiation transmitted thru the surface scattering layer (W/m2) --- !
IF( nn_qtrice == 0 ) THEN
@@ -1279,9 +1259,11 @@ CONTAINS
qtr_ice_top(:,:,:) = 0.3_wp * qsr_ice(:,:,:)
ENDIF
!
+ CALL iom_put( 'snowpre', sprecip ) ! Snow precipitation
+ CALL iom_put( 'precip' , tprecip ) ! Total precipitation
IF( iom_use('evap_ao_cea') .OR. iom_use('hflx_evap_cea') ) THEN
- CALL iom_put( 'evap_ao_cea' , zevap(:,:) * ( 1._wp - at_i_b(:,:) ) * tmask(:,:,1) ) ! ice-free oce evap (cell average)
- CALL iom_put( 'hflx_evap_cea', zevap(:,:) * ( 1._wp - at_i_b(:,:) ) * tmask(:,:,1) * zcptn(:,:) ) ! heat flux from evap (cell average)
+ CALL iom_put( 'evap_ao_cea' , zevap(:,:) * ( 1._wp - at_i_b(:,:) ) * smask0(:,:) ) ! ice-free oce evap (cell average)
+ CALL iom_put( 'hflx_evap_cea', zevap(:,:) * ( 1._wp - at_i_b(:,:) ) * smask0(:,:) * zcptn(:,:) ) ! heat flux from evap (cell average)
ENDIF
IF( iom_use('rain') .OR. iom_use('rain_ao_cea') .OR. iom_use('hflx_rain_cea') ) THEN
CALL iom_put( 'rain' , tprecip(:,:) - sprecip(:,:) ) ! liquid precipitation
@@ -1301,14 +1283,14 @@ CONTAINS
& + ( tprecip(:,:) - sprecip(:,:) ) * zcptrain(:,:) )
ENDIF
IF( iom_use('subl_ai_cea') .OR. iom_use('hflx_subl_cea') ) THEN
- CALL iom_put( 'subl_ai_cea' , SUM( a_i_b(:,:,:) * evap_ice(:,:,:), dim=3 ) * tmask(:,:,1) ) ! Sublimation over sea-ice (cell average)
- CALL iom_put( 'hflx_subl_cea', SUM( a_i_b(:,:,:) * qevap_ice(:,:,:), dim=3 ) * tmask(:,:,1) ) ! Heat flux from sublimation (cell average)
+ CALL iom_put( 'subl_ai_cea' , SUM( a_i_b(:,:,:) * evap_ice(:,:,:), dim=3 ) * smask0(:,:) ) ! Sublimation over sea-ice (cell average)
+ CALL iom_put( 'hflx_subl_cea', SUM( a_i_b(:,:,:) * qevap_ice(:,:,:), dim=3 ) * smask0(:,:) ) ! Heat flux from sublimation (cell average)
ENDIF
!
IF(sn_cfctl%l_prtctl) THEN
- ALLOCATE(zmsk(jpi,jpj,jpl))
+ ALLOCATE(zmsk(A2D(0),jpl))
DO jl = 1, jpl
- zmsk(:,:,jl) = tmask(:,:,1)
+ zmsk(:,:,jl) = smask0(:,:)
END DO
CALL prt_ctl(tab3d_1=qla_ice , clinfo1=' blk_ice: qla_ice : ', mask1=zmsk, &
& tab3d_2=z_qsb , clinfo2=' z_qsb : ' , mask2=zmsk, kdim=jpl)
@@ -1321,7 +1303,7 @@ CONTAINS
CALL prt_ctl(tab3d_1=ptsu , clinfo1=' blk_ice: ptsu : ', mask1=zmsk, &
& tab3d_2=qns_ice , clinfo2=' qns_ice : ' , mask2=zmsk, kdim=jpl)
CALL prt_ctl(tab2d_1=tprecip , clinfo1=' blk_ice: tprecip : ', mask1=tmask, &
- & tab2d_2=sprecip , clinfo2=' sprecip : ' , mask2=tmask )
+ & tab2d_2=sprecip , clinfo2=' sprecip : ' , mask2=tmask )
DEALLOCATE(zmsk)
ENDIF
@@ -1335,7 +1317,9 @@ CONTAINS
END SUBROUTINE blk_ice_2
- SUBROUTINE blk_ice_qcn( ld_virtual_itd, ptsu, ptb, phs, phi )
+ SUBROUTINE blk_ice_qcn( ld_virtual_itd, ptb, phs, phi, & ! <<== in
+ & pqcn_ice, pqml_ice, & ! ==>> out
+ & pqns_ice, ptsu ) ! ==>> inout
!!---------------------------------------------------------------------
!! *** ROUTINE blk_ice_qcn ***
!!
@@ -1350,12 +1334,15 @@ CONTAINS
!! - qcn_ice : surface inner conduction flux (W/m2)
!!
!!---------------------------------------------------------------------
- LOGICAL , INTENT(in ) :: ld_virtual_itd ! single-category option
- REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: ptsu ! sea ice / snow surface temperature
- REAL(wp), DIMENSION(:,:) , INTENT(in ) :: ptb ! sea ice base temperature
- REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: phs ! snow thickness
- REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: phi ! sea ice thickness
- !
+ LOGICAL , INTENT(in ) :: ld_virtual_itd ! single-category option
+ REAL(wp), DIMENSION(A2D(0)) , INTENT(in ) :: ptb ! sea ice base temperature
+ REAL(wp), DIMENSION(A2D(0),jpl), INTENT(in ) :: phs ! snow thickness
+ REAL(wp), DIMENSION(A2D(0),jpl), INTENT(in ) :: phi ! sea ice thickness
+ REAL(wp), DIMENSION(A2D(0),jpl), INTENT( out) :: pqcn_ice
+ REAL(wp), DIMENSION(A2D(0),jpl), INTENT( out) :: pqml_ice
+ REAL(wp), DIMENSION(A2D(0),jpl), INTENT(inout) :: pqns_ice
+ REAL(wp), DIMENSION(A2D(0),jpl), INTENT(inout) :: ptsu ! sea ice / snow surface temperature
+ !
INTEGER , PARAMETER :: nit = 10 ! number of iterations
REAL(wp), PARAMETER :: zepsilon = 0.1_wp ! characteristic thickness for enhanced conduction
!
@@ -1365,7 +1352,7 @@ CONTAINS
REAL(wp) :: zkeff_h, ztsu, ztsu0 !
REAL(wp) :: zqc, zqnet !
REAL(wp) :: zhe, zqa0 !
- REAL(wp), DIMENSION(jpi,jpj,jpl) :: zgfac ! enhanced conduction factor
+ REAL(wp), DIMENSION(A2D(0),jpl) :: zgfac ! enhanced conduction factor
!!---------------------------------------------------------------------
! -------------------------------------!
@@ -1383,7 +1370,7 @@ CONTAINS
zfac3 = 2._wp / zepsilon
!
DO jl = 1, jpl
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
zhe = ( rn_cnd_s * phi(ji,jj,jl) + rcnd_i * phs(ji,jj,jl) ) * zfac ! Effective thickness
IF( zhe >= zfac2 ) zgfac(ji,jj,jl) = MIN( 2._wp, 0.5_wp * ( 1._wp + LOG( zhe * zfac3 ) ) ) ! Enhanced conduction factor
END_2D
@@ -1398,13 +1385,13 @@ CONTAINS
zfac = rcnd_i * rn_cnd_s
!
DO jl = 1, jpl
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
!
zkeff_h = zfac * zgfac(ji,jj,jl) / & ! Effective conductivity of the snow-ice system divided by thickness
& ( rcnd_i * phs(ji,jj,jl) + rn_cnd_s * MAX( 0.01, phi(ji,jj,jl) ) )
ztsu = ptsu(ji,jj,jl) ! Store current iteration temperature
ztsu0 = ptsu(ji,jj,jl) ! Store initial surface temperature
- zqa0 = qsr_ice(ji,jj,jl) - qtr_ice_top(ji,jj,jl) + qns_ice(ji,jj,jl) ! Net initial atmospheric heat flux
+ zqa0 = qsr_ice(ji,jj,jl) - qtr_ice_top(ji,jj,jl) + pqns_ice(ji,jj,jl) ! Net initial atmospheric heat flux
!
DO iter = 1, nit ! --- Iterative loop
zqc = zkeff_h * ( ztsu - ptb(ji,jj) ) ! Conduction heat flux through snow-ice system (>0 downwards)
@@ -1412,10 +1399,10 @@ CONTAINS
ztsu = ztsu - zqnet / ( dqns_ice(ji,jj,jl) - zkeff_h ) ! Temperature update
END DO
!
- ptsu (ji,jj,jl) = MIN( rt0, ztsu )
- qcn_ice(ji,jj,jl) = zkeff_h * ( ptsu(ji,jj,jl) - ptb(ji,jj) )
- qns_ice(ji,jj,jl) = qns_ice(ji,jj,jl) + dqns_ice(ji,jj,jl) * ( ptsu(ji,jj,jl) - ztsu0 )
- qml_ice(ji,jj,jl) = ( qsr_ice(ji,jj,jl) - qtr_ice_top(ji,jj,jl) + qns_ice(ji,jj,jl) - qcn_ice(ji,jj,jl) ) &
+ ptsu (ji,jj,jl) = MIN( rt0, ztsu )
+ pqcn_ice(ji,jj,jl) = zkeff_h * ( ptsu(ji,jj,jl) - ptb(ji,jj) )
+ pqns_ice(ji,jj,jl) = pqns_ice(ji,jj,jl) + dqns_ice(ji,jj,jl) * ( ptsu(ji,jj,jl) - ztsu0 )
+ pqml_ice(ji,jj,jl) = ( qsr_ice(ji,jj,jl) - qtr_ice_top(ji,jj,jl) + pqns_ice(ji,jj,jl) - pqcn_ice(ji,jj,jl) ) &
& * MAX( 0._wp , SIGN( 1._wp, ptsu(ji,jj,jl) - rt0 ) )
! --- Diagnose the heat loss due to changing non-solar flux (as in icethd_zdf_bl99) --- !
diff --git a/src/OCE/SBC/sbcblk_algo_andreas.F90 b/src/OCE/SBC/sbcblk_algo_andreas.F90
index 5a2eb4113595c75c929953fceb95da6314a69ff3..7145a156fe42b3e658dcbea788db44783a43a7c3 100644
--- a/src/OCE/SBC/sbcblk_algo_andreas.F90
+++ b/src/OCE/SBC/sbcblk_algo_andreas.F90
@@ -85,34 +85,34 @@ CONTAINS
!!
!! ** Author: L. Brodeau, June 2019 / AeroBulk (https://github.com/brodeau/aerobulk/)
!!----------------------------------------------------------------------------------
- REAL(wp), INTENT(in ) :: zt ! height for t_zt and q_zt [m]
- REAL(wp), INTENT(in ) :: zu ! height for U_zu [m]
- REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: sst ! sea surface temperature [Kelvin]
- REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: t_zt ! potential air temperature [Kelvin]
- REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: ssq ! sea surface specific humidity [kg/kg]
- REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: q_zt ! specific air humidity at zt [kg/kg]
- REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: U_zu ! relative wind module at zu [m/s]
- REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Cd ! transfer coefficient for momentum (tau)
- REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Ch ! transfer coefficient for sensible heat (Q_sens)
- REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Ce ! transfert coefficient for evaporation (Q_lat)
- REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: t_zu ! pot. air temp. adjusted at zu [K]
- REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: q_zu ! spec. humidity adjusted at zu [kg/kg]
- REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Ubzu ! bulk wind speed at zu [m/s]
+ REAL(wp), INTENT(in ) :: zt ! height for t_zt and q_zt [m]
+ REAL(wp), INTENT(in ) :: zu ! height for U_zu [m]
+ REAL(wp), INTENT(in ), DIMENSION(A2D(0)) :: sst ! sea surface temperature [Kelvin]
+ REAL(wp), INTENT(in ), DIMENSION(A2D(0)) :: t_zt ! potential air temperature [Kelvin]
+ REAL(wp), INTENT(in ), DIMENSION(A2D(0)) :: ssq ! sea surface specific humidity [kg/kg]
+ REAL(wp), INTENT(in ), DIMENSION(A2D(0)) :: q_zt ! specific air humidity at zt [kg/kg]
+ REAL(wp), INTENT(in ), DIMENSION(A2D(0)) :: U_zu ! relative wind module at zu [m/s]
+ REAL(wp), INTENT( out), DIMENSION(A2D(0)) :: Cd ! transfer coefficient for momentum (tau)
+ REAL(wp), INTENT( out), DIMENSION(A2D(0)) :: Ch ! transfer coefficient for sensible heat (Q_sens)
+ REAL(wp), INTENT( out), DIMENSION(A2D(0)) :: Ce ! transfert coefficient for evaporation (Q_lat)
+ REAL(wp), INTENT( out), DIMENSION(A2D(0)) :: t_zu ! pot. air temp. adjusted at zu [K]
+ REAL(wp), INTENT( out), DIMENSION(A2D(0)) :: q_zu ! spec. humidity adjusted at zu [kg/kg]
+ REAL(wp), INTENT( out), DIMENSION(A2D(0)) :: Ubzu ! bulk wind speed at zu [m/s]
!
INTEGER , INTENT(in ), OPTIONAL :: nb_iter ! number of iterations
- REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: CdN
- REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: ChN
- REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: CeN
+ REAL(wp), INTENT( out), OPTIONAL, DIMENSION(A2D(0)) :: CdN
+ REAL(wp), INTENT( out), OPTIONAL, DIMENSION(A2D(0)) :: ChN
+ REAL(wp), INTENT( out), OPTIONAL, DIMENSION(A2D(0)) :: CeN
!
INTEGER :: nbit, jit ! iterations...
LOGICAL :: l_zt_equal_zu = .FALSE. ! if q and t are given at same height as U
!!
- REAL(wp), DIMENSION(jpi,jpj) :: u_star, t_star, q_star
- REAL(wp), DIMENSION(jpi,jpj) :: z0 ! roughness length (momentum) [m]
- REAL(wp), DIMENSION(jpi,jpj) :: UN10 ! Neutral wind speed at zu [m/s]
- REAL(wp), DIMENSION(jpi,jpj) :: zeta_u ! stability parameter at height zu
- REAL(wp), DIMENSION(jpi,jpj) :: ztmp0, ztmp1, ztmp2
- REAL(wp), DIMENSION(jpi,jpj) :: RiB ! square root of Cd
+ REAL(wp), DIMENSION(A2D(0)) :: u_star, t_star, q_star
+ REAL(wp), DIMENSION(A2D(0)) :: z0 ! roughness length (momentum) [m]
+ REAL(wp), DIMENSION(A2D(0)) :: UN10 ! Neutral wind speed at zu [m/s]
+ REAL(wp), DIMENSION(A2D(0)) :: zeta_u ! stability parameter at height zu
+ REAL(wp), DIMENSION(A2D(0)) :: ztmp0, ztmp1, ztmp2
+ REAL(wp), DIMENSION(A2D(0)) :: RiB ! square root of Cd
!!
!!----------------------------------------------------------------------------------
nbit = nb_iter0
@@ -217,13 +217,13 @@ CONTAINS
!!
!! ** Author: L. Brodeau, April 2020 / AeroBulk (https://github.com/brodeau/aerobulk/)
!!----------------------------------------------------------------------------------
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pun10 !: neutral-stability scalar wind speed at 10m (m/s)
- REAL(wp), DIMENSION(jpi,jpj) :: u_star_andreas !: friction velocity [m/s]
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pun10 !: neutral-stability scalar wind speed at 10m (m/s)
+ REAL(wp), DIMENSION(A2D(0)) :: u_star_andreas !: friction velocity [m/s]
!
INTEGER :: ji, jj ! dummy loop indices
REAL(wp) :: za, zt, zw ! local scalars
!!----------------------------------------------------------------------------------
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
zw = pun10(ji,jj)
za = zw - 8.271_wp
zt = za + SQRT( 0.12_wp*za*za + 0.181_wp )
@@ -243,8 +243,8 @@ CONTAINS
!!
!! ** Author: L. Brodeau, April 2020 / AeroBulk (https://github.com/brodeau/aerobulk/)
!!----------------------------------------------------------------------------------
- REAL(wp), DIMENSION(jpi,jpj) :: psi_m_andreas
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pzeta
+ REAL(wp), DIMENSION(A2D(0)) :: psi_m_andreas
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pzeta
!
REAL(wp), PARAMETER :: zam = 5._wp ! a_m (just below Eq.(9b)
REAL(wp), PARAMETER :: zbm = zam/6.5_wp ! b_m (just below Eq.(9b)
@@ -255,7 +255,7 @@ CONTAINS
INTEGER :: ji, jj ! dummy loop indices
REAL(wp) :: zta, zx2, zx, zpsi_unst, zbbm, zpsi_stab, zstab ! local scalars
!!----------------------------------------------------------------------------------
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
!
zta = MIN( pzeta(ji,jj) , 15._wp ) !! Very stable conditions (L positif and big!)
!
@@ -298,8 +298,8 @@ CONTAINS
!!
!! ** Author: L. Brodeau, June 2016 / AeroBulk (https://github.com/brodeau/aerobulk/)
!!----------------------------------------------------------------------------------
- REAL(wp), DIMENSION(jpi,jpj) :: psi_h_andreas
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pzeta
+ REAL(wp), DIMENSION(A2D(0)) :: psi_h_andreas
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pzeta
!
REAL(wp), PARAMETER :: zah = 5._wp ! a_h (just below Eq.(9b)
REAL(wp), PARAMETER :: zbh = 5._wp ! b_h (just below Eq.(9b)
@@ -309,7 +309,7 @@ CONTAINS
INTEGER :: ji, jj ! dummy loop indices
REAL(wp) :: zta, zz, zx2, zpsi_unst, zpsi_stab, zstab ! local scalars
!!----------------------------------------------------------------------------------
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
!
zta = MIN( pzeta(ji,jj) , 15._wp ) !! Very stable conditions (L positif and large!)
!
diff --git a/src/OCE/SBC/sbcblk_algo_coare3p0.F90 b/src/OCE/SBC/sbcblk_algo_coare3p0.F90
index 2ad244fcb4d788a921e25c502cfd966d479db70f..cd3da3ebd6b5853f812570fb9d666c583ed28080 100644
--- a/src/OCE/SBC/sbcblk_algo_coare3p0.F90
+++ b/src/OCE/SBC/sbcblk_algo_coare3p0.F90
@@ -71,7 +71,7 @@ CONTAINS
!!---------------------------------------------------------------------
IF( l_use_wl ) THEN
ierr = 0
- ALLOCATE ( Tau_ac(jpi,jpj) , Qnt_ac(jpi,jpj), dT_wl(jpi,jpj), Hz_wl(jpi,jpj), STAT=ierr )
+ ALLOCATE ( Tau_ac(A2D(0)) , Qnt_ac(A2D(0)), dT_wl(A2D(0)), Hz_wl(A2D(0)), STAT=ierr )
IF( ierr > 0 ) CALL ctl_stop( ' SBCBLK_ALGO_COARE3P0_INIT => allocation of Tau_ac, Qnt_ac, dT_wl & Hz_wl failed!' )
Tau_ac(:,:) = 0._wp
Qnt_ac(:,:) = 0._wp
@@ -80,7 +80,7 @@ CONTAINS
ENDIF
IF( l_use_cs ) THEN
ierr = 0
- ALLOCATE ( dT_cs(jpi,jpj), STAT=ierr )
+ ALLOCATE ( dT_cs(A2D(0)), STAT=ierr )
IF( ierr > 0 ) CALL ctl_stop( ' SBCBLK_ALGO_COARE3P0_INIT => allocation of dT_cs failed!' )
dT_cs(:,:) = -0.25_wp ! First guess of skin correction
ENDIF
@@ -151,44 +151,44 @@ CONTAINS
!!
!! ** Author: L. Brodeau, June 2019 / AeroBulk (https://github.com/brodeau/aerobulk/)
!!----------------------------------------------------------------------------------
- INTEGER, INTENT(in ) :: kt ! current time step
- REAL(wp), INTENT(in ) :: zt ! height for t_zt and q_zt [m]
- REAL(wp), INTENT(in ) :: zu ! height for U_zu [m]
- REAL(wp), INTENT(inout), DIMENSION(jpi,jpj) :: T_s ! sea surface temperature [Kelvin]
- REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: t_zt ! potential air temperature [Kelvin]
- REAL(wp), INTENT(inout), DIMENSION(jpi,jpj) :: q_s ! sea surface specific humidity [kg/kg]
- REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: q_zt ! specific air humidity at zt [kg/kg]
- REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: U_zu ! relative wind module at zu [m/s]
- LOGICAL , INTENT(in ) :: l_use_cs ! use the cool-skin parameterization
- LOGICAL , INTENT(in ) :: l_use_wl ! use the warm-layer parameterization
- REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Cd ! transfer coefficient for momentum (tau)
- REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Ch ! transfer coefficient for sensible heat (Q_sens)
- REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Ce ! transfert coefficient for evaporation (Q_lat)
- REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: t_zu ! pot. air temp. adjusted at zu [K]
- REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: q_zu ! spec. humidity adjusted at zu [kg/kg]
- REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Ubzu ! bulk wind speed at zu [m/s]
+ INTEGER, INTENT(in ) :: kt ! current time step
+ REAL(wp), INTENT(in ) :: zt ! height for t_zt and q_zt [m]
+ REAL(wp), INTENT(in ) :: zu ! height for U_zu [m]
+ REAL(wp), INTENT(inout), DIMENSION(A2D(0)) :: T_s ! sea surface temperature [Kelvin]
+ REAL(wp), INTENT(in ), DIMENSION(A2D(0)) :: t_zt ! potential air temperature [Kelvin]
+ REAL(wp), INTENT(inout), DIMENSION(A2D(0)) :: q_s ! sea surface specific humidity [kg/kg]
+ REAL(wp), INTENT(in ), DIMENSION(A2D(0)) :: q_zt ! specific air humidity at zt [kg/kg]
+ REAL(wp), INTENT(in ), DIMENSION(A2D(0)) :: U_zu ! relative wind module at zu [m/s]
+ LOGICAL , INTENT(in ) :: l_use_cs ! use the cool-skin parameterization
+ LOGICAL , INTENT(in ) :: l_use_wl ! use the warm-layer parameterization
+ REAL(wp), INTENT( out), DIMENSION(A2D(0)) :: Cd ! transfer coefficient for momentum (tau)
+ REAL(wp), INTENT( out), DIMENSION(A2D(0)) :: Ch ! transfer coefficient for sensible heat (Q_sens)
+ REAL(wp), INTENT( out), DIMENSION(A2D(0)) :: Ce ! transfert coefficient for evaporation (Q_lat)
+ REAL(wp), INTENT( out), DIMENSION(A2D(0)) :: t_zu ! pot. air temp. adjusted at zu [K]
+ REAL(wp), INTENT( out), DIMENSION(A2D(0)) :: q_zu ! spec. humidity adjusted at zu [kg/kg]
+ REAL(wp), INTENT( out), DIMENSION(A2D(0)) :: Ubzu ! bulk wind speed at zu [m/s]
!
- INTEGER , INTENT(in ), OPTIONAL :: nb_iter ! number of iterations
- REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: CdN
- REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: ChN
- REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: CeN
- REAL(wp), INTENT(in ), OPTIONAL, DIMENSION(jpi,jpj) :: Qsw ! [W/m^2]
- REAL(wp), INTENT(in ), OPTIONAL, DIMENSION(jpi,jpj) :: rad_lw ! [W/m^2]
- REAL(wp), INTENT(in ), OPTIONAL, DIMENSION(jpi,jpj) :: slp ! [Pa]
- REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: pdT_cs
- REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: pdT_wl ! [K]
- REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: pHz_wl ! [m]
+ INTEGER , INTENT(in ), OPTIONAL :: nb_iter ! number of iterations
+ REAL(wp), INTENT( out), OPTIONAL, DIMENSION(A2D(0)) :: CdN
+ REAL(wp), INTENT( out), OPTIONAL, DIMENSION(A2D(0)) :: ChN
+ REAL(wp), INTENT( out), OPTIONAL, DIMENSION(A2D(0)) :: CeN
+ REAL(wp), INTENT(in ), OPTIONAL, DIMENSION(A2D(0)) :: Qsw ! [W/m^2]
+ REAL(wp), INTENT(in ), OPTIONAL, DIMENSION(A2D(0)) :: rad_lw ! [W/m^2]
+ REAL(wp), INTENT(in ), OPTIONAL, DIMENSION(A2D(0)) :: slp ! [Pa]
+ REAL(wp), INTENT( out), OPTIONAL, DIMENSION(A2D(0)) :: pdT_cs
+ REAL(wp), INTENT( out), OPTIONAL, DIMENSION(A2D(0)) :: pdT_wl ! [K]
+ REAL(wp), INTENT( out), OPTIONAL, DIMENSION(A2D(0)) :: pHz_wl ! [m]
!
INTEGER :: nbit, jit
LOGICAL :: l_zt_equal_zu = .FALSE. ! if q and t are given at same height as U
!
- REAL(wp), DIMENSION(jpi,jpj) :: u_star, t_star, q_star
- REAL(wp), DIMENSION(jpi,jpj) :: dt_zu, dq_zu
- REAL(wp), DIMENSION(jpi,jpj) :: znu_a !: Nu_air, Viscosity of air
- REAL(wp), DIMENSION(jpi,jpj) :: z0, z0t
- REAL(wp), DIMENSION(jpi,jpj) :: zeta_u ! stability parameter at height zu
- REAL(wp), DIMENSION(jpi,jpj) :: ztmp0, ztmp1, ztmp2
- REAL(wp), DIMENSION(jpi,jpj) :: zpre, zrhoa, zta ! air pressure [Pa], density [kg/m3] & absolute temperature [k]
+ REAL(wp), DIMENSION(A2D(0)) :: u_star, t_star, q_star
+ REAL(wp), DIMENSION(A2D(0)) :: dt_zu, dq_zu
+ REAL(wp), DIMENSION(A2D(0)) :: znu_a !: Nu_air, Viscosity of air
+ REAL(wp), DIMENSION(A2D(0)) :: z0, z0t
+ REAL(wp), DIMENSION(A2D(0)) :: zeta_u ! stability parameter at height zu
+ REAL(wp), DIMENSION(A2D(0)) :: ztmp0, ztmp1, ztmp2
+ REAL(wp), DIMENSION(A2D(0)) :: zpre, zrhoa, zta ! air pressure [Pa], density [kg/m3] & absolute temperature [k]
!
REAL(wp), DIMENSION(:,:), ALLOCATABLE :: zeta_t ! stability parameter at height zt
REAL(wp), DIMENSION(:,:), ALLOCATABLE :: zsst ! to back up the initial bulk SST
@@ -201,7 +201,7 @@ CONTAINS
IF( PRESENT(nb_iter) ) nbit = nb_iter
l_zt_equal_zu = ( ABS(zu - zt) < 0.01_wp ) ! testing "zu == zt" is risky with double precision
- IF( .NOT. l_zt_equal_zu ) ALLOCATE( zeta_t(jpi,jpj) )
+ IF( .NOT. l_zt_equal_zu ) ALLOCATE( zeta_t(A2D(0)) )
!! Initializations for cool skin and warm layer:
IF( l_use_cs .AND. (.NOT.(PRESENT(Qsw) .AND. PRESENT(rad_lw) .AND. PRESENT(slp))) ) &
@@ -211,7 +211,7 @@ CONTAINS
& CALL ctl_stop( '['//TRIM(crtnm)//'] => ' , 'you need to provide Qsw, rad_lw & slp to use warm-layer param!' )
IF( l_use_cs .OR. l_use_wl ) THEN
- ALLOCATE ( zsst(jpi,jpj) )
+ ALLOCATE ( zsst(A2D(0)) )
zsst = T_s ! backing up the bulk SST
IF( l_use_cs ) T_s = T_s - 0.25_wp ! First guess of correction
q_s = rdct_qsat_salt*q_sat(MAX(T_s, 200._wp), slp) ! First guess of q_s
@@ -334,8 +334,8 @@ CONTAINS
CALL CS_COARE( Qsw, ztmp1, u_star, zsst, ztmp2 ) ! ! Qnsol -> ztmp1 / Qlat -> ztmp2
- T_s(:,:) = zsst(:,:) + dT_cs(:,:)*tmask(:,:,1)
- IF( l_use_wl ) T_s(:,:) = T_s(:,:) + dT_wl(:,:)*tmask(:,:,1)
+ T_s(:,:) = zsst(:,:) + dT_cs(:,:)*smask0(:,:)
+ IF( l_use_wl ) T_s(:,:) = T_s(:,:) + dT_wl(:,:)*smask0(:,:)
q_s(:,:) = rdct_qsat_salt*q_sat(MAX(T_s(:,:), 200._wp), slp(:,:))
ENDIF
@@ -347,8 +347,8 @@ CONTAINS
CALL WL_COARE( Qsw, ztmp1, zeta_u, zsst, MOD(nbit,jit) )
!! Updating T_s and q_s !!!
- T_s(:,:) = zsst(:,:) + dT_wl(:,:)*tmask(:,:,1)
- IF( l_use_cs ) T_s(:,:) = T_s(:,:) + dT_cs(:,:)*tmask(:,:,1)
+ T_s(:,:) = zsst(:,:) + dT_wl(:,:)*smask0(:,:)
+ IF( l_use_cs ) T_s(:,:) = T_s(:,:) + dT_cs(:,:)*smask0(:,:)
q_s(:,:) = rdct_qsat_salt*q_sat(MAX(T_s(:,:), 200._wp), slp(:,:))
ENDIF
@@ -392,13 +392,13 @@ CONTAINS
!!
!! Author: L. Brodeau, June 2016 / AeroBulk (https://github.com/brodeau/aerobulk/)
!!-------------------------------------------------------------------
- REAL(wp), DIMENSION(jpi,jpj) :: charn_coare3p0
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pwnd ! wind speed
+ REAL(wp), DIMENSION(A2D(0)) :: charn_coare3p0
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pwnd ! wind speed
!
INTEGER :: ji, jj ! dummy loop indices
REAL(wp) :: zw, zgt10, zgt18
!!-------------------------------------------------------------------
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
!
zw = pwnd(ji,jj) ! wind speed
!
@@ -426,13 +426,13 @@ CONTAINS
!!
!! ** Author: L. Brodeau, June 2016 / AeroBulk (https://github.com/brodeau/aerobulk/)
!!----------------------------------------------------------------------------------
- REAL(wp), DIMENSION(jpi,jpj) :: psi_m_coare
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pzeta
+ REAL(wp), DIMENSION(A2D(0)) :: psi_m_coare
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pzeta
!
INTEGER :: ji, jj ! dummy loop indices
REAL(wp) :: zta, zphi_m, zphi_c, zpsi_k, zpsi_c, zf, zc, zstab
!!----------------------------------------------------------------------------------
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
!
zta = pzeta(ji,jj)
!
@@ -474,13 +474,13 @@ CONTAINS
!! Author: L. Brodeau, June 2016 / AeroBulk
!! (https://github.com/brodeau/aerobulk/)
!!----------------------------------------------------------------
- REAL(wp), DIMENSION(jpi,jpj) :: psi_h_coare
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pzeta
+ REAL(wp), DIMENSION(A2D(0)) :: psi_h_coare
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pzeta
!
INTEGER :: ji, jj ! dummy loop indices
REAL(wp) :: zta, zphi_h, zphi_c, zpsi_k, zpsi_c, zf, zc, zstab
!!----------------------------------------------------------------
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
!
zta = pzeta(ji,jj)
!
diff --git a/src/OCE/SBC/sbcblk_algo_coare3p6.F90 b/src/OCE/SBC/sbcblk_algo_coare3p6.F90
index cb7fff12b99999e0c740d5d8a23393f8dcfec3e7..50f6800a0cd9b34f82ff23ae01ecbf999d654f39 100644
--- a/src/OCE/SBC/sbcblk_algo_coare3p6.F90
+++ b/src/OCE/SBC/sbcblk_algo_coare3p6.F90
@@ -61,7 +61,7 @@ CONTAINS
!!---------------------------------------------------------------------
IF( l_use_wl ) THEN
ierr = 0
- ALLOCATE ( Tau_ac(jpi,jpj) , Qnt_ac(jpi,jpj), dT_wl(jpi,jpj), Hz_wl(jpi,jpj), STAT=ierr )
+ ALLOCATE ( Tau_ac(A2D(0)) , Qnt_ac(A2D(0)), dT_wl(A2D(0)), Hz_wl(A2D(0)), STAT=ierr )
IF( ierr > 0 ) CALL ctl_stop( ' SBCBLK_ALGO_COARE3P6_INIT => allocation of Tau_ac, Qnt_ac, dT_wl & Hz_wl failed!' )
Tau_ac(:,:) = 0._wp
Qnt_ac(:,:) = 0._wp
@@ -70,7 +70,7 @@ CONTAINS
ENDIF
IF( l_use_cs ) THEN
ierr = 0
- ALLOCATE ( dT_cs(jpi,jpj), STAT=ierr )
+ ALLOCATE ( dT_cs(A2D(0)), STAT=ierr )
IF( ierr > 0 ) CALL ctl_stop( ' SBCBLK_ALGO_COARE3P6_INIT => allocation of dT_cs failed!' )
dT_cs(:,:) = -0.25_wp ! First guess of skin correction
ENDIF
@@ -141,44 +141,44 @@ CONTAINS
!!
!! ** Author: L. Brodeau, June 2019 / AeroBulk (https://github.com/brodeau/aerobulk/)
!!----------------------------------------------------------------------------------
- INTEGER, INTENT(in ) :: kt ! current time step
- REAL(wp), INTENT(in ) :: zt ! height for t_zt and q_zt [m]
- REAL(wp), INTENT(in ) :: zu ! height for U_zu [m]
- REAL(wp), INTENT(inout), DIMENSION(jpi,jpj) :: T_s ! sea surface temperature [Kelvin]
- REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: t_zt ! potential air temperature [Kelvin]
- REAL(wp), INTENT(inout), DIMENSION(jpi,jpj) :: q_s ! sea surface specific humidity [kg/kg]
- REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: q_zt ! specific air humidity at zt [kg/kg]
- REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: U_zu ! relative wind module at zu [m/s]
- LOGICAL , INTENT(in ) :: l_use_cs ! use the cool-skin parameterization
- LOGICAL , INTENT(in ) :: l_use_wl ! use the warm-layer parameterization
- REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Cd ! transfer coefficient for momentum (tau)
- REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Ch ! transfer coefficient for sensible heat (Q_sens)
- REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Ce ! transfert coefficient for evaporation (Q_lat)
- REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: t_zu ! pot. air temp. adjusted at zu [K]
- REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: q_zu ! spec. humidity adjusted at zu [kg/kg]
- REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Ubzu ! bulk wind speed at zu [m/s]
+ INTEGER, INTENT(in ) :: kt ! current time step
+ REAL(wp), INTENT(in ) :: zt ! height for t_zt and q_zt [m]
+ REAL(wp), INTENT(in ) :: zu ! height for U_zu [m]
+ REAL(wp), INTENT(inout), DIMENSION(A2D(0)) :: T_s ! sea surface temperature [Kelvin]
+ REAL(wp), INTENT(in ), DIMENSION(A2D(0)) :: t_zt ! potential air temperature [Kelvin]
+ REAL(wp), INTENT(inout), DIMENSION(A2D(0)) :: q_s ! sea surface specific humidity [kg/kg]
+ REAL(wp), INTENT(in ), DIMENSION(A2D(0)) :: q_zt ! specific air humidity at zt [kg/kg]
+ REAL(wp), INTENT(in ), DIMENSION(A2D(0)) :: U_zu ! relative wind module at zu [m/s]
+ LOGICAL , INTENT(in ) :: l_use_cs ! use the cool-skin parameterization
+ LOGICAL , INTENT(in ) :: l_use_wl ! use the warm-layer parameterization
+ REAL(wp), INTENT( out), DIMENSION(A2D(0)) :: Cd ! transfer coefficient for momentum (tau)
+ REAL(wp), INTENT( out), DIMENSION(A2D(0)) :: Ch ! transfer coefficient for sensible heat (Q_sens)
+ REAL(wp), INTENT( out), DIMENSION(A2D(0)) :: Ce ! transfert coefficient for evaporation (Q_lat)
+ REAL(wp), INTENT( out), DIMENSION(A2D(0)) :: t_zu ! pot. air temp. adjusted at zu [K]
+ REAL(wp), INTENT( out), DIMENSION(A2D(0)) :: q_zu ! spec. humidity adjusted at zu [kg/kg]
+ REAL(wp), INTENT( out), DIMENSION(A2D(0)) :: Ubzu ! bulk wind speed at zu [m/s]
!
- INTEGER , INTENT(in ), OPTIONAL :: nb_iter ! number of iterations
- REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: CdN
- REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: ChN
- REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: CeN
- REAL(wp), INTENT(in ), OPTIONAL, DIMENSION(jpi,jpj) :: Qsw ! [W/m^2]
- REAL(wp), INTENT(in ), OPTIONAL, DIMENSION(jpi,jpj) :: rad_lw ! [W/m^2]
- REAL(wp), INTENT(in ), OPTIONAL, DIMENSION(jpi,jpj) :: slp ! [Pa]
- REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: pdT_cs
- REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: pdT_wl ! [K]
- REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: pHz_wl ! [m]
+ INTEGER , INTENT(in ), OPTIONAL :: nb_iter ! number of iterations
+ REAL(wp), INTENT( out), OPTIONAL, DIMENSION(A2D(0)) :: CdN
+ REAL(wp), INTENT( out), OPTIONAL, DIMENSION(A2D(0)) :: ChN
+ REAL(wp), INTENT( out), OPTIONAL, DIMENSION(A2D(0)) :: CeN
+ REAL(wp), INTENT(in ), OPTIONAL, DIMENSION(A2D(0)) :: Qsw ! [W/m^2]
+ REAL(wp), INTENT(in ), OPTIONAL, DIMENSION(A2D(0)) :: rad_lw ! [W/m^2]
+ REAL(wp), INTENT(in ), OPTIONAL, DIMENSION(A2D(0)) :: slp ! [Pa]
+ REAL(wp), INTENT( out), OPTIONAL, DIMENSION(A2D(0)) :: pdT_cs
+ REAL(wp), INTENT( out), OPTIONAL, DIMENSION(A2D(0)) :: pdT_wl ! [K]
+ REAL(wp), INTENT( out), OPTIONAL, DIMENSION(A2D(0)) :: pHz_wl ! [m]
!
INTEGER :: nbit, jit
LOGICAL :: l_zt_equal_zu = .FALSE. ! if q and t are given at same height as U
!
- REAL(wp), DIMENSION(jpi,jpj) :: u_star, t_star, q_star
- REAL(wp), DIMENSION(jpi,jpj) :: dt_zu, dq_zu
- REAL(wp), DIMENSION(jpi,jpj) :: znu_a !: Nu_air, Viscosity of air
- REAL(wp), DIMENSION(jpi,jpj) :: z0, z0t
- REAL(wp), DIMENSION(jpi,jpj) :: zeta_u ! stability parameter at height zu
- REAL(wp), DIMENSION(jpi,jpj) :: ztmp0, ztmp1, ztmp2
- REAL(wp), DIMENSION(jpi,jpj) :: zpre, zrhoa, zta ! air pressure [Pa], density [kg/m3] & absolute temperature [k]
+ REAL(wp), DIMENSION(A2D(0)) :: u_star, t_star, q_star
+ REAL(wp), DIMENSION(A2D(0)) :: dt_zu, dq_zu
+ REAL(wp), DIMENSION(A2D(0)) :: znu_a !: Nu_air, Viscosity of air
+ REAL(wp), DIMENSION(A2D(0)) :: z0, z0t
+ REAL(wp), DIMENSION(A2D(0)) :: zeta_u ! stability parameter at height zu
+ REAL(wp), DIMENSION(A2D(0)) :: ztmp0, ztmp1, ztmp2
+ REAL(wp), DIMENSION(A2D(0)) :: zpre, zrhoa, zta ! air pressure [Pa], density [kg/m3] & absolute temperature [k]
!
REAL(wp), DIMENSION(:,:), ALLOCATABLE :: zeta_t ! stability parameter at height zt
REAL(wp), DIMENSION(:,:), ALLOCATABLE :: zsst ! to back up the initial bulk SST
@@ -191,7 +191,7 @@ CONTAINS
IF( PRESENT(nb_iter) ) nbit = nb_iter
l_zt_equal_zu = ( ABS(zu - zt) < 0.01_wp ) ! testing "zu == zt" is risky with double precision
- IF( .NOT. l_zt_equal_zu ) ALLOCATE( zeta_t(jpi,jpj) )
+ IF( .NOT. l_zt_equal_zu ) ALLOCATE( zeta_t(A2D(0)) )
!! Initializations for cool skin and warm layer:
IF( l_use_cs .AND. (.NOT.(PRESENT(Qsw) .AND. PRESENT(rad_lw) .AND. PRESENT(slp))) ) &
@@ -201,7 +201,7 @@ CONTAINS
& CALL ctl_stop( '['//TRIM(crtnm)//'] => ' , 'you need to provide Qsw, rad_lw & slp to use warm-layer param!' )
IF( l_use_cs .OR. l_use_wl ) THEN
- ALLOCATE ( zsst(jpi,jpj) )
+ ALLOCATE ( zsst(A2D(0)) )
zsst = T_s ! backing up the bulk SST
IF( l_use_cs ) T_s = T_s - 0.25_wp ! First guess of correction
q_s = rdct_qsat_salt*q_sat(MAX(T_s, 200._wp), slp) ! First guess of q_s
@@ -324,8 +324,8 @@ CONTAINS
CALL CS_COARE( Qsw, ztmp1, u_star, zsst, ztmp2 ) ! ! Qnsol -> ztmp1 / Qlat -> ztmp2
- T_s(:,:) = zsst(:,:) + dT_cs(:,:)*tmask(:,:,1)
- IF( l_use_wl ) T_s(:,:) = T_s(:,:) + dT_wl(:,:)*tmask(:,:,1)
+ T_s(:,:) = zsst(:,:) + dT_cs(:,:)*smask0(:,:)
+ IF( l_use_wl ) T_s(:,:) = T_s(:,:) + dT_wl(:,:)*smask0(:,:)
q_s(:,:) = rdct_qsat_salt*q_sat(MAX(T_s(:,:), 200._wp), slp(:,:))
ENDIF
@@ -337,8 +337,8 @@ CONTAINS
CALL WL_COARE( Qsw, ztmp1, zeta_u, zsst, MOD(nbit,jit) )
!! Updating T_s and q_s !!!
- T_s(:,:) = zsst(:,:) + dT_wl(:,:)*tmask(:,:,1)
- IF( l_use_cs ) T_s(:,:) = T_s(:,:) + dT_cs(:,:)*tmask(:,:,1)
+ T_s(:,:) = zsst(:,:) + dT_wl(:,:)*smask0(:,:)
+ IF( l_use_cs ) T_s(:,:) = T_s(:,:) + dT_cs(:,:)*smask0(:,:)
q_s(:,:) = rdct_qsat_salt*q_sat(MAX(T_s(:,:), 200._wp), slp(:,:))
ENDIF
@@ -378,8 +378,8 @@ CONTAINS
!!
!! Author: L. Brodeau, July 2019 / AeroBulk (https://github.com/brodeau/aerobulk/)
!!-------------------------------------------------------------------
- REAL(wp), DIMENSION(jpi,jpj) :: charn_coare3p6
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pwnd ! neutral wind speed at 10m
+ REAL(wp), DIMENSION(A2D(0)) :: charn_coare3p6
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pwnd ! neutral wind speed at 10m
!
REAL(wp), PARAMETER :: charn0_max = 0.028 !: value above which the Charnock parameter levels off for winds > 18 m/s
!!-------------------------------------------------------------------
@@ -395,10 +395,10 @@ CONTAINS
!!
!! Author: L. Brodeau, October 2019 / AeroBulk (https://github.com/brodeau/aerobulk/)
!!-------------------------------------------------------------------
- REAL(wp), DIMENSION(jpi,jpj) :: charn_coare3p6_wave
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pus ! friction velocity [m/s]
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pwsh ! significant wave height [m]
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pwps ! phase speed of dominant waves [m/s]
+ REAL(wp), DIMENSION(A2D(0)) :: charn_coare3p6_wave
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pus ! friction velocity [m/s]
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pwsh ! significant wave height [m]
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pwps ! phase speed of dominant waves [m/s]
!!-------------------------------------------------------------------
charn_coare3p6_wave = ( pwsh*0.2_wp*(pus/pwps)**2.2_wp ) * grav/(pus*pus)
!!
@@ -418,13 +418,13 @@ CONTAINS
!!
!! ** Author: L. Brodeau, June 2016 / AeroBulk (https://github.com/brodeau/aerobulk/)
!!----------------------------------------------------------------------------------
- REAL(wp), DIMENSION(jpi,jpj) :: psi_m_coare
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pzeta
+ REAL(wp), DIMENSION(A2D(0)) :: psi_m_coare
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pzeta
!
INTEGER :: ji, jj ! dummy loop indices
REAL(wp) :: zta, zphi_m, zphi_c, zpsi_k, zpsi_c, zf, zc, zstab
!!----------------------------------------------------------------------------------
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
!
zta = pzeta(ji,jj)
!
@@ -466,13 +466,13 @@ CONTAINS
!! Author: L. Brodeau, June 2016 / AeroBulk
!! (https://github.com/brodeau/aerobulk/)
!!----------------------------------------------------------------
- REAL(wp), DIMENSION(jpi,jpj) :: psi_h_coare
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pzeta
+ REAL(wp), DIMENSION(A2D(0)) :: psi_h_coare
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pzeta
!
INTEGER :: ji, jj ! dummy loop indices
REAL(wp) :: zta, zphi_h, zphi_c, zpsi_k, zpsi_c, zf, zc, zstab
!!----------------------------------------------------------------
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
!
zta = pzeta(ji,jj)
!
diff --git a/src/OCE/SBC/sbcblk_algo_ecmwf.F90 b/src/OCE/SBC/sbcblk_algo_ecmwf.F90
index d86c997565a355c17a2eee34b0f6b1ab72c06b92..eb316c81a35d78dbbe837788e3d03a477cad8f03 100644
--- a/src/OCE/SBC/sbcblk_algo_ecmwf.F90
+++ b/src/OCE/SBC/sbcblk_algo_ecmwf.F90
@@ -69,14 +69,14 @@ CONTAINS
!!---------------------------------------------------------------------
IF( l_use_wl ) THEN
ierr = 0
- ALLOCATE ( dT_wl(jpi,jpj), Hz_wl(jpi,jpj), STAT=ierr )
+ ALLOCATE ( dT_wl(A2D(0)), Hz_wl(A2D(0)), STAT=ierr )
IF( ierr > 0 ) CALL ctl_stop( ' SBCBLK_ALGO_ECMWF_INIT => allocation of dT_wl & Hz_wl failed!' )
dT_wl(:,:) = 0._wp
Hz_wl(:,:) = rd0 ! (rd0, constant, = 3m is default for Zeng & Beljaars)
ENDIF
IF( l_use_cs ) THEN
ierr = 0
- ALLOCATE ( dT_cs(jpi,jpj), STAT=ierr )
+ ALLOCATE ( dT_cs(A2D(0)), STAT=ierr )
IF( ierr > 0 ) CALL ctl_stop( ' SBCBLK_ALGO_ECMWF_INIT => allocation of dT_cs failed!' )
dT_cs(:,:) = -0.25_wp ! First guess of skin correction
ENDIF
@@ -147,48 +147,48 @@ CONTAINS
!!
!! ** Author: L. Brodeau, June 2019 / AeroBulk (https://github.com/brodeau/aerobulk/)
!!----------------------------------------------------------------------------------
- INTEGER, INTENT(in ) :: kt ! current time step
- REAL(wp), INTENT(in ) :: zt ! height for t_zt and q_zt [m]
- REAL(wp), INTENT(in ) :: zu ! height for U_zu [m]
- REAL(wp), INTENT(inout), DIMENSION(jpi,jpj) :: T_s ! sea surface temperature [Kelvin]
- REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: t_zt ! potential air temperature [Kelvin]
- REAL(wp), INTENT(inout), DIMENSION(jpi,jpj) :: q_s ! sea surface specific humidity [kg/kg]
- REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: q_zt ! specific air humidity at zt [kg/kg]
- REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: U_zu ! relative wind module at zu [m/s]
- LOGICAL , INTENT(in ) :: l_use_cs ! use the cool-skin parameterization
- LOGICAL , INTENT(in ) :: l_use_wl ! use the warm-layer parameterization
- REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Cd ! transfer coefficient for momentum (tau)
- REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Ch ! transfer coefficient for sensible heat (Q_sens)
- REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Ce ! transfert coefficient for evaporation (Q_lat)
- REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: t_zu ! pot. air temp. adjusted at zu [K]
- REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: q_zu ! spec. humidity adjusted at zu [kg/kg]
- REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Ubzu ! bulk wind speed at zu [m/s]
+ INTEGER, INTENT(in ) :: kt ! current time step
+ REAL(wp), INTENT(in ) :: zt ! height for t_zt and q_zt [m]
+ REAL(wp), INTENT(in ) :: zu ! height for U_zu [m]
+ REAL(wp), INTENT(inout), DIMENSION(A2D(0)) :: T_s ! sea surface temperature [Kelvin]
+ REAL(wp), INTENT(in ), DIMENSION(A2D(0)) :: t_zt ! potential air temperature [Kelvin]
+ REAL(wp), INTENT(inout), DIMENSION(A2D(0)) :: q_s ! sea surface specific humidity [kg/kg]
+ REAL(wp), INTENT(in ), DIMENSION(A2D(0)) :: q_zt ! specific air humidity at zt [kg/kg]
+ REAL(wp), INTENT(in ), DIMENSION(A2D(0)) :: U_zu ! relative wind module at zu [m/s]
+ LOGICAL , INTENT(in ) :: l_use_cs ! use the cool-skin parameterization
+ LOGICAL , INTENT(in ) :: l_use_wl ! use the warm-layer parameterization
+ REAL(wp), INTENT( out), DIMENSION(A2D(0)) :: Cd ! transfer coefficient for momentum (tau)
+ REAL(wp), INTENT( out), DIMENSION(A2D(0)) :: Ch ! transfer coefficient for sensible heat (Q_sens)
+ REAL(wp), INTENT( out), DIMENSION(A2D(0)) :: Ce ! transfert coefficient for evaporation (Q_lat)
+ REAL(wp), INTENT( out), DIMENSION(A2D(0)) :: t_zu ! pot. air temp. adjusted at zu [K]
+ REAL(wp), INTENT( out), DIMENSION(A2D(0)) :: q_zu ! spec. humidity adjusted at zu [kg/kg]
+ REAL(wp), INTENT( out), DIMENSION(A2D(0)) :: Ubzu ! bulk wind speed at zu [m/s]
!
- INTEGER , INTENT(in ), OPTIONAL :: nb_iter ! number of iterations
- REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: CdN
- REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: ChN
- REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: CeN
- REAL(wp), INTENT(in ), OPTIONAL, DIMENSION(jpi,jpj) :: Qsw ! [W/m^2]
- REAL(wp), INTENT(in ), OPTIONAL, DIMENSION(jpi,jpj) :: rad_lw ! [W/m^2]
- REAL(wp), INTENT(in ), OPTIONAL, DIMENSION(jpi,jpj) :: slp ! [Pa]
- REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: pdT_cs
- REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: pdT_wl ! [K]
- REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: pHz_wl ! [m]
+ INTEGER , INTENT(in ), OPTIONAL :: nb_iter ! number of iterations
+ REAL(wp), INTENT( out), OPTIONAL, DIMENSION(A2D(0)) :: CdN
+ REAL(wp), INTENT( out), OPTIONAL, DIMENSION(A2D(0)) :: ChN
+ REAL(wp), INTENT( out), OPTIONAL, DIMENSION(A2D(0)) :: CeN
+ REAL(wp), INTENT(in ), OPTIONAL, DIMENSION(A2D(0)) :: Qsw ! [W/m^2]
+ REAL(wp), INTENT(in ), OPTIONAL, DIMENSION(A2D(0)) :: rad_lw ! [W/m^2]
+ REAL(wp), INTENT(in ), OPTIONAL, DIMENSION(A2D(0)) :: slp ! [Pa]
+ REAL(wp), INTENT( out), OPTIONAL, DIMENSION(A2D(0)) :: pdT_cs
+ REAL(wp), INTENT( out), OPTIONAL, DIMENSION(A2D(0)) :: pdT_wl ! [K]
+ REAL(wp), INTENT( out), OPTIONAL, DIMENSION(A2D(0)) :: pHz_wl ! [m]
!
INTEGER :: nbit, jit
LOGICAL :: l_zt_equal_zu = .FALSE. ! if q and t are given at same height as U
!
- REAL(wp), DIMENSION(jpi,jpj) :: u_star, t_star, q_star
- REAL(wp), DIMENSION(jpi,jpj) :: dt_zu, dq_zu
- REAL(wp), DIMENSION(jpi,jpj) :: znu_a !: Nu_air, Viscosity of air
- REAL(wp), DIMENSION(jpi,jpj) :: Linv !: 1/L (inverse of Monin Obukhov length...
- REAL(wp), DIMENSION(jpi,jpj) :: z0, z0t, z0q
- REAL(wp), DIMENSION(jpi,jpj) :: zrhoa, zpre, zta ! air pressure [Pa], density [kg/m3] & absolute temperature [k]
+ REAL(wp), DIMENSION(A2D(0)) :: u_star, t_star, q_star
+ REAL(wp), DIMENSION(A2D(0)) :: dt_zu, dq_zu
+ REAL(wp), DIMENSION(A2D(0)) :: znu_a !: Nu_air, Viscosity of air
+ REAL(wp), DIMENSION(A2D(0)) :: Linv !: 1/L (inverse of Monin Obukhov length...
+ REAL(wp), DIMENSION(A2D(0)) :: z0, z0t, z0q
+ REAL(wp), DIMENSION(A2D(0)) :: zrhoa, zpre, zta ! air pressure [Pa], density [kg/m3] & absolute temperature [k]
!
REAL(wp), DIMENSION(:,:), ALLOCATABLE :: zsst ! to back up the initial bulk SST
!
- REAL(wp), DIMENSION(jpi,jpj) :: func_m, func_h
- REAL(wp), DIMENSION(jpi,jpj) :: ztmp0, ztmp1, ztmp2
+ REAL(wp), DIMENSION(A2D(0)) :: func_m, func_h
+ REAL(wp), DIMENSION(A2D(0)) :: ztmp0, ztmp1, ztmp2
CHARACTER(len=40), PARAMETER :: crtnm = 'turb_ecmwf@sbcblk_algo_ecmwf.F90'
!!----------------------------------------------------------------------------------
IF( kt == nit000 ) CALL SBCBLK_ALGO_ECMWF_INIT(l_use_cs, l_use_wl)
@@ -206,7 +206,7 @@ CONTAINS
& CALL ctl_stop( '['//TRIM(crtnm)//'] => ' , 'you need to provide Qsw, rad_lw & slp to use warm-layer param!' )
IF( l_use_cs .OR. l_use_wl ) THEN
- ALLOCATE ( zsst(jpi,jpj) )
+ ALLOCATE ( zsst(A2D(0)) )
zsst = T_s ! backing up the bulk SST
IF( l_use_cs ) T_s = T_s - 0.25_wp ! First guess of correction
q_s = rdct_qsat_salt*q_sat(MAX(T_s, 200._wp), slp) ! First guess of q_s
@@ -360,8 +360,8 @@ CONTAINS
CALL CS_ECMWF( Qsw, ztmp1, u_star, zsst ) ! Qnsol -> ztmp1
- T_s(:,:) = zsst(:,:) + dT_cs(:,:)*tmask(:,:,1)
- IF( l_use_wl ) T_s(:,:) = T_s(:,:) + dT_wl(:,:)*tmask(:,:,1)
+ T_s(:,:) = zsst(:,:) + dT_cs(:,:)*smask0(:,:)
+ IF( l_use_wl ) T_s(:,:) = T_s(:,:) + dT_wl(:,:)*smask0(:,:)
q_s(:,:) = rdct_qsat_salt*q_sat(MAX(T_s(:,:), 200._wp), slp(:,:))
ENDIF
@@ -372,8 +372,8 @@ CONTAINS
& ztmp1, ztmp2) ! Qnsol -> ztmp1 / Tau -> ztmp2
CALL WL_ECMWF( Qsw, ztmp1, u_star, zsst )
!! Updating T_s and q_s !!!
- T_s(:,:) = zsst(:,:) + dT_wl(:,:)*tmask(:,:,1) !
- IF( l_use_cs ) T_s(:,:) = T_s(:,:) + dT_cs(:,:)*tmask(:,:,1)
+ T_s(:,:) = zsst(:,:) + dT_wl(:,:)*smask0(:,:) !
+ IF( l_use_cs ) T_s(:,:) = T_s(:,:) + dT_cs(:,:)*smask0(:,:)
q_s(:,:) = rdct_qsat_salt*q_sat(MAX(T_s(:,:), 200._wp), slp(:,:))
ENDIF
@@ -413,14 +413,14 @@ CONTAINS
!!
!! ** Author: L. Brodeau, June 2016 / AeroBulk (https://github.com/brodeau/aerobulk/)
!!----------------------------------------------------------------------------------
- REAL(wp), DIMENSION(jpi,jpj) :: psi_m_ecmwf
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pzeta
+ REAL(wp), DIMENSION(A2D(0)) :: psi_m_ecmwf
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pzeta
!
INTEGER :: ji, jj ! dummy loop indices
REAL(wp) :: zta, zx2, zx, ztmp, zpsi_unst, zpsi_stab, zstab, zc
!!----------------------------------------------------------------------------------
zc = 5._wp/0.35_wp
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
!
zta = MIN( pzeta(ji,jj) , 5._wp ) !! Very stable conditions (L positif and big!):
@@ -454,15 +454,15 @@ CONTAINS
!!
!! ** Author: L. Brodeau, June 2016 / AeroBulk (https://github.com/brodeau/aerobulk/)
!!----------------------------------------------------------------------------------
- REAL(wp), DIMENSION(jpi,jpj) :: psi_h_ecmwf
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pzeta
+ REAL(wp), DIMENSION(A2D(0)) :: psi_h_ecmwf
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pzeta
!
INTEGER :: ji, jj ! dummy loop indices
REAL(wp) :: zta, zx2, zpsi_unst, zpsi_stab, zstab, zc
!!----------------------------------------------------------------------------------
zc = 5._wp/0.35_wp
!
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
!
zta = MIN(pzeta(ji,jj) , 5._wp) ! Very stable conditions (L positif and big!):
!
diff --git a/src/OCE/SBC/sbcblk_algo_ice_an05.F90 b/src/OCE/SBC/sbcblk_algo_ice_an05.F90
index 50ea20f6682af81c64258f1f549ac47700222717..36ed050eabd179a12ab59a318eefeccb6979fe21 100644
--- a/src/OCE/SBC/sbcblk_algo_ice_an05.F90
+++ b/src/OCE/SBC/sbcblk_algo_ice_an05.F90
@@ -79,26 +79,26 @@ CONTAINS
!!
!! ** Author: L. Brodeau, January 2020 / AeroBulk (https://github.com/brodeau/aerobulk/)
!!----------------------------------------------------------------------------------
- REAL(wp), INTENT(in ) :: zt ! height for t_zt and q_zt [m]
- REAL(wp), INTENT(in ) :: zu ! height for U_zu [m]
- REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: Ts_i ! ice surface temperature [Kelvin]
- REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: t_zt ! potential air temperature [Kelvin]
- REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: qs_i ! sat. spec. hum. at ice/air interface [kg/kg]
- REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: q_zt ! spec. air humidity at zt [kg/kg]
- REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: U_zu ! relative wind module at zu [m/s]
- REAL(wp), INTENT(out), DIMENSION(jpi,jpj) :: Cd_i ! drag coefficient over sea-ice
- REAL(wp), INTENT(out), DIMENSION(jpi,jpj) :: Ch_i ! transfert coefficient for heat over ice
- REAL(wp), INTENT(out), DIMENSION(jpi,jpj) :: Ce_i ! transfert coefficient for sublimation over ice
- REAL(wp), INTENT(out), DIMENSION(jpi,jpj) :: t_zu_i ! pot. air temp. adjusted at zu [K]
- REAL(wp), INTENT(out), DIMENSION(jpi,jpj) :: q_zu_i ! spec. humidity adjusted at zu [kg/kg]
+ REAL(wp), INTENT(in ) :: zt ! height for t_zt and q_zt [m]
+ REAL(wp), INTENT(in ) :: zu ! height for U_zu [m]
+ REAL(wp), INTENT(in ), DIMENSION(A2D(0)) :: Ts_i ! ice surface temperature [Kelvin]
+ REAL(wp), INTENT(in ), DIMENSION(A2D(0)) :: t_zt ! potential air temperature [Kelvin]
+ REAL(wp), INTENT(in ), DIMENSION(A2D(0)) :: qs_i ! sat. spec. hum. at ice/air interface [kg/kg]
+ REAL(wp), INTENT(in ), DIMENSION(A2D(0)) :: q_zt ! spec. air humidity at zt [kg/kg]
+ REAL(wp), INTENT(in ), DIMENSION(A2D(0)) :: U_zu ! relative wind module at zu [m/s]
+ REAL(wp), INTENT(out), DIMENSION(A2D(0)) :: Cd_i ! drag coefficient over sea-ice
+ REAL(wp), INTENT(out), DIMENSION(A2D(0)) :: Ch_i ! transfert coefficient for heat over ice
+ REAL(wp), INTENT(out), DIMENSION(A2D(0)) :: Ce_i ! transfert coefficient for sublimation over ice
+ REAL(wp), INTENT(out), DIMENSION(A2D(0)) :: t_zu_i ! pot. air temp. adjusted at zu [K]
+ REAL(wp), INTENT(out), DIMENSION(A2D(0)) :: q_zu_i ! spec. humidity adjusted at zu [kg/kg]
!!----------------------------------------------------------------------------------
- REAL(wp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: CdN
- REAL(wp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: ChN
- REAL(wp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: CeN
- REAL(wp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: xz0 ! Aerodynamic roughness length [m]
- REAL(wp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: xu_star ! u*, friction velocity
- REAL(wp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: xL ! zeta (zu/L)
- REAL(wp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: xUN10 ! Neutral wind at zu
+ REAL(wp), INTENT(out), DIMENSION(A2D(0)), OPTIONAL :: CdN
+ REAL(wp), INTENT(out), DIMENSION(A2D(0)), OPTIONAL :: ChN
+ REAL(wp), INTENT(out), DIMENSION(A2D(0)), OPTIONAL :: CeN
+ REAL(wp), INTENT(out), DIMENSION(A2D(0)), OPTIONAL :: xz0 ! Aerodynamic roughness length [m]
+ REAL(wp), INTENT(out), DIMENSION(A2D(0)), OPTIONAL :: xu_star ! u*, friction velocity
+ REAL(wp), INTENT(out), DIMENSION(A2D(0)), OPTIONAL :: xL ! zeta (zu/L)
+ REAL(wp), INTENT(out), DIMENSION(A2D(0)), OPTIONAL :: xUN10 ! Neutral wind at zu
!!----------------------------------------------------------------------------------
REAL(wp), DIMENSION(:,:), ALLOCATABLE :: Ubzu
REAL(wp), DIMENSION(:,:), ALLOCATABLE :: ztmp0, ztmp1, ztmp2 ! temporary stuff
@@ -116,10 +116,10 @@ CONTAINS
!!
CHARACTER(len=40), PARAMETER :: crtnm = 'turb_ice_an05@sbcblk_algo_ice_an05.f90'
!!----------------------------------------------------------------------------------
- ALLOCATE ( Ubzu(jpi,jpj), u_star(jpi,jpj), t_star(jpi,jpj), q_star(jpi,jpj), &
- & zeta_u(jpi,jpj), dt_zu(jpi,jpj), dq_zu(jpi,jpj), &
- & znu_a(jpi,jpj), ztmp1(jpi,jpj), ztmp2(jpi,jpj), &
- & z0(jpi,jpj), z0tq(jpi,jpj,2), ztmp0(jpi,jpj) )
+ ALLOCATE ( Ubzu(A2D(0)), u_star(A2D(0)), t_star(A2D(0)), q_star(A2D(0)), &
+ & zeta_u(A2D(0)), dt_zu(A2D(0)), dq_zu(A2D(0)), &
+ & znu_a(A2D(0)), ztmp1(A2D(0)), ztmp2(A2D(0)), &
+ & z0(A2D(0)), z0tq(A2D(0),2), ztmp0(A2D(0)) )
lreturn_cdn = PRESENT(CdN)
lreturn_chn = PRESENT(ChN)
@@ -130,7 +130,7 @@ CONTAINS
lreturn_UN10 = PRESENT(xUN10)
l_zt_equal_zu = ( ABS(zu - zt) < 0.01_wp )
- IF( .NOT. l_zt_equal_zu ) ALLOCATE( zeta_t(jpi,jpj) )
+ IF( .NOT. l_zt_equal_zu ) ALLOCATE( zeta_t(A2D(0)) )
!! Scalar wind speed cannot be below 0.2 m/s
Ubzu = MAX( U_zu, wspd_thrshld_ice )
@@ -227,14 +227,14 @@ CONTAINS
!!
!! Author: L. Brodeau, January 2020 / AeroBulk (https://github.com/brodeau/aerobulk/)
!!----------------------------------------------------------------------------------
- REAL(wp), DIMENSION(jpi,jpj) :: rough_leng_m ! roughness length over sea-ice [m]
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pus ! u* = friction velocity [m/s]
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pnua ! kinematic viscosity of air [m^2/s]
+ REAL(wp), DIMENSION(A2D(0)) :: rough_leng_m ! roughness length over sea-ice [m]
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pus ! u* = friction velocity [m/s]
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pnua ! kinematic viscosity of air [m^2/s]
!!
INTEGER :: ji, jj ! dummy loop indices
REAL(wp) :: zus, zz
!!----------------------------------------------------------------------------------
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
zus = MAX( pus(ji,jj) , 1.E-9_wp )
zz = (zus - 0.18_wp) / 0.1_wp
@@ -251,16 +251,16 @@ CONTAINS
!!
!! Author: L. Brodeau, January 2020 / AeroBulk (https://github.com/brodeau/aerobulk/)
!!----------------------------------------------------------------------------------
- REAL(wp), DIMENSION(jpi,jpj,2) :: rough_leng_tq ! temp.,hum. roughness lengthes over sea-ice [m]
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pz0 ! roughness length [m]
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pus ! u* = friction velocity [m/s]
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pnua ! kinematic viscosity of air [m^2/s]
+ REAL(wp), DIMENSION(A2D(0),2) :: rough_leng_tq ! temp.,hum. roughness lengthes over sea-ice [m]
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pz0 ! roughness length [m]
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pus ! u* = friction velocity [m/s]
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pnua ! kinematic viscosity of air [m^2/s]
!!
INTEGER :: ji, jj ! dummy loop indices
REAL(wp) :: zz0, zus, zre, zsmoot, ztrans, zrough
REAL(wp) :: zb0, zb1, zb2, zlog, zlog2, zlog_z0s_on_z0
!!----------------------------------------------------------------------------------
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
zz0 = pz0(ji,jj)
zus = MAX( pus(ji,jj) , 1.E-9_wp )
zre = MAX( zus*zz0/pnua(ji,jj) , 0._wp ) ! Roughness Reynolds number
@@ -315,13 +315,13 @@ CONTAINS
!!
!! ** Author: L. Brodeau, 2020 / AeroBulk (https://github.com/brodeau/aerobulk/)
!!----------------------------------------------------------------------------------
- REAL(wp), DIMENSION(jpi,jpj) :: psi_m_ice
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pzeta
+ REAL(wp), DIMENSION(A2D(0)) :: psi_m_ice
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pzeta
!
INTEGER :: ji, jj ! dummy loop indices
REAL(wp) :: zta, zx, zpsi_u, zpsi_s, zstab
!!----------------------------------------------------------------------------------
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) !
+ DO_2D( 0, 0, 0, 0 ) !
zta = pzeta(ji,jj)
!
! Unstable stratification:
@@ -360,13 +360,13 @@ CONTAINS
!!
!! ** Author: L. Brodeau, 2020 / AeroBulk (https://github.com/brodeau/aerobulk/)
!!----------------------------------------------------------------------------------
- REAL(wp), DIMENSION(jpi,jpj) :: psi_h_ice
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pzeta
+ REAL(wp), DIMENSION(A2D(0)) :: psi_h_ice
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pzeta
!
INTEGER :: ji, jj ! dummy loop indices
REAL(wp) :: zta, zx, zpsi_u, zpsi_s, zstab
!!----------------------------------------------------------------------------------
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) !
+ DO_2D( 0, 0, 0, 0 ) !
zta = pzeta(ji,jj)
!
! Unstable stratification:
diff --git a/src/OCE/SBC/sbcblk_algo_ice_cdn.F90 b/src/OCE/SBC/sbcblk_algo_ice_cdn.F90
index 87932e3966985a6ae8c676671104989e099c246f..0a9103f8a706baf1627109dde6d612425b193788 100644
--- a/src/OCE/SBC/sbcblk_algo_ice_cdn.F90
+++ b/src/OCE/SBC/sbcblk_algo_ice_cdn.F90
@@ -59,12 +59,12 @@ CONTAINS
!! ** References : Lupkes et al. JGR 2012 (theory)
!!
!!----------------------------------------------------------------------
- REAL(wp), DIMENSION(jpi,jpj) :: CdN10_f_LU12 ! neutral FORM drag coefficient contribution over sea-ice
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pfrice ! ice concentration [fraction] => at_i_b ! NOT USED if pSc2, phf and pDi all provided...
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pz0w ! roughness length over water [m]
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in), OPTIONAL :: pSc2 ! squared shletering function [0-1] (Sc->1 for large distance between floes, ->0 for small distances)
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in), OPTIONAL :: phf ! mean freeboard of floes [m]
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in), OPTIONAL :: pDi ! cross wind dimension of the floe (aka effective edge length for form drag) [m]
+ REAL(wp), DIMENSION(A2D(0)) :: CdN10_f_LU12 ! neutral FORM drag coefficient contribution over sea-ice
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pfrice ! ice concentration [fraction] => at_i_b ! NOT USED if pSc2, phf and pDi all provided...
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pz0w ! roughness length over water [m]
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in), OPTIONAL :: pSc2 ! squared shletering function [0-1] (Sc->1 for large distance between floes, ->0 for small distances)
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in), OPTIONAL :: phf ! mean freeboard of floes [m]
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in), OPTIONAL :: pDi ! cross wind dimension of the floe (aka effective edge length for form drag) [m]
!!----------------------------------------------------------------------
LOGICAL :: l_known_Sc2=.FALSE., l_known_hf=.FALSE., l_known_Di=.FALSE.
REAL(wp) :: ztmp, zrlog, zfri, zfrw, zSc2, zhf, zDi
@@ -74,7 +74,7 @@ CONTAINS
l_known_hf = PRESENT(phf)
l_known_Di = PRESENT(pDi)
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
zfri = pfrice(ji,jj)
zfrw = (1._wp - zfri)
@@ -113,9 +113,9 @@ CONTAINS
FUNCTION CdN_f_LU12_eq36( pzu, pfrice )
!!----------------------------------------------------------------------
- REAL(wp), DIMENSION(jpi,jpj) :: CdN_f_LU12_eq36 ! neutral FORM drag coefficient contribution over sea-ice
- REAL(wp), INTENT(in) :: pzu ! reference height [m]
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pfrice ! ice concentration [fraction] => at_i_b ! NOT USED if pSc2, phf and pDi all provided...
+ REAL(wp), DIMENSION(A2D(0)) :: CdN_f_LU12_eq36 ! neutral FORM drag coefficient contribution over sea-ice
+ REAL(wp), INTENT(in) :: pzu ! reference height [m]
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pfrice ! ice concentration [fraction] => at_i_b ! NOT USED if pSc2, phf and pDi all provided...
!!----------------------------------------------------------------------
REAL(wp) :: ztmp, zrlog, zfri, zhf, zDi
INTEGER :: ji, jj
@@ -127,7 +127,7 @@ CONTAINS
ztmp = 1._wp/rz0_w_0
zrlog = LOG(zhf*ztmp) / LOG(pzu*ztmp)
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
zfri = pfrice(ji,jj)
CdN_f_LU12_eq36(ji,jj) = 0.5_wp* 0.3_wp * zrlog*zrlog * zhf/zDi * (1._wp - zfri)**rBeta_0 ! Eq.(35) & (36)
!! 1/2 Ce
@@ -167,8 +167,8 @@ CONTAINS
!! Lupkes et al. GRL 2013 (application to GCM)
!!
!!----------------------------------------------------------------------
- REAL(wp), DIMENSION(jpi,jpj) :: CdN10_f_LU13 ! neutral FORM drag coefficient contribution over sea-ice
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pfrice ! ice concentration [fraction] => at_i_b
+ REAL(wp), DIMENSION(A2D(0)) :: CdN10_f_LU13 ! neutral FORM drag coefficient contribution over sea-ice
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pfrice ! ice concentration [fraction] => at_i_b
!!----------------------------------------------------------------------
INTEGER :: ji, jj
REAL(wp) :: zcoef
@@ -178,7 +178,7 @@ CONTAINS
!! We are not an AGCM, we are an OGCM!!! => we drop term "(1 - A)*Cd_w"
!! => so we keep only the last rhs terms of Eq.(1) of Lupkes et al, 2013 that we divide by "A":
!! (we multiply Cd_i_s and Cd_i_f by A later, when applying ocean-ice partitioning...
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
CdN10_f_LU13(ji,jj) = rCe_0 * pfrice(ji,jj)**(rMu_0 - 1._wp) * (1._wp - pfrice(ji,jj))**zcoef
END_2D
!! => seems okay for winter 100% sea-ice as second rhs term vanishes as pfrice == 1....
@@ -203,13 +203,13 @@ CONTAINS
!! ** References : Lupkes & Gryanik (2015)
!!
!!----------------------------------------------------------------------
- REAL(wp), DIMENSION(jpi,jpj) :: CdN_f_LG15 ! neutral FORM drag coefficient contribution over sea-ice
- REAL(wp), INTENT(in ) :: pzu ! reference height [m]
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pfrice ! ice concentration [fraction] => at_i_b ! NOT USED if pSc2, phf and pDi all provided...
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pz0i ! roughness length over ICE [m] (in LU12, it's over water ???)
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in), OPTIONAL :: pSc2 ! squared shletering function [0-1] (Sc->1 for large distance between floes, ->0 for small distances)
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in), OPTIONAL :: phf ! mean freeboard of floes [m]
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in), OPTIONAL :: pDi ! cross wind dimension of the floe (aka effective edge length for form drag) [m]
+ REAL(wp), DIMENSION(A2D(0)) :: CdN_f_LG15 ! neutral FORM drag coefficient contribution over sea-ice
+ REAL(wp), INTENT(in ) :: pzu ! reference height [m]
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pfrice ! ice concentration [fraction] => at_i_b ! NOT USED if pSc2, phf and pDi all provided...
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pz0i ! roughness length over ICE [m] (in LU12, it's over water ???)
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in), OPTIONAL :: pSc2 ! squared shletering function [0-1] (Sc->1 for large distance between floes, ->0 for small distances)
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in), OPTIONAL :: phf ! mean freeboard of floes [m]
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in), OPTIONAL :: pDi ! cross wind dimension of the floe (aka effective edge length for form drag) [m]
!!----------------------------------------------------------------------
LOGICAL :: l_known_Sc2=.FALSE., l_known_hf=.FALSE., l_known_Di=.FALSE.
REAL(wp) :: ztmp, zrlog, zfri, zfrw, zSc2, zhf, zDi
@@ -219,7 +219,7 @@ CONTAINS
l_known_hf = PRESENT(phf)
l_known_Di = PRESENT(pDi)
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
zfri = pfrice(ji,jj)
zfrw = (1._wp - zfri)
@@ -270,15 +270,15 @@ CONTAINS
!! ** References : Lupkes & Gryanik (2015)
!!
!!----------------------------------------------------------------------
- REAL(wp), DIMENSION(jpi,jpj) :: CdN_f_LG15_light ! neutral FORM drag coefficient contribution over sea-ice
- REAL(wp), INTENT(in) :: pzu ! reference height [m]
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pfrice ! ice concentration [fraction] => at_i_b
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pz0w ! roughness length over water [m]
+ REAL(wp), DIMENSION(A2D(0)) :: CdN_f_LG15_light ! neutral FORM drag coefficient contribution over sea-ice
+ REAL(wp), INTENT(in) :: pzu ! reference height [m]
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pfrice ! ice concentration [fraction] => at_i_b
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pz0w ! roughness length over water [m]
!!----------------------------------------------------------------------
REAL(wp) :: ztmp, zrlog, zfri
INTEGER :: ji, jj
!!----------------------------------------------------------------------
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
zfri = pfrice(ji,jj)
diff --git a/src/OCE/SBC/sbcblk_algo_ice_lg15.F90 b/src/OCE/SBC/sbcblk_algo_ice_lg15.F90
index 62ec01b8236d2735d600b354ea7bcd64d2025ac1..9c9302faa60317317f071f6b7238cb7b60457f5d 100644
--- a/src/OCE/SBC/sbcblk_algo_ice_lg15.F90
+++ b/src/OCE/SBC/sbcblk_algo_ice_lg15.F90
@@ -42,6 +42,8 @@ MODULE sbcblk_algo_ice_lg15
INTEGER , PARAMETER :: nbit = 8 ! number of itterations
+ !! * Substitutions
+# include "do_loop_substitute.h90"
!!----------------------------------------------------------------------
CONTAINS
@@ -92,27 +94,27 @@ CONTAINS
!!
!! ** Author: L. Brodeau, January 2020 / AeroBulk (https://github.com/brodeau/aerobulk/)
!!----------------------------------------------------------------------------------
- REAL(wp), INTENT(in ) :: zt ! height for t_zt and q_zt [m]
- REAL(wp), INTENT(in ) :: zu ! height for U_zu [m]
- REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: Ts_i ! ice surface temperature [Kelvin]
- REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: t_zt ! potential air temperature [Kelvin]
- REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: qs_i ! sat. spec. hum. at ice/air interface [kg/kg]
- REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: q_zt ! spec. air humidity at zt [kg/kg]
- REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: U_zu ! relative wind module at zu [m/s]
- REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: frice ! sea-ice concentration (fraction)
- REAL(wp), INTENT(out), DIMENSION(jpi,jpj) :: Cd_i ! drag coefficient over sea-ice
- REAL(wp), INTENT(out), DIMENSION(jpi,jpj) :: Ch_i ! transfert coefficient for heat over ice
- REAL(wp), INTENT(out), DIMENSION(jpi,jpj) :: Ce_i ! transfert coefficient for sublimation over ice
- REAL(wp), INTENT(out), DIMENSION(jpi,jpj) :: t_zu_i ! pot. air temp. adjusted at zu [K]
- REAL(wp), INTENT(out), DIMENSION(jpi,jpj) :: q_zu_i ! spec. humidity adjusted at zu [kg/kg]
+ REAL(wp), INTENT(in ) :: zt ! height for t_zt and q_zt [m]
+ REAL(wp), INTENT(in ) :: zu ! height for U_zu [m]
+ REAL(wp), INTENT(in ), DIMENSION(A2D(0)) :: Ts_i ! ice surface temperature [Kelvin]
+ REAL(wp), INTENT(in ), DIMENSION(A2D(0)) :: t_zt ! potential air temperature [Kelvin]
+ REAL(wp), INTENT(in ), DIMENSION(A2D(0)) :: qs_i ! sat. spec. hum. at ice/air interface [kg/kg]
+ REAL(wp), INTENT(in ), DIMENSION(A2D(0)) :: q_zt ! spec. air humidity at zt [kg/kg]
+ REAL(wp), INTENT(in ), DIMENSION(A2D(0)) :: U_zu ! relative wind module at zu [m/s]
+ REAL(wp), INTENT(in ), DIMENSION(A2D(0)) :: frice ! sea-ice concentration (fraction)
+ REAL(wp), INTENT(out), DIMENSION(A2D(0)) :: Cd_i ! drag coefficient over sea-ice
+ REAL(wp), INTENT(out), DIMENSION(A2D(0)) :: Ch_i ! transfert coefficient for heat over ice
+ REAL(wp), INTENT(out), DIMENSION(A2D(0)) :: Ce_i ! transfert coefficient for sublimation over ice
+ REAL(wp), INTENT(out), DIMENSION(A2D(0)) :: t_zu_i ! pot. air temp. adjusted at zu [K]
+ REAL(wp), INTENT(out), DIMENSION(A2D(0)) :: q_zu_i ! spec. humidity adjusted at zu [kg/kg]
!!----------------------------------------------------------------------------------
- REAL(wp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: CdN
- REAL(wp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: ChN
- REAL(wp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: CeN
- REAL(wp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: xz0 ! Aerodynamic roughness length [m]
- REAL(wp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: xu_star ! u*, friction velocity
- REAL(wp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: xL ! zeta (zu/L)
- REAL(wp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: xUN10 ! Neutral wind at zu
+ REAL(wp), INTENT(out), DIMENSION(A2D(0)), OPTIONAL :: CdN
+ REAL(wp), INTENT(out), DIMENSION(A2D(0)), OPTIONAL :: ChN
+ REAL(wp), INTENT(out), DIMENSION(A2D(0)), OPTIONAL :: CeN
+ REAL(wp), INTENT(out), DIMENSION(A2D(0)), OPTIONAL :: xz0 ! Aerodynamic roughness length [m]
+ REAL(wp), INTENT(out), DIMENSION(A2D(0)), OPTIONAL :: xu_star ! u*, friction velocity
+ REAL(wp), INTENT(out), DIMENSION(A2D(0)), OPTIONAL :: xL ! zeta (zu/L)
+ REAL(wp), INTENT(out), DIMENSION(A2D(0)), OPTIONAL :: xUN10 ! Neutral wind at zu
!!----------------------------------------------------------------------------------
REAL(wp), DIMENSION(:,:), ALLOCATABLE :: Ubzu
REAL(wp), DIMENSION(:,:), ALLOCATABLE :: ztmp1, ztmp2 ! temporary stuff
@@ -128,11 +130,11 @@ CONTAINS
!!
CHARACTER(len=40), PARAMETER :: crtnm = 'turb_ice_lg15@sbcblk_algo_ice_lg15.f90'
!!----------------------------------------------------------------------------------
- ALLOCATE ( Ubzu(jpi,jpj) )
- ALLOCATE ( ztmp1(jpi,jpj), ztmp2(jpi,jpj) )
- ALLOCATE ( dt_zu(jpi,jpj), dq_zu(jpi,jpj) )
- ALLOCATE ( zz0_s(jpi,jpj), zz0_f(jpi,jpj), RiB(jpi,jpj), &
- & zCdN_s(jpi,jpj), zChN_s(jpi,jpj), zCdN_f(jpi,jpj), zChN_f(jpi,jpj) )
+ ALLOCATE ( Ubzu(A2D(0)) )
+ ALLOCATE ( ztmp1(A2D(0)), ztmp2(A2D(0)) )
+ ALLOCATE ( dt_zu(A2D(0)), dq_zu(A2D(0)) )
+ ALLOCATE ( zz0_s(A2D(0)), zz0_f(A2D(0)), RiB(A2D(0)), &
+ & zCdN_s(A2D(0)), zChN_s(A2D(0)), zCdN_f(A2D(0)), zChN_f(A2D(0)) )
lreturn_cdn = PRESENT(CdN)
lreturn_chn = PRESENT(ChN)
diff --git a/src/OCE/SBC/sbcblk_algo_ice_lu12.F90 b/src/OCE/SBC/sbcblk_algo_ice_lu12.F90
index d46534a362b0ad9a7486ee86d45a5e8cec34bf0f..10a4dbf60ff50a4931b0d7c0ae915330f17330ef 100644
--- a/src/OCE/SBC/sbcblk_algo_ice_lu12.F90
+++ b/src/OCE/SBC/sbcblk_algo_ice_lu12.F90
@@ -32,6 +32,8 @@ MODULE sbcblk_algo_ice_lu12
REAL(wp), PARAMETER :: rz0_i_s_0 = 0.69e-3_wp ! Eq.(43) of Lupkes & Gryanik (2015) [m] => to estimate CdN10 for skin drag!
REAL(wp), PARAMETER :: rz0_i_f_0 = 4.54e-4_wp ! bottom p.562 MIZ [m] (LG15)
+ !! * Substitutions
+# include "do_loop_substitute.h90"
!!----------------------------------------------------------------------
CONTAINS
@@ -79,27 +81,27 @@ CONTAINS
!!
!! ** Author: L. Brodeau, January 2020 / AeroBulk (https://github.com/brodeau/aerobulk/)
!!----------------------------------------------------------------------------------
- REAL(wp), INTENT(in ) :: zt ! height for t_zt and q_zt [m]
- REAL(wp), INTENT(in ) :: zu ! height for U_zu [m]
- REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: Ts_i ! ice surface temperature [Kelvin]
- REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: t_zt ! potential air temperature [Kelvin]
- REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: qs_i ! sat. spec. hum. at ice/air interface [kg/kg]
- REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: q_zt ! spec. air humidity at zt [kg/kg]
- REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: U_zu ! relative wind module at zu [m/s]
- REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: frice ! sea-ice concentration (fraction)
- REAL(wp), INTENT(out), DIMENSION(jpi,jpj) :: Cd_i ! drag coefficient over sea-ice
- REAL(wp), INTENT(out), DIMENSION(jpi,jpj) :: Ch_i ! transfert coefficient for heat over ice
- REAL(wp), INTENT(out), DIMENSION(jpi,jpj) :: Ce_i ! transfert coefficient for sublimation over ice
- REAL(wp), INTENT(out), DIMENSION(jpi,jpj) :: t_zu_i ! pot. air temp. adjusted at zu [K]
- REAL(wp), INTENT(out), DIMENSION(jpi,jpj) :: q_zu_i ! spec. humidity adjusted at zu [kg/kg]
+ REAL(wp), INTENT(in ) :: zt ! height for t_zt and q_zt [m]
+ REAL(wp), INTENT(in ) :: zu ! height for U_zu [m]
+ REAL(wp), INTENT(in ), DIMENSION(A2D(0)) :: Ts_i ! ice surface temperature [Kelvin]
+ REAL(wp), INTENT(in ), DIMENSION(A2D(0)) :: t_zt ! potential air temperature [Kelvin]
+ REAL(wp), INTENT(in ), DIMENSION(A2D(0)) :: qs_i ! sat. spec. hum. at ice/air interface [kg/kg]
+ REAL(wp), INTENT(in ), DIMENSION(A2D(0)) :: q_zt ! spec. air humidity at zt [kg/kg]
+ REAL(wp), INTENT(in ), DIMENSION(A2D(0)) :: U_zu ! relative wind module at zu [m/s]
+ REAL(wp), INTENT(in ), DIMENSION(A2D(0)) :: frice ! sea-ice concentration (fraction)
+ REAL(wp), INTENT(out), DIMENSION(A2D(0)) :: Cd_i ! drag coefficient over sea-ice
+ REAL(wp), INTENT(out), DIMENSION(A2D(0)) :: Ch_i ! transfert coefficient for heat over ice
+ REAL(wp), INTENT(out), DIMENSION(A2D(0)) :: Ce_i ! transfert coefficient for sublimation over ice
+ REAL(wp), INTENT(out), DIMENSION(A2D(0)) :: t_zu_i ! pot. air temp. adjusted at zu [K]
+ REAL(wp), INTENT(out), DIMENSION(A2D(0)) :: q_zu_i ! spec. humidity adjusted at zu [kg/kg]
!!----------------------------------------------------------------------------------
- REAL(wp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: CdN
- REAL(wp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: ChN
- REAL(wp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: CeN
- REAL(wp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: xz0 ! Aerodynamic roughness length [m]
- REAL(wp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: xu_star ! u*, friction velocity
- REAL(wp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: xL ! zeta (zu/L)
- REAL(wp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: xUN10 ! Neutral wind at zu
+ REAL(wp), INTENT(out), DIMENSION(A2D(0)), OPTIONAL :: CdN
+ REAL(wp), INTENT(out), DIMENSION(A2D(0)), OPTIONAL :: ChN
+ REAL(wp), INTENT(out), DIMENSION(A2D(0)), OPTIONAL :: CeN
+ REAL(wp), INTENT(out), DIMENSION(A2D(0)), OPTIONAL :: xz0 ! Aerodynamic roughness length [m]
+ REAL(wp), INTENT(out), DIMENSION(A2D(0)), OPTIONAL :: xu_star ! u*, friction velocity
+ REAL(wp), INTENT(out), DIMENSION(A2D(0)), OPTIONAL :: xL ! zeta (zu/L)
+ REAL(wp), INTENT(out), DIMENSION(A2D(0)), OPTIONAL :: xUN10 ! Neutral wind at zu
!!----------------------------------------------------------------------------------
REAL(wp), DIMENSION(:,:), ALLOCATABLE :: dt_zu, dq_zu, z0
REAL(wp), DIMENSION(:,:), ALLOCATABLE :: Ubzu
@@ -109,8 +111,8 @@ CONTAINS
!!
CHARACTER(len=40), PARAMETER :: crtnm = 'turb_ice_lu12@sbcblk_algo_ice_lu12.f90'
!!----------------------------------------------------------------------------------
- ALLOCATE ( Ubzu(jpi,jpj) )
- ALLOCATE ( dt_zu(jpi,jpj), dq_zu(jpi,jpj), z0(jpi,jpj) )
+ ALLOCATE ( Ubzu(A2D(0)) )
+ ALLOCATE ( dt_zu(A2D(0)), dq_zu(A2D(0)), z0(A2D(0)) )
lreturn_cdn = PRESENT(CdN)
lreturn_chn = PRESENT(ChN)
diff --git a/src/OCE/SBC/sbcblk_algo_ncar.F90 b/src/OCE/SBC/sbcblk_algo_ncar.F90
index bb520dbf07993c584ac4e9f50c3187e18a711a05..4e218454e57d5c49520cfacc72269b82f82947f3 100644
--- a/src/OCE/SBC/sbcblk_algo_ncar.F90
+++ b/src/OCE/SBC/sbcblk_algo_ncar.F90
@@ -79,32 +79,32 @@ CONTAINS
!!
!! ** Author: L. Brodeau, June 2019 / AeroBulk (https://github.com/brodeau/aerobulk/)
!!----------------------------------------------------------------------------------
- REAL(wp), INTENT(in ) :: zt ! height for t_zt and q_zt [m]
- REAL(wp), INTENT(in ) :: zu ! height for U_zu [m]
- REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: sst ! sea surface temperature [Kelvin]
- REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: t_zt ! potential air temperature [Kelvin]
- REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: ssq ! sea surface specific humidity [kg/kg]
- REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: q_zt ! specific air humidity at zt [kg/kg]
- REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: U_zu ! relative wind module at zu [m/s]
- REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Cd ! transfer coefficient for momentum (tau)
- REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Ch ! transfer coefficient for sensible heat (Q_sens)
- REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Ce ! transfert coefficient for evaporation (Q_lat)
- REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: t_zu ! pot. air temp. adjusted at zu [K]
- REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: q_zu ! spec. humidity adjusted at zu [kg/kg]
- REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Ubzu ! bulk wind speed at zu [m/s]
+ REAL(wp), INTENT(in ) :: zt ! height for t_zt and q_zt [m]
+ REAL(wp), INTENT(in ) :: zu ! height for U_zu [m]
+ REAL(wp), INTENT(in ), DIMENSION(A2D(0)) :: sst ! sea surface temperature [Kelvin]
+ REAL(wp), INTENT(in ), DIMENSION(A2D(0)) :: t_zt ! potential air temperature [Kelvin]
+ REAL(wp), INTENT(in ), DIMENSION(A2D(0)) :: ssq ! sea surface specific humidity [kg/kg]
+ REAL(wp), INTENT(in ), DIMENSION(A2D(0)) :: q_zt ! specific air humidity at zt [kg/kg]
+ REAL(wp), INTENT(in ), DIMENSION(A2D(0)) :: U_zu ! relative wind module at zu [m/s]
+ REAL(wp), INTENT( out), DIMENSION(A2D(0)) :: Cd ! transfer coefficient for momentum (tau)
+ REAL(wp), INTENT( out), DIMENSION(A2D(0)) :: Ch ! transfer coefficient for sensible heat (Q_sens)
+ REAL(wp), INTENT( out), DIMENSION(A2D(0)) :: Ce ! transfert coefficient for evaporation (Q_lat)
+ REAL(wp), INTENT( out), DIMENSION(A2D(0)) :: t_zu ! pot. air temp. adjusted at zu [K]
+ REAL(wp), INTENT( out), DIMENSION(A2D(0)) :: q_zu ! spec. humidity adjusted at zu [kg/kg]
+ REAL(wp), INTENT( out), DIMENSION(A2D(0)) :: Ubzu ! bulk wind speed at zu [m/s]
!
- INTEGER , INTENT(in ), OPTIONAL :: nb_iter ! number of iterations
- REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: CdN
- REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: ChN
- REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: CeN
+ INTEGER , INTENT(in ), OPTIONAL :: nb_iter ! number of iterations
+ REAL(wp), INTENT( out), OPTIONAL, DIMENSION(A2D(0)) :: CdN
+ REAL(wp), INTENT( out), OPTIONAL, DIMENSION(A2D(0)) :: ChN
+ REAL(wp), INTENT( out), OPTIONAL, DIMENSION(A2D(0)) :: CeN
!
INTEGER :: nbit, jit ! iterations...
LOGICAL :: l_zt_equal_zu = .FALSE. ! if q and t are given at same height as U
!
- REAL(wp), DIMENSION(jpi,jpj) :: zCdN, zCeN, zChN ! 10m neutral latent/sensible coefficient
- REAL(wp), DIMENSION(jpi,jpj) :: zsqrt_Cd, zsqrt_CdN ! root square of Cd and Cd_neutral
- REAL(wp), DIMENSION(jpi,jpj) :: zeta_u ! stability parameter at height zu
- REAL(wp), DIMENSION(jpi,jpj) :: ztmp0, ztmp1, ztmp2
+ REAL(wp), DIMENSION(A2D(0)) :: zCdN, zCeN, zChN ! 10m neutral latent/sensible coefficient
+ REAL(wp), DIMENSION(A2D(0)) :: zsqrt_Cd, zsqrt_CdN ! root square of Cd and Cd_neutral
+ REAL(wp), DIMENSION(A2D(0)) :: zeta_u ! stability parameter at height zu
+ REAL(wp), DIMENSION(A2D(0)) :: ztmp0, ztmp1, ztmp2
!!----------------------------------------------------------------------------------
nbit = nb_iter0
IF( PRESENT(nb_iter) ) nbit = nb_iter
@@ -119,7 +119,7 @@ CONTAINS
!! Neutral coefficients at 10m:
IF( ln_cdgw ) THEN ! wave drag case
- cdn_wave(:,:) = cdn_wave(:,:) + rsmall * ( 1._wp - tmask(:,:,1) )
+ cdn_wave(:,:) = cdn_wave(:,:) + rsmall * ( 1._wp - smask0(:,:) )
zCdN (:,:) = cdn_wave(:,:)
ELSE
zCdN = cd_n10_ncar( Ubzu )
@@ -231,14 +231,14 @@ CONTAINS
!!
!! ** Author: L. Brodeau, june 2016 / AeroBulk (https://github.com/brodeau/aerobulk/)
!!----------------------------------------------------------------------------------
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pw10 ! scalar wind speed at 10m (m/s)
- REAL(wp), DIMENSION(jpi,jpj) :: cd_n10_ncar
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pw10 ! scalar wind speed at 10m (m/s)
+ REAL(wp), DIMENSION(A2D(0)) :: cd_n10_ncar
!
INTEGER :: ji, jj ! dummy loop indices
REAL(wp) :: zgt33, zw, zw6 ! local scalars
!!----------------------------------------------------------------------------------
!
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
!
zw = pw10(ji,jj)
zw6 = zw*zw*zw
@@ -264,9 +264,9 @@ CONTAINS
!! Origin: Large & Yeager 2008, Eq. (9) and (12)
!!----------------------------------------------------------------------------------
- REAL(wp), DIMENSION(jpi,jpj) :: ch_n10_ncar
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: psqrtcdn10 ! sqrt( CdN10 )
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pstab ! stable ABL => 1 / unstable ABL => 0
+ REAL(wp), DIMENSION(A2D(0)) :: ch_n10_ncar
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: psqrtcdn10 ! sqrt( CdN10 )
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pstab ! stable ABL => 1 / unstable ABL => 0
!!----------------------------------------------------------------------------------
IF( ANY(pstab < -0.00001) .OR. ANY(pstab > 1.00001) ) THEN
PRINT *, 'ERROR: ch_n10_ncar@mod_blk_ncar.f90: pstab ='
@@ -283,8 +283,8 @@ CONTAINS
!! Estimate of the neutral heat transfer coefficient at 10m !!
!! Origin: Large & Yeager 2008, Eq. (9) and (13)
!!----------------------------------------------------------------------------------
- REAL(wp), DIMENSION(jpi,jpj) :: ce_n10_ncar
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: psqrtcdn10 ! sqrt( CdN10 )
+ REAL(wp), DIMENSION(A2D(0)) :: ce_n10_ncar
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: psqrtcdn10 ! sqrt( CdN10 )
!!----------------------------------------------------------------------------------
ce_n10_ncar = MAX( 1.e-3_wp * ( 34.6_wp * psqrtcdn10 ) , Cx_min )
!
@@ -301,13 +301,13 @@ CONTAINS
!!
!! ** Author: L. Brodeau, June 2016 / AeroBulk (https://github.com/brodeau/aerobulk/)
!!----------------------------------------------------------------------------------
- REAL(wp), DIMENSION(jpi,jpj) :: psi_m_ncar
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pzeta
+ REAL(wp), DIMENSION(A2D(0)) :: psi_m_ncar
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pzeta
!
INTEGER :: ji, jj ! dummy loop indices
REAL(wp) :: zta, zx2, zx, zpsi_unst, zpsi_stab, zstab ! local scalars
!!----------------------------------------------------------------------------------
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
zta = pzeta(ji,jj)
!
zx2 = SQRT( ABS(1._wp - 16._wp*zta) ) ! (1 - 16z)^0.5
@@ -339,14 +339,14 @@ CONTAINS
!!
!! ** Author: L. Brodeau, June 2016 / AeroBulk (https://github.com/brodeau/aerobulk/)
!!----------------------------------------------------------------------------------
- REAL(wp), DIMENSION(jpi,jpj) :: psi_h_ncar
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pzeta
+ REAL(wp), DIMENSION(A2D(0)) :: psi_h_ncar
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pzeta
!
INTEGER :: ji, jj ! dummy loop indices
REAL(wp) :: zta, zx2, zpsi_unst, zpsi_stab, zstab ! local scalars
!!----------------------------------------------------------------------------------
!
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
!
zta = pzeta(ji,jj)
!
diff --git a/src/OCE/SBC/sbcblk_skin_coare.F90 b/src/OCE/SBC/sbcblk_skin_coare.F90
index 42720bd939e3dfb1dd45ed1545495120efe50732..ddd6af7f2d0f7ad4f70a3679e7ed8e455bd6cb2e 100644
--- a/src/OCE/SBC/sbcblk_skin_coare.F90
+++ b/src/OCE/SBC/sbcblk_skin_coare.F90
@@ -79,16 +79,16 @@ CONTAINS
!! *pSST* bulk SST (taken at depth gdept_1d(1)) [K]
!! *pQlat* surface latent heat flux [K]
!!------------------------------------------------------------------
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pQsw ! net solar a.k.a shortwave radiation into the ocean (after albedo) [W/m^2]
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pQnsol ! non-solar heat flux to the ocean [W/m^2]
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pustar ! friction velocity, temperature and humidity (u*,t*,q*)
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pSST ! bulk SST [K]
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pQlat ! latent heat flux [W/m^2]
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pQsw ! net solar a.k.a shortwave radiation into the ocean (after albedo) [W/m^2]
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pQnsol ! non-solar heat flux to the ocean [W/m^2]
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pustar ! friction velocity, temperature and humidity (u*,t*,q*)
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pSST ! bulk SST [K]
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pQlat ! latent heat flux [W/m^2]
!!---------------------------------------------------------------------
INTEGER :: ji, jj, jc
REAL(wp) :: zQabs, zdlt, zfr, zalfa, zqlat, zus
!!---------------------------------------------------------------------
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
zQabs = pQnsol(ji,jj) ! first guess of heat flux absorbed within the viscous sublayer of thicknes delta,
! ! => we DO not miss a lot assuming 0 solar flux absorbed in the tiny layer of thicknes zdlt...
@@ -129,11 +129,11 @@ CONTAINS
!! *pSST* bulk SST (taken at depth gdept_1d(1)) [K]
!! *iwait* if /= 0 then wait before updating accumulated fluxes, we are within a converging itteration loop...
!!---------------------------------------------------------------------
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pQsw ! surface net solar radiation into the ocean [W/m^2] => >= 0 !
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pQnsol ! surface net non-solar heat flux into the ocean [W/m^2] => normally < 0 !
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pTau ! wind stress [N/m^2]
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pSST ! bulk SST at depth gdept_1d(1) [K]
- INTEGER , INTENT(in) :: iwait ! if /= 0 then wait before updating accumulated fluxes
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pQsw ! surface net solar radiation into the ocean [W/m^2] => >= 0 !
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pQnsol ! surface net non-solar heat flux into the ocean [W/m^2] => normally < 0 !
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pTau ! wind stress [N/m^2]
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pSST ! bulk SST at depth gdept_1d(1) [K]
+ INTEGER , INTENT(in) :: iwait ! if /= 0 then wait before updating accumulated fluxes
!!
INTEGER :: ji,jj
!
@@ -155,7 +155,7 @@ CONTAINS
ztime = REAL(nsec_day,wp)/(24._wp*3600._wp) ! time of current time step since 00:00 for current day (UTC) -> ztime = 0 -> 00:00 / ztime = 0.5 -> 12:00 ...
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
l_exit = .FALSE.
l_destroy_wl = .FALSE.
diff --git a/src/OCE/SBC/sbcblk_skin_ecmwf.F90 b/src/OCE/SBC/sbcblk_skin_ecmwf.F90
index 0f4cf8d5d37f7fa8cfa6bbefed0b68e822c7382f..e38437168acc696a864ce3c681c677ae731cd891 100644
--- a/src/OCE/SBC/sbcblk_skin_ecmwf.F90
+++ b/src/OCE/SBC/sbcblk_skin_ecmwf.F90
@@ -87,15 +87,15 @@ CONTAINS
!! *pustar* friction velocity u* [m/s]
!! *pSST* bulk SST (taken at depth gdept_1d(1)) [K]
!!------------------------------------------------------------------
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pQsw ! net solar a.k.a shortwave radiation into the ocean (after albedo) [W/m^2]
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pQnsol ! non-solar heat flux to the ocean [W/m^2]
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pustar ! friction velocity, temperature and humidity (u*,t*,q*)
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pSST ! bulk SST [K]
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pQsw ! net solar a.k.a shortwave radiation into the ocean (after albedo) [W/m^2]
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pQnsol ! non-solar heat flux to the ocean [W/m^2]
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pustar ! friction velocity, temperature and humidity (u*,t*,q*)
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pSST ! bulk SST [K]
!!---------------------------------------------------------------------
INTEGER :: ji, jj, jc
REAL(wp) :: zQabs, zdlt, zfr, zalfa, zus
!!---------------------------------------------------------------------
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
zQabs = pQnsol(ji,jj) ! first guess of heat flux absorbed within the viscous sublayer of thicknes delta,
! ! => we DO not miss a lot assuming 0 solar flux absorbed in the tiny layer of thicknes zdlt...
@@ -147,12 +147,12 @@ CONTAINS
!! *pustar* friction velocity u* [m/s]
!! *pSST* bulk SST (taken at depth gdept_1d(1)) [K]
!!------------------------------------------------------------------
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pQsw ! surface net solar radiation into the ocean [W/m^2] => >= 0 !
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pQnsol ! surface net non-solar heat flux into the ocean [W/m^2] => normally < 0 !
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pustar ! friction velocity [m/s]
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pSST ! bulk SST at depth gdept_1d(1) [K]
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pQsw ! surface net solar radiation into the ocean [W/m^2] => >= 0 !
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pQnsol ! surface net non-solar heat flux into the ocean [W/m^2] => normally < 0 !
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pustar ! friction velocity [m/s]
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pSST ! bulk SST at depth gdept_1d(1) [K]
!!
- REAL(wp), DIMENSION(jpi,jpj), OPTIONAL, INTENT(in) :: pustk ! surface Stokes velocity [m/s]
+ REAL(wp), DIMENSION(A2D(0)), OPTIONAL, INTENT(in) :: pustk ! surface Stokes velocity [m/s]
!
INTEGER :: ji, jj, jc
!
@@ -173,7 +173,7 @@ CONTAINS
l_pustk_known = .FALSE.
IF( PRESENT(pustk) ) l_pustk_known = .TRUE.
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
zHwl = Hz_wl(ji,jj) ! first guess for warm-layer depth (and unique..., less advanced than COARE3p6 !)
! it is = rd0 (3m) in default Zeng & Beljaars case...
diff --git a/src/OCE/SBC/sbcclo.F90 b/src/OCE/SBC/sbcclo.F90
index ba956f5e32dfa77dfea9106ee2855e2b2659d716..1f48db25bb7ce34f03f2a7f901daeb8c1faf7db2 100644
--- a/src/OCE/SBC/sbcclo.F90
+++ b/src/OCE/SBC/sbcclo.F90
@@ -44,6 +44,8 @@ MODULE sbcclo
!
INTEGER, SAVE, ALLOCATABLE, DIMENSION(:) :: mcsgrpg, mcsgrpr, mcsgrpe !: closed sea group for glo, rnf and emp
!
+ !! * Substitutions
+# include "do_loop_substitute.h90"
CONTAINS
!
!!----------------------------------------------------------------------
@@ -120,8 +122,8 @@ MODULE sbcclo
CALL iom_put('qclosea',zqcs)
!
! 3. update emp and qns
- emp(:,:) = emp(:,:) + zwcs(:,:)
- qns(:,:) = qns(:,:) + zqcs(:,:)
+ emp(A2D(0)) = emp(A2D(0)) + zwcs(A2D(0))
+ qns(:,:) = qns(:,:) + zqcs(A2D(0))
!
END SUBROUTINE sbc_clo
!
@@ -289,7 +291,7 @@ MODULE sbcclo
!! 1. Work out net freshwater over the closed sea from EMP - RNF.
!! Work out net heat associated with the correction (needed for conservation)
!! (PM: should we consider used delayed glob sum ?)
- zcsfw = glob_sum( 'closea', e1e2t(:,:) * ( emp(:,:)-rnf(:,:) ) * imsk_src(:,:) )
+ zcsfw = glob_sum( 'closea', e1e2t(A2D(0)) * ( emp(A2D(0))-rnf(A2D(0)) ) * imsk_src(A2D(0)) )
!
!! 2. Deal with runoff special case (net evaporation spread globally)
!! and compute trg mask
diff --git a/src/OCE/SBC/sbccpl.F90 b/src/OCE/SBC/sbccpl.F90
index eddf626a522f3479f787e155a6dc76ed02900634..4daed86431a7fb00a214346bde97dd324089cc02 100644
--- a/src/OCE/SBC/sbccpl.F90
+++ b/src/OCE/SBC/sbccpl.F90
@@ -65,18 +65,19 @@ MODULE sbccpl
PUBLIC sbc_cpl_ice_flx ! routine called by icestp.F90
PUBLIC sbc_cpl_alloc ! routine called in sbcice_cice.F90
+ !! received fields are only in the interior (without halos)
INTEGER, PARAMETER :: jpr_otx1 = 1 ! 3 atmosphere-ocean stress components on grid 1
INTEGER, PARAMETER :: jpr_oty1 = 2 !
INTEGER, PARAMETER :: jpr_otz1 = 3 !
- INTEGER, PARAMETER :: jpr_otx2 = 4 ! 3 atmosphere-ocean stress components on grid 2
- INTEGER, PARAMETER :: jpr_oty2 = 5 !
- INTEGER, PARAMETER :: jpr_otz2 = 6 !
+!!$ INTEGER, PARAMETER :: jpr_otx2 = 4 ! 3 atmosphere-ocean stress components on grid 2
+!!$ INTEGER, PARAMETER :: jpr_oty2 = 5 !
+!!$ INTEGER, PARAMETER :: jpr_otz2 = 6 !
INTEGER, PARAMETER :: jpr_itx1 = 7 ! 3 atmosphere-ice stress components on grid 1
INTEGER, PARAMETER :: jpr_ity1 = 8 !
INTEGER, PARAMETER :: jpr_itz1 = 9 !
- INTEGER, PARAMETER :: jpr_itx2 = 10 ! 3 atmosphere-ice stress components on grid 2
- INTEGER, PARAMETER :: jpr_ity2 = 11 !
- INTEGER, PARAMETER :: jpr_itz2 = 12 !
+!!$ INTEGER, PARAMETER :: jpr_itx2 = 10 ! 3 atmosphere-ice stress components on grid 2
+!!$ INTEGER, PARAMETER :: jpr_ity2 = 11 !
+!!$ INTEGER, PARAMETER :: jpr_itz2 = 12 !
INTEGER, PARAMETER :: jpr_qsroce = 13 ! Qsr above the ocean
INTEGER, PARAMETER :: jpr_qsrice = 14 ! Qsr above the ice
INTEGER, PARAMETER :: jpr_qsrmix = 15
@@ -128,10 +129,11 @@ MODULE sbccpl
INTEGER, PARAMETER :: jpr_isf = 60
INTEGER, PARAMETER :: jpr_icb = 61
INTEGER, PARAMETER :: jpr_ts_ice = 62 ! Sea ice surface temp
- !!INTEGER, PARAMETER :: jpr_qtrice = 63 ! Transmitted solar thru sea-ice
-
- INTEGER, PARAMETER :: jprcv = 62 ! total number of fields received
+ INTEGER, PARAMETER :: jpr_qtrice = 63 ! Transmitted solar thru sea-ice
+ INTEGER, PARAMETER :: jprcv = 63 ! total number of fields received
+
+ !! sent fields are only in the interior (without halos)
INTEGER, PARAMETER :: jps_fice = 1 ! ice fraction sent to the atmosphere
INTEGER, PARAMETER :: jps_toce = 2 ! ocean temperature
INTEGER, PARAMETER :: jps_tice = 3 ! ice temperature
@@ -194,7 +196,7 @@ MODULE sbccpl
& sn_snd_thick1, sn_snd_cond, sn_snd_mpnd , sn_snd_sstfrz, sn_snd_ttilyr
! ! Received from the atmosphere
TYPE(FLD_C) :: sn_rcv_w10m, sn_rcv_taumod, sn_rcv_tau, sn_rcv_dqnsdt, sn_rcv_qsr, &
- & sn_rcv_qns , sn_rcv_emp , sn_rcv_rnf, sn_rcv_ts_ice
+ & sn_rcv_qns , sn_rcv_emp , sn_rcv_rnf, sn_rcv_ts_ice, sn_rcv_qtrice
TYPE(FLD_C) :: sn_rcv_cal, sn_rcv_iceflx, sn_rcv_co2, sn_rcv_mslp, sn_rcv_icb, sn_rcv_isf
! ! Send to waves
TYPE(FLD_C) :: sn_snd_ifrac, sn_snd_crtw, sn_snd_wlev
@@ -202,7 +204,6 @@ MODULE sbccpl
TYPE(FLD_C) :: sn_rcv_hsig, sn_rcv_phioc, sn_rcv_sdrfx, sn_rcv_sdrfy, sn_rcv_wper, sn_rcv_wnum, &
& sn_rcv_wstrf, sn_rcv_wdrag, sn_rcv_charn, sn_rcv_taw, sn_rcv_bhd, sn_rcv_tusd, sn_rcv_tvsd
! ! Other namelist parameters
-!! TYPE(FLD_C) :: sn_rcv_qtrice
INTEGER :: nn_cplmodel ! Maximum number of models to/from which NEMO is potentialy sending/receiving data
LOGICAL :: ln_usecplmask ! use a coupling mask file to merge data received from several models
! -> file cplmask.nc with the float variable called cplmask (jpi,jpj,nn_cplmodel)
@@ -239,12 +240,12 @@ CONTAINS
!!----------------------------------------------------------------------
ierr(:) = 0
!
- ALLOCATE( alb_oce_mix(jpi,jpj), nrcvinfo(jprcv), STAT=ierr(1) )
+ ALLOCATE( alb_oce_mix(A2D(0)), nrcvinfo(jprcv), STAT=ierr(1) )
#if ! defined key_si3 && ! defined key_cice
ALLOCATE( a_i(jpi,jpj,1) , STAT=ierr(2) ) ! used in sbcice_if.F90 (done here as there is no sbc_ice_if_init)
#endif
- ALLOCATE( xcplmask(jpi,jpj,0:nn_cplmodel) , STAT=ierr(3) )
+ ALLOCATE( xcplmask(A2D(0),0:nn_cplmodel) , STAT=ierr(3) )
!
IF( .NOT. ln_apr_dyn ) ALLOCATE( ssh_ib(jpi,jpj), ssh_ibb(jpi,jpj), apr(jpi, jpj), STAT=ierr(4) )
@@ -271,7 +272,7 @@ CONTAINS
!
INTEGER :: jn ! dummy loop index
INTEGER :: ios, inum ! Local integer
- REAL(wp), DIMENSION(jpi,jpj) :: zacs, zaos
+ REAL(wp), DIMENSION(A2D(0)) :: zacs, zaos
!!
NAMELIST/namsbc_cpl/ nn_cplmodel , ln_usecplmask, nn_cats_cpl , ln_scale_ice_flux, &
& sn_snd_temp , sn_snd_alb , sn_snd_thick, sn_snd_crt , sn_snd_co2 , &
@@ -281,7 +282,7 @@ CONTAINS
& sn_rcv_sdrfx , sn_rcv_sdrfy , sn_rcv_wper , sn_rcv_wnum , sn_rcv_wstrf , &
& sn_rcv_charn , sn_rcv_taw , sn_rcv_bhd , sn_rcv_tusd , sn_rcv_tvsd, &
& sn_rcv_wdrag , sn_rcv_qns , sn_rcv_emp , sn_rcv_rnf , sn_rcv_cal , &
- & sn_rcv_iceflx, sn_rcv_co2 , sn_rcv_icb , sn_rcv_isf , sn_rcv_ts_ice, & !!, sn_rcv_qtrice
+ & sn_rcv_iceflx, sn_rcv_co2 , sn_rcv_icb , sn_rcv_isf , sn_rcv_ts_ice, sn_rcv_qtrice, &
& sn_rcv_mslp
!!---------------------------------------------------------------------
@@ -313,7 +314,6 @@ CONTAINS
WRITE(numout,*)' surface stress = ', TRIM(sn_rcv_tau%cldes ), ' (', TRIM(sn_rcv_tau%clcat ), ')'
WRITE(numout,*)' - referential = ', sn_rcv_tau%clvref
WRITE(numout,*)' - orientation = ', sn_rcv_tau%clvor
- WRITE(numout,*)' - mesh = ', sn_rcv_tau%clvgrd
WRITE(numout,*)' non-solar heat flux sensitivity = ', TRIM(sn_rcv_dqnsdt%cldes), ' (', TRIM(sn_rcv_dqnsdt%clcat), ')'
WRITE(numout,*)' solar heat flux = ', TRIM(sn_rcv_qsr%cldes ), ' (', TRIM(sn_rcv_qsr%clcat ), ')'
WRITE(numout,*)' non-solar heat flux = ', TRIM(sn_rcv_qns%cldes ), ' (', TRIM(sn_rcv_qns%clcat ), ')'
@@ -323,7 +323,7 @@ CONTAINS
WRITE(numout,*)' iceberg = ', TRIM(sn_rcv_icb%cldes ), ' (', TRIM(sn_rcv_icb%clcat ), ')'
WRITE(numout,*)' ice shelf = ', TRIM(sn_rcv_isf%cldes ), ' (', TRIM(sn_rcv_isf%clcat ), ')'
WRITE(numout,*)' sea ice heat fluxes = ', TRIM(sn_rcv_iceflx%cldes), ' (', TRIM(sn_rcv_iceflx%clcat), ')'
-!! WRITE(numout,*)' transmitted solar thru sea-ice = ', TRIM(sn_rcv_qtrice%cldes), ' (', TRIM(sn_rcv_qtrice%clcat), ')'
+ WRITE(numout,*)' transmitted solar thru sea-ice = ', TRIM(sn_rcv_qtrice%cldes), ' (', TRIM(sn_rcv_qtrice%clcat), ')'
WRITE(numout,*)' atm co2 = ', TRIM(sn_rcv_co2%cldes ), ' (', TRIM(sn_rcv_co2%clcat ), ')'
WRITE(numout,*)' Sea ice surface skin temperature= ', TRIM(sn_rcv_ts_ice%cldes), ' (', TRIM(sn_rcv_ts_ice%clcat), ')'
WRITE(numout,*)' surface waves:'
@@ -358,7 +358,7 @@ CONTAINS
WRITE(numout,*)' - mesh = ', sn_snd_crtw%clvgrd
ENDIF
IF( lwp .AND. ln_wave) THEN ! control print
- WRITE(numout,*)' surface waves:'
+ WRITE(numout,*)' surface waves:'
WRITE(numout,*)' Significant wave heigth = ', TRIM(sn_rcv_hsig%cldes ), ' (', TRIM(sn_rcv_hsig%clcat ), ')'
WRITE(numout,*)' Wave to oce energy flux = ', TRIM(sn_rcv_phioc%cldes ), ' (', TRIM(sn_rcv_phioc%clcat ), ')'
WRITE(numout,*)' Surface Stokes drift grid u = ', TRIM(sn_rcv_sdrfx%cldes ), ' (', TRIM(sn_rcv_sdrfx%clcat ), ')'
@@ -368,8 +368,8 @@ CONTAINS
WRITE(numout,*)' Stress frac adsorbed by waves = ', TRIM(sn_rcv_wstrf%cldes ), ' (', TRIM(sn_rcv_wstrf%clcat ), ')'
WRITE(numout,*)' Neutral surf drag coefficient = ', TRIM(sn_rcv_wdrag%cldes ), ' (', TRIM(sn_rcv_wdrag%clcat ), ')'
WRITE(numout,*)' Charnock coefficient = ', TRIM(sn_rcv_charn%cldes ), ' (', TRIM(sn_rcv_charn%clcat ), ')'
- WRITE(numout,*)' Transport associated to Stokes drift grid u = ', TRIM(sn_rcv_tusd%cldes ), ' (', TRIM(sn_rcv_tusd%clcat ), ')'
- WRITE(numout,*)' Transport associated to Stokes drift grid v = ', TRIM(sn_rcv_tvsd%cldes ), ' (', TRIM(sn_rcv_tvsd%clcat ), ')'
+ WRITE(numout,*)' Transport associated to Stokes drift u = ', TRIM(sn_rcv_tusd%cldes ), ' (', TRIM(sn_rcv_tusd%clcat ), ')'
+ WRITE(numout,*)' Transport associated to Stokes drift v = ', TRIM(sn_rcv_tvsd%cldes ), ' (', TRIM(sn_rcv_tvsd%clcat ), ')'
WRITE(numout,*)' Bernouilli pressure head = ', TRIM(sn_rcv_bhd%cldes ), ' (', TRIM(sn_rcv_bhd%clcat ), ')'
WRITE(numout,*)'Wave to ocean momentum flux and Net wave-supported stress = ', TRIM(sn_rcv_taw%cldes ), ' (', TRIM(sn_rcv_taw%clcat ), ')'
WRITE(numout,*)' Surface current to waves = ', TRIM(sn_snd_crtw%cldes ), ' (', TRIM(sn_snd_crtw%clcat ), ')'
@@ -390,6 +390,7 @@ CONTAINS
! define the north fold type of lbc (srcv(:)%nsgn)
! default definitions of srcv
+ ALLOCATE( srcv(jprcv) )
srcv(:)%laction = .FALSE. ; srcv(:)%clgrid = 'T' ; srcv(:)%nsgn = 1. ; srcv(:)%nct = 1
! ! ------------------------- !
@@ -399,87 +400,26 @@ CONTAINS
srcv(jpr_otx1)%clname = 'O_OTaux1' ! 1st ocean component on grid ONE (T or U)
srcv(jpr_oty1)%clname = 'O_OTauy1' ! 2nd - - - -
srcv(jpr_otz1)%clname = 'O_OTauz1' ! 3rd - - - -
- srcv(jpr_otx2)%clname = 'O_OTaux2' ! 1st ocean component on grid TWO (V)
- srcv(jpr_oty2)%clname = 'O_OTauy2' ! 2nd - - - -
- srcv(jpr_otz2)%clname = 'O_OTauz2' ! 3rd - - - -
!
srcv(jpr_itx1)%clname = 'O_ITaux1' ! 1st ice component on grid ONE (T, F, I or U)
srcv(jpr_ity1)%clname = 'O_ITauy1' ! 2nd - - - -
srcv(jpr_itz1)%clname = 'O_ITauz1' ! 3rd - - - -
- srcv(jpr_itx2)%clname = 'O_ITaux2' ! 1st ice component on grid TWO (V)
- srcv(jpr_ity2)%clname = 'O_ITauy2' ! 2nd - - - -
- srcv(jpr_itz2)%clname = 'O_ITauz2' ! 3rd - - - -
!
! Vectors: change of sign at north fold ONLY if on the local grid
IF( TRIM( sn_rcv_tau%cldes ) == 'oce only' .OR. TRIM( sn_rcv_tau%cldes ) == 'oce and ice' &
.OR. TRIM( sn_rcv_tau%cldes ) == 'mixed oce-ice' ) THEN ! avoid working with the atmospheric fields if they are not coupled
!
- IF( TRIM( sn_rcv_tau%clvor ) == 'local grid' ) srcv(jpr_otx1:jpr_itz2)%nsgn = -1.
-
- ! ! Set grid and action
- SELECT CASE( TRIM( sn_rcv_tau%clvgrd ) ) ! 'T', 'U,V', 'U,V,I', 'U,V,F', 'T,I', 'T,F', or 'T,U,V'
- CASE( 'T' )
- srcv(jpr_otx1:jpr_itz2)%clgrid = 'T' ! oce and ice components given at T-point
- srcv(jpr_otx1:jpr_otz1)%laction = .TRUE. ! receive oce components on grid 1
- srcv(jpr_itx1:jpr_itz1)%laction = .TRUE. ! receive ice components on grid 1
- CASE( 'U,V' )
- srcv(jpr_otx1:jpr_otz1)%clgrid = 'U' ! oce components given at U-point
- srcv(jpr_otx2:jpr_otz2)%clgrid = 'V' ! and V-point
- srcv(jpr_itx1:jpr_itz1)%clgrid = 'U' ! ice components given at U-point
- srcv(jpr_itx2:jpr_itz2)%clgrid = 'V' ! and V-point
- srcv(jpr_otx1:jpr_itz2)%laction = .TRUE. ! receive oce and ice components on both grid 1 & 2
- CASE( 'U,V,T' )
- srcv(jpr_otx1:jpr_otz1)%clgrid = 'U' ! oce components given at U-point
- srcv(jpr_otx2:jpr_otz2)%clgrid = 'V' ! and V-point
- srcv(jpr_itx1:jpr_itz1)%clgrid = 'T' ! ice components given at T-point
- srcv(jpr_otx1:jpr_otz2)%laction = .TRUE. ! receive oce components on grid 1 & 2
- srcv(jpr_itx1:jpr_itz1)%laction = .TRUE. ! receive ice components on grid 1 only
- CASE( 'U,V,I' )
- srcv(jpr_otx1:jpr_otz1)%clgrid = 'U' ! oce components given at U-point
- srcv(jpr_otx2:jpr_otz2)%clgrid = 'V' ! and V-point
- srcv(jpr_itx1:jpr_itz1)%clgrid = 'I' ! ice components given at I-point
- srcv(jpr_otx1:jpr_otz2)%laction = .TRUE. ! receive oce components on grid 1 & 2
- srcv(jpr_itx1:jpr_itz1)%laction = .TRUE. ! receive ice components on grid 1 only
- CASE( 'U,V,F' )
- srcv(jpr_otx1:jpr_otz1)%clgrid = 'U' ! oce components given at U-point
- srcv(jpr_otx2:jpr_otz2)%clgrid = 'V' ! and V-point
- srcv(jpr_itx1:jpr_itz1)%clgrid = 'F' ! ice components given at F-point
- srcv(jpr_otx1:jpr_otz2)%laction = .TRUE. ! receive oce components on grid 1 & 2
- srcv(jpr_itx1:jpr_itz1)%laction = .TRUE. ! receive ice components on grid 1 only
- CASE( 'T,I' )
- srcv(jpr_otx1:jpr_itz2)%clgrid = 'T' ! oce and ice components given at T-point
- srcv(jpr_itx1:jpr_itz1)%clgrid = 'I' ! ice components given at I-point
- srcv(jpr_otx1:jpr_otz1)%laction = .TRUE. ! receive oce components on grid 1
- srcv(jpr_itx1:jpr_itz1)%laction = .TRUE. ! receive ice components on grid 1
- CASE( 'T,F' )
- srcv(jpr_otx1:jpr_itz2)%clgrid = 'T' ! oce and ice components given at T-point
- srcv(jpr_itx1:jpr_itz1)%clgrid = 'F' ! ice components given at F-point
- srcv(jpr_otx1:jpr_otz1)%laction = .TRUE. ! receive oce components on grid 1
- srcv(jpr_itx1:jpr_itz1)%laction = .TRUE. ! receive ice components on grid 1
- CASE( 'T,U,V' )
- srcv(jpr_otx1:jpr_otz1)%clgrid = 'T' ! oce components given at T-point
- srcv(jpr_itx1:jpr_itz1)%clgrid = 'U' ! ice components given at U-point
- srcv(jpr_itx2:jpr_itz2)%clgrid = 'V' ! and V-point
- srcv(jpr_otx1:jpr_otz1)%laction = .TRUE. ! receive oce components on grid 1 only
- srcv(jpr_itx1:jpr_itz2)%laction = .TRUE. ! receive ice components on grid 1 & 2
- CASE default
- CALL ctl_stop( 'sbc_cpl_init: wrong definition of sn_rcv_tau%clvgrd' )
- END SELECT
+ IF( TRIM( sn_rcv_tau%clvor ) == 'local grid' ) srcv(jpr_otx1:jpr_itz1)%nsgn = -1.
+
+ ! ! Set grid and action
+ srcv(jpr_otx1:jpr_otz1)%laction = .TRUE. ! receive oce components on grid 1
+ srcv(jpr_itx1:jpr_itz1)%laction = .TRUE. ! receive ice components on grid 1
!
IF( TRIM( sn_rcv_tau%clvref ) == 'spherical' ) & ! spherical: 3rd component not received
- & srcv( (/jpr_otz1, jpr_otz2, jpr_itz1, jpr_itz2/) )%laction = .FALSE.
- !
- IF( TRIM( sn_rcv_tau%clvor ) == 'local grid' ) THEN ! already on local grid -> no need of the second grid
- srcv(jpr_otx2:jpr_otz2)%laction = .FALSE.
- srcv(jpr_itx2:jpr_itz2)%laction = .FALSE.
- srcv(jpr_oty1)%clgrid = srcv(jpr_oty2)%clgrid ! not needed but cleaner...
- srcv(jpr_ity1)%clgrid = srcv(jpr_ity2)%clgrid ! not needed but cleaner...
- ENDIF
+ & srcv( (/jpr_otz1, jpr_itz1/) )%laction = .FALSE.
!
- IF( TRIM( sn_rcv_tau%cldes ) /= 'oce and ice' ) THEN ! 'oce and ice' case ocean stress on ocean mesh used
- srcv(jpr_itx1:jpr_itz2)%laction = .FALSE. ! ice components not received
- srcv(jpr_itx1)%clgrid = 'U' ! ocean stress used after its transformation
- srcv(jpr_ity1)%clgrid = 'V' ! i.e. it is always at U- & V-points for i- & j-comp. resp.
+ IF( TRIM( sn_rcv_tau%cldes ) /= 'oce and ice' ) THEN ! 'oce and ice' case ocean stress on ocean mesh used
+ srcv(jpr_itx1:jpr_itz1)%laction = .FALSE. ! ice components not received
ENDIF
ENDIF
@@ -612,18 +552,18 @@ CONTAINS
ENDIF
srcv(jpr_topm:jpr_botm)%laction = .TRUE.
ENDIF
-!! ! ! --------------------------- !
-!! ! ! transmitted solar thru ice !
-!! ! ! --------------------------- !
-!! srcv(jpr_qtrice)%clname = 'OQtr'
-!! IF( TRIM(sn_rcv_qtrice%cldes) == 'coupled' ) THEN
-!! IF ( TRIM( sn_rcv_qtrice%clcat ) == 'yes' ) THEN
-!! srcv(jpr_qtrice)%nct = nn_cats_cpl
-!! ELSE
-!! CALL ctl_stop( 'sbc_cpl_init: sn_rcv_qtrice%clcat should always be set to yes currently' )
-!! ENDIF
-!! srcv(jpr_qtrice)%laction = .TRUE.
-!! ENDIF
+ ! ! --------------------------- !
+ ! ! transmitted solar thru ice !
+ ! ! --------------------------- !
+ srcv(jpr_qtrice)%clname = 'OQtr'
+ IF( TRIM(sn_rcv_qtrice%cldes) == 'coupled' ) THEN
+ IF ( TRIM( sn_rcv_qtrice%clcat ) == 'yes' ) THEN
+ srcv(jpr_qtrice)%nct = nn_cats_cpl
+ ELSE
+ CALL ctl_stop( 'sbc_cpl_init: sn_rcv_qtrice%clcat should always be set to yes currently' )
+ ENDIF
+ srcv(jpr_qtrice)%laction = .TRUE.
+ ENDIF
! ! ------------------------- !
! ! ice skin temperature !
! ! ------------------------- !
@@ -725,11 +665,10 @@ CONTAINS
srcv(:)%clgrid = 'T' ! force default definition in case of opa <-> sas coupling
srcv(:)%nsgn = 1. ! force default definition in case of opa <-> sas coupling
srcv( (/jpr_qsroce, jpr_qnsoce, jpr_oemp, jpr_sflx, jpr_fice, jpr_otx1, jpr_oty1, jpr_taum/) )%laction = .TRUE.
- srcv(jpr_otx1)%clgrid = 'U' ! oce components given at U-point
- srcv(jpr_oty1)%clgrid = 'V' ! and V-point
+ srcv(jpr_otx1)%clgrid = 'T' ! oce components given at T-point
+ srcv(jpr_oty1)%clgrid = 'T'
! Vectors: change of sign at north fold ONLY if on the local grid
srcv( (/jpr_otx1,jpr_oty1/) )%nsgn = -1.
- sn_rcv_tau%clvgrd = 'U,V'
sn_rcv_tau%clvor = 'local grid'
sn_rcv_tau%clvref = 'spherical'
sn_rcv_emp%cldes = 'oce only'
@@ -802,19 +741,19 @@ CONTAINS
! Allocate all parts of frcv used for received fields !
! =================================================== !
DO jn = 1, jprcv
- IF( srcv(jn)%laction ) ALLOCATE( frcv(jn)%z3(jpi,jpj,srcv(jn)%nct) )
+ IF( srcv(jn)%laction ) ALLOCATE( frcv(jn)%z3(A2D(0),srcv(jn)%nct) )
END DO
! Allocate taum part of frcv which is used even when not received as coupling field
- IF( .NOT. srcv(jpr_taum)%laction ) ALLOCATE( frcv(jpr_taum)%z3(jpi,jpj,srcv(jpr_taum)%nct) )
+ IF( .NOT. srcv(jpr_taum)%laction ) ALLOCATE( frcv(jpr_taum)%z3(A2D(0),srcv(jpr_taum)%nct) )
! Allocate w10m part of frcv which is used even when not received as coupling field
- IF( .NOT. srcv(jpr_w10m)%laction ) ALLOCATE( frcv(jpr_w10m)%z3(jpi,jpj,srcv(jpr_w10m)%nct) )
+ IF( .NOT. srcv(jpr_w10m)%laction ) ALLOCATE( frcv(jpr_w10m)%z3(A2D(0),srcv(jpr_w10m)%nct) )
! Allocate jpr_otx1 part of frcv which is used even when not received as coupling field
- IF( .NOT. srcv(jpr_otx1)%laction ) ALLOCATE( frcv(jpr_otx1)%z3(jpi,jpj,srcv(jpr_otx1)%nct) )
- IF( .NOT. srcv(jpr_oty1)%laction ) ALLOCATE( frcv(jpr_oty1)%z3(jpi,jpj,srcv(jpr_oty1)%nct) )
+ IF( .NOT. srcv(jpr_otx1)%laction ) ALLOCATE( frcv(jpr_otx1)%z3(A2D(0),srcv(jpr_otx1)%nct) )
+ IF( .NOT. srcv(jpr_oty1)%laction ) ALLOCATE( frcv(jpr_oty1)%z3(A2D(0),srcv(jpr_oty1)%nct) )
! Allocate itx1 and ity1 as they are used in sbc_cpl_ice_tau even if srcv(jpr_itx1)%laction = .FALSE.
IF( k_ice /= 0 ) THEN
- IF( .NOT. srcv(jpr_itx1)%laction ) ALLOCATE( frcv(jpr_itx1)%z3(jpi,jpj,srcv(jpr_itx1)%nct) )
- IF( .NOT. srcv(jpr_ity1)%laction ) ALLOCATE( frcv(jpr_ity1)%z3(jpi,jpj,srcv(jpr_ity1)%nct) )
+ IF( .NOT. srcv(jpr_itx1)%laction ) ALLOCATE( frcv(jpr_itx1)%z3(A2D(0),srcv(jpr_itx1)%nct) )
+ IF( .NOT. srcv(jpr_ity1)%laction ) ALLOCATE( frcv(jpr_ity1)%z3(A2D(0),srcv(jpr_ity1)%nct) )
ENDIF
! ================================ !
@@ -823,8 +762,9 @@ CONTAINS
! for each field: define the OASIS name (ssnd(:)%clname)
! define send or not from the namelist parameters (ssnd(:)%laction)
! define the north fold type of lbc (ssnd(:)%nsgn)
-
+
! default definitions of nsnd
+ ALLOCATE( ssnd(jpsnd) )
ssnd(:)%laction = .FALSE. ; ssnd(:)%clgrid = 'T' ; ssnd(:)%nsgn = 1. ; ssnd(:)%nct = 1
! ! ------------------------- !
@@ -1113,15 +1053,14 @@ CONTAINS
IF(ln_usecplmask) THEN
xcplmask(:,:,:) = 0.
CALL iom_open( 'cplmask', inum )
- CALL iom_get( inum, jpdom_unknown, 'cplmask', xcplmask(1:jpi,1:jpj,1:nn_cplmodel), &
- & kstart = (/ mig(1),mjg(1),1 /), kcount = (/ jpi,jpj,nn_cplmodel /) )
+ CALL iom_get( inum, jpdom_unknown, 'cplmask', xcplmask(:,:,1:nn_cplmodel), &
+ & kstart = (/ mig(Nis0,0),mjg(Njs0,0),1 /), kcount = (/ Ni_0,Nj_0,nn_cplmodel /) )
CALL iom_close( inum )
ELSE
xcplmask(:,:,:) = 1.
ENDIF
xcplmask(:,:,0) = 1. - SUM( xcplmask(:,:,1:nn_cplmodel), dim = 3 )
!
- !
END SUBROUTINE sbc_cpl_init
@@ -1162,7 +1101,7 @@ CONTAINS
!! ** Method : receive all fields from the atmosphere and transform
!! them into ocean surface boundary condition fields
!!
- !! ** Action : update utau, vtau ocean stress at U,V grid
+ !! ** Action : update utau, vtau ocean stress at T-point
!! taum wind stress module at T-point
!! wndm wind speed module at T-point over free ocean or leads in presence of sea-ice
!! qns non solar heat fluxes including emp heat content (ocean only case)
@@ -1186,7 +1125,8 @@ CONTAINS
REAL(wp) :: zcdrag = 1.5e-3 ! drag coefficient
REAL(wp) :: zzx, zzy ! temporary variables
REAL(wp) :: r1_grau ! = 1.e0 / (grav * rho0)
- REAL(wp), DIMENSION(jpi,jpj) :: ztx, zty, zmsk, zemp, zqns, zqsr, zcloud_fra
+ REAL(wp), DIMENSION(A2D(0)) :: ztx, zty, zmsk, zemp
+ REAL(wp), DIMENSION(A2D(0)) :: zqns, zqsr, zcloud_fra
!!----------------------------------------------------------------------
!
IF( kt == nit000 ) THEN
@@ -1201,7 +1141,7 @@ CONTAINS
ENDIF
ENDIF
!
- IF( ln_mixcpl ) zmsk(:,:) = 1. - xcplmask(:,:,0)
+ IF( ln_mixcpl ) zmsk (:,:) = 1. - xcplmask (:,:,0)
!
! ! ======================================================= !
! ! Receive all the atmos. fields (including ice information)
@@ -1221,39 +1161,20 @@ CONTAINS
IF( TRIM( sn_rcv_tau%clvref ) == 'cartesian' ) THEN ! 2 components on the sphere
! ! (cartesian to spherical -> 3 to 2 components)
!
- CALL geo2oce( frcv(jpr_otx1)%z3(:,:,1), frcv(jpr_oty1)%z3(:,:,1), frcv(jpr_otz1)%z3(:,:,1), &
- & srcv(jpr_otx1)%clgrid, ztx, zty )
+ CALL geo2oce( frcv(jpr_otx1)%z3(:,:,1), frcv(jpr_oty1)%z3(:,:,1), frcv(jpr_otz1)%z3(:,:,1), 'T', ztx, zty )
frcv(jpr_otx1)%z3(:,:,1) = ztx(:,:) ! overwrite 1st comp. on the 1st grid
frcv(jpr_oty1)%z3(:,:,1) = zty(:,:) ! overwrite 2nd comp. on the 1st grid
!
- IF( srcv(jpr_otx2)%laction ) THEN
- CALL geo2oce( frcv(jpr_otx2)%z3(:,:,1), frcv(jpr_oty2)%z3(:,:,1), frcv(jpr_otz2)%z3(:,:,1), &
- & srcv(jpr_otx2)%clgrid, ztx, zty )
- frcv(jpr_otx2)%z3(:,:,1) = ztx(:,:) ! overwrite 1st comp. on the 2nd grid
- frcv(jpr_oty2)%z3(:,:,1) = zty(:,:) ! overwrite 2nd comp. on the 2nd grid
- ENDIF
- !
ENDIF
!
IF( TRIM( sn_rcv_tau%clvor ) == 'eastward-northward' ) THEN ! 2 components oriented along the local grid
! ! (geographical to local grid -> rotate the components)
- CALL rot_rep( frcv(jpr_otx1)%z3(:,:,1), frcv(jpr_oty1)%z3(:,:,1), srcv(jpr_otx1)%clgrid, 'en->i', ztx )
- IF( srcv(jpr_otx2)%laction ) THEN
- CALL rot_rep( frcv(jpr_otx2)%z3(:,:,1), frcv(jpr_oty2)%z3(:,:,1), srcv(jpr_otx2)%clgrid, 'en->j', zty )
- ELSE
- CALL rot_rep( frcv(jpr_otx1)%z3(:,:,1), frcv(jpr_oty1)%z3(:,:,1), srcv(jpr_otx1)%clgrid, 'en->j', zty )
- ENDIF
+ CALL rot_rep( frcv(jpr_otx1)%z3(:,:,1), frcv(jpr_oty1)%z3(:,:,1), 'T', 'en->i', ztx )
+ CALL rot_rep( frcv(jpr_otx1)%z3(:,:,1), frcv(jpr_oty1)%z3(:,:,1), 'T', 'en->j', zty )
frcv(jpr_otx1)%z3(:,:,1) = ztx(:,:) ! overwrite 1st component on the 1st grid
frcv(jpr_oty1)%z3(:,:,1) = zty(:,:) ! overwrite 2nd component on the 2nd grid
ENDIF
!
- IF( srcv(jpr_otx1)%clgrid == 'T' ) THEN
- DO_2D( 0, 0, 0, 0 ) ! T ==> (U,V)
- frcv(jpr_otx1)%z3(ji,jj,1) = 0.5 * ( frcv(jpr_otx1)%z3(ji+1,jj ,1) + frcv(jpr_otx1)%z3(ji,jj,1) )
- frcv(jpr_oty1)%z3(ji,jj,1) = 0.5 * ( frcv(jpr_oty1)%z3(ji ,jj+1,1) + frcv(jpr_oty1)%z3(ji,jj,1) )
- END_2D
- CALL lbc_lnk( 'sbccpl', frcv(jpr_otx1)%z3(:,:,1), 'U', -1.0_wp, frcv(jpr_oty1)%z3(:,:,1), 'V', -1.0_wp )
- ENDIF
llnewtx = .TRUE.
ELSE
llnewtx = .FALSE.
@@ -1273,11 +1194,10 @@ CONTAINS
! => need to be done only when otx1 was changed
IF( llnewtx ) THEN
DO_2D( 0, 0, 0, 0 )
- zzx = frcv(jpr_otx1)%z3(ji-1,jj ,1) + frcv(jpr_otx1)%z3(ji,jj,1)
- zzy = frcv(jpr_oty1)%z3(ji ,jj-1,1) + frcv(jpr_oty1)%z3(ji,jj,1)
+ zzx = frcv(jpr_otx1)%z3(ji,jj,1)
+ zzy = frcv(jpr_oty1)%z3(ji,jj,1)
frcv(jpr_taum)%z3(ji,jj,1) = 0.5 * SQRT( zzx * zzx + zzy * zzy )
END_2D
- CALL lbc_lnk( 'sbccpl', frcv(jpr_taum)%z3(:,:,1), 'T', 1.0_wp )
llnewtau = .TRUE.
ELSE
llnewtau = .FALSE.
@@ -1286,7 +1206,7 @@ CONTAINS
llnewtau = nrcvinfo(jpr_taum) == OASIS_Rcv
! Stress module can be negative when received (interpolation problem)
IF( llnewtau ) THEN
- frcv(jpr_taum)%z3(:,:,1) = MAX( 0._wp, frcv(jpr_taum)%z3(:,:,1) )
+ frcv(jpr_taum)%z3(A2D(0),1) = MAX( 0._wp, frcv(jpr_taum)%z3(A2D(0),1) )
ENDIF
ENDIF
!
@@ -1297,7 +1217,7 @@ CONTAINS
! => need to be done only when taumod was changed
IF( llnewtau ) THEN
zcoef = 1. / ( zrhoa * zcdrag )
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
frcv(jpr_w10m)%z3(ji,jj,1) = SQRT( frcv(jpr_taum)%z3(ji,jj,1) * zcoef )
END_2D
ENDIF
@@ -1305,7 +1225,7 @@ CONTAINS
!!$ ! ! ========================= !
!!$ SELECT CASE( TRIM( sn_rcv_clouds%cldes ) ) ! cloud fraction !
!!$ ! ! ========================= !
-!!$ cloud_fra(:,:) = frcv(jpr_clfra)*z3(:,:,1)
+!!$ cloud_fra(:,:) = frcv(jpr_clfra)*z3(A2D(0),1)
!!$ END SELECT
!!$
zcloud_fra(:,:) = pp_cldf ! should be real cloud fraction instead (as in the bulk) but needs to be read from atm.
@@ -1343,13 +1263,14 @@ CONTAINS
! ! Mean Sea Level Pressure ! (taum)
! ! ========================= !
IF( srcv(jpr_mslp)%laction ) THEN ! UKMO SHELF effect of atmospheric pressure on SSH
- IF( kt /= nit000 ) ssh_ibb(:,:) = ssh_ib(:,:) !* Swap of ssh_ib fields
+ IF( kt /= nit000 ) ssh_ibb(A2D(0)) = ssh_ib(A2D(0)) !* Swap of ssh_ib fields
r1_grau = 1.e0 / (grav * rho0) !* constant for optimization
- ssh_ib(:,:) = - ( frcv(jpr_mslp)%z3(:,:,1) - rpref ) * r1_grau ! equivalent ssh (inverse barometer)
- apr (:,:) = frcv(jpr_mslp)%z3(:,:,1) !atmospheric pressure
+ ssh_ib(A2D(0)) = - ( frcv(jpr_mslp)%z3(:,:,1) - rpref ) * r1_grau ! equivalent ssh (inverse barometer)
+ apr (A2D(0)) = frcv(jpr_mslp)%z3(:,:,1) !atmospheric pressure
- IF( kt == nit000 ) ssh_ibb(:,:) = ssh_ib(:,:) ! correct this later (read from restart if possible)
+ IF( kt == nit000 ) ssh_ibb(A2D(0)) = ssh_ib(A2D(0)) ! correct this later (read from restart if possible)
+ CALL lbc_lnk( 'sbccpl', ssh_ib, 'T', 1.0_wp, ssh_ibb, 'T', 1.0_wp )
ENDIF
!
IF( ln_sdw ) THEN ! Stokes Drift correction activated
@@ -1445,30 +1366,34 @@ CONTAINS
! ! SST !
! ! ================== !
IF( srcv(jpr_toce)%laction ) THEN ! received by sas in case of opa <-> sas coupling
- sst_m(:,:) = frcv(jpr_toce)%z3(:,:,1)
- IF( srcv(jpr_soce)%laction .AND. l_useCT ) THEN ! make sure that sst_m is the potential temperature
- sst_m(:,:) = eos_pt_from_ct( sst_m(:,:), sss_m(:,:) )
+ IF( srcv(jpr_soce)%laction .AND. l_useCT ) THEN ! make sure that sst_m is the potential temperature
+ CALL eos_pt_from_ct( frcv(jpr_toce)%z3(:,:,1), sss_m(:,:), sst_m(:,:), kbnd=0 )
+ ELSE
+ sst_m(A2D(0)) = frcv(jpr_toce)%z3(:,:,1)
ENDIF
+ CALL iom_put( 'sst_m', sst_m )
ENDIF
! ! ================== !
! ! SSH !
! ! ================== !
IF( srcv(jpr_ssh )%laction ) THEN ! received by sas in case of opa <-> sas coupling
- ssh_m(:,:) = frcv(jpr_ssh )%z3(:,:,1)
+ ssh_m(A2D(0)) = frcv(jpr_ssh )%z3(:,:,1)
CALL iom_put( 'ssh_m', ssh_m )
ENDIF
! ! ================== !
! ! surface currents !
! ! ================== !
IF( srcv(jpr_ocx1)%laction ) THEN ! received by sas in case of opa <-> sas coupling
- ssu_m(:,:) = frcv(jpr_ocx1)%z3(:,:,1)
- uu(:,:,1,Kbb) = ssu_m(:,:) ! will be used in icestp in the call of ice_forcing_tau
+ ssu_m(A2D(0)) = frcv(jpr_ocx1)%z3(:,:,1)
+ CALL lbc_lnk( 'sbccpl', ssu_m, 'U', -1.0_wp )
+ uu(:,:,1,Kbb) = ssu_m(:,:) ! will be used in icestp in the call of ice_update_tau
uu(:,:,1,Kmm) = ssu_m(:,:) ! will be used in sbc_cpl_snd if atmosphere coupling
CALL iom_put( 'ssu_m', ssu_m )
ENDIF
IF( srcv(jpr_ocy1)%laction ) THEN
- ssv_m(:,:) = frcv(jpr_ocy1)%z3(:,:,1)
- vv(:,:,1,Kbb) = ssv_m(:,:) ! will be used in icestp in the call of ice_forcing_tau
+ ssv_m(A2D(0)) = frcv(jpr_ocy1)%z3(:,:,1)
+ CALL lbc_lnk( 'sbccpl', ssv_m, 'V', -1.0_wp )
+ vv(:,:,1,Kbb) = ssv_m(:,:) ! will be used in icestp in the call of ice_update_tau
vv(:,:,1,Kmm) = ssv_m(:,:) ! will be used in sbc_cpl_snd if atmosphere coupling
CALL iom_put( 'ssv_m', ssv_m )
ENDIF
@@ -1476,14 +1401,14 @@ CONTAINS
! ! first T level thickness !
! ! ======================== !
IF( srcv(jpr_e3t1st )%laction ) THEN ! received by sas in case of opa <-> sas coupling
- e3t_m(:,:) = frcv(jpr_e3t1st )%z3(:,:,1)
- CALL iom_put( 'e3t_m', e3t_m(:,:) )
+ e3t_m(A2D(0)) = frcv(jpr_e3t1st )%z3(:,:,1)
+ CALL iom_put( 'e3t_m', e3t_m )
ENDIF
! ! ================================ !
! ! fraction of solar net radiation !
! ! ================================ !
IF( srcv(jpr_fraqsr)%laction ) THEN ! received by sas in case of opa <-> sas coupling
- frq_m(:,:) = frcv(jpr_fraqsr)%z3(:,:,1)
+ frq_m(A2D(0)) = frcv(jpr_fraqsr)%z3(:,:,1)
CALL iom_put( 'frq_m', frq_m )
ENDIF
@@ -1506,12 +1431,12 @@ CONTAINS
ENDIF
!
! ! runoffs and calving (added in emp)
- IF( srcv(jpr_rnf)%laction ) rnf(:,:) = frcv(jpr_rnf)%z3(:,:,1)
+ IF( srcv(jpr_rnf)%laction ) rnf(A2D(0)) = frcv(jpr_rnf)%z3(:,:,1)
IF( srcv(jpr_cal)%laction ) zemp(:,:) = zemp(:,:) - frcv(jpr_cal)%z3(:,:,1)
IF( srcv(jpr_icb)%laction ) THEN
fwficb(:,:) = frcv(jpr_icb)%z3(:,:,1)
- rnf(:,:) = rnf(:,:) + fwficb(:,:) ! iceberg added to runfofs
+ rnf(A2D(0)) = rnf(A2D(0)) + fwficb(:,:) ! iceberg added to runfofs
ENDIF
!
! ice shelf fwf
@@ -1519,8 +1444,8 @@ CONTAINS
fwfisf_oasis(:,:) = frcv(jpr_isf)%z3(:,:,1) ! fresh water flux from the isf to the ocean ( > 0 = melting )
END IF
- IF( ln_mixcpl ) THEN ; emp(:,:) = emp(:,:) * xcplmask(:,:,0) + zemp(:,:) * zmsk(:,:)
- ELSE ; emp(:,:) = zemp(:,:)
+ IF( ln_mixcpl ) THEN ; emp(A2D(0)) = emp(A2D(0)) * xcplmask(:,:,0) + zemp(:,:) * zmsk(:,:)
+ ELSE ; emp(A2D(0)) = zemp(:,:)
ENDIF
!
! ! non solar heat flux over the ocean (qns)
@@ -1530,7 +1455,7 @@ CONTAINS
ENDIF
! update qns over the free ocean with:
IF( nn_components /= jp_iam_oce ) THEN
- zqns(:,:) = zqns(:,:) - zemp(:,:) * sst_m(:,:) * rcp ! remove heat content due to mass flux (assumed to be at SST)
+ zqns(:,:) = zqns(:,:) - zemp(:,:) * sst_m(A2D(0)) * rcp ! remove heat content due to mass flux (assumed to be at SST)
IF( srcv(jpr_snow )%laction ) THEN
zqns(:,:) = zqns(:,:) - frcv(jpr_snow)%z3(:,:,1) * rLfus ! energy for melting solid precipitation over the free ocean
ENDIF
@@ -1593,13 +1518,13 @@ CONTAINS
!!
!! ** Action : return ptau_i, ptau_j, the stress over the ice
!!----------------------------------------------------------------------
- REAL(wp), INTENT(inout), DIMENSION(:,:) :: p_taui ! i- & j-components of atmos-ice stress [N/m2]
- REAL(wp), INTENT(inout), DIMENSION(:,:) :: p_tauj ! at I-point (B-grid) or U & V-point (C-grid)
+ REAL(wp), INTENT(inout), DIMENSION(A2D(0)) :: p_taui ! i- & j-components of atmos-ice stress [N/m2]
+ REAL(wp), INTENT(inout), DIMENSION(A2D(0)) :: p_tauj ! at T-point
!!
INTEGER :: ji, jj ! dummy loop indices
INTEGER :: itx ! index of taux over ice
- REAL(wp) :: zztmp1, zztmp2
- REAL(wp), DIMENSION(jpi,jpj) :: ztx, zty
+ REAL(wp) :: zztmp1, zztmp2
+ REAL(wp), DIMENSION(A2D(0)) :: ztx, zty
!!----------------------------------------------------------------------
!
#if defined key_si3 || defined key_cice
@@ -1616,28 +1541,16 @@ CONTAINS
!
IF( TRIM( sn_rcv_tau%clvref ) == 'cartesian' ) THEN ! 2 components on the sphere
! ! (cartesian to spherical -> 3 to 2 components)
- CALL geo2oce( frcv(jpr_itx1)%z3(:,:,1), frcv(jpr_ity1)%z3(:,:,1), frcv(jpr_itz1)%z3(:,:,1), &
- & srcv(jpr_itx1)%clgrid, ztx, zty )
+ CALL geo2oce( frcv(jpr_itx1)%z3(:,:,1), frcv(jpr_ity1)%z3(:,:,1), frcv(jpr_itz1)%z3(:,:,1), 'T', ztx, zty )
frcv(jpr_itx1)%z3(:,:,1) = ztx(:,:) ! overwrite 1st comp. on the 1st grid
frcv(jpr_ity1)%z3(:,:,1) = zty(:,:) ! overwrite 2nd comp. on the 1st grid
!
- IF( srcv(jpr_itx2)%laction ) THEN
- CALL geo2oce( frcv(jpr_itx2)%z3(:,:,1), frcv(jpr_ity2)%z3(:,:,1), frcv(jpr_itz2)%z3(:,:,1), &
- & srcv(jpr_itx2)%clgrid, ztx, zty )
- frcv(jpr_itx2)%z3(:,:,1) = ztx(:,:) ! overwrite 1st comp. on the 2nd grid
- frcv(jpr_ity2)%z3(:,:,1) = zty(:,:) ! overwrite 2nd comp. on the 2nd grid
- ENDIF
- !
ENDIF
!
IF( TRIM( sn_rcv_tau%clvor ) == 'eastward-northward' ) THEN ! 2 components oriented along the local grid
! ! (geographical to local grid -> rotate the components)
- CALL rot_rep( frcv(jpr_itx1)%z3(:,:,1), frcv(jpr_ity1)%z3(:,:,1), srcv(jpr_itx1)%clgrid, 'en->i', ztx )
- IF( srcv(jpr_itx2)%laction ) THEN
- CALL rot_rep( frcv(jpr_itx2)%z3(:,:,1), frcv(jpr_ity2)%z3(:,:,1), srcv(jpr_itx2)%clgrid, 'en->j', zty )
- ELSE
- CALL rot_rep( frcv(jpr_itx1)%z3(:,:,1), frcv(jpr_ity1)%z3(:,:,1), srcv(jpr_itx1)%clgrid, 'en->j', zty )
- ENDIF
+ CALL rot_rep( frcv(jpr_itx1)%z3(:,:,1), frcv(jpr_ity1)%z3(:,:,1), 'T', 'en->i', ztx )
+ CALL rot_rep( frcv(jpr_itx1)%z3(:,:,1), frcv(jpr_ity1)%z3(:,:,1), 'T', 'en->j', zty )
frcv(jpr_itx1)%z3(:,:,1) = ztx(:,:) ! overwrite 1st component on the 1st grid
frcv(jpr_ity1)%z3(:,:,1) = zty(:,:) ! overwrite 2nd component on the 1st grid
ENDIF
@@ -1651,29 +1564,8 @@ CONTAINS
! ! ======================= !
! ! put on ice grid !
! ! ======================= !
- !
- ! j+1 j -----V---F
- ! ice stress on ice velocity point ! |
- ! (C-grid ==>(U,V)) j | T U
- ! | |
- ! j j-1 -I-------|
- ! (for I) | |
- ! i-1 i i
- ! i i+1 (for I)
- SELECT CASE ( srcv(jpr_itx1)%clgrid )
- CASE( 'U' )
- p_taui(:,:) = frcv(jpr_itx1)%z3(:,:,1) ! (U,V) ==> (U,V)
- p_tauj(:,:) = frcv(jpr_ity1)%z3(:,:,1)
- CASE( 'T' )
- DO_2D( 0, 0, 0, 0 ) ! T ==> (U,V)
- ! take care of the land-sea mask to avoid "pollution" of coastal stress. p[uv]taui used in frazil and rheology
- zztmp1 = 0.5_wp * ( 2. - umask(ji,jj,1) ) * MAX( tmask(ji,jj,1),tmask(ji+1,jj ,1) )
- zztmp2 = 0.5_wp * ( 2. - vmask(ji,jj,1) ) * MAX( tmask(ji,jj,1),tmask(ji ,jj+1,1) )
- p_taui(ji,jj) = zztmp1 * ( frcv(jpr_itx1)%z3(ji+1,jj ,1) + frcv(jpr_itx1)%z3(ji,jj,1) )
- p_tauj(ji,jj) = zztmp2 * ( frcv(jpr_ity1)%z3(ji ,jj+1,1) + frcv(jpr_ity1)%z3(ji,jj,1) )
- END_2D
- CALL lbc_lnk( 'sbccpl', p_taui, 'U', -1., p_tauj, 'V', -1. )
- END SELECT
+ p_taui(:,:) = frcv(jpr_itx1)%z3(:,:,1)
+ p_tauj(:,:) = frcv(jpr_ity1)%z3(:,:,1)
ENDIF
!
@@ -1739,22 +1631,23 @@ CONTAINS
!! dqns_ice d(non-solar heat flux)/d(Temperature) over the ice
!! sprecip solid precipitation over the ocean
!!----------------------------------------------------------------------
- INTEGER, INTENT(in) :: kt ! ocean model time step index (only for a_i_last_couple)
- REAL(wp), INTENT(in) , DIMENSION(:,:) :: picefr ! ice fraction [0 to 1]
- ! !! ! optional arguments, used only in 'mixed oce-ice' case or for Met-Office coupling
- REAL(wp), INTENT(in) , DIMENSION(:,:,:), OPTIONAL :: palbi ! all skies ice albedo
- REAL(wp), INTENT(in) , DIMENSION(:,: ), OPTIONAL :: psst ! sea surface temperature [Celsius]
- REAL(wp), INTENT(inout), DIMENSION(:,:,:), OPTIONAL :: pist ! ice surface temperature [Kelvin] => inout for Met-Office
- REAL(wp), INTENT(in) , DIMENSION(:,:,:), OPTIONAL :: phs ! snow depth [m]
- REAL(wp), INTENT(in) , DIMENSION(:,:,:), OPTIONAL :: phi ! ice thickness [m]
+ INTEGER, INTENT(in) :: kt ! ocean model time step index (only for a_i_last_couple)
+ REAL(wp), INTENT(in) , DIMENSION(A2D(0)) :: picefr ! ice fraction [0 to 1]
+ ! !! optional arguments, used only in 'mixed oce-ice' case or for Met-Office coupling
+ REAL(wp), INTENT(in) , DIMENSION(A2D(0),jpl), OPTIONAL :: palbi ! all skies ice albedo
+ REAL(wp), INTENT(in) , DIMENSION(A2D(0) ), OPTIONAL :: psst ! sea surface temperature [Celsius]
+ REAL(wp), INTENT(inout), DIMENSION(A2D(0),jpl), OPTIONAL :: pist ! ice surface temperature [Kelvin] => inout for Met-Office
+ REAL(wp), INTENT(in) , DIMENSION(A2D(0),jpl), OPTIONAL :: phs ! snow depth [m]
+ REAL(wp), INTENT(in) , DIMENSION(A2D(0),jpl), OPTIONAL :: phi ! ice thickness [m]
!
INTEGER :: ji, jj, jl ! dummy loop index
- REAL(wp), DIMENSION(jpi,jpj) :: zcptn, zcptrain, zcptsnw, ziceld, zmsk, zsnw
- REAL(wp), DIMENSION(jpi,jpj) :: zemp_tot, zemp_ice, zemp_oce, ztprecip, zsprecip , zevap_oce, zdevap_ice
- REAL(wp), DIMENSION(jpi,jpj) :: zqns_tot, zqns_oce, zqsr_tot, zqsr_oce, zqprec_ice, zqemp_oce, zqemp_ice
- REAL(wp), DIMENSION(jpi,jpj) :: zevap_ice_total
- REAL(wp), DIMENSION(jpi,jpj,jpl) :: zqns_ice, zqsr_ice, zdqns_ice, zqevap_ice, zevap_ice, zqtr_ice_top, ztsu
- REAL(wp), DIMENSION(jpi,jpj) :: ztri
+ REAL(wp), DIMENSION(A2D(0)) :: zcptn, zcptrain, zcptsnw, ziceld, zmsk, zsnw
+ REAL(wp), DIMENSION(A2D(0)) :: zemp_tot, zemp_ice, zemp_oce, ztprecip, zsprecip , zevap_oce, zdevap_ice
+ REAL(wp), DIMENSION(A2D(0)) :: zqns_tot, zqns_oce, zqsr_tot, zqsr_oce, zqprec_ice, zqemp_oce, zqemp_ice
+ REAL(wp), DIMENSION(A2D(0)) :: zevap_ice_total
+ REAL(wp), DIMENSION(A2D(0)) :: ztri
+ REAL(wp), DIMENSION(A2D(0),jpl) :: zqns_ice, zqsr_ice, zdqns_ice, zqevap_ice, zevap_ice, zqtr_ice_top
+ REAL(wp), DIMENSION(A2D(0),jpl) :: ztsu
!!----------------------------------------------------------------------
!
#if defined key_si3 || defined key_cice
@@ -1768,7 +1661,7 @@ CONTAINS
!
IF( ln_mixcpl ) zmsk(:,:) = 1. - xcplmask(:,:,0)
ziceld(:,:) = 1._wp - picefr(:,:)
- zcptn (:,:) = rcp * sst_m(:,:)
+ zcptn (:,:) = rcp * sst_m(A2D(0))
!
! ! ========================= !
! ! freshwater budget ! (emp_tot)
@@ -1780,9 +1673,9 @@ CONTAINS
! ! sublimation - solid precipitation (cell average) (emp_ice)
SELECT CASE( TRIM( sn_rcv_emp%cldes ) )
CASE( 'conservative' ) ! received fields: jpr_rain, jpr_snow, jpr_ievp, jpr_tevp
- zsprecip(:,:) = frcv(jpr_snow)%z3(:,:,1) ! May need to ensure positive here
- ztprecip(:,:) = frcv(jpr_rain)%z3(:,:,1) + zsprecip(:,:) ! May need to ensure positive here
- zemp_tot(:,:) = frcv(jpr_tevp)%z3(:,:,1) - ztprecip(:,:)
+ zsprecip(:,:) = frcv(jpr_snow)%z3(:,:,1) ! May need to ensure positive here
+ ztprecip(:,:) = frcv(jpr_rain)%z3(:,:,1) + zsprecip(:,:) ! May need to ensure positive here
+ zemp_tot(:,:) = frcv(jpr_tevp)%z3(:,:,1) - ztprecip(:,:)
CASE( 'oce and ice' ) ! received fields: jpr_sbpr, jpr_semp, jpr_oemp, jpr_ievp
zemp_tot(:,:) = ziceld(:,:) * frcv(jpr_oemp)%z3(:,:,1) + picefr(:,:) * frcv(jpr_sbpr)%z3(:,:,1)
zemp_ice(:,:) = frcv(jpr_semp)%z3(:,:,1) * picefr(:,:)
@@ -1794,17 +1687,19 @@ CONTAINS
END SELECT
! --- evaporation over ice (kg/m2/s) --- !
- IF (ln_scale_ice_flux) THEN ! typically met-office requirements
- IF (sn_rcv_emp%clcat == 'yes') THEN
- WHERE( a_i(:,:,:) > 1.e-10 ) ; zevap_ice(:,:,:) = frcv(jpr_ievp)%z3(:,:,:) * a_i_last_couple(:,:,:) / a_i(:,:,:)
- ELSEWHERE ; zevap_ice(:,:,:) = 0._wp
+ IF( ln_scale_ice_flux ) THEN ! typically met-office requirements
+ IF( sn_rcv_emp%clcat == 'yes' ) THEN
+ WHERE( a_i(A2D(0),:) > 1.e-10 ) ; zevap_ice(:,:,:) = frcv(jpr_ievp)%z3(:,:,:) * &
+ & a_i_last_couple(A2D(0),:) / a_i(A2D(0),:)
+ ELSEWHERE ; zevap_ice(:,:,:) = 0._wp
END WHERE
- WHERE( picefr(:,:) > 1.e-10 ) ; zevap_ice_total(:,:) = SUM( zevap_ice(:,:,:) * a_i(:,:,:), dim=3 ) / picefr(:,:)
- ELSEWHERE ; zevap_ice_total(:,:) = 0._wp
+ WHERE( picefr(:,:) > 1.e-10 ) ; zevap_ice_total(:,:) = SUM( zevap_ice(:,:,:) * a_i(A2D(0),:), dim=3 ) / picefr(:,:)
+ ELSEWHERE ; zevap_ice_total(:,:) = 0._wp
END WHERE
ELSE
- WHERE( picefr(:,:) > 1.e-10 ) ; zevap_ice(:,:,1) = frcv(jpr_ievp)%z3(:,:,1) * SUM( a_i_last_couple, dim=3 ) / picefr(:,:)
- ELSEWHERE ; zevap_ice(:,:,1) = 0._wp
+ WHERE( picefr(:,:) > 1.e-10 ) ; zevap_ice(:,:,1) = frcv(jpr_ievp)%z3(:,:,1) * &
+ & SUM( a_i_last_couple(A2D(0),:), dim=3 ) / picefr(:,:)
+ ELSEWHERE ; zevap_ice(:,:,1) = 0._wp
END WHERE
zevap_ice_total(:,:) = zevap_ice(:,:,1)
DO jl = 2, jpl
@@ -1812,9 +1707,9 @@ CONTAINS
ENDDO
ENDIF
ELSE
- IF (sn_rcv_emp%clcat == 'yes') THEN
+ IF( sn_rcv_emp%clcat == 'yes' ) THEN
zevap_ice(:,:,1:jpl) = frcv(jpr_ievp)%z3(:,:,1:jpl)
- WHERE( picefr(:,:) > 1.e-10 ) ; zevap_ice_total(:,:) = SUM( zevap_ice(:,:,:) * a_i(:,:,:), dim=3 ) / picefr(:,:)
+ WHERE( picefr(:,:) > 1.e-10 ) ; zevap_ice_total(:,:) = SUM( zevap_ice(:,:,:) * a_i(A2D(0),:), dim=3 ) / picefr(:,:)
ELSEWHERE ; zevap_ice_total(:,:) = 0._wp
END WHERE
ELSE
@@ -1826,7 +1721,7 @@ CONTAINS
ENDIF
ENDIF
- IF ( TRIM( sn_rcv_emp%cldes ) == 'conservative' ) THEN
+ IF( TRIM( sn_rcv_emp%cldes ) == 'conservative' ) THEN
! For conservative case zemp_ice has not been defined yet. Do it now.
zemp_ice(:,:) = zevap_ice_total(:,:) * picefr(:,:) - frcv(jpr_snow)%z3(:,:,1) * picefr(:,:)
ENDIF
@@ -1847,7 +1742,7 @@ CONTAINS
! --- Continental fluxes --- !
IF( srcv(jpr_rnf)%laction ) THEN ! runoffs (included in emp later on)
- rnf(:,:) = frcv(jpr_rnf)%z3(:,:,1)
+ rnf(A2D(0)) = frcv(jpr_rnf)%z3(:,:,1)
ENDIF
IF( srcv(jpr_cal)%laction ) THEN ! calving (put in emp_tot and emp_oce)
zemp_tot(:,:) = zemp_tot(:,:) - frcv(jpr_cal)%z3(:,:,1)
@@ -1855,7 +1750,7 @@ CONTAINS
ENDIF
IF( srcv(jpr_icb)%laction ) THEN ! iceberg added to runoffs
fwficb(:,:) = frcv(jpr_icb)%z3(:,:,1)
- rnf(:,:) = rnf(:,:) + fwficb(:,:)
+ rnf(A2D(0)) = rnf(A2D(0)) + fwficb(:,:)
ENDIF
IF( srcv(jpr_isf)%laction ) THEN ! iceshelf (fwfisf > 0 mean melting)
fwfisf_oasis(:,:) = frcv(jpr_isf)%z3(:,:,1)
@@ -1913,29 +1808,29 @@ CONTAINS
!!$ ENDIF
!
! outputs
- IF( srcv(jpr_cal)%laction ) CALL iom_put( 'calving_cea' , frcv(jpr_cal)%z3(:,:,1) * tmask(:,:,1) ) ! calving
- IF( srcv(jpr_icb)%laction ) CALL iom_put( 'iceberg_cea' , frcv(jpr_icb)%z3(:,:,1) * tmask(:,:,1) ) ! icebergs
+ IF( srcv(jpr_cal)%laction ) CALL iom_put( 'calving_cea' , frcv(jpr_cal)%z3(:,:,1) * tmask(A2D(0),1) ) ! calving
+ IF( srcv(jpr_icb)%laction ) CALL iom_put( 'iceberg_cea' , frcv(jpr_icb)%z3(:,:,1) * tmask(A2D(0),1) ) ! icebergs
IF( iom_use('snowpre') ) CALL iom_put( 'snowpre' , sprecip(:,:) ) ! Snow
IF( iom_use('precip') ) CALL iom_put( 'precip' , tprecip(:,:) ) ! total precipitation
IF( iom_use('rain') ) CALL iom_put( 'rain' , tprecip(:,:) - sprecip(:,:) ) ! liquid precipitation
IF( iom_use('snow_ao_cea') ) CALL iom_put( 'snow_ao_cea' , sprecip(:,:) * ( 1._wp - zsnw(:,:) ) ) ! Snow over ice-free ocean (cell average)
IF( iom_use('snow_ai_cea') ) CALL iom_put( 'snow_ai_cea' , sprecip(:,:) * zsnw(:,:) ) ! Snow over sea-ice (cell average)
IF( iom_use('rain_ao_cea') ) CALL iom_put( 'rain_ao_cea' , ( tprecip(:,:) - sprecip(:,:) ) * ziceld(:,:) ) ! liquid precipitation over ocean (cell average)
- IF( iom_use('subl_ai_cea') ) CALL iom_put( 'subl_ai_cea' , zevap_ice_total(:,:) * picefr(:,:) * tmask(:,:,1) ) ! Sublimation over sea-ice (cell average)
+ IF( iom_use('subl_ai_cea') ) CALL iom_put( 'subl_ai_cea' , zevap_ice_total(:,:) * picefr(:,:) * smask0(:,:) ) ! Sublimation over sea-ice (cell average)
IF( iom_use('evap_ao_cea') ) CALL iom_put( 'evap_ao_cea' , ( frcv(jpr_tevp)%z3(:,:,1) &
- & - zevap_ice_total(:,:) * picefr(:,:) ) * tmask(:,:,1) ) ! ice-free oce evap (cell average)
+ & - zevap_ice_total(:,:) * picefr(:,:) ) * smask0(:,:) ) ! ice-free oce evap (cell average)
! note: runoff output is done in sbcrnf (which includes icebergs too) and iceshelf output is done in sbcisf
!! IF( srcv(jpr_rnf)%laction ) CALL iom_put( 'runoffs' , rnf(:,:) * tmask(:,:,1) ) ! runoff
-!! IF( srcv(jpr_isf)%laction ) CALL iom_put( 'iceshelf_cea', fwfisf(:,:) * tmask(:,:,1) ) ! iceshelf
+ IF( srcv(jpr_isf)%laction ) CALL iom_put( 'iceshelf_cea', frcv(jpr_isf)%z3(:,:,1) * smask0(:,:) ) ! iceshelf
!
! ! ========================= !
SELECT CASE( TRIM( sn_rcv_iceflx%cldes ) ) ! ice topmelt and botmelt !
! ! ========================= !
- CASE ('coupled')
- IF (ln_scale_ice_flux) THEN
- WHERE( a_i(:,:,:) > 1.e-10_wp )
- qml_ice(:,:,:) = frcv(jpr_topm)%z3(:,:,:) * a_i_last_couple(:,:,:) / a_i(:,:,:)
- qcn_ice(:,:,:) = frcv(jpr_botm)%z3(:,:,:) * a_i_last_couple(:,:,:) / a_i(:,:,:)
+ CASE( 'coupled' )
+ IF( ln_scale_ice_flux ) THEN
+ WHERE( a_i(A2D(0),:) > 1.e-10_wp )
+ qml_ice(:,:,:) = frcv(jpr_topm)%z3(:,:,:) * a_i_last_couple(A2D(0),:) / a_i(A2D(0),:)
+ qcn_ice(:,:,:) = frcv(jpr_botm)%z3(:,:,:) * a_i_last_couple(A2D(0),:) / a_i(A2D(0),:)
ELSEWHERE
qml_ice(:,:,:) = 0.0_wp
qcn_ice(:,:,:) = 0.0_wp
@@ -1958,7 +1853,7 @@ CONTAINS
ENDIF
! Calculate the total non solar heat flux. The ocean only non solar heat flux (zqns_oce) will be recalculated after this CASE
! statement to be consistent with other coupling methods even though .zqns_oce = frcv(jpr_qnsoce)%z3(:,:,1)
- zqns_tot(:,:) = frcv(jpr_qnsoce)%z3(:,:,1) + SUM( zqns_ice(:,:,:) * a_i(:,:,:), dim=3 )
+ zqns_tot(:,:) = frcv(jpr_qnsoce)%z3(:,:,1) + SUM( zqns_ice(:,:,:) * a_i(A2D(0),:), dim=3 )
CASE( 'conservative' ) ! the required fields are directly provided
zqns_tot(:,:) = frcv(jpr_qnsmix)%z3(:,:,1)
IF( TRIM(sn_rcv_qns%clcat) == 'yes' ) THEN
@@ -1972,7 +1867,7 @@ CONTAINS
zqns_tot(:,:) = ziceld(:,:) * frcv(jpr_qnsoce)%z3(:,:,1)
IF( TRIM(sn_rcv_qns%clcat) == 'yes' ) THEN
DO jl=1,jpl
- zqns_tot(:,: ) = zqns_tot(:,:) + a_i(:,:,jl) * frcv(jpr_qnsice)%z3(:,:,jl)
+ zqns_tot(:,: ) = zqns_tot(:,:) + a_i(A2D(0),jl) * frcv(jpr_qnsice)%z3(:,:,jl)
zqns_ice(:,:,jl) = frcv(jpr_qnsice)%z3(:,:,jl)
ENDDO
ELSE
@@ -2001,21 +1896,22 @@ CONTAINS
!
! --- calving (removed from qns_tot) --- !
IF( srcv(jpr_cal)%laction ) zqns_tot(:,:) = zqns_tot(:,:) - frcv(jpr_cal)%z3(:,:,1) * rLfus ! remove latent heat of calving
- ! we suppose it melts at 0deg, though it should be temp. of surrounding ocean
+ ! we suppose it melts at 0deg, though it should be temp. of surrounding ocean
! --- iceberg (removed from qns_tot) --- !
IF( srcv(jpr_icb)%laction ) zqns_tot(:,:) = zqns_tot(:,:) - frcv(jpr_icb)%z3(:,:,1) * rLfus ! remove latent heat of iceberg melting
! --- non solar flux over ocean --- !
! note: ziceld cannot be = 0 since we limit the ice concentration to amax
zqns_oce = 0._wp
- WHERE( ziceld /= 0._wp ) zqns_oce(:,:) = ( zqns_tot(:,:) - SUM( a_i * zqns_ice, dim=3 ) ) / ziceld(:,:)
+ WHERE( ziceld /= 0._wp ) zqns_oce(:,:) = ( zqns_tot(:,:) - SUM( a_i(A2D(0),:) * zqns_ice(:,:,:), dim=3 ) ) / ziceld(:,:)
! Heat content per unit mass of snow (J/kg)
- WHERE( SUM( a_i, dim=3 ) > 1.e-10 ) ; zcptsnw(:,:) = rcpi * SUM( (tn_ice - rt0) * a_i, dim=3 ) / SUM( a_i, dim=3 )
- ELSEWHERE ; zcptsnw(:,:) = zcptn(:,:)
+ WHERE( SUM( a_i(A2D(0),:), dim=3 ) > 1.e-10 ) ; zcptsnw(:,:) = rcpi * SUM( (tn_ice(:,:,:) - rt0) * a_i(A2D(0),:), dim=3 ) &
+ & / SUM( a_i(A2D(0),:), dim=3 )
+ ELSEWHERE ; zcptsnw(:,:) = zcptn(:,:)
ENDWHERE
! Heat content per unit mass of rain (J/kg)
- zcptrain(:,:) = rcp * ( SUM( (tn_ice(:,:,:) - rt0) * a_i(:,:,:), dim=3 ) + sst_m(:,:) * ziceld(:,:) )
+ zcptrain(:,:) = rcp * ( SUM( (tn_ice(:,:,:) - rt0) * a_i(A2D(0),:), dim=3 ) + sst_m(A2D(0)) * ziceld(:,:) )
! --- enthalpy of snow precip over ice in J/m3 (to be used in 1D-thermo) --- !
zqprec_ice(:,:) = rhos * ( zcptsnw(:,:) - rLfus )
@@ -2086,7 +1982,7 @@ CONTAINS
& CALL iom_put('hflx_rain_cea' , ( tprecip(:,:) - sprecip(:,:) ) * zcptrain(:,:) )
IF ( iom_use('hflx_evap_cea') ) & ! heat flux from evap (cell average)
& CALL iom_put('hflx_evap_cea' , ( frcv(jpr_tevp)%z3(:,:,1) - zevap_ice_total(:,:) * picefr(:,:) ) &
- & * zcptn(:,:) * tmask(:,:,1) )
+ & * zcptn(:,:) * smask0(:,:) )
IF ( iom_use('hflx_prec_cea') ) & ! heat flux from all precip (cell avg)
& CALL iom_put('hflx_prec_cea' , sprecip(:,:) * ( zcptsnw(:,:) - rLfus ) &
& + ( tprecip(:,:) - sprecip(:,:) ) * zcptrain(:,:) )
@@ -2097,7 +1993,7 @@ CONTAINS
IF ( iom_use('hflx_snow_ai_cea') ) & ! heat flux from snow (over ice)
& CALL iom_put('hflx_snow_ai_cea', sprecip(:,:) * ( zcptsnw(:,:) - rLfus ) * zsnw(:,:) )
IF( iom_use('hflx_subl_cea') ) & ! heat flux from sublimation
- & CALL iom_put('hflx_subl_cea' , SUM( qevap_ice(:,:,:) * a_i(:,:,:), dim=3 ) * tmask(:,:,1) )
+ & CALL iom_put('hflx_subl_cea' , SUM( qevap_ice(:,:,:) * a_i(A2D(0),:), dim=3 ) * smask0(:,:) )
! note: hflx for runoff and iceshelf are done in sbcrnf and sbcisf resp.
!
! ! ========================= !
@@ -2145,7 +2041,7 @@ CONTAINS
zqsr_tot(:,: ) = ziceld(:,:) * frcv(jpr_qsroce)%z3(:,:,1)
IF( TRIM(sn_rcv_qsr%clcat) == 'yes' ) THEN
DO jl = 1, jpl
- zqsr_tot(:,: ) = zqsr_tot(:,:) + a_i(:,:,jl) * frcv(jpr_qsrice)%z3(:,:,jl)
+ zqsr_tot(:,: ) = zqsr_tot(:,:) + a_i(A2D(0),jl) * frcv(jpr_qsrice)%z3(:,:,jl)
zqsr_ice(:,:,jl) = frcv(jpr_qsrice)%z3(:,:,jl)
END DO
ELSE
@@ -2162,14 +2058,14 @@ CONTAINS
IF ( TRIM(sn_rcv_qsr%clcat) == 'yes' ) THEN
DO jl = 1, jpl
zqsr_ice(:,:,jl) = frcv(jpr_qsrmix)%z3(:,:,jl) * ( 1.- palbi(:,:,jl) ) &
- & / ( 1.- ( alb_oce_mix(:,: ) * ziceld(:,:) &
- & + palbi (:,:,jl) * picefr(:,:) ) )
+ & / ( 1.- ( alb_oce_mix(:,: ) * ziceld(:,:) &
+ & + palbi (:,:,jl) * picefr(:,:) ) )
END DO
ELSE
DO jl = 1, jpl
zqsr_ice(:,:,jl) = frcv(jpr_qsrmix)%z3(:,:, 1) * ( 1.- palbi(:,:,jl) ) &
- & / ( 1.- ( alb_oce_mix(:,: ) * ziceld(:,:) &
- & + palbi (:,:,jl) * picefr(:,:) ) )
+ & / ( 1.- ( alb_oce_mix(:,: ) * ziceld(:,:) &
+ & + palbi (:,:,jl) * picefr(:,:) ) )
END DO
ENDIF
CASE( 'none' ) ! Not available as for now: needs additional coding
@@ -2177,7 +2073,7 @@ CONTAINS
CALL ctl_stop('STOP', 'sbccpl/sbc_cpl_ice_flx: some fields are not defined. Change sn_rcv_qsr value in namelist namsbc_cpl')
END SELECT
IF( ln_dm2dc .AND. ln_cpl ) THEN ! modify qsr to include the diurnal cycle
- zqsr_tot(:,: ) = sbc_dcy( zqsr_tot(:,: ) )
+ zqsr_tot(:,:) = sbc_dcy( zqsr_tot(:,:) )
DO jl = 1, jpl
zqsr_ice(:,:,jl) = sbc_dcy( zqsr_ice(:,:,jl) )
END DO
@@ -2213,33 +2109,34 @@ CONTAINS
!
ELSEIF( ln_cndflx .AND. .NOT.ln_cndemulate ) THEN !== conduction flux as surface forcing ==!
!
-!! SELECT CASE( TRIM( sn_rcv_qtrice%cldes ) )
-!! !
-!! ! ! ===> here we receive the qtr_ice_top array from the coupler
-!! CASE ('coupled')
-!! IF (ln_scale_ice_flux) THEN
-!! WHERE( a_i(:,:,:) > 1.e-10_wp )
-!! zqtr_ice_top(:,:,:) = frcv(jpr_qtrice)%z3(:,:,:) * a_i_last_couple(:,:,:) / a_i(:,:,:)
-!! ELSEWHERE
-!! zqtr_ice_top(:,:,:) = 0.0_wp
-!! ENDWHERE
-!! ELSE
-!! zqtr_ice_top(:,:,:) = frcv(jpr_qtrice)%z3(:,:,:)
-!! ENDIF
-!!
-!! ! Add retrieved transmitted solar radiation onto the ice and total solar radiation
-!! zqsr_ice(:,:,:) = zqsr_ice(:,:,:) + zqtr_ice_top(:,:,:)
-!! zqsr_tot(:,:) = zqsr_tot(:,:) + SUM( zqtr_ice_top(:,:,:) * a_i(:,:,:), dim=3 )
-!!
-!! ! if we are not getting this data from the coupler then assume zero (fully opaque ice)
-!! CASE ('none')
- zqtr_ice_top(:,:,:) = 0._wp
-!! END SELECT
+ !
+ SELECT CASE( TRIM( sn_rcv_qtrice%cldes ) )
+ !
+ ! ! ===> here we receive the qtr_ice_top array from the coupler
+ CASE ('coupled')
+ IF (ln_scale_ice_flux) THEN
+ WHERE( a_i(A2D(0),:) > 1.e-10_wp )
+ zqtr_ice_top(:,:,:) = frcv(jpr_qtrice)%z3(:,:,:) * a_i_last_couple(A2D(0),:) / a_i(A2D(0),:)
+ ELSEWHERE
+ zqtr_ice_top(:,:,:) = 0.0_wp
+ ENDWHERE
+ ELSE
+ zqtr_ice_top(:,:,:) = frcv(jpr_qtrice)%z3(:,:,:)
+ ENDIF
+
+ ! Add retrieved transmitted solar radiation onto the ice and total solar radiation
+ zqsr_ice(:,:,:) = zqsr_ice(:,:,:) + zqtr_ice_top(:,:,:)
+ zqsr_tot(:,:) = zqsr_tot(:,:) + SUM( zqtr_ice_top(:,:,:) * a_i(A2D(0),:), dim=3 )
+
+ ! if we are not getting this data from the coupler then assume zero (fully opaque ice)
+ CASE ('none')
+ zqtr_ice_top(:,:,:) = 0._wp
+ END SELECT
!
ENDIF
IF( ln_mixcpl ) THEN
- qsr_tot(:,:) = qsr(:,:) * ziceld(:,:) + SUM( qsr_ice(:,:,:) * a_i(:,:,:), dim=3 ) ! total flux from blk
+ qsr_tot(:,:) = qsr(:,:) * ziceld(:,:) + SUM( qsr_ice(:,:,:) * a_i(A2D(0),:), dim=3 ) ! total flux from blk
qsr_tot(:,:) = qsr_tot(:,:) * xcplmask(:,:,0) + zqsr_tot(:,:) * zmsk(:,:)
DO jl = 1, jpl
qsr_ice (:,:,jl) = qsr_ice (:,:,jl) * xcplmask(:,:,0) + zqsr_ice (:,:,jl) * zmsk(:,:)
@@ -2254,7 +2151,7 @@ CONTAINS
! --- solar flux over ocean --- !
! note: ziceld cannot be = 0 since we limit the ice concentration to amax
zqsr_oce = 0._wp
- WHERE( ziceld /= 0._wp ) zqsr_oce(:,:) = ( zqsr_tot(:,:) - SUM( a_i * zqsr_ice, dim=3 ) ) / ziceld(:,:)
+ WHERE( ziceld /= 0._wp ) zqsr_oce(:,:) = ( zqsr_tot(:,:) - SUM( a_i(A2D(0),:) * zqsr_ice(:,:,:), dim=3 ) ) / ziceld(:,:)
IF( ln_mixcpl ) THEN ; qsr_oce(:,:) = qsr_oce(:,:) * xcplmask(:,:,0) + zqsr_oce(:,:)* zmsk(:,:)
ELSE ; qsr_oce(:,:) = zqsr_oce(:,:) ; ENDIF
@@ -2299,25 +2196,27 @@ CONTAINS
INTEGER :: ji, jj, jl ! dummy loop indices
INTEGER :: isec, info ! local integer
REAL(wp) :: zumax, zvmax
- REAL(wp), DIMENSION(jpi,jpj) :: zfr_l, ztmp1, ztmp2, zotx1, zoty1, zotz1, zitx1, zity1, zitz1
- REAL(wp), DIMENSION(jpi,jpj,jpl) :: ztmp3, ztmp4
+ REAL(wp), DIMENSION(A2D(0)) :: zat_i, zfr_l, ztmp1, ztmp2, zotx1, zoty1, zotz1, zitx1, zity1, zitz1
+ REAL(wp), DIMENSION(A2D(0),1) :: ze3t_i
+ REAL(wp), DIMENSION(A2D(0),jpl) :: ztmp3, ztmp4
!!----------------------------------------------------------------------
!
isec = ( kt - nit000 ) * NINT( rn_Dt ) ! date of exchanges
info = OASIS_idle
- zfr_l(:,:) = 1.- fr_i(:,:)
+ zfr_l(:,:) = 1.- fr_i(A2D(0))
+ zat_i(:,:) = SUM( a_i(A2D(0),:), dim=3 )
! ! ------------------------- !
! ! Surface temperature ! in Kelvin
! ! ------------------------- !
IF( ssnd(jps_toce)%laction .OR. ssnd(jps_tice)%laction .OR. ssnd(jps_tmix)%laction ) THEN
IF( nn_components == jp_iam_oce ) THEN
- ztmp1(:,:) = ts(:,:,1,jp_tem,Kmm) ! send temperature as it is (potential or conservative) -> use of l_useCT on the received part
+ ztmp1(:,:) = ts(A2D(0),1,jp_tem,Kmm) ! send temperature as it is (potential or conservative) -> use of l_useCT on the received part
ELSE
! we must send the surface potential temperature
- IF( l_useCT ) THEN ; ztmp1(:,:) = eos_pt_from_ct( ts(:,:,1,jp_tem,Kmm), ts(:,:,1,jp_sal,Kmm) )
- ELSE ; ztmp1(:,:) = ts(:,:,1,jp_tem,Kmm)
+ IF( l_useCT ) THEN ; CALL eos_pt_from_ct( ts(:,:,1,jp_tem,Kmm), ts(:,:,1,jp_sal,Kmm), ztmp1(:,:), kbnd=0 )
+ ELSE ; ztmp1(:,:) = ts(A2D(0),1,jp_tem,Kmm)
ENDIF
!
SELECT CASE( sn_snd_temp%cldes)
@@ -2327,8 +2226,8 @@ CONTAINS
CASE( 'yes' )
ztmp3(:,:,1:jpl) = tn_ice(:,:,1:jpl)
CASE( 'no' )
- WHERE( SUM( a_i, dim=3 ) /= 0. )
- ztmp3(:,:,1) = SUM( tn_ice * a_i, dim=3 ) / SUM( a_i, dim=3 )
+ WHERE( zat_i(:,:) /= 0. )
+ ztmp3(:,:,1) = SUM( tn_ice(:,:,:) * a_i(A2D(0),:), dim=3 ) / zat_i(:,:)
ELSEWHERE
ztmp3(:,:,1) = rt0
END WHERE
@@ -2337,36 +2236,36 @@ CONTAINS
CASE( 'weighted oce and ice' ) ; ztmp1(:,:) = ( ztmp1(:,:) + rt0 ) * zfr_l(:,:)
SELECT CASE( sn_snd_temp%clcat )
CASE( 'yes' )
- ztmp3(:,:,1:jpl) = tn_ice(:,:,1:jpl) * a_i(:,:,1:jpl)
+ ztmp3(:,:,1:jpl) = tn_ice(:,:,1:jpl) * a_i(A2D(0),1:jpl)
CASE( 'no' )
ztmp3(:,:,:) = 0.0
DO jl=1,jpl
- ztmp3(:,:,1) = ztmp3(:,:,1) + tn_ice(:,:,jl) * a_i(:,:,jl)
+ ztmp3(:,:,1) = ztmp3(:,:,1) + tn_ice(:,:,jl) * a_i(A2D(0),jl)
ENDDO
CASE default ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_temp%clcat' )
END SELECT
- CASE( 'oce and weighted ice') ; ztmp1(:,:) = ts(:,:,1,jp_tem,Kmm) + rt0
+ CASE( 'oce and weighted ice') ; ztmp1(:,:) = ts(A2D(0),1,jp_tem,Kmm) + rt0
SELECT CASE( sn_snd_temp%clcat )
CASE( 'yes' )
- ztmp3(:,:,1:jpl) = tn_ice(:,:,1:jpl) * a_i(:,:,1:jpl)
+ ztmp3(:,:,1:jpl) = tn_ice(:,:,1:jpl) * a_i(A2D(0),1:jpl)
CASE( 'no' )
ztmp3(:,:,:) = 0.0
DO jl=1,jpl
- ztmp3(:,:,1) = ztmp3(:,:,1) + tn_ice(:,:,jl) * a_i(:,:,jl)
+ ztmp3(:,:,1) = ztmp3(:,:,1) + tn_ice(:,:,jl) * a_i(A2D(0),jl)
ENDDO
CASE default ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_temp%clcat' )
END SELECT
CASE( 'mixed oce-ice' )
ztmp1(:,:) = ( ztmp1(:,:) + rt0 ) * zfr_l(:,:)
DO jl=1,jpl
- ztmp1(:,:) = ztmp1(:,:) + tn_ice(:,:,jl) * a_i(:,:,jl)
+ ztmp1(:,:) = ztmp1(:,:) + tn_ice(:,:,jl) * a_i(A2D(0),jl)
ENDDO
CASE default ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_temp%cldes' )
END SELECT
ENDIF
- IF( ssnd(jps_toce)%laction ) CALL cpl_snd( jps_toce, isec, RESHAPE ( ztmp1, (/jpi,jpj,1/) ), info )
+ IF( ssnd(jps_toce)%laction ) CALL cpl_snd( jps_toce, isec, RESHAPE ( ztmp1, (/Ni_0,Nj_0,1/) ), info )
IF( ssnd(jps_tice)%laction ) CALL cpl_snd( jps_tice, isec, ztmp3, info )
- IF( ssnd(jps_tmix)%laction ) CALL cpl_snd( jps_tmix, isec, RESHAPE ( ztmp1, (/jpi,jpj,1/) ), info )
+ IF( ssnd(jps_tmix)%laction ) CALL cpl_snd( jps_tmix, isec, RESHAPE ( ztmp1, (/Ni_0,Nj_0,1/) ), info )
ENDIF
!
! ! ------------------------- !
@@ -2377,7 +2276,7 @@ CONTAINS
IF( ssnd(jps_ttilyr)%laction) THEN
SELECT CASE( sn_snd_ttilyr%cldes)
CASE ('weighted ice')
- ztmp3(:,:,1:jpl) = t1_ice(:,:,1:jpl) * a_i(:,:,1:jpl)
+ ztmp3(:,:,1:jpl) = t1_ice(:,:,1:jpl) * a_i(A2D(0),1:jpl)
CASE default ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_ttilyr%cldes' )
END SELECT
IF( ssnd(jps_ttilyr)%laction ) CALL cpl_snd( jps_ttilyr, isec, ztmp3, info )
@@ -2393,8 +2292,8 @@ CONTAINS
CASE( 'yes' )
ztmp3(:,:,1:jpl) = alb_ice(:,:,1:jpl)
CASE( 'no' )
- WHERE( SUM( a_i, dim=3 ) /= 0. )
- ztmp1(:,:) = SUM( alb_ice (:,:,1:jpl) * a_i(:,:,1:jpl), dim=3 ) / SUM( a_i(:,:,1:jpl), dim=3 )
+ WHERE( zat_i(:,:) /= 0. )
+ ztmp1(:,:) = SUM( alb_ice (:,:,1:jpl) * a_i(A2D(0),1:jpl), dim=3 ) / zat_i(:,:)
ELSEWHERE
ztmp1(:,:) = alb_oce_mix(:,:)
END WHERE
@@ -2403,10 +2302,10 @@ CONTAINS
CASE( 'weighted ice' ) ;
SELECT CASE( sn_snd_alb%clcat )
CASE( 'yes' )
- ztmp3(:,:,1:jpl) = alb_ice(:,:,1:jpl) * a_i(:,:,1:jpl)
+ ztmp3(:,:,1:jpl) = alb_ice(:,:,1:jpl) * a_i(A2D(0),1:jpl)
CASE( 'no' )
- WHERE( fr_i (:,:) > 0. )
- ztmp1(:,:) = SUM ( alb_ice(:,:,1:jpl) * a_i(:,:,1:jpl), dim=3 )
+ WHERE( fr_i (A2D(0)) > 0. )
+ ztmp1(:,:) = SUM ( alb_ice(:,:,1:jpl) * a_i(A2D(0),1:jpl), dim=3 )
ELSEWHERE
ztmp1(:,:) = 0.
END WHERE
@@ -2419,16 +2318,16 @@ CONTAINS
CASE( 'yes' )
CALL cpl_snd( jps_albice, isec, ztmp3, info ) !-> MV this has never been checked in coupled mode
CASE( 'no' )
- CALL cpl_snd( jps_albice, isec, RESHAPE ( ztmp1, (/jpi,jpj,1/) ), info )
+ CALL cpl_snd( jps_albice, isec, RESHAPE ( ztmp1, (/Ni_0,Nj_0,1/) ), info )
END SELECT
ENDIF
IF( ssnd(jps_albmix)%laction ) THEN ! mixed ice-ocean
ztmp1(:,:) = alb_oce_mix(:,:) * zfr_l(:,:)
DO jl = 1, jpl
- ztmp1(:,:) = ztmp1(:,:) + alb_ice(:,:,jl) * a_i(:,:,jl)
+ ztmp1(:,:) = ztmp1(:,:) + alb_ice(:,:,jl) * a_i(A2D(0),jl)
END DO
- CALL cpl_snd( jps_albmix, isec, RESHAPE ( ztmp1, (/jpi,jpj,1/) ), info )
+ CALL cpl_snd( jps_albmix, isec, RESHAPE ( ztmp1, (/Ni_0,Nj_0,1/) ), info )
ENDIF
! ! ------------------------- !
! ! Ice fraction & Thickness !
@@ -2436,8 +2335,8 @@ CONTAINS
! Send ice fraction field to atmosphere
IF( ssnd(jps_fice)%laction ) THEN
SELECT CASE( sn_snd_thick%clcat )
- CASE( 'yes' ) ; ztmp3(:,:,1:jpl) = a_i(:,:,1:jpl)
- CASE( 'no' ) ; ztmp3(:,:,1 ) = fr_i(:,: )
+ CASE( 'yes' ) ; ztmp3(:,:,1:jpl) = a_i(A2D(0),1:jpl)
+ CASE( 'no' ) ; ztmp3(:,:,1 ) = fr_i(A2D(0) )
CASE default ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_thick%clcat' )
END SELECT
CALL cpl_snd( jps_fice, isec, ztmp3, info )
@@ -2457,8 +2356,8 @@ CONTAINS
IF( ssnd(jps_fice1)%laction ) THEN
SELECT CASE( sn_snd_thick1%clcat )
- CASE( 'yes' ) ; ztmp3(:,:,1:jpl) = a_i(:,:,1:jpl)
- CASE( 'no' ) ; ztmp3(:,:,1 ) = fr_i(:,: )
+ CASE( 'yes' ) ; ztmp3(:,:,1:jpl) = a_i(A2D(0),1:jpl)
+ CASE( 'no' ) ; ztmp3(:,:,1 ) = fr_i(A2D(0) )
CASE default ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_thick1%clcat' )
END SELECT
CALL cpl_snd( jps_fice1, isec, ztmp3, info )
@@ -2466,7 +2365,7 @@ CONTAINS
! Send ice fraction field to OCE (sent by SAS in SAS-OCE coupling)
IF( ssnd(jps_fice2)%laction ) THEN
- ztmp3(:,:,1) = fr_i(:,:)
+ ztmp3(:,:,1) = fr_i(A2D(0))
IF( ssnd(jps_fice2)%laction ) CALL cpl_snd( jps_fice2, isec, ztmp3, info )
ENDIF
@@ -2477,25 +2376,25 @@ CONTAINS
CASE( 'weighted ice and snow' )
SELECT CASE( sn_snd_thick%clcat )
CASE( 'yes' )
- ztmp3(:,:,1:jpl) = h_i(:,:,1:jpl) * a_i(:,:,1:jpl)
- ztmp4(:,:,1:jpl) = h_s(:,:,1:jpl) * a_i(:,:,1:jpl)
+ ztmp3(:,:,1:jpl) = h_i(A2D(0),1:jpl) * a_i(A2D(0),1:jpl)
+ ztmp4(:,:,1:jpl) = h_s(A2D(0),1:jpl) * a_i(A2D(0),1:jpl)
CASE( 'no' )
ztmp3(:,:,:) = 0.0 ; ztmp4(:,:,:) = 0.0
DO jl=1,jpl
- ztmp3(:,:,1) = ztmp3(:,:,1) + h_i(:,:,jl) * a_i(:,:,jl)
- ztmp4(:,:,1) = ztmp4(:,:,1) + h_s(:,:,jl) * a_i(:,:,jl)
+ ztmp3(:,:,1) = ztmp3(:,:,1) + h_i(A2D(0),jl) * a_i(A2D(0),jl)
+ ztmp4(:,:,1) = ztmp4(:,:,1) + h_s(A2D(0),jl) * a_i(A2D(0),jl)
ENDDO
CASE default ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_thick%clcat' )
END SELECT
CASE( 'ice and snow' )
SELECT CASE( sn_snd_thick%clcat )
CASE( 'yes' )
- ztmp3(:,:,1:jpl) = h_i(:,:,1:jpl)
- ztmp4(:,:,1:jpl) = h_s(:,:,1:jpl)
+ ztmp3(:,:,1:jpl) = h_i(A2D(0),1:jpl)
+ ztmp4(:,:,1:jpl) = h_s(A2D(0),1:jpl)
CASE( 'no' )
WHERE( SUM( a_i, dim=3 ) /= 0. )
- ztmp3(:,:,1) = SUM( h_i * a_i, dim=3 ) / SUM( a_i, dim=3 )
- ztmp4(:,:,1) = SUM( h_s * a_i, dim=3 ) / SUM( a_i, dim=3 )
+ ztmp3(:,:,1) = SUM( h_i(A2D(0),:) * a_i(A2D(0),:), dim=3 ) / zat_i(:,:)
+ ztmp4(:,:,1) = SUM( h_s(A2D(0),:) * a_i(A2D(0),:), dim=3 ) / zat_i(:,:)
ELSEWHERE
ztmp3(:,:,1) = 0.
ztmp4(:,:,1) = 0.
@@ -2519,13 +2418,13 @@ CONTAINS
SELECT CASE( sn_snd_mpnd%clcat )
CASE( 'yes' )
ztmp3(:,:,1:jpl) = a_ip_eff(:,:,1:jpl)
- ztmp4(:,:,1:jpl) = h_ip(:,:,1:jpl)
+ ztmp4(:,:,1:jpl) = h_ip(A2D(0),1:jpl)
CASE( 'no' )
ztmp3(:,:,:) = 0.0
ztmp4(:,:,:) = 0.0
DO jl=1,jpl
ztmp3(:,:,1) = ztmp3(:,:,1) + a_ip_frac(:,:,jpl)
- ztmp4(:,:,1) = ztmp4(:,:,1) + h_ip(:,:,jpl)
+ ztmp4(:,:,1) = ztmp4(:,:,1) + h_ip(A2D(0),jpl)
ENDDO
CASE default ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_mpnd%clcat' )
END SELECT
@@ -2544,11 +2443,11 @@ CONTAINS
CASE( 'weighted ice' )
SELECT CASE( sn_snd_cond%clcat )
CASE( 'yes' )
- ztmp3(:,:,1:jpl) = cnd_ice(:,:,1:jpl) * a_i(:,:,1:jpl)
+ ztmp3(:,:,1:jpl) = cnd_ice(:,:,1:jpl) * a_i(A2D(0),1:jpl)
CASE( 'no' )
ztmp3(:,:,:) = 0.0
DO jl=1,jpl
- ztmp3(:,:,1) = ztmp3(:,:,1) + cnd_ice(:,:,jl) * a_i(:,:,jl)
+ ztmp3(:,:,1) = ztmp3(:,:,1) + cnd_ice(:,:,jl) * a_i(A2D(0),jl)
ENDDO
CASE default ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_cond%clcat' )
END SELECT
@@ -2564,25 +2463,26 @@ CONTAINS
! ! CO2 flux from PISCES !
! ! ------------------------- !
IF( ssnd(jps_co2)%laction .AND. l_co2cpl ) THEN
- ztmp1(:,:) = oce_co2(:,:) * 1000. ! conversion in molC/m2/s
- CALL cpl_snd( jps_co2, isec, RESHAPE ( ztmp1, (/jpi,jpj,1/) ) , info )
+ ztmp1(:,:) = oce_co2(A2D(0)) * 1000. ! conversion in molC/m2/s
+ CALL cpl_snd( jps_co2, isec, RESHAPE ( ztmp1, (/Ni_0,Nj_0,1/) ) , info )
ENDIF
!
! ! ------------------------- !
IF( ssnd(jps_ocx1)%laction ) THEN ! Surface current !
! ! ------------------------- !
!
- ! j+1 j -----V---F
- ! surface velocity always sent from T point ! |
- ! j | T U
- ! | |
- ! j j-1 -I-------|
- ! (for I) | |
- ! i-1 i i
- ! i i+1 (for I)
+ ! j -----V---F
+ ! surface velocity always sent from T point ! |
+ ! j | T U
+ ! | |
+ ! j-1 -I-------|
+ ! | |
+ ! i-1 i i
+ !!clem: make a new variable at T-point to replace uu and vv => uuT and vvT for instance
IF( nn_components == jp_iam_oce ) THEN
- zotx1(:,:) = uu(:,:,1,Kmm)
- zoty1(:,:) = vv(:,:,1,Kmm)
+ zotx1(:,:) = uu(A2D(0),1,Kmm)
+ zoty1(:,:) = vv(A2D(0),1,Kmm)
+ !!clem : should be demi sum, no? Or uuT and vvT
ELSE
SELECT CASE( TRIM( sn_snd_crt%cldes ) )
CASE( 'oce only' ) ! C-grid ==> T
@@ -2597,7 +2497,7 @@ CONTAINS
zitx1(ji,jj) = 0.5 * ( u_ice(ji,jj ) + u_ice(ji-1,jj ) ) * fr_i(ji,jj)
zity1(ji,jj) = 0.5 * ( v_ice(ji,jj ) + v_ice(ji ,jj-1 ) ) * fr_i(ji,jj)
END_2D
- CALL lbc_lnk( 'sbccpl', zitx1, 'T', -1.0_wp, zity1, 'T', -1.0_wp )
+!!$ CALL lbc_lnk( 'sbccpl', zitx1, 'T', -1.0_wp, zity1, 'T', -1.0_wp )
CASE( 'mixed oce-ice' ) ! Ocean and Ice on C-grid ==> T
DO_2D( 0, 0, 0, 0 )
zotx1(ji,jj) = 0.5 * ( uu (ji,jj,1,Kmm) + uu (ji-1,jj ,1,Kmm) ) * zfr_l(ji,jj) &
@@ -2606,7 +2506,7 @@ CONTAINS
& + 0.5 * ( v_ice(ji,jj ) + v_ice(ji ,jj-1 ) ) * fr_i(ji,jj)
END_2D
END SELECT
- CALL lbc_lnk( 'sbccpl', zotx1, ssnd(jps_ocx1)%clgrid, -1.0_wp, zoty1, ssnd(jps_ocy1)%clgrid, -1.0_wp )
+!!$ CALL lbc_lnk( 'sbccpl', zotx1, ssnd(jps_ocx1)%clgrid, -1.0_wp, zoty1, ssnd(jps_ocy1)%clgrid, -1.0_wp )
!
ENDIF
!
@@ -2638,13 +2538,13 @@ CONTAINS
ENDIF
ENDIF
!
- IF( ssnd(jps_ocx1)%laction ) CALL cpl_snd( jps_ocx1, isec, RESHAPE ( zotx1, (/jpi,jpj,1/) ), info ) ! ocean x current 1st grid
- IF( ssnd(jps_ocy1)%laction ) CALL cpl_snd( jps_ocy1, isec, RESHAPE ( zoty1, (/jpi,jpj,1/) ), info ) ! ocean y current 1st grid
- IF( ssnd(jps_ocz1)%laction ) CALL cpl_snd( jps_ocz1, isec, RESHAPE ( zotz1, (/jpi,jpj,1/) ), info ) ! ocean z current 1st grid
+ IF( ssnd(jps_ocx1)%laction ) CALL cpl_snd( jps_ocx1, isec, RESHAPE ( zotx1, (/Ni_0,Nj_0,1/) ), info ) ! ocean x current 1st grid
+ IF( ssnd(jps_ocy1)%laction ) CALL cpl_snd( jps_ocy1, isec, RESHAPE ( zoty1, (/Ni_0,Nj_0,1/) ), info ) ! ocean y current 1st grid
+ IF( ssnd(jps_ocz1)%laction ) CALL cpl_snd( jps_ocz1, isec, RESHAPE ( zotz1, (/Ni_0,Nj_0,1/) ), info ) ! ocean z current 1st grid
!
- IF( ssnd(jps_ivx1)%laction ) CALL cpl_snd( jps_ivx1, isec, RESHAPE ( zitx1, (/jpi,jpj,1/) ), info ) ! ice x current 1st grid
- IF( ssnd(jps_ivy1)%laction ) CALL cpl_snd( jps_ivy1, isec, RESHAPE ( zity1, (/jpi,jpj,1/) ), info ) ! ice y current 1st grid
- IF( ssnd(jps_ivz1)%laction ) CALL cpl_snd( jps_ivz1, isec, RESHAPE ( zitz1, (/jpi,jpj,1/) ), info ) ! ice z current 1st grid
+ IF( ssnd(jps_ivx1)%laction ) CALL cpl_snd( jps_ivx1, isec, RESHAPE ( zitx1, (/Ni_0,Nj_0,1/) ), info ) ! ice x current 1st grid
+ IF( ssnd(jps_ivy1)%laction ) CALL cpl_snd( jps_ivy1, isec, RESHAPE ( zity1, (/Ni_0,Nj_0,1/) ), info ) ! ice y current 1st grid
+ IF( ssnd(jps_ivz1)%laction ) CALL cpl_snd( jps_ivz1, isec, RESHAPE ( zitz1, (/Ni_0,Nj_0,1/) ), info ) ! ice z current 1st grid
!
ENDIF
!
@@ -2652,42 +2552,42 @@ CONTAINS
! ! Surface current to waves !
! ! ------------------------- !
IF( ssnd(jps_ocxw)%laction .OR. ssnd(jps_ocyw)%laction ) THEN
- !
- ! j+1 j -----V---F
- ! surface velocity always sent from T point ! |
- ! j | T U
- ! | |
- ! j j-1 -I-------|
- ! (for I) | |
- ! i-1 i i
- ! i i+1 (for I)
- SELECT CASE( TRIM( sn_snd_crtw%cldes ) )
- CASE( 'oce only' ) ! C-grid ==> T
- DO_2D( 0, 0, 0, 0 )
- zotx1(ji,jj) = 0.5 * ( uu(ji,jj,1,Kmm) + uu(ji-1,jj ,1,Kmm) )
- zoty1(ji,jj) = 0.5 * ( vv(ji,jj,1,Kmm) + vv(ji , jj-1,1,Kmm) )
- END_2D
- CASE( 'weighted oce and ice' ) ! Ocean and Ice on C-grid ==> T
- DO_2D( 0, 0, 0, 0 )
- zotx1(ji,jj) = 0.5 * ( uu (ji,jj,1,Kmm) + uu (ji-1,jj ,1,Kmm) ) * zfr_l(ji,jj)
- zoty1(ji,jj) = 0.5 * ( vv (ji,jj,1,Kmm) + vv (ji ,jj-1,1,Kmm) ) * zfr_l(ji,jj)
- zitx1(ji,jj) = 0.5 * ( u_ice(ji,jj ) + u_ice(ji-1,jj ) ) * fr_i(ji,jj)
- zity1(ji,jj) = 0.5 * ( v_ice(ji,jj ) + v_ice(ji ,jj-1 ) ) * fr_i(ji,jj)
- END_2D
- CALL lbc_lnk( 'sbccpl', zitx1, 'T', -1.0_wp, zity1, 'T', -1.0_wp )
- CASE( 'mixed oce-ice' ) ! Ocean and Ice on C-grid ==> T
- DO_2D( 0, 0, 0, 0 )
- zotx1(ji,jj) = 0.5 * ( uu (ji,jj,1,Kmm) + uu (ji-1,jj ,1,Kmm) ) * zfr_l(ji,jj) &
- & + 0.5 * ( u_ice(ji,jj ) + u_ice(ji-1,jj ) ) * fr_i(ji,jj)
- zoty1(ji,jj) = 0.5 * ( vv (ji,jj,1,Kmm) + vv (ji ,jj-1,1,Kmm) ) * zfr_l(ji,jj) &
- & + 0.5 * ( v_ice(ji,jj ) + v_ice(ji ,jj-1 ) ) * fr_i(ji,jj)
- END_2D
- END SELECT
- CALL lbc_lnk( 'sbccpl', zotx1, ssnd(jps_ocxw)%clgrid, -1.0_wp, zoty1, ssnd(jps_ocyw)%clgrid, -1.0_wp )
+ !
+ ! j -----V---F
+ ! surface velocity always sent from T point ! |
+ ! j | T U
+ ! | |
+ ! j-1 -I-------|
+ ! | |
+ ! i-1 i i
+ !!clem: make a new variable at T-point to replace uu and vv => uuT and vvT for instance
+ SELECT CASE( TRIM( sn_snd_crtw%cldes ) )
+ CASE( 'oce only' ) ! C-grid ==> T
+ DO_2D( 0, 0, 0, 0 )
+ zotx1(ji,jj) = 0.5 * ( uu(ji,jj,1,Kmm) + uu(ji-1,jj ,1,Kmm) )
+ zoty1(ji,jj) = 0.5 * ( vv(ji,jj,1,Kmm) + vv(ji , jj-1,1,Kmm) )
+ END_2D
+ CASE( 'weighted oce and ice' ) ! Ocean and Ice on C-grid ==> T
+ DO_2D( 0, 0, 0, 0 )
+ zotx1(ji,jj) = 0.5 * ( uu (ji,jj,1,Kmm) + uu (ji-1,jj ,1,Kmm) ) * zfr_l(ji,jj)
+ zoty1(ji,jj) = 0.5 * ( vv (ji,jj,1,Kmm) + vv (ji ,jj-1,1,Kmm) ) * zfr_l(ji,jj)
+ zitx1(ji,jj) = 0.5 * ( u_ice(ji,jj ) + u_ice(ji-1,jj ) ) * fr_i(ji,jj)
+ zity1(ji,jj) = 0.5 * ( v_ice(ji,jj ) + v_ice(ji ,jj-1 ) ) * fr_i(ji,jj)
+ END_2D
+!!$ CALL lbc_lnk( 'sbccpl', zitx1, 'T', -1.0_wp, zity1, 'T', -1.0_wp )
+ CASE( 'mixed oce-ice' ) ! Ocean and Ice on C-grid ==> T
+ DO_2D( 0, 0, 0, 0 )
+ zotx1(ji,jj) = 0.5 * ( uu (ji,jj,1,Kmm) + uu (ji-1,jj ,1,Kmm) ) * zfr_l(ji,jj) &
+ & + 0.5 * ( u_ice(ji,jj ) + u_ice(ji-1,jj ) ) * fr_i(ji,jj)
+ zoty1(ji,jj) = 0.5 * ( vv (ji,jj,1,Kmm) + vv (ji ,jj-1,1,Kmm) ) * zfr_l(ji,jj) &
+ & + 0.5 * ( v_ice(ji,jj ) + v_ice(ji ,jj-1 ) ) * fr_i(ji,jj)
+ END_2D
+ END SELECT
+!!$ CALL lbc_lnk( 'sbccpl', zotx1, ssnd(jps_ocxw)%clgrid, -1.0_wp, zoty1, ssnd(jps_ocyw)%clgrid, -1.0_wp )
!
!
IF( TRIM( sn_snd_crtw%clvor ) == 'eastward-northward' ) THEN ! Rotation of the components
- ! ! Ocean component
+ ! ! Ocean component
CALL rot_rep( zotx1, zoty1, ssnd(jps_ocxw)%clgrid, 'ij->e', ztmp1 ) ! 1st component
CALL rot_rep( zotx1, zoty1, ssnd(jps_ocxw)%clgrid, 'ij->n', ztmp2 ) ! 2nd component
zotx1(:,:) = ztmp1(:,:) ! overwrite the components
@@ -2700,26 +2600,26 @@ CONTAINS
ENDIF
ENDIF
!
-! ! spherical coordinates to cartesian -> 2 components to 3 components
-! IF( TRIM( sn_snd_crtw%clvref ) == 'cartesian' ) THEN
-! ztmp1(:,:) = zotx1(:,:) ! ocean currents
-! ztmp2(:,:) = zoty1(:,:)
-! CALL oce2geo ( ztmp1, ztmp2, 'T', zotx1, zoty1, zotz1 )
-! !
-! IF( ssnd(jps_ivx1)%laction ) THEN ! ice velocities
-! ztmp1(:,:) = zitx1(:,:)
-! ztmp1(:,:) = zity1(:,:)
-! CALL oce2geo ( ztmp1, ztmp2, 'T', zitx1, zity1, zitz1 )
-! ENDIF
-! ENDIF
+ ! ! spherical coordinates to cartesian -> 2 components to 3 components
+ ! IF( TRIM( sn_snd_crtw%clvref ) == 'cartesian' ) THEN
+ ! ztmp1(:,:) = zotx1(:,:) ! ocean currents
+ ! ztmp2(:,:) = zoty1(:,:)
+ ! CALL oce2geo ( ztmp1, ztmp2, 'T', zotx1, zoty1, zotz1 )
+ ! !
+ ! IF( ssnd(jps_ivx1)%laction ) THEN ! ice velocities
+ ! ztmp1(:,:) = zitx1(:,:)
+ ! ztmp1(:,:) = zity1(:,:)
+ ! CALL oce2geo ( ztmp1, ztmp2, 'T', zitx1, zity1, zitz1 )
+ ! ENDIF
+ ! ENDIF
!
- IF( ssnd(jps_ocxw)%laction ) CALL cpl_snd( jps_ocxw, isec, RESHAPE ( zotx1, (/jpi,jpj,1/) ), info ) ! ocean x current 1st grid
- IF( ssnd(jps_ocyw)%laction ) CALL cpl_snd( jps_ocyw, isec, RESHAPE ( zoty1, (/jpi,jpj,1/) ), info ) ! ocean y current 1st grid
+ IF( ssnd(jps_ocxw)%laction ) CALL cpl_snd( jps_ocxw, isec, RESHAPE ( zotx1, (/Ni_0,Nj_0,1/) ), info ) ! ocean x current 1st grid
+ IF( ssnd(jps_ocyw)%laction ) CALL cpl_snd( jps_ocyw, isec, RESHAPE ( zoty1, (/Ni_0,Nj_0,1/) ), info ) ! ocean y current 1st grid
!
ENDIF
!
IF( ssnd(jps_ficet)%laction ) THEN
- CALL cpl_snd( jps_ficet, isec, RESHAPE ( fr_i, (/jpi,jpj,1/) ), info )
+ CALL cpl_snd( jps_ficet, isec, RESHAPE ( fr_i(A2D(0)), (/Ni_0,Nj_0,1/) ), info )
ENDIF
! ! ------------------------- !
! ! Water levels to waves !
@@ -2727,14 +2627,14 @@ CONTAINS
IF( ssnd(jps_wlev)%laction ) THEN
IF( ln_apr_dyn ) THEN
IF( kt /= nit000 ) THEN
- ztmp1(:,:) = ssh(:,:,Kbb) - 0.5 * ( ssh_ib(:,:) + ssh_ibb(:,:) )
+ ztmp1(:,:) = ssh(A2D(0),Kbb) - 0.5 * ( ssh_ib(A2D(0)) + ssh_ibb(A2D(0)) )
ELSE
- ztmp1(:,:) = ssh(:,:,Kbb)
+ ztmp1(:,:) = ssh(A2D(0),Kbb)
ENDIF
ELSE
- ztmp1(:,:) = ssh(:,:,Kmm)
+ ztmp1(:,:) = ssh(A2D(0),Kmm)
ENDIF
- CALL cpl_snd( jps_wlev , isec, RESHAPE ( ztmp1, (/jpi,jpj,1/) ), info )
+ CALL cpl_snd( jps_wlev , isec, RESHAPE ( ztmp1, (/Ni_0,Nj_0,1/) ), info )
ENDIF
!
! Fields sent by OCE to SAS when doing OCE<->SAS coupling
@@ -2742,44 +2642,45 @@ CONTAINS
IF( ssnd(jps_ssh )%laction ) THEN
! ! removed inverse barometer ssh when Patm
! forcing is used (for sea-ice dynamics)
- IF( ln_apr_dyn ) THEN ; ztmp1(:,:) = ssh(:,:,Kbb) - 0.5 * ( ssh_ib(:,:) + ssh_ibb(:,:) )
- ELSE ; ztmp1(:,:) = ssh(:,:,Kmm)
+ IF( ln_apr_dyn ) THEN ; ztmp1(:,:) = ssh(A2D(0),Kbb) - 0.5 * ( ssh_ib(A2D(0)) + ssh_ibb(A2D(0)) )
+ ELSE ; ztmp1(:,:) = ssh(A2D(0),Kmm)
ENDIF
- CALL cpl_snd( jps_ssh , isec, RESHAPE ( ztmp1 , (/jpi,jpj,1/) ), info )
+ CALL cpl_snd( jps_ssh , isec, RESHAPE ( ztmp1 , (/Ni_0,Nj_0,1/) ), info )
ENDIF
! ! SSS
IF( ssnd(jps_soce )%laction ) THEN
- CALL cpl_snd( jps_soce , isec, RESHAPE ( ts(:,:,1,jp_sal,Kmm), (/jpi,jpj,1/) ), info )
+ CALL cpl_snd( jps_soce , isec, RESHAPE ( ts(A2D(0),1,jp_sal,Kmm), (/Ni_0,Nj_0,1/) ), info )
ENDIF
! ! first T level thickness
+ ze3t_i(A2D(0),1) = e3t(Nis0:Nie0,Njs0:Nje0,1,Kmm)
IF( ssnd(jps_e3t1st )%laction ) THEN
- CALL cpl_snd( jps_e3t1st, isec, RESHAPE ( e3t(:,:,1,Kmm) , (/jpi,jpj,1/) ), info )
+ CALL cpl_snd( jps_e3t1st, isec, RESHAPE ( ze3t_i , (/Ni_0,Nj_0,1/) ), info )
ENDIF
! ! Qsr fraction
IF( ssnd(jps_fraqsr)%laction ) THEN
- CALL cpl_snd( jps_fraqsr, isec, RESHAPE ( fraqsr_1lev(:,:) , (/jpi,jpj,1/) ), info )
+ CALL cpl_snd( jps_fraqsr, isec, RESHAPE ( fraqsr_1lev(A2D(0)) , (/Ni_0,Nj_0,1/) ), info )
ENDIF
!
! Fields sent by SAS to OCE when OASIS coupling
! ! Solar heat flux
- IF( ssnd(jps_qsroce)%laction ) CALL cpl_snd( jps_qsroce, isec, RESHAPE ( qsr , (/jpi,jpj,1/) ), info )
- IF( ssnd(jps_qnsoce)%laction ) CALL cpl_snd( jps_qnsoce, isec, RESHAPE ( qns , (/jpi,jpj,1/) ), info )
- IF( ssnd(jps_oemp )%laction ) CALL cpl_snd( jps_oemp , isec, RESHAPE ( emp , (/jpi,jpj,1/) ), info )
- IF( ssnd(jps_sflx )%laction ) CALL cpl_snd( jps_sflx , isec, RESHAPE ( sfx , (/jpi,jpj,1/) ), info )
- IF( ssnd(jps_otx1 )%laction ) CALL cpl_snd( jps_otx1 , isec, RESHAPE ( utau, (/jpi,jpj,1/) ), info )
- IF( ssnd(jps_oty1 )%laction ) CALL cpl_snd( jps_oty1 , isec, RESHAPE ( vtau, (/jpi,jpj,1/) ), info )
- IF( ssnd(jps_rnf )%laction ) CALL cpl_snd( jps_rnf , isec, RESHAPE ( rnf , (/jpi,jpj,1/) ), info )
- IF( ssnd(jps_taum )%laction ) CALL cpl_snd( jps_taum , isec, RESHAPE ( taum, (/jpi,jpj,1/) ), info )
+ IF( ssnd(jps_qsroce)%laction ) CALL cpl_snd( jps_qsroce, isec, RESHAPE ( qsr (:,:) , (/Ni_0,Nj_0,1/) ), info )
+ IF( ssnd(jps_qnsoce)%laction ) CALL cpl_snd( jps_qnsoce, isec, RESHAPE ( qns (:,:) , (/Ni_0,Nj_0,1/) ), info )
+ IF( ssnd(jps_oemp )%laction ) CALL cpl_snd( jps_oemp , isec, RESHAPE ( emp (A2D(0)), (/Ni_0,Nj_0,1/) ), info )
+ IF( ssnd(jps_sflx )%laction ) CALL cpl_snd( jps_sflx , isec, RESHAPE ( sfx (:,:) , (/Ni_0,Nj_0,1/) ), info )
+ IF( ssnd(jps_otx1 )%laction ) CALL cpl_snd( jps_otx1 , isec, RESHAPE ( utau(A2D(0)), (/Ni_0,Nj_0,1/) ), info )
+ IF( ssnd(jps_oty1 )%laction ) CALL cpl_snd( jps_oty1 , isec, RESHAPE ( vtau(A2D(0)), (/Ni_0,Nj_0,1/) ), info )
+ IF( ssnd(jps_rnf )%laction ) CALL cpl_snd( jps_rnf , isec, RESHAPE ( rnf (A2D(0)), (/Ni_0,Nj_0,1/) ), info )
+ IF( ssnd(jps_taum )%laction ) CALL cpl_snd( jps_taum , isec, RESHAPE ( taum(:,:) , (/Ni_0,Nj_0,1/) ), info )
#if defined key_si3
! ! ------------------------- !
! ! Sea surface freezing temp !
! ! ------------------------- !
! needed by Met Office
- CALL eos_fzp(ts(:,:,1,jp_sal,Kmm), sstfrz)
+ CALL eos_fzp( ts(:,:,1,jp_sal,Kmm), sstfrz(:,:), kbnd=0 )
ztmp1(:,:) = sstfrz(:,:) + rt0
- IF( ssnd(jps_sstfrz)%laction ) CALL cpl_snd( jps_sstfrz, isec, RESHAPE ( ztmp1, (/jpi,jpj,1/) ), info)
+ IF( ssnd(jps_sstfrz)%laction ) CALL cpl_snd( jps_sstfrz, isec, RESHAPE ( ztmp1, (/Ni_0,Nj_0,1/) ), info)
#endif
!
END SUBROUTINE sbc_cpl_snd
diff --git a/src/OCE/SBC/sbcdcy.F90 b/src/OCE/SBC/sbcdcy.F90
index a6ccd03321f0f73ef86af9e943cbcfbf03513ab4..5ccd7ec71b85dc87adbc38976692badd07c73b6e 100644
--- a/src/OCE/SBC/sbcdcy.F90
+++ b/src/OCE/SBC/sbcdcy.F90
@@ -49,8 +49,8 @@ CONTAINS
!!----------------------------------------------------------------------
!! *** FUNCTION sbc_dcy_alloc ***
!!----------------------------------------------------------------------
- ALLOCATE( raa (jpi,jpj) , rbb (jpi,jpj) , rcc (jpi,jpj) , rab (jpi,jpj) , &
- & rtmd(jpi,jpj) , rdawn_dcy(jpi,jpj) , rdusk_dcy(jpi,jpj) , rscal(jpi,jpj) , STAT=sbc_dcy_alloc )
+ ALLOCATE( raa (A2D(0)) , rbb (A2D(0)) , rcc (A2D(0)) , rab (A2D(0)) , &
+ & rtmd(A2D(0)) , rdawn_dcy(A2D(0)) , rdusk_dcy(A2D(0)) , rscal(A2D(0)) , STAT=sbc_dcy_alloc )
!
CALL mpp_sum ( 'sbcdcy', sbc_dcy_alloc )
IF( sbc_dcy_alloc /= 0 ) CALL ctl_stop( 'STOP', 'sbc_dcy_alloc: failed to allocate arrays' )
@@ -71,12 +71,12 @@ CONTAINS
!! Impact of resolving the diurnal cycle in an ocean--atmosphere GCM.
!! Part 1: a diurnally forced OGCM. Climate Dynamics 29:6, 575-590.
!!----------------------------------------------------------------------
- LOGICAL , OPTIONAL , INTENT(in) :: l_mask ! use the routine for night mask computation
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pqsrin ! input daily QSR flux
- REAL(wp), DIMENSION(jpi,jpj) :: zqsrout ! output QSR flux with diurnal cycle
+ LOGICAL , OPTIONAL , INTENT(in) :: l_mask ! use the routine for night mask computation
+ REAL(wp), DIMENSION(A2D(0)), INTENT(in) :: pqsrin ! input daily QSR flux
+ REAL(wp), DIMENSION(A2D(0)) :: zqsrout ! output QSR flux with diurnal cycle
!!
INTEGER :: ji, jj ! dummy loop indices
- INTEGER, DIMENSION(jpi,jpj) :: imask_night ! night mask
+ INTEGER, DIMENSION(A2D(0)) :: imask_night ! night mask
REAL(wp) :: zlo, zup, zlousd, zupusd
REAL(wp) :: ztmp, ztmp1, ztmp2
REAL(wp) :: ztmpm, ztmpm1, ztmpm2
@@ -100,16 +100,16 @@ CONTAINS
! Setting parameters for each new day:
CALL sbc_dcy_param()
- !CALL iom_put( "rdusk_dcy", rdusk_dcy(:,:)*tmask(:,:,1) ) !LB
- !CALL iom_put( "rdawn_dcy", rdawn_dcy(:,:)*tmask(:,:,1) ) !LB
- !CALL iom_put( "rscal_dcy", rscal(:,:)*tmask(:,:,1) ) !LB
+ !CALL iom_put( "rdusk_dcy", rdusk_dcy(:,:)*smask0(:,:) ) !LB
+ !CALL iom_put( "rdawn_dcy", rdawn_dcy(:,:)*smask0(:,:) ) !LB
+ !CALL iom_put( "rscal_dcy", rscal(:,:)*smask0(:,:) ) !LB
! 3. update qsr with the diurnal cycle
! ------------------------------------
imask_night(:,:) = 0
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
ztmpm = 0._wp
IF( ABS(rab(ji,jj)) < 1. ) THEN ! day duration is less than 24h
!
@@ -161,7 +161,7 @@ CONTAINS
SUBROUTINE sbc_dcy_param( )
!!
INTEGER :: ji, jj ! dummy loop indices
- !INTEGER, DIMENSION(jpi,jpj) :: imask_night ! night mask
+ !INTEGER, DIMENSION(A2D(0)) :: imask_night ! night mask
REAL(wp) :: zdsws, zdecrad, ztx, zsin, zcos
REAL(wp) :: ztmp, ztest
!---------------------------statement functions------------------------
@@ -192,7 +192,7 @@ CONTAINS
! Compute A and B needed to compute the time integral of the diurnal cycle
zsin = SIN( zdecrad ) ; zcos = COS( zdecrad )
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
ztmp = rad * gphit(ji,jj)
raa(ji,jj) = SIN( ztmp ) * zsin
rbb(ji,jj) = COS( ztmp ) * zcos
@@ -201,7 +201,7 @@ CONTAINS
! rab to test if the day time is equal to 0, less than 24h of full day
rab(:,:) = -raa(:,:) / rbb(:,:)
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
IF( ABS(rab(ji,jj)) < 1._wp ) THEN ! day duration is less than 24h
! When is it night?
ztx = 1._wp/(2._wp*rpi) * (ACOS(rab(ji,jj)) - rcc(ji,jj))
@@ -225,7 +225,7 @@ CONTAINS
! S* = the inverse of the time integral of the diurnal cycle from dawn to dusk
! Avoid possible infinite scaling factor, associated with very short daylight
! periods, by ignoring periods less than 1/1000th of a day (ticket #1040)
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
IF( ABS(rab(ji,jj)) < 1._wp ) THEN ! day duration is less than 24h
rscal(ji,jj) = 0.0_wp
IF( rdawn_dcy(ji,jj) < rdusk_dcy(ji,jj) ) THEN ! day time in one part
diff --git a/src/OCE/SBC/sbcflx.F90 b/src/OCE/SBC/sbcflx.F90
index c9ad4fcb5df00ee1384f884615a47ecd87470b2d..eae94f9ff05861d84c873824dd1ca89e5d2fae0c 100644
--- a/src/OCE/SBC/sbcflx.F90
+++ b/src/OCE/SBC/sbcflx.F90
@@ -34,8 +34,12 @@ MODULE sbcflx
INTEGER , PARAMETER :: jp_qtot = 3 ! index of total (non solar+solar) heat file
INTEGER , PARAMETER :: jp_qsr = 4 ! index of solar heat file
INTEGER , PARAMETER :: jp_emp = 5 ! index of evaporation-precipation file
- !!INTEGER , PARAMETER :: jp_sfx = 6 ! index of salt flux flux
- INTEGER , PARAMETER :: jpfld = 5 !! 6 ! maximum number of files to read
+!!$ INTEGER , PARAMETER :: jp_sfx = 6 ! index of salt flux flux
+!!$ INTEGER , PARAMETER :: jp_sithic = 7 ! index of sea ice thickness
+!!$ INTEGER , PARAMETER :: jp_sivolu = 8 ! index of sea ice volume per area
+!!$ INTEGER , PARAMETER :: jp_siconc = 9 ! index of sea ice fraction
+ INTEGER , PARAMETER :: jpfld = 5 ! maximum number of files to read
+!!$ INTEGER , PARAMETER :: jpfld = 9 ! maximum number of files to read
TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf ! structure of input fields (file informations, fields read)
!! * Substitutions
@@ -88,7 +92,7 @@ CONTAINS
CHARACTER(len=100) :: cn_dir ! Root directory for location of flx files
TYPE(FLD_N), DIMENSION(jpfld) :: slf_i ! array of namelist information structures
TYPE(FLD_N) :: sn_utau, sn_vtau, sn_qtot, sn_qsr, sn_emp !!, sn_sfx ! informations about the fields to be read
- NAMELIST/namsbc_flx/ cn_dir, sn_utau, sn_vtau, sn_qtot, sn_qsr, sn_emp !!, sn_sfx
+ NAMELIST/namsbc_flx/ cn_dir, sn_utau, sn_vtau, sn_qtot, sn_qsr, sn_emp !!, sn_sfx, sn_sithic, sn_sivolu, sn_siconc
!!---------------------------------------------------------------------
!
IF( kt == nit000 ) THEN ! First call kt=nit000
@@ -108,19 +112,22 @@ CONTAINS
slf_i(jp_utau) = sn_utau ; slf_i(jp_vtau) = sn_vtau
slf_i(jp_qtot) = sn_qtot ; slf_i(jp_qsr ) = sn_qsr
slf_i(jp_emp ) = sn_emp !! ; slf_i(jp_sfx ) = sn_sfx
+ !!slf_i(jp_sithic) = sn_sithic
+ !!slf_i(jp_sivolu) = sn_sivolu
+ !!slf_i(jp_siconc) = sn_siconc
!
ALLOCATE( sf(jpfld), STAT=ierror ) ! set sf structure
IF( ierror > 0 ) THEN
CALL ctl_stop( 'sbc_flx: unable to allocate sf structure' ) ; RETURN
ENDIF
DO ji= 1, jpfld
- ALLOCATE( sf(ji)%fnow(jpi,jpj,1) )
- IF( slf_i(ji)%ln_tint ) ALLOCATE( sf(ji)%fdta(jpi,jpj,1,2) )
+ ALLOCATE( sf(ji)%fnow(A2D(0),1) )
+ IF( slf_i(ji)%ln_tint ) ALLOCATE( sf(ji)%fdta(A2D(0),1,2) )
END DO
! ! fill sf with slf_i and control print
CALL fld_fill( sf, slf_i, cn_dir, 'sbc_flx', 'flux formulation for ocean surface boundary condition', 'namsbc_flx' )
- sf(jp_utau)%cltype = 'U' ; sf(jp_utau)%zsgn = -1._wp ! vector field at U point: overwrite default definition of cltype and zsgn
- sf(jp_vtau)%cltype = 'V' ; sf(jp_vtau)%zsgn = -1._wp ! vector field at V point: overwrite default definition of cltype and zsgn
+ sf(jp_utau)%cltype = 'T' ; sf(jp_utau)%zsgn = -1._wp ! vector field at T point: overwrite default definition of cltype and zsgn
+ sf(jp_vtau)%cltype = 'T' ; sf(jp_vtau)%zsgn = -1._wp ! vector field at T point: overwrite default definition of cltype and zsgn
!
ENDIF
@@ -129,33 +136,44 @@ CONTAINS
IF( MOD( kt-1, nn_fsbc ) == 0 ) THEN ! update ocean fluxes at each SBC frequency
IF( ln_dm2dc ) THEN ! modify now Qsr to include the diurnal cycle
- qsr(:,:) = sbc_dcy( sf(jp_qsr)%fnow(:,:,1) ) * tmask(:,:,1)
+ qsr(:,:) = sbc_dcy( sf(jp_qsr)%fnow(:,:,1) ) * smask0(:,:)
ELSE
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
- qsr(ji,jj) = sf(jp_qsr)%fnow(ji,jj,1) * tmask(ji,jj,1)
- END_2D
+ qsr(:,:) = sf(jp_qsr)%fnow(:,:,1) * smask0(:,:)
ENDIF
#if defined key_top
IF( ln_trcdc2dm ) THEN ! diurnal cycle in TOP
IF( ln_dm2dc ) THEN
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
- qsr_mean(ji,jj) = sf(jp_qsr)%fnow(ji,jj,1) * tmask(ji,jj,1)
+ DO_2D( 0, 0, 0, 0 ) ! set the ocean fluxes from read fields
+ qsr_mean(ji,jj) = sf(jp_qsr)%fnow(ji,jj,1) * smask0(ji,jj)
END_2D
ELSE
ncpl_qsr_freq = sf(jp_qsr)%freqh * 3600 ! qsr_mean will be computed in TOP
ENDIF
ENDIF
#endif
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) ! set the ocean fluxes from read fields
- utau(ji,jj) = sf(jp_utau)%fnow(ji,jj,1) * umask(ji,jj,1)
- vtau(ji,jj) = sf(jp_vtau)%fnow(ji,jj,1) * vmask(ji,jj,1)
- qns (ji,jj) = ( sf(jp_qtot)%fnow(ji,jj,1) - sf(jp_qsr)%fnow(ji,jj,1) ) * tmask(ji,jj,1)
- emp (ji,jj) = sf(jp_emp )%fnow(ji,jj,1) * tmask(ji,jj,1)
- !!sfx (ji,jj) = sf(jp_sfx )%fnow(ji,jj,1) * tmask(ji,jj,1)
+ DO_2D( 0, 0, 0, 0 ) ! set the ocean fluxes from read fields
+ utau(ji,jj) = sf(jp_utau)%fnow(ji,jj,1) * smask0(ji,jj)
+ vtau(ji,jj) = sf(jp_vtau)%fnow(ji,jj,1) * smask0(ji,jj)
+ qns (ji,jj) = ( sf(jp_qtot)%fnow(ji,jj,1) - sf(jp_qsr)%fnow(ji,jj,1) ) * smask0(ji,jj)
+ emp (ji,jj) = sf(jp_emp )%fnow(ji,jj,1) * smask0(ji,jj)
+ !!sfx (ji,jj) = sf(jp_sfx )%fnow(ji,jj,1) * smask0(ji,jj)
+ !!hcpl_i(ji,jj) = sf(jp_sithic)%fnow(ji,jj,1) * smask0(ji,jj)
+ !!vcpl_i(ji,jj) = sf(jp_sivolu)%fnow(ji,jj,1) * smask0(ji,jj)
+ !!fr_i(ji,jj) = sf(jp_siconc)%fnow(ji,jj,1) * smask0(ji,jj)
END_2D
- ! ! add to qns the heat due to e-p
- !!clem: I do not think it is needed
- !!qns(:,:) = qns(:,:) - emp(:,:) * sst_m(:,:) * rcp ! mass flux is at SST
+ !
+ !! Yona : add global qfrz to qns
+ !!IF( ln_frz .AND. ln_frzglob ) THEN
+ !! zqfrz = glob_sum(qfrz_m(:,:) * e1t(A2D(0)) * e2t(A2D(0)) * smask0(:,:)) / glob_sum(e1t(A2D(0)) * e2t(A2D(0)) * smask0(:,:))
+ !! qns(:,:) = ( qns(:,:) - zqfrz ) * smask0(:,:)
+ !!ENDIF
+ !!Yona
+ !
+ !! Yona : add anomalies if they are activated
+ !!IF( ln_flx_ano ) THEN
+ !! CALL sbc_flx_ano( kt )
+ !!ENDIF
+ !! Yona
!
IF( nitend-nit000 <= 100 .AND. lwp ) THEN ! control print (if less than 100 time-step asked)
WRITE(numout,*)
@@ -170,19 +188,15 @@ CONTAINS
ENDIF
!
ENDIF
- ! ! module of wind stress and wind speed at T-point
- ! Note the use of 0.5*(2-umask) in order to unmask the stress along coastlines
+ !
+ ! module of wind stress and wind speed at T-point
zcoef = 1. / ( zrhoa * zcdrag )
DO_2D( 0, 0, 0, 0 )
- ztx = ( utau(ji-1,jj ) + utau(ji,jj) ) * 0.5_wp * ( 2._wp - MIN( umask(ji-1,jj ,1), umask(ji,jj,1) ) )
- zty = ( vtau(ji ,jj-1) + vtau(ji,jj) ) * 0.5_wp * ( 2._wp - MIN( vmask(ji ,jj-1,1), vmask(ji,jj,1) ) )
- zmod = SQRT( ztx * ztx + zty * zty ) * tmask(ji,jj,1)
+ zmod = SQRT( utau(ji,jj) * utau(ji,jj) + vtau(ji,jj) * vtau(ji,jj) ) * smask0(ji,jj)
taum(ji,jj) = zmod
wndm(ji,jj) = SQRT( zmod * zcoef ) !!clem: not used?
END_2D
!
- CALL lbc_lnk( 'sbcflx', taum, 'T', 1._wp, wndm, 'T', 1._wp )
- !
END SUBROUTINE sbc_flx
!!======================================================================
diff --git a/src/OCE/SBC/sbcfwb.F90 b/src/OCE/SBC/sbcfwb.F90
index 3cb6d7e241160ea7fe667cf78dad3213d056a5b6..616267af84f6e3405dbaee537b15da23abae2d6e 100644
--- a/src/OCE/SBC/sbcfwb.F90
+++ b/src/OCE/SBC/sbcfwb.F90
@@ -18,8 +18,8 @@ MODULE sbcfwb
USE oce ! ocean dynamics and tracers
USE dom_oce ! ocean space and time domain
USE sbc_oce ! surface ocean boundary condition
- USE isf_oce , ONLY : fwfisf_cav, fwfisf_par ! ice shelf melting contribution
- USE sbc_ice , ONLY : snwice_mass_b, snwice_fmass
+ USE isf_oce , ONLY : fwfisf_cav, fwfisf_par, ln_isfcpl, ln_isfcpl_cons, risfcpl_cons_ssh ! ice shelf melting contribution
+ USE sbc_ice , ONLY : snwice_mass, snwice_mass_b, snwice_fmass
USE phycst ! physical constants
USE sbcrnf ! ocean runoffs
USE sbcssr ! Sea-Surface damping terms
@@ -57,6 +57,8 @@ MODULE sbcfwb
!$AGRIF_END_DO_NOT_TREAT
#endif
+ !! * Substitutions
+# include "do_loop_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
!! $Id: sbcfwb.F90 15439 2021-10-22 17:53:09Z clem $
@@ -168,8 +170,8 @@ CONTAINS
IF ( Agrif_Root() ) THEN
#if defined key_agrif
ALLOCATE(agrif_tmp(Agrif_nb_fine_grids()+1))
- agrif_tmp(:) = 1.e+40_dp ! Initialize to a big value
- agrif_tmp(1) = glob_sum( 'sbcfwb', e1e2t(:,:) * tmask_agrif(:,:)) ! Coarse grid value
+ agrif_tmp(:) = HUGE(1._wp) ! Initialize to a big value
+ agrif_tmp(1) = glob_sum( 'sbcfwb', e1e2t(A2D(0)) * tmask_agrif(A2D(0)) ) ! Coarse grid value
CALL Agrif_step_child_adj(glob_sum_area_agrif) ! Get value over child grids
CALL mpp_min('sbcfwb', agrif_tmp(:)) ! Required with // sisters to populate the value of each grid on each processor
area = SUM(agrif_tmp) ! Sum over all grids
@@ -178,7 +180,7 @@ CONTAINS
IF (lwp) WRITE(numout,*) ' ', igrid, agrif_tmp(igrid)/1000._wp/1000._wp
END DO
#else
- area = glob_sum( 'sbcfwb', e1e2t(:,:) * tmask(:,:,1)) ! interior global domain surface
+ area = glob_sum( 'sbcfwb', e1e2t(A2D(0)) * smask0(:,:) ) ! interior global domain surface
#endif
IF (lwp) WRITE(numout,*) 'Total Domain area (km**2):', area/1000._wp/1000._wp
!
@@ -230,15 +232,15 @@ CONTAINS
IF( MOD( kt-1, kn_fsbc ) == 0 ) THEN
SELECT CASE (nn_fwb_voltype)
CASE( 1 )
- z_fwfprv(1) = glob_sum( 'sbcfwb', e1e2t(:,:) * ( emp(:,:) - rnf(:,:) &
- & - fwfisf_cav(:,:) - fwfisf_par(:,:) &
- & - snwice_fmass(:,:) ) )
- !y_fwfnow(1) = local_sum( e1e2t(:,:) * ( emp(:,:) - rnf(:,:) - fwfisf_cav(:,:) - fwfisf_par(:,:) - snwice_fmass(:,:) ) )
+ z_fwfprv(1) = glob_sum( 'sbcfwb', e1e2t(A2D(0)) * ( emp(A2D(0)) - rnf(A2D(0)) &
+ & - fwfisf_cav(A2D(0)) - fwfisf_par(A2D(0)) &
+ & - snwice_fmass(A2D(0)) ) )
+ !y_fwfnow(1) = local_sum( e1e2t(A2D(0)) * ( emp(A2D(0)) - rnf(A2D(0)) - fwfisf_cav(A2D(0)) - fwfisf_par(A2D(0)) - snwice_fmass(A2D(0)) ) )
!CALL mpp_delay_sum( 'sbcfwb', 'fwb', y_fwfnow(:), z_fwfprv(:), kt == nitend - nn_fsbc + 1 )
CASE( 2 )
- z_fwfprv(1) = glob_sum( 'sbcfwb', e1e2t(:,:) * ( emp(:,:) - rnf(:,:) &
- & - fwfisf_cav(:,:) - fwfisf_par(:,:) ))
- !y_fwfnow(1) = local_sum( e1e2t(:,:) * ( emp(:,:) - rnf(:,:) - fwfisf_cav(:,:) - fwfisf_par(:,:) ) )
+ z_fwfprv(1) = glob_sum( 'sbcfwb', e1e2t(A2D(0)) * ( emp(A2D(0)) - rnf(A2D(0)) &
+ & - fwfisf_cav(A2D(0)) - fwfisf_par(A2D(0)) ))
+ !y_fwfnow(1) = local_sum( e1e2t(A2D(0)) * ( emp(A2D(0)) - rnf(A2D(0)) - fwfisf_cav(A2D(0)) - fwfisf_par(A2D(0)) ) )
!CALL mpp_delay_sum( 'sbcfwb', 'fwb', y_fwfnow(:), z_fwfprv(:), kt == nitend - nn_fsbc + 1 )
END SELECT
ENDIF
@@ -271,12 +273,12 @@ CONTAINS
!
IF( MOD( kt-1, kn_fsbc ) == 0 ) THEN
a_fwb_b = a_fwb ! time swap
- agrif_tmp(:) = 1.e+40_dp ! Initialize to a big value
+ agrif_tmp(:) = HUGE(1._wp) ! Initialize to a big value
SELECT CASE (nn_fwb_voltype)
CASE( 1 )
- agrif_tmp(1) = glob_sum( 'sbcfwb', e1e2t(:,:) * tmask_agrif(:,:) * ( ssh(:,:,Kmm) + snwice_mass_b(:,:) * r1_rho0 ))
+ agrif_tmp(1) = glob_sum( 'sbcfwb', e1e2t(A2D(0)) * tmask_agrif(A2D(0)) * ( ssh(A2D(0),Kmm) + snwice_mass_b(A2D(0)) * r1_rho0 ))
CASE( 2 )
- agrif_tmp(1) = glob_sum( 'sbcfwb', e1e2t(:,:) * tmask_agrif(:,:) * ssh(:,:,Kmm))
+ agrif_tmp(1) = glob_sum( 'sbcfwb', e1e2t(A2D(0)) * tmask_agrif(A2D(0)) * ssh(A2D(0),Kmm))
END SELECT
CALL Agrif_step_child_adj(glob_sum_volume_agrif) ! Get value over child grids
CALL mpp_min('sbcfwb', agrif_tmp(:)) ! Required with // sisters to populate the value of each grid on each processor
@@ -295,8 +297,8 @@ CONTAINS
#endif
!
IF( MOD( kt-1, kn_fsbc ) == 0 ) THEN ! correct the freshwater fluxes on all grids
- emp(:,:) = emp(:,:) + emp_corr * tmask(:,:,1)
- qns(:,:) = qns(:,:) - emp_corr * rcp * sst_m(:,:) * tmask(:,:,1) ! account for change to the heat budget due to fw correction
+ emp(A2D(0)) = emp(A2D(0)) + emp_corr * smask0(:,:)
+ qns(:,:) = qns(:,:) - emp_corr * rcp * sst_m(A2D(0)) * smask0(:,:) ! account for change to the heat budget due to fw correction
ENDIF
IF ( Agrif_Root() ) THEN
@@ -316,8 +318,8 @@ CONTAINS
! outputs
IF( MOD( kt-1, kn_fsbc ) == 0 ) THEN
- IF( iom_use('hflx_fwb_cea') ) CALL iom_put( 'hflx_fwb_cea', -emp_corr * rcp * sst_m(:,:) * tmask(:,:,1) )
- IF( iom_use('vflx_fwb_cea') ) CALL iom_put( 'vflx_fwb_cea', -emp_corr * tmask(:,:,1) )
+ IF( iom_use('hflx_fwb_cea') ) CALL iom_put( 'hflx_fwb_cea', -emp_corr * rcp * sst_m(A2D(0)) * smask0(:,:) )
+ IF( iom_use('vflx_fwb_cea') ) CALL iom_put( 'vflx_fwb_cea', -emp_corr * smask0(:,:) )
ENDIF
!
CASE ( 2 ) !== set volume annual trend ==!
@@ -350,12 +352,12 @@ CONTAINS
a_fwb_b = a_fwb
! mean sea level taking into account ice+snow
#if defined key_agrif
- agrif_tmp(:) = 1.e+40_dp ! Initialize to a big value
+ agrif_tmp(:) = HUGE(1._wp) ! Initialize to a big value
SELECT CASE (nn_fwb_voltype)
CASE( 1 )
- agrif_tmp(1) = glob_sum( 'sbcfwb', e1e2t(:,:) * tmask_agrif(:,:) * ( ssh(:,:,Kmm) + snwice_mass_b(:,:) * r1_rho0 ))
+ agrif_tmp(1) = glob_sum( 'sbcfwb', e1e2t(A2D(0)) * tmask_agrif(A2D(0)) * ( ssh(A2D(0),Kmm) + snwice_mass_b(A2D(0)) * r1_rho0 ))
CASE( 2 )
- agrif_tmp(1) = glob_sum( 'sbcfwb', e1e2t(:,:) * tmask_agrif(:,:) * ssh(:,:,Kmm) )
+ agrif_tmp(1) = glob_sum( 'sbcfwb', e1e2t(A2D(0)) * tmask_agrif(A2D(0)) * ssh(A2D(0),Kmm) )
END SELECT
CALL Agrif_step_child_adj(glob_sum_volume_agrif) ! Get value over child grids
CALL mpp_min('sbcfwb', agrif_tmp(:)) ! Required with // sisters to populate the value of each grid on each processor
@@ -363,9 +365,9 @@ CONTAINS
#else
SELECT CASE (nn_fwb_voltype)
CASE( 1 )
- a_fwb = glob_sum( 'sbcfwb', e1e2t(:,:) * ( ssh(:,:,Kmm) + snwice_mass_b(:,:) * r1_rho0 ) )
+ a_fwb = glob_sum( 'sbcfwb', e1e2t(A2D(0)) * ( ssh(A2D(0),Kmm) + snwice_mass_b(A2D(0)) * r1_rho0 ) )
CASE( 2 )
- a_fwb = glob_sum( 'sbcfwb', e1e2t(:,:) * ssh(:,:,Kmm) )
+ a_fwb = glob_sum( 'sbcfwb', e1e2t(A2D(0)) * ssh(A2D(0),Kmm) )
END SELECT
#endif
a_fwb = a_fwb * rho0 / area - hvolg_n * rho0
@@ -374,7 +376,7 @@ CONTAINS
! hence namelist rn_fwb0 still rules
IF ( a_fwb_b == 999._wp ) a_fwb_b = a_fwb
!
- emp_corr = ( a_fwb - a_fwb_b ) / ( rday * REAL(nyear_len(0), wp) ) + emp_corr
+ emp_corr = ( a_fwb - a_fwb_b ) / ( rday * REAL(nyear_len(1), wp) ) + emp_corr
IF(lwp) WRITE(numout,*)
IF(lwp) WRITE(numout,*)'sbc_fwb : Compute new global mass at step = ', kt
IF(lwp) WRITE(numout,*)'sbc_fwb : New averaged liquid height (ocean + snow + ice) = ', a_fwb * r1_rho0, 'm'
@@ -390,11 +392,11 @@ CONTAINS
ENDIF
!
IF( MOD( kt-1, kn_fsbc ) == 0 ) THEN ! correct the freshwater fluxes
- emp(:,:) = emp(:,:) + emp_corr * tmask(:,:,1)
- qns(:,:) = qns(:,:) - emp_corr * rcp * sst_m(:,:) * tmask(:,:,1) ! account for change to the heat budget due to fw correction
+ emp(A2D(0)) = emp(A2D(0)) + emp_corr * smask0(:,:)
+ qns(:,:) = qns(:,:) - emp_corr * rcp * sst_m(A2D(0)) * smask0(:,:) ! account for change to the heat budget due to fw correction
! outputs
- IF( iom_use('hflx_fwb_cea') ) CALL iom_put( 'hflx_fwb_cea', -emp_corr * rcp * sst_m(:,:) * tmask(:,:,1) )
- IF( iom_use('vflx_fwb_cea') ) CALL iom_put( 'vflx_fwb_cea', -emp_corr * tmask(:,:,1) )
+ IF( iom_use('hflx_fwb_cea') ) CALL iom_put( 'hflx_fwb_cea', -emp_corr * rcp * sst_m(A2D(0)) * smask0(:,:) )
+ IF( iom_use('vflx_fwb_cea') ) CALL iom_put( 'vflx_fwb_cea', -emp_corr * smask0(:,:) )
ENDIF
IF ( Agrif_Root() ) THEN
@@ -417,58 +419,55 @@ CONTAINS
!
CASE ( 3 ) !== set volume at each time step and spread out the correction over erp area ==!
!
- ALLOCATE( ztmsk_neg(jpi,jpj) , ztmsk_pos(jpi,jpj) , ztmsk_tospread(jpi,jpj) , z_wgt(jpi,jpj) , zerp_cor(jpi,jpj) )
+ ALLOCATE( ztmsk_neg(A2D(0)) , ztmsk_pos(A2D(0)) , ztmsk_tospread(A2D(0)) , z_wgt(A2D(0)) , zerp_cor(A2D(0)) )
!
IF( MOD( kt-1, kn_fsbc ) == 0 ) THEN
- ztmsk_pos(:,:) = tmask_i(:,:) ! Select <0 and >0 area of erp
+ ztmsk_pos(:,:) = smask0_i(:,:) ! Select <0 and >0 area of erp
WHERE( erp < 0._wp ) ztmsk_pos = 0._wp
- ztmsk_neg(:,:) = tmask_i(:,:) - ztmsk_pos(:,:)
+ ztmsk_neg(:,:) = smask0_i(:,:) - ztmsk_pos(:,:)
! ! fwf global mean (excluding ocean to ice/snow exchanges)
SELECT CASE (nn_fwb_voltype)
CASE( 1 )
- z_fwf = -emp_ext + glob_sum( 'sbcfwb', e1e2t(:,:) * ( emp(:,:) - rnf(:,:) - fwfisf_cav(:,:) - fwfisf_par(:,:) - snwice_fmass(:,:) ) ) / area
+ z_fwf = -emp_ext + glob_sum( 'sbcfwb', e1e2t(A2D(0)) * ( emp(A2D(0)) - rnf(A2D(0)) - fwfisf_cav(A2D(0)) - fwfisf_par(A2D(0)) - snwice_fmass(A2D(0)) ) ) / area
CASE( 2 )
- z_fwf = -emp_ext + glob_sum( 'sbcfwb', e1e2t(:,:) * ( emp(:,:) - rnf(:,:) - fwfisf_cav(:,:) - fwfisf_par(:,:) ) ) / area
+ z_fwf = -emp_ext + glob_sum( 'sbcfwb', e1e2t(A2D(0)) * ( emp(A2D(0)) - rnf(A2D(0)) - fwfisf_cav(A2D(0)) - fwfisf_par(A2D(0)) ) ) / area
END SELECT
!
IF( z_fwf < 0._wp ) THEN ! spread out over >0 erp area to increase evaporation
- zsurf_pos = glob_sum( 'sbcfwb', e1e2t(:,:)*ztmsk_pos(:,:) )
+ zsurf_pos = glob_sum( 'sbcfwb', e1e2t(A2D(0))*ztmsk_pos(:,:) )
zsurf_tospread = zsurf_pos
ztmsk_tospread(:,:) = ztmsk_pos(:,:)
ELSE ! spread out over <0 erp area to increase precipitation
- zsurf_neg = glob_sum( 'sbcfwb', e1e2t(:,:)*ztmsk_neg(:,:) ) ! Area filled by <0 and >0 erp
+ zsurf_neg = glob_sum( 'sbcfwb', e1e2t(A2D(0))*ztmsk_neg(:,:) ) ! Area filled by <0 and >0 erp
zsurf_tospread = zsurf_neg
ztmsk_tospread(:,:) = ztmsk_neg(:,:)
ENDIF
!
- zsum_fwf = glob_sum( 'sbcfwb', e1e2t(:,:) * z_fwf ) ! fwf global mean over <0 or >0 erp area
+ zsum_fwf = glob_sum( 'sbcfwb', e1e2t(A2D(0)) * z_fwf ) ! fwf global mean over <0 or >0 erp area
!!gm : zsum_fwf = z_fwf * area ??? it is right? I think so....
z_fwf_nsrf = zsum_fwf / ( zsurf_tospread + rsmall )
! ! weight to respect erp field 2D structure
- zsum_erp = glob_sum( 'sbcfwb', ztmsk_tospread(:,:) * erp(:,:) * e1e2t(:,:) )
+ zsum_erp = glob_sum( 'sbcfwb', ztmsk_tospread(:,:) * erp(:,:) * e1e2t(A2D(0)) )
z_wgt(:,:) = ztmsk_tospread(:,:) * erp(:,:) / ( zsum_erp + rsmall )
! ! final correction term to apply
zerp_cor(:,:) = -1. * z_fwf_nsrf * zsurf_tospread * z_wgt(:,:)
!
-!!gm ===>>>> lbc_lnk should be useless as all the computation is done over the whole domain !
- CALL lbc_lnk( 'sbcfwb', zerp_cor, 'T', 1.0_wp )
- !
- emp(:,:) = emp(:,:) + zerp_cor(:,:)
- qns(:,:) = qns(:,:) - zerp_cor(:,:) * rcp * sst_m(:,:) ! account for change to the heat budget due to fw correction
- erp(:,:) = erp(:,:) + zerp_cor(:,:)
+ emp(A2D(0)) = emp(A2D(0)) + zerp_cor(:,:)
+ qns(:,:) = qns(:,:) - zerp_cor(:,:) * rcp * sst_m(A2D(0)) ! account for change to the heat budget due to fw correction
+ erp(:,:) = erp(:,:) + zerp_cor(:,:)
! outputs
- IF( iom_use('hflx_fwb_cea') ) CALL iom_put( 'hflx_fwb_cea', -zerp_cor(:,:) * rcp * sst_m(:,:) )
+ IF( iom_use('hflx_fwb_cea') ) CALL iom_put( 'hflx_fwb_cea', -zerp_cor(:,:) * rcp * sst_m(A2D(0)) )
IF( iom_use('vflx_fwb_cea') ) CALL iom_put( 'vflx_fwb_cea', -zerp_cor(:,:) )
!
IF( lwp ) THEN ! control print
IF( z_fwf < 0._wp ) THEN
WRITE(numout,*)' z_fwf < 0'
- WRITE(numout,*)' SUM(erp+) = ', SUM( ztmsk_tospread(:,:)*erp(:,:)*e1e2t(:,:) )*1.e-9,' Sv'
+ WRITE(numout,*)' SUM(erp+) = ', SUM( ztmsk_tospread(:,:)*erp(:,:)*e1e2t(A2D(0)) )*1.e-9,' Sv'
ELSE
WRITE(numout,*)' z_fwf >= 0'
- WRITE(numout,*)' SUM(erp-) = ', SUM( ztmsk_tospread(:,:)*erp(:,:)*e1e2t(:,:) )*1.e-9,' Sv'
+ WRITE(numout,*)' SUM(erp-) = ', SUM( ztmsk_tospread(:,:)*erp(:,:)*e1e2t(A2D(0)) )*1.e-9,' Sv'
ENDIF
- WRITE(numout,*)' SUM(empG) = ', SUM( z_fwf*e1e2t(:,:) )*1.e-9,' Sv'
+ WRITE(numout,*)' SUM(empG) = ', SUM( z_fwf*e1e2t(A2D(0)) )*1.e-9,' Sv'
WRITE(numout,*)' z_fwf = ', z_fwf ,' Kg/m2/s'
WRITE(numout,*)' z_fwf_nsrf = ', z_fwf_nsrf ,' Kg/m2/s'
WRITE(numout,*)' MIN(zerp_cor) = ', MINVAL(zerp_cor)
@@ -477,6 +476,37 @@ CONTAINS
ENDIF
DEALLOCATE( ztmsk_neg , ztmsk_pos , ztmsk_tospread , z_wgt , zerp_cor )
!
+ CASE ( 4 ) !== global mean fwf set to zero (ISOMIP case) ==!
+ !
+ IF( MOD( kt-1, kn_fsbc ) == 0 ) THEN
+ ! ! fwf global mean (excluding ocean to ice/snow exchanges)
+ emp_corr = glob_sum( 'sbcfwb', e1e2t(A2D(0)) * ( emp(A2D(0)) - rnf(A2D(0)) - fwfisf_cav(A2D(0)) - fwfisf_par(A2D(0)) &
+ & - snwice_fmass(A2D(0)) ) ) / area
+ ! clem: use y_fwfnow instead to improve performance?
+ !y_fwfnow(1) = local_sum( e1e2t(A2D(0)) * ( emp(A2D(0)) - rnf(A2D(0)) - fwfisf_cav(A2D(0)) - fwfisf_par(A2D(0)) &
+ ! & - snwice_fmass(A2D(0)) ) )
+ ! correction for ice sheet coupling testing (ie remove the excess through the surface)
+ ! test impact on the melt as conservation correction made in depth
+ ! test conservation level as sbcfwb is conserving
+ ! avoid the model to blow up for large ssh drop (isomip OCEAN3 with melt switch off and uniform T/S)
+ IF (ln_isfcpl .AND. ln_isfcpl_cons) THEN
+ emp_corr = emp_corr + glob_sum( 'sbcfwb', e1e2t(A2D(0)) * risfcpl_cons_ssh(A2D(0)) * rho0 ) / area
+ ! y_fwfnow(1) = y_fwfnow(1) + local_sum( e1e2t(A2D(0)) * risfcpl_cons_ssh(A2D(0)) * rho0 )
+ END IF
+ !CALL mpp_delay_sum( 'sbcfwb', 'fwb', y_fwfnow(:), z_fwfprv(:), kt == nitend - nn_fsbc + 1 )
+ !emp_corr = z_fwfprv(1) / area
+ !
+ emp(A2D(0)) = emp(A2D(0)) - emp_corr * smask0(:,:) ! (Eq. 34 AD2015)
+ qns(:,:) = qns(:,:) + emp_corr * rcp * sst_m(A2D(0)) * smask0(:,:) ! (Eq. 35 AD2015) ! use sst_m to avoid generation of any bouyancy fluxes
+ sfx(:,:) = sfx(:,:) + emp_corr * sss_m(A2D(0)) * smask0(:,:) ! (Eq. 36 AD2015) ! use sss_m to avoid generation of any bouyancy fluxes
+ !
+ IF( iom_use('hflx_fwb_cea') ) CALL iom_put( 'hflx_fwb_cea', emp_corr * rcp * sst_m(A2D(0)) * smask0(:,:) )
+ IF( iom_use('vflx_fwb_cea') ) CALL iom_put( 'vflx_fwb_cea', emp_corr * smask0(:,:) )
+ ENDIF
+ !
+ CASE DEFAULT !== you should never be there ==!
+ CALL ctl_stop( 'sbc_fwb : wrong nn_fwb value for the FreshWater Budget correction, choose either 1, 2 or 3' )
+ !
END SELECT
!
END SUBROUTINE sbc_fwb
diff --git a/src/OCE/SBC/sbcice_cice.F90 b/src/OCE/SBC/sbcice_cice.F90
index 5f7f75770b3ec439806d3c4bfa2a4727652eaae5..d05ccfd32cd33c0624cdb6633335f1dc7bbd4967 100644
--- a/src/OCE/SBC/sbcice_cice.F90
+++ b/src/OCE/SBC/sbcice_cice.F90
@@ -12,9 +12,9 @@ MODULE sbcice_cice
USE oce ! ocean dynamics and tracers
USE dom_oce ! ocean space and time domain
# if defined key_qco
- USE domqco ! Variable volume
-# else
- USE domvvl ! Variable volume
+ USE domqco ! Variable volume
+# elif defined key_linssh
+ ! ! Fix in time volume
# endif
USE phycst, only : rcp, rho0, r1_rho0, rhos, rhoi
USE in_out_manager ! I/O manager
@@ -238,41 +238,8 @@ CONTAINS
!!gm especially here it is assumed zstar coordinate, but it can be ztilde....
#if defined key_qco
IF( .NOT.ln_linssh ) CALL dom_qco_zgr( Kbb, Kmm ) ! interpolation scale factor, depth and water column
-#else
- IF( .NOT.ln_linssh ) THEN
- !
- DO jk = 1,jpkm1 ! adjust initial vertical scale factors
- e3t(:,:,jk,Kmm) = e3t_0(:,:,jk)*( 1._wp + ssh(:,:,Kmm)*r1_ht_0(:,:)*tmask(:,:,jk) )
- e3t(:,:,jk,Kbb) = e3t_0(:,:,jk)*( 1._wp + ssh(:,:,Kbb)*r1_ht_0(:,:)*tmask(:,:,jk) )
- ENDDO
- e3t(:,:,:,Krhs) = e3t(:,:,:,Kbb)
- ! Reconstruction of all vertical scale factors at now and before time-steps
- ! =============================================================================
- ! Horizontal scale factor interpolations
- ! --------------------------------------
- CALL dom_vvl_interpol( e3t(:,:,:,Kbb), e3u(:,:,:,Kbb), 'U' )
- CALL dom_vvl_interpol( e3t(:,:,:,Kbb), e3v(:,:,:,Kbb), 'V' )
- CALL dom_vvl_interpol( e3t(:,:,:,Kmm), e3u(:,:,:,Kmm), 'U' )
- CALL dom_vvl_interpol( e3t(:,:,:,Kmm), e3v(:,:,:,Kmm), 'V' )
- CALL dom_vvl_interpol( e3u(:,:,:,Kmm), e3f(:,:,:), 'F' )
- ! Vertical scale factor interpolations
- ! ------------------------------------
- CALL dom_vvl_interpol( e3t(:,:,:,Kmm), e3w (:,:,:,Kmm), 'W' )
- CALL dom_vvl_interpol( e3u(:,:,:,Kmm), e3uw(:,:,:,Kmm), 'UW' )
- CALL dom_vvl_interpol( e3v(:,:,:,Kmm), e3vw(:,:,:,Kmm), 'VW' )
- CALL dom_vvl_interpol( e3u(:,:,:,Kbb), e3uw(:,:,:,Kbb), 'UW' )
- CALL dom_vvl_interpol( e3v(:,:,:,Kbb), e3vw(:,:,:,Kbb), 'VW' )
- ! t- and w- points depth
- ! ----------------------
- gdept(:,:,1,Kmm) = 0.5_wp * e3w(:,:,1,Kmm)
- gdepw(:,:,1,Kmm) = 0.0_wp
- gde3w(:,:,1) = gdept(:,:,1,Kmm) - ssh(:,:,Kmm)
- DO jk = 2, jpk
- gdept(:,:,jk,Kmm) = gdept(:,:,jk-1,Kmm) + e3w(:,:,jk,Kmm)
- gdepw(:,:,jk,Kmm) = gdepw(:,:,jk-1,Kmm) + e3t(:,:,jk-1,Kmm)
- gde3w(:,:,jk) = gdept(:,:,jk ,Kmm) - sshn (:,:)
- END DO
- ENDIF
+#elif defined key_linssh
+ !
#endif
ENDIF
ENDIF
@@ -566,7 +533,7 @@ taum(:,:)=(1.0-fr_i(:,:))*taum(:,:)+fr_i(:,:)*SQRT(ztmp1*ztmp1 + ztmp2*ztmp2)
WHERE (ztmp1(:,:).lt.0.0) ztmp2(:,:)=MAX(ztmp2(:,:),ztmp1(:,:)*sss_m(:,:)/1000.0)
sfx(:,:)=ztmp2(:,:)*1000.0
emp(:,:)=emp(:,:)-ztmp1(:,:)
- fmmflx(:,:) = ztmp1(:,:) !!Joakim edit
+ fwfice(:,:) = -ztmp1(:,:) !!Joakim edit
CALL lbc_lnk( 'sbcice_cice', emp , 'T', 1.0_wp, sfx , 'T', 1.0_wp )
diff --git a/src/OCE/SBC/sbcice_if.F90 b/src/OCE/SBC/sbcice_if.F90
index d5acb2918258945b4f211692d26a6fe6aab713ea..c406c7408c2a598b4241057d699e292b002ff454 100644
--- a/src/OCE/SBC/sbcice_if.F90
+++ b/src/OCE/SBC/sbcice_if.F90
@@ -85,8 +85,8 @@ CONTAINS
ALLOCATE( sf_ice(1), STAT=ierror )
IF( ierror > 0 ) CALL ctl_stop( 'STOP', 'sbc_ice_if: unable to allocate sf_ice structure' )
- ALLOCATE( sf_ice(1)%fnow(jpi,jpj,1) )
- IF( sn_ice%ln_tint ) ALLOCATE( sf_ice(1)%fdta(jpi,jpj,1,2) )
+ ALLOCATE( sf_ice(1)%fnow(A2D(0),1) )
+ IF( sn_ice%ln_tint ) ALLOCATE( sf_ice(1)%fdta(A2D(0),1,2) )
! fill sf_ice with sn_ice and control print
CALL fld_fill( sf_ice, (/ sn_ice /), cn_dir, 'sbc_ice_if', 'ice-if sea-ice model', 'namsbc_iif' )
@@ -108,8 +108,12 @@ CONTAINS
IF( ln_cpl ) a_i(:,:,1) = fr_i(:,:)
! Flux and ice fraction computation
- DO_2D( 1, 1, 1, 1 )
- !
+ DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ zt_fzp = fr_i(ji,jj) ! freezing point temperature
+ ts(ji,jj,1,jp_tem,Kmm) = MAX( ts(ji,jj,1,jp_tem,Kmm), zt_fzp ) ! avoid over-freezing point temperature
+ END_2D
+
+ DO_2D( 0, 0, 0, 0 )
zt_fzp = fr_i(ji,jj) ! freezing point temperature
zfr_obs = sf_ice(1)%fnow(ji,jj,1) ! observed ice cover
! ! ocean ice fraction (0/1) from the freezing point temperature
@@ -117,8 +121,6 @@ CONTAINS
ELSE ; fr_i(ji,jj) = 0.e0
ENDIF
- ts(ji,jj,1,jp_tem,Kmm) = MAX( ts(ji,jj,1,jp_tem,Kmm), zt_fzp ) ! avoid over-freezing point temperature
-
qsr(ji,jj) = ( 1. - zfr_obs ) * qsr(ji,jj) ! solar heat flux : zero below observed ice cover
! ! non solar heat flux : add a damping term
@@ -127,7 +129,7 @@ CONTAINS
zqri = ztrp * ( ts(ji,jj,1,jp_tem,Kbb) - ( zt_fzp - 1.) )
zqrj = ztrp * MIN( 0., ts(ji,jj,1,jp_tem,Kbb) - zt_fzp )
zqrp = ( zfr_obs * ( (1. - fr_i(ji,jj) ) * zqri &
- & + fr_i(ji,jj) * zqrj ) ) * tmask(ji,jj,1)
+ & + fr_i(ji,jj) * zqrj ) ) * smask0(ji,jj)
! ! non-solar heat flux
! # qns unchanged if no climatological ice (zfr_obs=0)
@@ -136,7 +138,7 @@ CONTAINS
! (-2=arctic, -4=antarctic)
zqi = -3. + SIGN( 1._wp, ff_f(ji,jj) )
qns(ji,jj) = ( ( 1.- zfr_obs ) * qns(ji,jj) &
- & + zfr_obs * fr_i(ji,jj) * zqi ) * tmask(ji,jj,1) &
+ & + zfr_obs * fr_i(ji,jj) * zqi ) * smask0(ji,jj) &
& + zqrp
END_2D
!
diff --git a/src/OCE/SBC/sbcmod.F90 b/src/OCE/SBC/sbcmod.F90
index dbbb7c71dca93e597d3650d6cafb49c4c04a9699..cb1c832f29e34d6d4c4eecd6ad3fbfa98e629d72 100644
--- a/src/OCE/SBC/sbcmod.F90
+++ b/src/OCE/SBC/sbcmod.F90
@@ -162,8 +162,8 @@ CONTAINS
!
IF( .NOT.ln_usr ) THEN ! the model calendar needs some specificities (except in user defined case)
IF( MOD( rday , rn_Dt ) /= 0. ) CALL ctl_stop( 'the time step must devide the number of second of in a day' )
- IF( MOD( rday , 2. ) /= 0. ) CALL ctl_stop( 'the number of second of in a day must be an even number' )
- IF( MOD( rn_Dt , 2. ) /= 0. ) CALL ctl_stop( 'the time step (in second) must be an even number' )
+ IF( MOD( rday , 2. ) /= 0. ) CALL ctl_stop( 'the number of second of in a day must be an even number' )
+ IF( MOD( rn_Dt, 2. ) /= 0. ) CALL ctl_stop( 'the time step (in second) must be an even number' )
ENDIF
! !** check option consistency
!
@@ -232,7 +232,7 @@ CONTAINS
ENDIF
!
sfx (:,:) = 0._wp !* salt flux due to freezing/melting
- fmmflx(:,:) = 0._wp !* freezing minus melting flux
+ fwfice(:,:) = 0._wp !* ice-ocean freshwater flux
cloud_fra(:,:) = pp_cldf !* cloud fraction over sea ice (used in si3)
taum(:,:) = 0._wp !* wind stress module (needed in GLS in case of reduced restart)
@@ -378,7 +378,7 @@ CONTAINS
!!
!! ** Action : - set the ocean surface boundary condition at before and now
!! time step, i.e.
- !! utau_b, vtau_b, qns_b, qsr_b, emp_n, sfx_b, qrp_b, erp_b
+ !! utau_b, vtau_b, qns_b, qsr_b, emp_b, sfx_b
!! utau , vtau , qns , qsr , emp , sfx , qrp , erp
!! - updte the ice fraction : fr_i
!!----------------------------------------------------------------------
@@ -386,12 +386,10 @@ CONTAINS
INTEGER, INTENT(in) :: Kbb, Kmm ! ocean time level indices
INTEGER :: jj, ji ! dummy loop argument
!
- LOGICAL :: ll_sas, ll_opa ! local logical
+ LOGICAL :: ll_sas, ll_opa ! local logical
!
- REAL(wp) :: zthscl ! wd tanh scale
- REAL(wp), DIMENSION(jpi,jpj) :: zwdht, zwght ! wd dep over wd limit, wgt
- REAL(wp), DIMENSION(jpi,jpj) :: z2d ! temporary array used for iom_put
-
+ REAL(wp) :: zthscl ! wd tanh scale
+ REAL(wp) :: zwdht, zwght ! wd dep over wd limit, wgt
!!---------------------------------------------------------------------
!
IF( ln_timing ) CALL timing_start('sbc')
@@ -399,20 +397,22 @@ CONTAINS
! ! ---------------------------------------- !
IF( kt /= nit000 ) THEN ! Swap of forcing fields !
! ! ---------------------------------------- !
- utau_b(:,:) = utau(:,:) ! Swap the ocean forcing fields
- vtau_b(:,:) = vtau(:,:) ! (except at nit000 where before fields
- qns_b (:,:) = qns (:,:) ! are set at the end of the routine)
- emp_b (:,:) = emp (:,:)
- sfx_b (:,:) = sfx (:,:)
+ utau_b(:,:) = utauU(:,:) ! Swap the ocean forcing fields
+ vtau_b(:,:) = vtauV(:,:) ! (except at nit000 where before fields
+ qns_b (:,:) = qns (:,:) ! are set at the end of the routine)
+ emp_b (:,:) = emp (:,:)
+ sfx_b (:,:) = sfx (:,:)
IF( ln_rnf ) THEN
rnf_b (:,: ) = rnf (:,: )
rnf_tsc_b(:,:,:) = rnf_tsc(:,:,:)
ENDIF
- !
+ !
ENDIF
! ! ---------------------------------------- !
! ! forcing field computation !
! ! ---------------------------------------- !
+ ! most of the following routines update fields only in the interior
+ ! with the exception of sbcssm, sbcrnf and sbcwave modules
!
ll_sas = nn_components == jp_iam_sas ! component flags
ll_opa = nn_components == jp_iam_oce
@@ -437,66 +437,75 @@ CONTAINS
CASE( jp_abl ) ; CALL sbc_abl ( kt ) ! ABL formulation for the ocean
CASE( jp_purecpl ) ; CALL sbc_cpl_rcv ( kt, nn_fsbc, nn_ice, Kbb, Kmm ) ! pure coupled formulation
CASE( jp_none )
- IF( ll_opa ) CALL sbc_cpl_rcv ( kt, nn_fsbc, nn_ice, Kbb, Kmm ) ! OCE-SAS coupling: OCE receiving fields from SAS
+ IF( ll_opa ) CALL sbc_cpl_rcv ( kt, nn_fsbc, nn_ice, Kbb, Kmm ) ! OCE-SAS coupling: OCE receiving fields from SAS
END SELECT
- IF( ln_mixcpl ) CALL sbc_cpl_rcv ( kt, nn_fsbc, nn_ice, Kbb, Kmm ) ! forced-coupled mixed formulation after forcing
!
- IF( ln_wave .AND. ln_tauoc ) THEN ! Wave stress reduction
- DO_2D( 0, 0, 0, 0)
- utau(ji,jj) = utau(ji,jj) * ( tauoc_wave(ji,jj) + tauoc_wave(ji+1,jj) ) * 0.5_wp
- vtau(ji,jj) = vtau(ji,jj) * ( tauoc_wave(ji,jj) + tauoc_wave(ji,jj+1) ) * 0.5_wp
- END_2D
- !
- CALL lbc_lnk( 'sbcwave', utau, 'U', -1. )
- CALL lbc_lnk( 'sbcwave', vtau, 'V', -1. )
+ IF( ln_mixcpl ) CALL sbc_cpl_rcv ( kt, nn_fsbc, nn_ice, Kbb, Kmm ) ! forced-coupled mixed formulation after forcing
+ !
+ IF( ln_wave .AND. ln_tauoc ) THEN ! Wave stress reduction
!
- taum(:,:) = taum(:,:)*tauoc_wave(:,:)
+ DO_2D( 0, 0, 0, 0 )
+ utau(ji,jj) = utau(ji,jj) * tauoc_wave(ji,jj)
+ vtau(ji,jj) = vtau(ji,jj) * tauoc_wave(ji,jj)
+ taum(ji,jj) = taum(ji,jj) * tauoc_wave(ji,jj)
+ END_2D
!
IF( kt == nit000 ) CALL ctl_warn( 'sbc: You are subtracting the wave stress to the ocean.', &
& 'If not requested select ln_tauoc=.false.' )
!
- ELSEIF( ln_wave .AND. ln_taw ) THEN ! Wave stress reduction
- utau(:,:) = utau(:,:) - tawx(:,:) + twox(:,:)
- vtau(:,:) = vtau(:,:) - tawy(:,:) + twoy(:,:)
- CALL lbc_lnk( 'sbcwave', utau, 'U', -1. )
- CALL lbc_lnk( 'sbcwave', vtau, 'V', -1. )
- !
- DO_2D( 0, 0, 0, 0)
- taum(ji,jj) = sqrt((.5*(utau(ji-1,jj)+utau(ji,jj)))**2 + (.5*(vtau(ji,jj-1)+vtau(ji,jj)))**2)
+ ELSEIF( ln_wave .AND. ln_taw ) THEN ! Wave stress reduction
+ DO_2D( 0, 0, 0, 0 )
+ utau(ji,jj) = utau(ji,jj) - ( tawx(ji,jj) - twox(ji,jj) )
+ vtau(ji,jj) = vtau(ji,jj) - ( tawy(ji,jj) - twoy(ji,jj) )
+ taum(ji,jj) = SQRT( utau(ji,jj)*utau(ji,jj) + vtau(ji,jj)*vtau(ji,jj) )
END_2D
!
IF( kt == nit000 ) CALL ctl_warn( 'sbc: You are subtracting the wave stress to the ocean.', &
& 'If not requested select ln_taw=.false.' )
!
ENDIF
- CALL lbc_lnk( 'sbcmod', taum(:,:), 'T', 1. )
+ !
+ !clem: these calls are needed for sbccpl only => only for SAS I think?
+ IF( ll_sas .OR. ll_opa ) CALL lbc_lnk( 'sbcmod', sst_m, 'T', 1.0_wp, sss_m, 'T', 1.0_wp, ssh_m, 'T', 1.0_wp, &
+ & frq_m, 'T', 1.0_wp, e3t_m, 'T', 1.0_wp, fr_i , 'T', 1.0_wp )
+ !clem : these calls are needed for sbccpl => it needs an IF statement but it's complicated
+ IF( ln_rnf .AND. l_rnfcpl ) CALL lbc_lnk( 'sbcmod', rnf, 'T', 1.0_wp )
!
IF( ln_icebergs ) THEN ! save pure stresses (with no ice-ocean stress) for use by icebergs
- utau_icb(:,:) = utau(:,:) ; vtau_icb(:,:) = vtau(:,:)
+ ! Note the use of 0.5*(2-umask) in order to unmask the stress along coastlines
+ ! and the use of MAX(tmask(i,j),tmask(i+1,j) is to mask tau over ice shelves
+ CALL lbc_lnk( 'sbcmod', utau, 'T', -1.0_wp, vtau, 'T', -1.0_wp )
+ DO_2D( 0, 0, 0, 0 )
+ utau_icb(ji,jj) = 0.5_wp * ( utau(ji,jj) + utau(ji+1,jj) ) * &
+ & ( 2. - umask(ji,jj,1) ) * MAX( tmask(ji,jj,1), tmask(ji+1,jj,1) )
+ vtau_icb(ji,jj) = 0.5_wp * ( vtau(ji,jj) + vtau(ji,jj+1) ) * &
+ & ( 2. - vmask(ji,jj,1) ) * MAX( tmask(ji,jj,1), tmask(ji,jj+1,1) )
+ END_2D
+ CALL lbc_lnk( 'sbcmod', utau_icb, 'U', -1.0_wp, vtau_icb, 'V', -1.0_wp )
ENDIF
!
! !== Misc. Options ==!
!
- SELECT CASE( nn_ice ) ! Update heat and freshwater fluxes over sea-ice areas
- CASE( 1 ) ; CALL sbc_ice_if ( kt, Kbb, Kmm ) ! Ice-cover climatology ("Ice-if" model)
+ SELECT CASE( nn_ice ) ! Update heat and freshwater fluxes over sea-ice areas
+ CASE( 1 ) ; CALL sbc_ice_if ( kt, Kbb, Kmm ) ! Ice-cover climatology ("Ice-if" model)
#if defined key_si3
- CASE( 2 ) ; CALL ice_stp ( kt, Kbb, Kmm, nsbc ) ! SI3 ice model
+ CASE( 2 ) ; CALL ice_stp ( kt, Kbb, Kmm, nsbc ) ! SI3 ice model
#endif
- CASE( 3 ) ; CALL sbc_ice_cice ( kt, nsbc ) ! CICE ice model
+ CASE( 3 ) ; CALL sbc_ice_cice ( kt, nsbc ) ! CICE ice model
END SELECT
-
- IF( ln_icebergs ) CALL icb_stp( kt, Kmm ) ! compute icebergs
+ !==> clem: from here on, the following fields are ok on the halos: snwice_mass, snwice_mass_b, snwice_fmass
+ ! but not utau, vtau, emp (must be done later on)
+
+ IF( ln_icebergs ) CALL icb_stp( kt, Kmm ) ! compute icebergs
! Icebergs do not melt over the haloes.
! So emp values over the haloes are no more consistent with the inner domain values.
! A lbc_lnk is therefore needed to ensure reproducibility and restartability.
! see ticket #2113 for discussion about this lbc_lnk.
- ! The lbc_lnk is also needed for SI3 with nn_hls > 1 as emp is not yet defined for these points in iceupdate.F90
- IF( (ln_icebergs .AND. .NOT. ln_passive_mode) .OR. (nn_ice == 2 .AND. nn_hls == 2) ) THEN
- CALL lbc_lnk( 'sbcmod', emp, 'T', 1.0_wp )
- ENDIF
-
- IF( ln_rnf ) CALL sbc_rnf( kt ) ! add runoffs to fresh water fluxes
+!!$ IF( ln_icebergs .AND. .NOT. ln_passive_mode ) CALL lbc_lnk( 'sbcmod', emp, 'T', 1.0_wp )
+ !clem: not needed anymore since lbc is done afterwards
+
+ IF( ln_rnf ) CALL sbc_rnf( kt ) ! add runoffs to fresh water fluxes
IF( ln_ssr ) CALL sbc_ssr( kt ) ! add SST/SSS damping term
@@ -506,33 +515,49 @@ CONTAINS
! Should not be run if ln_diurnal_only
IF( l_sbc_clo ) CALL sbc_clo( kt )
-!!$!RBbug do not understand why see ticket 667
-!!$!clem: it looks like it is necessary for the north fold (in certain circumstances). Don't know why.
-!!$ CALL lbc_lnk( 'sbcmod', emp, 'T', 1.0_wp )
IF( ll_wd ) THEN ! If near WAD point limit the flux for now
zthscl = atanh(rn_wd_sbcfra) ! taper frac default is .999
- zwdht(:,:) = ssh(:,:,Kmm) + ht_0(:,:) - rn_wdmin1 ! do this calc of water
- ! depth above wd limit once
- WHERE( zwdht(:,:) <= 0.0 )
- taum(:,:) = 0.0
- utau(:,:) = 0.0
- vtau(:,:) = 0.0
- qns (:,:) = 0.0
- qsr (:,:) = 0.0
- emp (:,:) = min(emp(:,:),0.0) !can allow puddles to grow but not shrink
- sfx (:,:) = 0.0
- END WHERE
- zwght(:,:) = tanh(zthscl*zwdht(:,:))
- WHERE( zwdht(:,:) > 0.0 .and. zwdht(:,:) < rn_wd_sbcdep ) ! 5 m hard limit here is arbitrary
- qsr (:,:) = qsr(:,:) * zwght(:,:)
- qns (:,:) = qns(:,:) * zwght(:,:)
- taum (:,:) = taum(:,:) * zwght(:,:)
- utau (:,:) = utau(:,:) * zwght(:,:)
- vtau (:,:) = vtau(:,:) * zwght(:,:)
- sfx (:,:) = sfx(:,:) * zwght(:,:)
- emp (:,:) = emp(:,:) * zwght(:,:)
- END WHERE
+ DO_2D( 0, 0, 0, 0 )
+ zwdht = ssh(ji,jj,Kmm) + ht_0(ji,jj) - rn_wdmin1 ! do this calc of water depth above wd limit once
+ zwght = TANH(zthscl*zwdht)
+ IF( zwdht <= 0.0 ) THEN
+ taum(ji,jj) = 0.0
+ utau(ji,jj) = 0.0
+ vtau(ji,jj) = 0.0
+ qns (ji,jj) = 0.0
+ qsr (ji,jj) = 0.0
+ emp (ji,jj) = MIN(emp(ji,jj),0.0) !can allow puddles to grow but not shrink
+ sfx (ji,jj) = 0.0
+ ELSEIF( zwdht > 0.0 .AND. zwdht < rn_wd_sbcdep ) THEN ! 5 m hard limit here is arbitrary
+ qsr (ji,jj) = qsr(ji,jj) * zwght
+ qns (ji,jj) = qns(ji,jj) * zwght
+ taum (ji,jj) = taum(ji,jj) * zwght
+ utau (ji,jj) = utau(ji,jj) * zwght
+ vtau (ji,jj) = vtau(ji,jj) * zwght
+ sfx (ji,jj) = sfx(ji,jj) * zwght
+ emp (ji,jj) = emp(ji,jj) * zwght
+ ENDIF
+ END_2D
+ ENDIF
+
+ ! clem: these should be the only fields that are needed over the entire domain
+ ! (in addition to snwice_mass)
+ IF( ln_rnf ) THEN
+ CALL lbc_lnk( 'sbcmod', utau, 'T', -1.0_wp, vtau , 'T', -1.0_wp, emp, 'T', 1.0_wp, &
+ & rnf , 'T', 1.0_wp )
+ ELSE
+ CALL lbc_lnk( 'sbcmod', utau, 'T', -1.0_wp, vtau , 'T', -1.0_wp, emp, 'T', 1.0_wp )
ENDIF
+ ! --- calculate utau and vtau on U,V-points --- !
+ ! Note the use of 0.5*(2-umask) in order to unmask the stress along coastlines
+ ! and the use of MAX(tmask(i,j),tmask(i+1,j) is to mask tau over ice shelves
+ DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 )
+ utauU (ji,jj) = 0.5_wp * ( utau(ji,jj) + utau(ji+1,jj) ) * &
+ & ( 2. - umask(ji,jj,1) ) * MAX( tmask(ji,jj,1), tmask(ji+1,jj,1) )
+ vtauV (ji,jj) = 0.5_wp * ( vtau(ji,jj) + vtau(ji,jj+1) ) * &
+ & ( 2. - vmask(ji,jj,1) ) * MAX( tmask(ji,jj,1), tmask(ji,jj+1,1) )
+ END_2D
+ IF( nn_hls == 1 ) CALL lbc_lnk( 'sbcmod', utauU, 'U', -1.0_wp, vtauV, 'V', -1.0_wp )
!
IF( kt == nit000 ) THEN ! set the forcing field at nit000 - 1 !
! ! ---------------------------------------- !
@@ -542,27 +567,28 @@ CONTAINS
IF( ln_rstart .AND. .NOT.l_1st_euler ) THEN !* MLF: Restart: read in restart file
#endif
IF(lwp) WRITE(numout,*) ' nit000-1 surface forcing fields read in the restart file'
- CALL iom_get( numror, jpdom_auto, 'utau_b', utau_b ) ! i-stress
- CALL iom_get( numror, jpdom_auto, 'vtau_b', vtau_b ) ! j-stress
- CALL iom_get( numror, jpdom_auto, 'qns_b', qns_b ) ! non solar heat flux
- CALL iom_get( numror, jpdom_auto, 'emp_b', emp_b ) ! freshwater flux
+ CALL iom_get( numror, jpdom_auto, 'utau_b', utau_b, cd_type = 'U', psgn = -1._wp ) ! i-stress
+ CALL iom_get( numror, jpdom_auto, 'vtau_b', vtau_b, cd_type = 'V', psgn = -1._wp ) ! j-stress
+ CALL iom_get( numror, jpdom_auto, 'qns_b', qns_b, cd_type = 'T', psgn = 1._wp ) ! non solar heat flux
+ CALL iom_get( numror, jpdom_auto, 'emp_b', emp_b, cd_type = 'T', psgn = 1._wp ) ! freshwater flux
! NB: The 3D heat content due to qsr forcing (qsr_hc_b) is treated in traqsr
! To ensure restart capability with 3.3x/3.4 restart files !! to be removed in v3.6
IF( iom_varid( numror, 'sfx_b', ldstop = .FALSE. ) > 0 ) THEN
- CALL iom_get( numror, jpdom_auto, 'sfx_b', sfx_b ) ! before salt flux (T-point)
+ CALL iom_get( numror, jpdom_auto, 'sfx_b', sfx_b, cd_type = 'T', psgn = 1._wp ) ! before salt flux (T-point)
ELSE
sfx_b (:,:) = sfx(:,:)
ENDIF
ELSE !* no restart: set from nit000 values
IF(lwp) WRITE(numout,*) ' nit000-1 surface forcing fields set to nit000'
- utau_b(:,:) = utau(:,:)
- vtau_b(:,:) = vtau(:,:)
+ utau_b(:,:) = utauU(:,:)
+ vtau_b(:,:) = vtauV(:,:)
qns_b (:,:) = qns (:,:)
emp_b (:,:) = emp (:,:)
sfx_b (:,:) = sfx (:,:)
ENDIF
ENDIF
!
+ !
#if defined key_RK3
! ! ---------------------------------------- !
IF( lrst_oce .AND. lk_SWE ) THEN ! RK3: Write in the ocean restart file !
@@ -577,41 +603,26 @@ CONTAINS
IF(lwp) WRITE(numout,*) 'sbc : ocean surface forcing fields written in ocean restart file ', &
& 'at it= ', kt,' date= ', ndastp
IF(lwp) WRITE(numout,*) '~~~~'
- CALL iom_rstput( kt, nitrst, numrow, 'utau_b' , utau )
- CALL iom_rstput( kt, nitrst, numrow, 'vtau_b' , vtau )
- CALL iom_rstput( kt, nitrst, numrow, 'qns_b' , qns )
+ CALL iom_rstput( kt, nitrst, numrow, 'utau_b' , utauU )
+ CALL iom_rstput( kt, nitrst, numrow, 'vtau_b' , vtauV )
+ CALL iom_rstput( kt, nitrst, numrow, 'qns_b' , qns )
! The 3D heat content due to qsr forcing is treated in traqsr
! CALL iom_rstput( kt, nitrst, numrow, 'qsr_b' , qsr )
- CALL iom_rstput( kt, nitrst, numrow, 'emp_b' , emp )
- CALL iom_rstput( kt, nitrst, numrow, 'sfx_b' , sfx )
+ CALL iom_rstput( kt, nitrst, numrow, 'emp_b' , emp )
+ CALL iom_rstput( kt, nitrst, numrow, 'sfx_b' , sfx )
ENDIF
! ! ---------------------------------------- !
! ! Outputs and control print !
! ! ---------------------------------------- !
IF( MOD( kt-1, nn_fsbc ) == 0 ) THEN
- IF( iom_use("empmr") ) THEN
- DO_2D( 0, 0, 0, 0 )
- z2d(ji,jj) = emp(ji,jj) - rnf(ji,jj)
- END_2D
- CALL iom_put( "empmr" , z2d ) ! upward water flux
- ENDIF
- IF( iom_use("empbmr") ) THEN
- DO_2D( 0, 0, 0, 0 )
- z2d(ji,jj) = emp_b(ji,jj) - rnf(ji,jj)
- END_2D
- CALL iom_put( "empbmr" , z2d ) ! before upward water flux ( needed to recalculate the time evolution of ssh in offline )
- ENDIF
- CALL iom_put( "saltflx", sfx ) ! downward salt flux (includes virtual salt flux beneath ice in linear free surface case)
- CALL iom_put( "fmmflx" , fmmflx ) ! Freezing-melting water flux
- IF( iom_use("qt") ) THEN
- DO_2D( 0, 0, 0, 0 )
- z2d(ji,jj) = qns(ji,jj) + qsr(ji,jj)
- END_2D
- CALL iom_put( "qt" , z2d ) ! total heat flux
- ENDIF
+ CALL iom_put( "empmr" , emp(A2D(0))-rnf(A2D(0)) ) ! upward water flux
+ CALL iom_put( "empbmr" , emp_b(A2D(0))-rnf(A2D(0)) ) ! before upward water flux (for ssh in offline )
+ CALL iom_put( "saltflx", sfx ) ! downward salt flux
+ CALL iom_put( "fwfice" , fwfice ) ! ice-ocean freshwater flux
+ CALL iom_put( "qt" , qns+qsr ) ! total heat flux
CALL iom_put( "qns" , qns ) ! solar heat flux
CALL iom_put( "qsr" , qsr ) ! solar heat flux
- IF( nn_ice > 0 .OR. ll_opa ) CALL iom_put( "ice_cover", fr_i ) ! ice fraction
+ IF( nn_ice > 0 .OR. ll_opa ) CALL iom_put( "ice_cover", fr_i(:,:) ) ! ice fraction
CALL iom_put( "taum" , taum ) ! wind stress module
CALL iom_put( "wspd" , wndm ) ! wind speed module over free ocean or leads in presence of sea-ice
CALL iom_put( "qrp" , qrp ) ! heat flux damping
@@ -621,14 +632,14 @@ CONTAINS
IF(sn_cfctl%l_prtctl) THEN ! print mean trends (used for debugging)
CALL prt_ctl(tab2d_1=fr_i , clinfo1=' fr_i - : ', mask1=tmask )
CALL prt_ctl(tab2d_1=(emp-rnf) , clinfo1=' emp-rnf - : ', mask1=tmask )
- CALL prt_ctl(tab2d_1=(sfx-rnf) , clinfo1=' sfx-rnf - : ', mask1=tmask )
+ CALL prt_ctl(tab2d_1=(sfx-rnf(A2D(0))) , clinfo1=' sfx-rnf - : ', mask1=tmask )
CALL prt_ctl(tab2d_1=qns , clinfo1=' qns - : ', mask1=tmask )
CALL prt_ctl(tab2d_1=qsr , clinfo1=' qsr - : ', mask1=tmask )
CALL prt_ctl(tab3d_1=tmask , clinfo1=' tmask - : ', mask1=tmask, kdim=jpk )
- CALL prt_ctl(tab3d_1=ts(:,:,:,jp_tem,Kmm), clinfo1=' sst - : ', mask1=tmask, kdim=1 )
- CALL prt_ctl(tab3d_1=ts(:,:,:,jp_sal,Kmm), clinfo1=' sss - : ', mask1=tmask, kdim=1 )
- CALL prt_ctl(tab2d_1=utau , clinfo1=' utau - : ', mask1=umask, &
- & tab2d_2=vtau , clinfo2=' vtau - : ', mask2=vmask )
+ CALL prt_ctl(tab2d_1=sst_m , clinfo1=' sst - : ', mask1=tmask )
+ CALL prt_ctl(tab2d_1=sss_m , clinfo1=' sss - : ', mask1=tmask )
+ CALL prt_ctl(tab2d_1=utau , clinfo1=' utau - : ', mask1=tmask, &
+ & tab2d_2=vtau , clinfo2=' vtau - : ', mask2=tmask )
ENDIF
IF( kt == nitend ) CALL sbc_final ! Close down surface module if necessary
diff --git a/src/OCE/SBC/sbcrnf.F90 b/src/OCE/SBC/sbcrnf.F90
index 758d4f4ba0c3038309ca5c2a251381b8e3ff438a..4ceb8bcade5895befe7fcebfd90f62169b685d75 100644
--- a/src/OCE/SBC/sbcrnf.F90
+++ b/src/OCE/SBC/sbcrnf.F90
@@ -83,9 +83,9 @@ CONTAINS
!!----------------------------------------------------------------------
!! *** ROUTINE sbc_rnf_alloc ***
!!----------------------------------------------------------------------
- ALLOCATE( rnfmsk(jpi,jpj) , rnfmsk_z(jpk) , &
- & h_rnf (jpi,jpj) , nk_rnf (jpi,jpj) , &
- & rnf_tsc_b(jpi,jpj,jpts) , rnf_tsc (jpi,jpj,jpts) , STAT=sbc_rnf_alloc )
+ ALLOCATE( rnfmsk(jpi,jpj) , rnfmsk_z(jpk) , & ! needed over the whole domain by muscl (traadv_muscl)
+ & h_rnf (A2D(0)) , nk_rnf (A2D(0)) , &
+ & rnf_tsc_b(A2D(0),jpts) , rnf_tsc (A2D(0),jpts) , STAT=sbc_rnf_alloc )
!
CALL mpp_sum ( 'sbcrnf', sbc_rnf_alloc )
IF( sbc_rnf_alloc > 0 ) CALL ctl_warn('sbc_rnf_alloc: allocation of arrays failed')
@@ -109,8 +109,6 @@ CONTAINS
INTEGER :: ji, jj ! dummy loop indices
INTEGER :: z_err = 0 ! dummy integer for error handling
!!----------------------------------------------------------------------
- REAL(wp), DIMENSION(jpi,jpj) :: ztfrz ! freezing point used for temperature correction
- !
!
! !-------------------!
! ! Update runoff !
@@ -118,8 +116,8 @@ CONTAINS
!
!
IF( .NOT. l_rnfcpl ) THEN
- CALL fld_read ( kt, nn_fsbc, sf_rnf ) ! Read Runoffs data and provide it at kt ( runoffs + iceberg )
- IF( ln_rnf_icb ) CALL fld_read ( kt, nn_fsbc, sf_i_rnf ) ! idem for iceberg flux if required
+ CALL fld_read ( kt, nn_fsbc, sf_rnf ) ! Read Runoffs data and provide it at kt ( runoffs + iceberg )
+ IF( ln_rnf_icb ) CALL fld_read ( kt, nn_fsbc, sf_i_rnf ) ! idem for iceberg flux if required
ENDIF
IF( ln_rnf_tem ) CALL fld_read ( kt, nn_fsbc, sf_t_rnf ) ! idem for runoffs temperature if required
IF( ln_rnf_sal ) CALL fld_read ( kt, nn_fsbc, sf_s_rnf ) ! idem for runoffs salinity if required
@@ -127,10 +125,10 @@ CONTAINS
IF( MOD( kt - 1, nn_fsbc ) == 0 ) THEN
!
IF( .NOT. l_rnfcpl ) THEN
- rnf(:,:) = rn_rfact * ( sf_rnf(1)%fnow(:,:,1) ) * tmask(:,:,1) ! updated runoff value at time step kt
+ rnf(A2D(0)) = rn_rfact * ( sf_rnf(1)%fnow(:,:,1) ) * smask0(:,:) ! updated runoff value at time step kt
IF( ln_rnf_icb ) THEN
- fwficb(:,:) = rn_rfact * ( sf_i_rnf(1)%fnow(:,:,1) ) * tmask(:,:,1) ! updated runoff value at time step kt
- rnf(:,:) = rnf(:,:) + fwficb(:,:)
+ fwficb(:,:) = rn_rfact * ( sf_i_rnf(1)%fnow(:,:,1) ) * smask0(:,:) ! updated runoff value at time step kt
+ rnf(A2D(0)) = rnf(A2D(0)) + fwficb(:,:)
qns(:,:) = qns(:,:) - fwficb(:,:) * rLfus
!!qns_tot(:,:) = qns_tot(:,:) - fwficb(:,:) * rLfus
!!qns_oce(:,:) = qns_oce(:,:) - fwficb(:,:) * rLfus
@@ -141,17 +139,16 @@ CONTAINS
!
! ! set temperature & salinity content of runoffs
IF( ln_rnf_tem ) THEN ! use runoffs temperature data
- rnf_tsc(:,:,jp_tem) = ( sf_t_rnf(1)%fnow(:,:,1) ) * rnf(:,:) * r1_rho0
- CALL eos_fzp( sss_m(:,:), ztfrz(:,:) )
+ rnf_tsc(:,:,jp_tem) = ( sf_t_rnf(1)%fnow(:,:,1) ) * rnf(A2D(0)) * r1_rho0
WHERE( sf_t_rnf(1)%fnow(:,:,1) == -999._wp ) ! if missing data value use SST as runoffs temperature
- rnf_tsc(:,:,jp_tem) = sst_m(:,:) * rnf(:,:) * r1_rho0
+ rnf_tsc(:,:,jp_tem) = sst_m(A2D(0)) * rnf(A2D(0)) * r1_rho0
END WHERE
ELSE ! use SST as runoffs temperature
!CEOD River is fresh water so must at least be 0 unless we consider ice
- rnf_tsc(:,:,jp_tem) = MAX( sst_m(:,:), 0.0_wp ) * rnf(:,:) * r1_rho0
+ rnf_tsc(:,:,jp_tem) = MAX( sst_m(A2D(0)), 0.0_wp ) * rnf(A2D(0)) * r1_rho0
ENDIF
! ! use runoffs salinity data
- IF( ln_rnf_sal ) rnf_tsc(:,:,jp_sal) = ( sf_s_rnf(1)%fnow(:,:,1) ) * rnf(:,:) * r1_rho0
+ IF( ln_rnf_sal ) rnf_tsc(:,:,jp_sal) = ( sf_s_rnf(1)%fnow(:,:,1) ) * rnf(A2D(0)) * r1_rho0
! ! else use S=0 for runoffs (done one for all in the init)
CALL iom_put( 'runoffs' , rnf(:,:) ) ! output runoff mass flux
IF( iom_use('hflx_rnf_cea') ) CALL iom_put( 'hflx_rnf_cea', rnf_tsc(:,:,jp_tem) * rho0 * rcp ) ! output runoff sensible heat (W/m2)
@@ -168,13 +165,15 @@ CONTAINS
CALL iom_get( numror, jpdom_auto, 'rnf_sc_b', rnf_tsc_b(:,:,jp_sal) ) ! before salinity content of runoff
ELSE !* no restart: set from nit000 values
IF(lwp) WRITE(numout,*) ' nit000-1 runoff forcing fields set to nit000'
- rnf_b (:,: ) = rnf (:,: )
- rnf_tsc_b(:,:,:) = rnf_tsc(:,:,:)
+ CALL lbc_lnk( 'sbcrnf', rnf, 'T', 1.0_wp )
+ rnf_b (:,:) = rnf (:,:)
+ rnf_tsc_b(:,:,:) = rnf_tsc(:,:,:)
ENDIF
ENDIF
! ! ---------------------------------------- !
IF( lrst_oce ) THEN ! Write in the ocean restart file !
! ! ---------------------------------------- !
+ !
IF(lwp) WRITE(numout,*)
IF(lwp) WRITE(numout,*) 'sbcrnf : runoff forcing fields written in ocean restart file ', &
& 'at it= ', kt,' date= ', ndastp
@@ -210,7 +209,7 @@ CONTAINS
!
IF( ln_rnf_depth .OR. ln_rnf_depth_ini ) THEN !== runoff distributed over several levels ==!
IF( ln_linssh ) THEN !* constant volume case : just apply the runoff input flow
- DO_2D_OVR( nn_hls-1, nn_hls, nn_hls-1, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
DO jk = 1, nk_rnf(ji,jj)
#if defined key_RK3
phdivn(ji,jj,jk) = phdivn(ji,jj,jk) - rnf(ji,jj) * r1_rho0 / h_rnf(ji,jj) ! RK3: rnf forcing at n+1/2
@@ -220,14 +219,10 @@ CONTAINS
END DO
END_2D
ELSE !* variable volume case
- DO_2D_OVR( nn_hls, nn_hls, nn_hls, nn_hls ) ! update the depth over which runoffs are distributed
+ DO_2D( 0, 0, 0, 0 ) ! update the depth over which runoffs are distributed
h_rnf(ji,jj) = 0._wp
- DO jk = 1, nk_rnf(ji,jj) ! recalculates h_rnf to be the depth in metres
- h_rnf(ji,jj) = h_rnf(ji,jj) + e3t(ji,jj,jk,Kmm) ! to the bottom of the relevant grid box
- END DO
- END_2D
- DO_2D_OVR( nn_hls-1, nn_hls, nn_hls-1, nn_hls ) ! apply the runoff input flow
DO jk = 1, nk_rnf(ji,jj)
+ h_rnf(ji,jj) = h_rnf(ji,jj) + e3t(ji,jj,jk,Kmm) ! recalculates h_rnf to be the depth in metres to the bottom of the relevant grid box
#if defined key_RK3
phdivn(ji,jj,jk) = phdivn(ji,jj,jk) - rnf(ji,jj) * r1_rho0 / h_rnf(ji,jj) ! RK3: rnf forcing at n+1/2
#else
@@ -237,10 +232,8 @@ CONTAINS
END_2D
ENDIF
ELSE !== runoff put only at the surface ==!
- DO_2D_OVR( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
h_rnf (ji,jj) = e3t(ji,jj,1,Kmm) ! update h_rnf to be depth of top box
- END_2D
- DO_2D_OVR( nn_hls-1, nn_hls, nn_hls-1, nn_hls )
#if defined key_RK3
phdivn(ji,jj,1) = phdivn(ji,jj,1) - rnf(ji,jj) * r1_rho0 / e3t(ji,jj,1,Kmm) ! RK3: rnf forcing at n+1/2
#else
@@ -269,7 +262,7 @@ CONTAINS
INTEGER :: ios ! Local integer output status for namelist read
INTEGER :: nbrec ! temporary integer
REAL(wp) :: zacoef
- REAL(wp), DIMENSION(jpi,jpj,2) :: zrnfcl
+ REAL(wp), DIMENSION(A2D(0),2) :: zrnfcl
!!
NAMELIST/namsbc_rnf/ cn_dir , ln_rnf_depth, ln_rnf_tem, ln_rnf_sal, ln_rnf_icb, &
& sn_rnf, sn_cnf , sn_i_rnf, sn_s_rnf , sn_t_rnf , sn_dep_rnf, &
@@ -323,8 +316,8 @@ CONTAINS
IF( ierror > 0 ) THEN
CALL ctl_stop( 'sbc_rnf_init: unable to allocate sf_rnf structure' ) ; RETURN
ENDIF
- ALLOCATE( sf_rnf(1)%fnow(jpi,jpj,1) )
- IF( sn_rnf%ln_tint ) ALLOCATE( sf_rnf(1)%fdta(jpi,jpj,1,2) )
+ ALLOCATE( sf_rnf(1)%fnow(A2D(0),1) )
+ IF( sn_rnf%ln_tint ) ALLOCATE( sf_rnf(1)%fdta(A2D(0),1,2) )
CALL fld_fill( sf_rnf, (/ sn_rnf /), cn_dir, 'sbc_rnf_init', 'read runoffs data', 'namsbc_rnf', no_print )
!
IF( ln_rnf_icb ) THEN ! Create (if required) sf_i_rnf structure
@@ -334,11 +327,13 @@ CONTAINS
IF( ierror > 0 ) THEN
CALL ctl_stop( 'sbc_rnf_init: unable to allocate sf_i_rnf structure' ) ; RETURN
ENDIF
- ALLOCATE( sf_i_rnf(1)%fnow(jpi,jpj,1) )
- IF( sn_i_rnf%ln_tint ) ALLOCATE( sf_i_rnf(1)%fdta(jpi,jpj,1,2) )
+ ALLOCATE( sf_i_rnf(1)%fnow(A2D(0),1) )
+ IF( sn_i_rnf%ln_tint ) ALLOCATE( sf_i_rnf(1)%fdta(A2D(0),1,2) )
CALL fld_fill (sf_i_rnf, (/ sn_i_rnf /), cn_dir, 'sbc_rnf_init', 'read iceberg flux data', 'namsbc_rnf' )
ELSE
- fwficb(:,:) = 0._wp
+ DO_2D( 0, 0, 0, 0 )
+ fwficb(ji,jj) = 0._wp
+ END_2D
ENDIF
ENDIF
@@ -350,8 +345,8 @@ CONTAINS
IF( ierror > 0 ) THEN
CALL ctl_stop( 'sbc_rnf_init: unable to allocate sf_t_rnf structure' ) ; RETURN
ENDIF
- ALLOCATE( sf_t_rnf(1)%fnow(jpi,jpj,1) )
- IF( sn_t_rnf%ln_tint ) ALLOCATE( sf_t_rnf(1)%fdta(jpi,jpj,1,2) )
+ ALLOCATE( sf_t_rnf(1)%fnow(A2D(0),1) )
+ IF( sn_t_rnf%ln_tint ) ALLOCATE( sf_t_rnf(1)%fdta(A2D(0),1,2) )
CALL fld_fill (sf_t_rnf, (/ sn_t_rnf /), cn_dir, 'sbc_rnf_init', 'read runoff temperature data', 'namsbc_rnf', no_print )
ENDIF
!
@@ -362,8 +357,8 @@ CONTAINS
IF( ierror > 0 ) THEN
CALL ctl_stop( 'sbc_rnf_init: unable to allocate sf_s_rnf structure' ) ; RETURN
ENDIF
- ALLOCATE( sf_s_rnf(1)%fnow(jpi,jpj,1) )
- IF( sn_s_rnf%ln_tint ) ALLOCATE( sf_s_rnf(1)%fdta(jpi,jpj,1,2) )
+ ALLOCATE( sf_s_rnf(1)%fnow(A2D(0),1) )
+ IF( sn_s_rnf%ln_tint ) ALLOCATE( sf_s_rnf(1)%fdta(A2D(0),1,2) )
CALL fld_fill (sf_s_rnf, (/ sn_s_rnf /), cn_dir, 'sbc_rnf_init', 'read runoff salinity data', 'namsbc_rnf', no_print )
ENDIF
!
@@ -378,8 +373,7 @@ CONTAINS
CALL iom_get ( inum, jpdom_global, sn_dep_rnf%clvar, h_rnf, kfill = jpfillcopy ) ! read the river mouth. no 0 on halos!
CALL iom_close( inum ) ! close file
!
- nk_rnf(:,:) = 0 ! set the number of level over which river runoffs are applied
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 ) ! set the number of level over which river runoffs are applied
IF( h_rnf(ji,jj) > 0._wp ) THEN
jk = 2
DO WHILE ( jk < mbkt(ji,jj) .AND. gdept_0(ji,jj,jk) < h_rnf(ji,jj) ) ; jk = jk + 1
@@ -392,7 +386,8 @@ CONTAINS
WRITE(999,*) 'ji, jj, h_rnf(ji,jj) :', ji, jj, h_rnf(ji,jj)
ENDIF
END_2D
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) ! set the associated depth
+ !
+ DO_2D( 0, 0, 0, 0 ) ! set the associated depth
h_rnf(ji,jj) = 0._wp
DO jk = 1, nk_rnf(ji,jj)
h_rnf(ji,jj) = h_rnf(ji,jj) + e3t(ji,jj,jk,Kmm)
@@ -407,7 +402,7 @@ CONTAINS
IF(lwp) WRITE(numout,*) ' depth over which runoffs is spread rn_dep_max = ', rn_dep_max
IF(lwp) WRITE(numout,*) ' create (=1) a runoff depth file or not (=0) nn_rnf_depth_file = ', nn_rnf_depth_file
- CALL iom_open( TRIM( sn_rnf%clname ), inum ) ! open runoff file
+ CALL iom_open( TRIM( sn_rnf%clname ), inum ) ! open runoff file
nbrec = iom_getszuld( inum )
zrnfcl(:,:,1) = 0._wp ! init the max to 0. in 1
DO jm = 1, nbrec
@@ -416,21 +411,20 @@ CONTAINS
END DO
CALL iom_close( inum )
!
- h_rnf(:,:) = 1.
- !
- zacoef = rn_dep_max / rn_rnf_max ! coef of linear relation between runoff and its depth (150m for max of runoff)
+ zacoef = rn_dep_max / rn_rnf_max ! coef of linear relation between runoff and its depth (150m for max of runoff)
!
- WHERE( zrnfcl(:,:,1) > 0._wp ) h_rnf(:,:) = zacoef * zrnfcl(:,:,1) ! compute depth for all runoffs
+ WHERE( zrnfcl(:,:,1) > 0._wp ) ; h_rnf(:,:) = zacoef * zrnfcl(:,:,1) ! compute depth for all runoffs
+ ELSEWHERE ; h_rnf(:,:) = 1._wp
+ ENDWHERE
!
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) ! take in account min depth of ocean rn_hmin
+ DO_2D( 0, 0, 0, 0 ) ! take in account min depth of ocean rn_hmin
IF( zrnfcl(ji,jj,1) > 0._wp ) THEN
jk = mbkt(ji,jj)
h_rnf(ji,jj) = MIN( h_rnf(ji,jj), gdept_0(ji,jj,jk ) )
ENDIF
END_2D
!
- nk_rnf(:,:) = 0 ! number of levels on which runoffs are distributed
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 ) ! number of levels on which runoffs are distributed
IF( zrnfcl(ji,jj,1) > 0._wp ) THEN
jk = 2
DO WHILE ( jk < mbkt(ji,jj) .AND. gdept_0(ji,jj,jk) < h_rnf(ji,jj) ) ; jk = jk + 1
@@ -441,27 +435,33 @@ CONTAINS
ENDIF
END_2D
!
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) ! set the associated depth
+ DO_2D( 0, 0, 0, 0 ) ! set the associated depth
h_rnf(ji,jj) = 0._wp
DO jk = 1, nk_rnf(ji,jj)
h_rnf(ji,jj) = h_rnf(ji,jj) + e3t(ji,jj,jk,Kmm)
END DO
END_2D
!
- IF( nn_rnf_depth_file == 1 ) THEN ! save output nb levels for runoff
+ IF( nn_rnf_depth_file == 1 ) THEN ! save output nb levels for runoff
IF(lwp) WRITE(numout,*) ' ==>>> create runoff depht file'
CALL iom_open ( TRIM( sn_dep_rnf%clname ), inum, ldwrt = .TRUE. )
CALL iom_rstput( 0, 0, inum, 'rodepth', h_rnf )
CALL iom_close ( inum )
ENDIF
- ELSE ! runoffs applied at the surface
- nk_rnf(:,:) = 1
- h_rnf (:,:) = e3t(:,:,1,Kmm)
+ ELSE ! runoffs applied at the surface
+ DO_2D( 0, 0, 0, 0 )
+ nk_rnf(ji,jj) = 1
+ h_rnf (ji,jj) = e3t(ji,jj,1,Kmm)
+ END_2D
ENDIF
!
- rnf(:,:) = 0._wp ! runoff initialisation
- rnf_tsc(:,:,:) = 0._wp ! runoffs temperature & salinty contents initilisation
- !
+ DO_2D( 0, 0, 0, 0 )
+ rnf(ji,jj) = 0._wp ! runoff initialisation
+ END_2D
+ DO_3D( 0, 0, 0, 0, 1, jpts )
+ rnf_tsc(ji,jj,jk) = 0._wp ! runoffs temperature & salinty contents initilisation
+ END_3D
+ !
! ! ========================
! ! River mouth vicinity
! ! ========================
@@ -479,7 +479,7 @@ CONTAINS
nkrnf = 2
DO WHILE( nkrnf /= jpkm1 .AND. gdepw_1d(nkrnf+1) < rn_hrnf ) ; nkrnf = nkrnf + 1
END DO
- IF( ln_sco ) CALL ctl_warn( 'sbc_rnf_init: number of levels over which Kz is increased is computed for zco...' )
+ IF( l_sco ) CALL ctl_warn( 'sbc_rnf_init: number of levels over which Kz is increased is computed for zco...' )
ENDIF
IF(lwp) WRITE(numout,*)
IF(lwp) WRITE(numout,*) ' ==>>> Specific treatment used in vicinity of river mouths :'
@@ -493,11 +493,13 @@ CONTAINS
ELSE ! No treatment at river mouths
IF(lwp) WRITE(numout,*)
IF(lwp) WRITE(numout,*) ' ==>>> No specific treatment at river mouths'
- rnfmsk (:,:) = 0._wp
+ DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ rnfmsk(ji,jj) = 0._wp
+ END_2D
rnfmsk_z(:) = 0._wp
nkrnf = 0
ENDIF
- !
+ !
END SUBROUTINE sbc_rnf_init
@@ -535,9 +537,9 @@ CONTAINS
ENDIF
!
! horizontal mask (read in NetCDF file)
- CALL iom_open ( cl_rnfile, inum ) ! open file
- CALL iom_get ( inum, jpdom_global, sn_cnf%clvar, rnfmsk ) ! read the river mouth array
- CALL iom_close( inum ) ! close file
+ CALL iom_open ( cl_rnfile, inum ) ! open file
+ CALL iom_get ( inum, jpdom_global, sn_cnf%clvar, rnfmsk(A2D(0)) ) ! read the river mouth array
+ CALL iom_close( inum ) ! close file
!
IF( l_clo_rnf ) CALL clo_rnf( rnfmsk ) ! closed sea inflow set as river mouth
!
@@ -548,6 +550,8 @@ CONTAINS
rnfmsk_z(4) = 0.25 ! **********
rnfmsk_z(5) = 0.125
!
+ CALL lbc_lnk( 'rnf_mouth', rnfmsk, 'T', 1._wp ) ! needed by muscl scheme (traadv_muscl)
+ !
END SUBROUTINE rnf_mouth
!!======================================================================
diff --git a/src/OCE/SBC/sbcssm.F90 b/src/OCE/SBC/sbcssm.F90
index 1db7fb00a76649dbac077eb4d7e9f56a6c78a676..e00f4d24decc87737953fb27d010032577bb1942 100644
--- a/src/OCE/SBC/sbcssm.F90
+++ b/src/OCE/SBC/sbcssm.F90
@@ -31,6 +31,7 @@ MODULE sbcssm
LOGICAL, SAVE :: l_ssm_mean = .FALSE. ! keep track of whether means have been read from restart file
+# include "do_loop_substitute.h90"
# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
@@ -58,6 +59,7 @@ CONTAINS
INTEGER :: ji, jj ! loop index
REAL(wp) :: zcoef, zf_sbc ! local scalar
REAL(wp), DIMENSION(jpi,jpj,jpts) :: zts
+ REAL(wp), DIMENSION(:,:), ALLOCATABLE :: ztc ! Working array for conservative temperature calculation
!!---------------------------------------------------------------------
!
! !* surface T-, U-, V- ocean level variables (T, S, depth, velocity)
@@ -74,7 +76,7 @@ CONTAINS
! ! ---------------------------------------- !
ssu_m(:,:) = uu(:,:,1,Kbb)
ssv_m(:,:) = vv(:,:,1,Kbb)
- IF( l_useCT ) THEN ; sst_m(:,:) = eos_pt_from_ct( zts(:,:,jp_tem), zts(:,:,jp_sal) )
+ IF( l_useCT ) THEN ; CALL eos_pt_from_ct( zts(:,:,jp_tem), zts(:,:,jp_sal), sst_m(:,:) )
ELSE ; sst_m(:,:) = zts(:,:,jp_tem)
ENDIF
sss_m(:,:) = zts(:,:,jp_sal)
@@ -92,6 +94,8 @@ CONTAINS
frq_m(:,:) = fraqsr_1lev(:,:)
!
ELSE
+ IF( l_useCT ) ALLOCATE( ztc(A2D(nn_hls)) )
+ !
! ! ----------------------------------------------- !
IF( kt == nit000 .AND. .NOT. l_ssm_mean ) THEN ! Initialisation: 1st time-step, no input means !
! ! ----------------------------------------------- !
@@ -101,8 +105,11 @@ CONTAINS
zcoef = REAL( nn_fsbc - 1, wp )
ssu_m(:,:) = zcoef * uu(:,:,1,Kbb)
ssv_m(:,:) = zcoef * vv(:,:,1,Kbb)
- IF( l_useCT ) THEN ; sst_m(:,:) = zcoef * eos_pt_from_ct( zts(:,:,jp_tem), zts(:,:,jp_sal) )
- ELSE ; sst_m(:,:) = zcoef * zts(:,:,jp_tem)
+ IF( l_useCT ) THEN
+ CALL eos_pt_from_ct( zts(:,:,jp_tem), zts(:,:,jp_sal), ztc(:,:) )
+ sst_m(:,:) = zcoef * ztc(:,:)
+ ELSE
+ sst_m(:,:) = zcoef * zts(:,:,jp_tem)
ENDIF
sss_m(:,:) = zcoef * zts(:,:,jp_sal)
! ! removed inverse barometer ssh when Patm forcing is used (for sea-ice dynamics)
@@ -133,8 +140,11 @@ CONTAINS
! ! ---------------------------------------- !
ssu_m(:,:) = ssu_m(:,:) + uu(:,:,1,Kbb)
ssv_m(:,:) = ssv_m(:,:) + vv(:,:,1,Kbb)
- IF( l_useCT ) THEN ; sst_m(:,:) = sst_m(:,:) + eos_pt_from_ct( zts(:,:,jp_tem), zts(:,:,jp_sal) )
- ELSE ; sst_m(:,:) = sst_m(:,:) + zts(:,:,jp_tem)
+ IF( l_useCT ) THEN
+ CALL eos_pt_from_ct( zts(:,:,jp_tem), zts(:,:,jp_sal), ztc(:,:) )
+ sst_m(:,:) = sst_m(:,:) + ztc(:,:)
+ ELSE
+ sst_m(:,:) = sst_m(:,:) + zts(:,:,jp_tem)
ENDIF
sss_m(:,:) = sss_m(:,:) + zts(:,:,jp_sal)
! ! removed inverse barometer ssh when Patm forcing is used (for sea-ice dynamics)
@@ -182,6 +192,8 @@ CONTAINS
!
ENDIF
!
+ IF( l_useCT ) DEALLOCATE( ztc )
+ !
ENDIF
!
IF( MOD( kt - 1 , nn_fsbc ) == 0 ) THEN ! Mean value at each nn_fsbc time-step !
@@ -258,7 +270,7 @@ CONTAINS
IF(lwp) WRITE(numout,*) ' default initialisation of ss._m arrays'
ssu_m(:,:) = uu(:,:,1,Kbb)
ssv_m(:,:) = vv(:,:,1,Kbb)
- IF( l_useCT ) THEN ; sst_m(:,:) = eos_pt_from_ct( ts(:,:,1,jp_tem,Kmm), ts(:,:,1,jp_sal,Kmm) )
+ IF( l_useCT ) THEN ; CALL eos_pt_from_ct( ts(:,:,1,jp_tem,Kmm), ts(:,:,1,jp_sal,Kmm), sst_m(:,:) )
ELSE ; sst_m(:,:) = ts(:,:,1,jp_tem,Kmm)
ENDIF
sss_m(:,:) = ts (:,:,1,jp_sal,Kmm)
diff --git a/src/OCE/SBC/sbcssr.F90 b/src/OCE/SBC/sbcssr.F90
index 09088c45c0e777ab2ef5e70f86db178cfa2a2470..2b607dbb95b6257935b108d45edcc1733e6b06b3 100644
--- a/src/OCE/SBC/sbcssr.F90
+++ b/src/OCE/SBC/sbcssr.F90
@@ -97,8 +97,8 @@ CONTAINS
erp(:,:) = 0._wp
!
IF( nn_sstr == 1 ) THEN !* Temperature restoring term
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
- zqrp = rn_dqdt * ( sst_m(ji,jj) - sf_sst(1)%fnow(ji,jj,1) ) * tmask(ji,jj,1)
+ DO_2D( 0, 0, 0, 0 )
+ zqrp = rn_dqdt * ( sst_m(ji,jj) - sf_sst(1)%fnow(ji,jj,1) ) * smask0(ji,jj)
qns(ji,jj) = qns(ji,jj) + zqrp
qrp(ji,jj) = zqrp
END_2D
@@ -107,7 +107,7 @@ CONTAINS
IF( nn_sssr /= 0 .AND. nn_sssr_ice /= 1 ) THEN
! use fraction of ice ( fr_i ) to adjust relaxation under ice if nn_sssr_ice .ne. 1
! n.b. coefice is initialised and fixed to 1._wp if nn_sssr_ice = 1
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
SELECT CASE ( nn_sssr_ice )
CASE ( 0 ) ; coefice(ji,jj) = 1._wp - fr_i(ji,jj) ! no/reduced damping under ice
CASE DEFAULT ; coefice(ji,jj) = 1._wp + ( nn_sssr_ice - 1 ) * fr_i(ji,jj) ! reinforced damping (x nn_sssr_ice) under ice )
@@ -117,10 +117,10 @@ CONTAINS
!
IF( nn_sssr == 1 ) THEN !* Salinity damping term (salt flux only (sfx))
zsrp = rn_deds / rday ! from [mm/day] to [kg/m2/s]
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
zerp = zsrp * ( 1. - 2.*rnfmsk(ji,jj) ) & ! No damping in vicinity of river mouths
& * coefice(ji,jj) & ! Optional control of damping under sea-ice
- & * ( sss_m(ji,jj) - sf_sss(1)%fnow(ji,jj,1) ) * tmask(ji,jj,1)
+ & * ( sss_m(ji,jj) - sf_sss(1)%fnow(ji,jj,1) ) * smask0(ji,jj)
sfx(ji,jj) = sfx(ji,jj) + zerp ! salt flux
erp(ji,jj) = zerp / MAX( sss_m(ji,jj), 1.e-20 ) ! converted into an equivalent volume flux (diagnostic only)
END_2D
@@ -128,21 +128,21 @@ CONTAINS
ELSEIF( nn_sssr == 2 ) THEN !* Salinity damping term (volume flux (emp) and associated heat flux (qns)
zsrp = rn_deds / rday ! from [mm/day] to [kg/m2/s]
zerp_bnd = rn_sssr_bnd / rday ! - -
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
zerp = zsrp * ( 1. - 2.*rnfmsk(ji,jj) ) & ! No damping in vicinity of river mouths
& * coefice(ji,jj) & ! Optional control of damping under sea-ice
& * ( sss_m(ji,jj) - sf_sss(1)%fnow(ji,jj,1) ) &
- & / MAX( sss_m(ji,jj), 1.e-20 ) * tmask(ji,jj,1)
+ & / MAX( sss_m(ji,jj), 1.e-20 ) * smask0(ji,jj)
IF( ln_sssr_bnd ) zerp = SIGN( 1.0_wp, zerp ) * MIN( zerp_bnd, ABS(zerp) )
- emp(ji,jj) = emp (ji,jj) + zerp
- qns(ji,jj) = qns(ji,jj) - zerp * rcp * sst_m(ji,jj)
erp(ji,jj) = zerp
- qrp(ji,jj) = qrp(ji,jj) - zerp * rcp * sst_m(ji,jj)
+ emp(ji,jj) = emp(ji,jj) + erp(ji,jj)
+ qns(ji,jj) = qns(ji,jj) - erp(ji,jj) * rcp * sst_m(ji,jj)
+ qrp(ji,jj) = qrp(ji,jj) - erp(ji,jj) * rcp * sst_m(ji,jj)
END_2D
ENDIF
! outputs
CALL iom_put( 'hflx_ssr_cea', qrp(:,:) )
- IF( nn_sssr == 1 ) CALL iom_put( 'sflx_ssr_cea', erp(:,:) * sss_m(:,:) )
+ IF( nn_sssr == 1 ) CALL iom_put( 'sflx_ssr_cea', erp(:,:) * sss_m(A2D(0)) )
IF( nn_sssr == 2 ) CALL iom_put( 'vflx_ssr_cea', -erp(:,:) )
!
ENDIF
@@ -207,12 +207,12 @@ CONTAINS
!
ALLOCATE( sf_sst(1), STAT=ierror )
IF( ierror > 0 ) CALL ctl_stop( 'STOP', 'sbc_ssr: unable to allocate sf_sst structure' )
- ALLOCATE( sf_sst(1)%fnow(jpi,jpj,1), STAT=ierror )
+ ALLOCATE( sf_sst(1)%fnow(A2D(0),1), STAT=ierror )
IF( ierror > 0 ) CALL ctl_stop( 'STOP', 'sbc_ssr: unable to allocate sf_sst now array' )
!
! fill sf_sst with sn_sst and control print
CALL fld_fill( sf_sst, (/ sn_sst /), cn_dir, 'sbc_ssr', 'SST restoring term toward SST data', 'namsbc_ssr', no_print )
- IF( sf_sst(1)%ln_tint ) ALLOCATE( sf_sst(1)%fdta(jpi,jpj,1,2), STAT=ierror )
+ IF( sf_sst(1)%ln_tint ) ALLOCATE( sf_sst(1)%fdta(A2D(0),1,2), STAT=ierror )
IF( ierror > 0 ) CALL ctl_stop( 'STOP', 'sbc_ssr: unable to allocate sf_sst data array' )
!
ENDIF
@@ -221,12 +221,12 @@ CONTAINS
!
ALLOCATE( sf_sss(1), STAT=ierror )
IF( ierror > 0 ) CALL ctl_stop( 'STOP', 'sbc_ssr: unable to allocate sf_sss structure' )
- ALLOCATE( sf_sss(1)%fnow(jpi,jpj,1), STAT=ierror )
+ ALLOCATE( sf_sss(1)%fnow(A2D(0),1), STAT=ierror )
IF( ierror > 0 ) CALL ctl_stop( 'STOP', 'sbc_ssr: unable to allocate sf_sss now array' )
!
! fill sf_sss with sn_sss and control print
CALL fld_fill( sf_sss, (/ sn_sss /), cn_dir, 'sbc_ssr', 'SSS restoring term toward SSS data', 'namsbc_ssr', no_print )
- IF( sf_sss(1)%ln_tint ) ALLOCATE( sf_sss(1)%fdta(jpi,jpj,1,2), STAT=ierror )
+ IF( sf_sss(1)%ln_tint ) ALLOCATE( sf_sss(1)%fdta(A2D(0),1,2), STAT=ierror )
IF( ierror > 0 ) CALL ctl_stop( 'STOP', 'sbc_ssr: unable to allocate sf_sss data array' )
!
ENDIF
@@ -244,7 +244,7 @@ CONTAINS
!!----------------------------------------------------------------------
sbc_ssr_alloc = 0 ! set to zero if no array to be allocated
IF( .NOT. ALLOCATED( erp ) ) THEN
- ALLOCATE( qrp(jpi,jpj), erp(jpi,jpj), coefice(jpi,jpj), STAT= sbc_ssr_alloc )
+ ALLOCATE( qrp(A2D(0)), erp(A2D(0)), coefice(A2D(0)), STAT= sbc_ssr_alloc )
!
IF( lk_mpp ) CALL mpp_sum ( 'sbcssr', sbc_ssr_alloc )
IF( sbc_ssr_alloc /= 0 ) CALL ctl_warn('sbc_ssr_alloc: failed to allocate arrays.')
diff --git a/src/OCE/SBC/sbcwave.F90 b/src/OCE/SBC/sbcwave.F90
index 2264938d72a9f274537fd9378d55ba6e458c38c4..2478160203fd740178f839fbd80a04a12f515ec1 100644
--- a/src/OCE/SBC/sbcwave.F90
+++ b/src/OCE/SBC/sbcwave.F90
@@ -22,7 +22,6 @@ MODULE sbcwave
USE dom_oce ! ocean domain variables
USE sbc_oce ! Surface boundary condition: ocean fields
USE bdy_oce ! open boundary condition variables
- USE domvvl ! domain: variable volume layers
USE zdf_oce, ONLY : ln_zdfswm ! Qiao wave enhanced mixing
!
USE iom ! I/O manager library
@@ -115,14 +114,13 @@ CONTAINS
INTEGER :: jj, ji, jk ! dummy loop argument
INTEGER :: ik ! local integer
REAL(wp) :: ztransp, zfac, ztemp, zsp0, zsqrt, zbreiv16_w
- REAL(wp) :: zdep_u, zdep_v, zkh_u, zkh_v, zda_u, zda_v, sdtrp
+ REAL(wp) :: zdep_u, zdep_v, zkh_u, zkh_v, zda_u, zda_v, sdtrp, zInt_w0, zInt_w1
REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: zk_t, zk_u, zk_v, zu0_sd, zv0_sd ! 2D workspace
- REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: ze3divh, zInt_w ! 3D workspace
+ REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: ze3divh ! 3D workspace
!!---------------------------------------------------------------------
!
ALLOCATE( ze3divh(jpi,jpj,jpkm1) ) ! jpkm1 -> avoid lbc_lnk on jpk that is not defined
- ALLOCATE( zInt_w(jpi,jpj,jpk) )
- ALLOCATE( zk_t(jpi,jpj), zk_u(jpi,jpj), zk_v(jpi,jpj), zu0_sd(jpi,jpj), zv0_sd(jpi,jpj) )
+ ALLOCATE( zk_t(A2D(1)), zk_u(A2D(0)), zk_v(A2D(0)), zu0_sd(A2D(1)), zv0_sd(A2D(1)) )
zk_t (:,:) = 0._wp
zk_u (:,:) = 0._wp
zk_v (:,:) = 0._wp
@@ -138,7 +136,7 @@ CONTAINS
! sdtrp is the norm of Stokes transport
!
zfac = 0.166666666667_wp
- DO_2D( 1, 1, 1, 1 ) ! In the deep-water limit we have ke = ||ust0||/( 6 * ||transport|| )
+ DO_2D( 0, 1, 0, 1 ) ! In the deep-water limit we have ke = ||ust0||/( 6 * ||transport|| )
zsp0 = SQRT( ut0sd(ji,jj)*ut0sd(ji,jj) + vt0sd(ji,jj)*vt0sd(ji,jj) ) !<-- norm of Surface Stokes drift
tsd2d(ji,jj) = zsp0
IF( cpl_tusd .AND. cpl_tvsd ) THEN !stokes transport is provided in coupled mode
@@ -150,35 +148,40 @@ CONTAINS
ENDIF
zk_t (ji,jj) = zfac * zsp0 / MAX ( sdtrp, 0.0000001_wp ) !<-- ke = ||ust0||/( 6 * ||transport|| )
END_2D
- !# define zInt_w ze3divh
- DO_3D( 1, 1, 1, 1, 1, jpk ) ! Compute the primitive of Breivik 2016 function at W-points
- zfac = - 2._wp * zk_t (ji,jj) * gdepw(ji,jj,jk,Kmm) !<-- zfac should be negative definite
- ztemp = EXP ( zfac )
- zsqrt = SQRT( -zfac )
- zbreiv16_w = ztemp - SQRT(rpi)*zsqrt*ERFC(zsqrt) !Eq. 16 Breivik 2016
- zInt_w(ji,jj,jk) = ztemp - 4._wp * zk_t (ji,jj) * gdepw(ji,jj,jk,Kmm) * zbreiv16_w
- END_3D
-!
+ !
DO jk = 1, jpkm1
zfac = 0.166666666667_wp
- DO_2D( 1, 1, 1, 1 ) !++ Compute the FV Breivik 2016 function at T-points
+ DO_2D( 0, 1, 0, 1 ) !++ Compute the FV Breivik 2016 function at T-points
+ ! zInt at jk
+ zfac = - 2._wp * zk_t (ji,jj) * gdepw(ji,jj,jk,Kmm) !<-- zfac should be negative definite
+ ztemp = EXP ( zfac )
+ zsqrt = SQRT( -zfac )
+ zbreiv16_w = ztemp - SQRT(rpi)*zsqrt*ERFC(zsqrt) !Eq. 16 Breivik 2016
+ zInt_w0 = ztemp - 4._wp * zk_t (ji,jj) * gdepw(ji,jj,jk,Kmm) * zbreiv16_w
+ ! zInt at jk+1
+ zfac = - 2._wp * zk_t (ji,jj) * gdepw(ji,jj,jk+1,Kmm) !<-- zfac should be negative definite
+ ztemp = EXP ( zfac )
+ zsqrt = SQRT( -zfac )
+ zbreiv16_w = ztemp - SQRT(rpi)*zsqrt*ERFC(zsqrt) !Eq. 16 Breivik 2016
+ zInt_w1 = ztemp - 4._wp * zk_t (ji,jj) * gdepw(ji,jj,jk+1,Kmm) * zbreiv16_w
+ !
+ !
zsp0 = zfac / MAX(zk_t (ji,jj),0.0000001_wp)
- ztemp = zInt_w(ji,jj,jk) - zInt_w(ji,jj,jk+1)
+ ztemp = zInt_w0 - zInt_w1
zu0_sd(ji,jj) = ut0sd(ji,jj) * zsp0 * ztemp * tmask(ji,jj,jk)
zv0_sd(ji,jj) = vt0sd(ji,jj) * zsp0 * ztemp * tmask(ji,jj,jk)
END_2D
- DO_2D( 1, 0, 1, 0 ) ! ++ Interpolate at U/V points
+ DO_2D( 0, 0, 0, 0 ) ! ++ Interpolate at U/V points
zfac = 1.0_wp / e3u(ji ,jj,jk,Kmm)
usd(ji,jj,jk) = 0.5_wp * zfac * ( zu0_sd(ji,jj)+zu0_sd(ji+1,jj) ) * umask(ji,jj,jk)
zfac = 1.0_wp / e3v(ji ,jj,jk,Kmm)
vsd(ji,jj,jk) = 0.5_wp * zfac * ( zv0_sd(ji,jj)+zv0_sd(ji,jj+1) ) * vmask(ji,jj,jk)
END_2D
ENDDO
- !# undef zInt_w
- !
+ !
ELSE
zfac = 2.0_wp * rpi / 16.0_wp
- DO_2D( 1, 1, 1, 1 )
+ DO_2D( 0, 1, 0, 1 )
! Stokes drift velocity estimated from Hs and Tmean
ztransp = zfac * hsw(ji,jj)*hsw(ji,jj) / MAX( wmp(ji,jj), 0.0000001_wp )
! Stokes surface speed
@@ -186,7 +189,7 @@ CONTAINS
! Wavenumber scale
zk_t(ji,jj) = ABS( tsd2d(ji,jj) ) / MAX( ABS( 5.97_wp*ztransp ), 0.0000001_wp )
END_2D
- DO_2D( 1, 0, 1, 0 ) ! exp. wave number & Stokes drift velocity at u- & v-points
+ DO_2D( 0, 0, 0, 0 ) ! exp. wave number & Stokes drift velocity at u- & v-points
zk_u(ji,jj) = 0.5_wp * ( zk_t(ji,jj) + zk_t(ji+1,jj) )
zk_v(ji,jj) = 0.5_wp * ( zk_t(ji,jj) + zk_t(ji,jj+1) )
!
@@ -217,11 +220,10 @@ CONTAINS
! !== vertical Stokes Drift 3D velocity ==!
!
DO_3D( 0, 1, 0, 1, 1, jpkm1 ) ! Horizontal e3*divergence
- ze3divh(ji,jj,jk) = ( e2u(ji ,jj) * e3u(ji ,jj,jk,Kmm) * usd(ji ,jj,jk) &
- & - e2u(ji-1,jj) * e3u(ji-1,jj,jk,Kmm) * usd(ji-1,jj,jk) &
- & + e1v(ji,jj ) * e3v(ji,jj ,jk,Kmm) * vsd(ji,jj ,jk) &
- & - e1v(ji,jj-1) * e3v(ji,jj-1,jk,Kmm) * vsd(ji,jj-1,jk) ) &
- & * r1_e1e2t(ji,jj)
+ ze3divh(ji,jj,jk) = ( ( e2u(ji ,jj) * e3u(ji ,jj,jk,Kmm) * usd(ji ,jj,jk) & ! add () for NP repro
+ & - e2u(ji-1,jj) * e3u(ji-1,jj,jk,Kmm) * usd(ji-1,jj,jk) ) &
+ & + ( e1v(ji,jj ) * e3v(ji,jj ,jk,Kmm) * vsd(ji,jj ,jk) &
+ & - e1v(ji,jj-1) * e3v(ji,jj-1,jk,Kmm) * vsd(ji,jj-1,jk) ) ) * r1_e1e2t(ji,jj)
END_3D
!
CALL lbc_lnk( 'sbcwave', ze3divh, 'T', 1.0_wp )
@@ -248,7 +250,7 @@ CONTAINS
CALL iom_put( "vstokes", vsd )
CALL iom_put( "wstokes", wsd )
! !
- DEALLOCATE( ze3divh, zInt_w )
+ DEALLOCATE( ze3divh )
DEALLOCATE( zk_t, zk_u, zk_v, zu0_sd, zv0_sd )
!
END SUBROUTINE sbc_stokes
@@ -274,12 +276,12 @@ CONTAINS
!
IF( ln_cdgw .AND. .NOT. cpl_wdrag ) THEN !== Neutral drag coefficient ==!
CALL fld_read( kt, nn_fsbc, sf_cd ) ! read from external forcing
- cdn_wave(:,:) = sf_cd(1)%fnow(:,:,1) * tmask(:,:,1)
+ cdn_wave(:,:) = sf_cd(1)%fnow(:,:,1) * smask0(:,:)
ENDIF
IF( ln_tauoc .AND. .NOT. cpl_wstrf ) THEN !== Wave induced stress ==!
CALL fld_read( kt, nn_fsbc, sf_tauoc ) ! read stress reduction factor due to wave from external forcing
- tauoc_wave(:,:) = sf_tauoc(1)%fnow(:,:,1) * tmask(:,:,1)
+ tauoc_wave(:,:) = sf_tauoc(1)%fnow(:,:,1) * smask0(:,:)
ELSEIF ( ln_taw .AND. cpl_taw ) THEN
IF (kt < 1) THEN ! The first fields gave by OASIS have very high erroneous values ....
twox(:,:)=0._wp
@@ -315,7 +317,7 @@ CONTAINS
! coupling routines
IF( ln_zdfswm .AND. .NOT. cpl_wnum ) THEN !==wavenumber==!
CALL fld_read( kt, nn_fsbc, sf_wn ) ! read wave parameters from external forcing
- wnum(:,:) = sf_wn(1)%fnow(:,:,1) * tmask(:,:,1)
+ wnum(:,:) = sf_wn(1)%fnow(:,:,1) * smask0(:,:)
ENDIF
!
@@ -391,10 +393,10 @@ CONTAINS
! !== Allocate wave arrays ==!
ALLOCATE( ut0sd (jpi,jpj) , vt0sd (jpi,jpj) )
ALLOCATE( hsw (jpi,jpj) , wmp (jpi,jpj) )
- ALLOCATE( wnum (jpi,jpj) )
ALLOCATE( tsd2d (jpi,jpj) , div_sd(jpi,jpj) , bhd_wave(jpi,jpj) )
ALLOCATE( usd (jpi,jpj,jpk), vsd (jpi,jpj,jpk), wsd (jpi,jpj,jpk) )
- ALLOCATE( tusd (jpi,jpj) , tvsd (jpi,jpj) , ZMX (jpi,jpj,jpk) )
+ ALLOCATE( tusd (jpi,jpj) , tvsd (jpi,jpj) )
+ ALLOCATE( wnum (A2D(0)) , ZMX (A2D(0),jpk) )
usd (:,:,:) = 0._wp
vsd (:,:,:) = 0._wp
wsd (:,:,:) = 0._wp
@@ -422,30 +424,30 @@ CONTAINS
ALLOCATE( sf_cd(1), STAT=ierror ) !* allocate and fill sf_wave with sn_cdg
IF( ierror > 0 ) CALL ctl_stop( 'STOP', 'sbc_wave_init: unable to allocate sf_wave structure' )
!
- ALLOCATE( sf_cd(1)%fnow(jpi,jpj,1) )
- IF( sn_cdg%ln_tint ) ALLOCATE( sf_cd(1)%fdta(jpi,jpj,1,2) )
+ ALLOCATE( sf_cd(1)%fnow(A2D(0),1) )
+ IF( sn_cdg%ln_tint ) ALLOCATE( sf_cd(1)%fdta(A2D(0),1,2) )
CALL fld_fill( sf_cd, (/ sn_cdg /), cn_dir, 'sbc_wave_init', 'Wave module ', 'namsbc_wave' )
ENDIF
- ALLOCATE( cdn_wave(jpi,jpj) )
+ ALLOCATE( cdn_wave(A2D(0)) )
cdn_wave(:,:) = 0._wp
ENDIF
IF( ln_charn ) THEN ! wave drag
IF( .NOT. cpl_charn ) THEN
CALL ctl_stop( 'STOP', 'Charnock based wind stress can be used in coupled mode only' )
ENDIF
- ALLOCATE( charn(jpi,jpj) )
+ ALLOCATE( charn(A2D(0)) )
charn(:,:) = 0._wp
ENDIF
IF( ln_taw ) THEN ! wind stress
IF( .NOT. cpl_taw ) THEN
CALL ctl_stop( 'STOP', 'wind stress from wave model can be used in coupled mode only, use ln_cdgw instead' )
ENDIF
- ALLOCATE( tawx(jpi,jpj) )
- ALLOCATE( tawy(jpi,jpj) )
- ALLOCATE( twox(jpi,jpj) )
- ALLOCATE( twoy(jpi,jpj) )
- ALLOCATE( tauoc_wavex(jpi,jpj) )
- ALLOCATE( tauoc_wavey(jpi,jpj) )
+ ALLOCATE( tawx(A2D(0)) )
+ ALLOCATE( tawy(A2D(0)) )
+ ALLOCATE( twox(A2D(0)) )
+ ALLOCATE( twoy(A2D(0)) )
+ ALLOCATE( tauoc_wavex(A2D(0)) )
+ ALLOCATE( tauoc_wavey(A2D(0)) )
tawx(:,:) = 0._wp
tawy(:,:) = 0._wp
twox(:,:) = 0._wp
@@ -458,7 +460,7 @@ CONTAINS
IF( .NOT. cpl_phioc ) THEN
CALL ctl_stop( 'STOP', 'phioc can be used in coupled mode only' )
ENDIF
- ALLOCATE( phioc(jpi,jpj) )
+ ALLOCATE( phioc(A2D(0)) )
phioc(:,:) = 0._wp
ENDIF
@@ -467,11 +469,11 @@ CONTAINS
ALLOCATE( sf_tauoc(1), STAT=ierror ) !* allocate and fill sf_wave with sn_tauoc
IF( ierror > 0 ) CALL ctl_stop( 'STOP', 'sbc_wave_init: unable to allocate sf_tauoc structure' )
!
- ALLOCATE( sf_tauoc(1)%fnow(jpi,jpj,1) )
- IF( sn_tauoc%ln_tint ) ALLOCATE( sf_tauoc(1)%fdta(jpi,jpj,1,2) )
+ ALLOCATE( sf_tauoc(1)%fnow(A2D(0),1) )
+ IF( sn_tauoc%ln_tint ) ALLOCATE( sf_tauoc(1)%fdta(A2D(0),1,2) )
CALL fld_fill( sf_tauoc, (/ sn_tauoc /), cn_dir, 'sbc_wave_init', 'Wave module', 'namsbc_wave' )
ENDIF
- ALLOCATE( tauoc_wave(jpi,jpj) )
+ ALLOCATE( tauoc_wave(A2D(0)) )
tauoc_wave(:,:) = 0._wp
ENDIF
@@ -518,8 +520,8 @@ CONTAINS
IF( .NOT. cpl_wnum ) THEN
ALLOCATE( sf_wn(1), STAT=ierror ) !* allocate and fill sf_wave with sn_wnum
IF( ierror > 0 ) CALL ctl_stop( 'STOP', 'sbc_wave_init: unable to allocate sf_wn structure' )
- ALLOCATE( sf_wn(1)%fnow(jpi,jpj,1) )
- IF( sn_wnum%ln_tint ) ALLOCATE( sf_wn(1)%fdta(jpi,jpj,1,2) )
+ ALLOCATE( sf_wn(1)%fnow(A2D(0),1) )
+ IF( sn_wnum%ln_tint ) ALLOCATE( sf_wn(1)%fdta(A2D(0),1,2) )
CALL fld_fill( sf_wn, (/ sn_wnum /), cn_dir, 'sbc_wave', 'Wave module', 'namsbc_wave' )
ENDIF
!
diff --git a/src/OCE/TRA/eosbn2.F90 b/src/OCE/TRA/eosbn2.F90
index 81fda25e0249bd92da7d324c7e133ee8beb125d1..f3b908ec95011c8fa7624ef9d9850fc31bb1b55a 100644
--- a/src/OCE/TRA/eosbn2.F90
+++ b/src/OCE/TRA/eosbn2.F90
@@ -38,7 +38,7 @@ MODULE eosbn2
!! eos_init : set eos parameters (namelist)
!!----------------------------------------------------------------------
USE dom_oce ! ocean space and time domain
- USE domutl, ONLY : is_tile
+ USE domutl, ONLY : lbnd_ij
USE phycst ! physical constants
USE stopar ! Stochastic T/S fluctuations
USE stopts ! Stochastic T/S fluctuations
@@ -53,7 +53,7 @@ MODULE eosbn2
! !! * Interface
INTERFACE eos
- MODULE PROCEDURE eos_insitu_New, eos_insitu, eos_insitu_pot, eos_insitu_2d, eos_insitu_pot_2d
+ MODULE PROCEDURE eos_insitu_New, eos_insitu_pot_New, eos_insitu, eos_insitu_pot, eos_insitu_2d, eos_insitu_pot_2d
END INTERFACE
!
INTERFACE eos_rab
@@ -61,7 +61,7 @@ MODULE eosbn2
END INTERFACE
!
INTERFACE eos_fzp
- MODULE PROCEDURE eos_fzp_2d, eos_fzp_0d
+ MODULE PROCEDURE eos_fzp_3d, eos_fzp_2d, eos_fzp_0d, eos_fzp_3d_New
END INTERFACE
!
PUBLIC eos ! called by step, istate, tranpc and zpsgrd modules
@@ -83,9 +83,11 @@ MODULE eosbn2
INTEGER , PARAMETER :: np_teos10 = -1 ! parameter for using TEOS10
INTEGER , PARAMETER :: np_eos80 = 0 ! parameter for using EOS80
- INTEGER , PARAMETER :: np_seos = 1 ! parameter for using Simplified Equation of state
+ INTEGER , PARAMETER :: np_seos = 1 ! parameter for using Simplified Equation of state
! !!! simplified eos coefficients (default value: Vallis 2006)
+ REAL(wp), PUBLIC :: rn_T0 = 10._wp ! reference temperature
+ REAL(wp), PUBLIC :: rn_S0 = 35._wp ! reference salinity
REAL(wp), PUBLIC :: rn_a0 = 1.6550e-1_wp ! thermal expansion coeff.
REAL(wp), PUBLIC :: rn_b0 = 7.6554e-1_wp ! saline expansion coeff.
REAL(wp) :: rn_lambda1 = 5.9520e-2_wp ! cabbeling coeff. in T^2
@@ -186,7 +188,23 @@ MODULE eosbn2
!!----------------------------------------------------------------------
CONTAINS
- SUBROUTINE eos_insitu_New( pts, Knn, prd )
+ SUBROUTINE eos_insitu_New( pts, Knn, prd, kbnd )
+ !!
+ REAL(wp), DIMENSION(:,:,:,:,:), INTENT(in ) :: pts ! T-S
+ INTEGER , INTENT(in ) :: Knn ! time-level
+ REAL(wp), DIMENSION(:,:,: ) , INTENT( out) :: prd ! in situ density
+ INTEGER, OPTIONAL, INTENT(in ) :: kbnd ! number of halo points to calculate
+ !
+ INTEGER :: ibnd
+ !!
+ ibnd = nn_hls
+ IF( PRESENT(kbnd) ) ibnd = kbnd
+
+ CALL eos_insitu_New_t( pts, lbnd_ij(pts), Knn, prd, lbnd_ij(prd), ibnd )
+ END SUBROUTINE eos_insitu_New
+
+
+ SUBROUTINE eos_insitu_New_t( pts, ktts, Knn, prd, ktrd, kbnd )
!!----------------------------------------------------------------------
!! *** ROUTINE eos_insitu ***
!!
@@ -220,9 +238,11 @@ CONTAINS
!! Vallis, Atmospheric and Oceanic Fluid Dynamics, 2006
!! TEOS-10 Manual, 2010
!!----------------------------------------------------------------------
- REAL(wp), DIMENSION(:,:,:,:,:), INTENT(in ) :: pts ! T-S
- INTEGER , INTENT(in ) :: Knn ! time-level
- REAL(wp), DIMENSION(:,:,: ), INTENT( out) :: prd ! in situ density
+ INTEGER, DIMENSION(2), INTENT(in ) :: ktts, ktrd
+ INTEGER, INTENT(in ) :: kbnd ! number of halo points to calculate
+ REAL(wp), DIMENSION(AB2D(ktts),JPK,JPTS,JPT), INTENT(in ) :: pts ! T-S
+ INTEGER, INTENT(in ) :: Knn ! time-level
+ REAL(wp), DIMENSION(AB2D(ktrd),JPK ), INTENT( out) :: prd ! in situ density
!
INTEGER :: ji, jj, jk ! dummy loop indices
REAL(wp) :: zt , zh , zs , ztm ! local scalars
@@ -235,7 +255,7 @@ CONTAINS
!
CASE( np_teos10, np_eos80 ) !== polynomial TEOS-10 / EOS-80 ==!
!
- DO_3D(nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 )
+ DO_3D( kbnd, kbnd, kbnd, kbnd, 1, jpkm1 )
!
zh = gdept(ji,jj,jk,Knn) * r1_Z0 ! depth
zt = pts (ji,jj,jk,jp_tem,Knn) * r1_T0 ! temperature
@@ -271,9 +291,9 @@ CONTAINS
!
CASE( np_seos ) !== simplified EOS ==!
!
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 )
- zt = pts (ji,jj,jk,jp_tem,Knn) - 10._wp
- zs = pts (ji,jj,jk,jp_sal,Knn) - 35._wp
+ DO_3D( kbnd, kbnd, kbnd, kbnd, 1, jpkm1 )
+ zt = pts (ji,jj,jk,jp_tem,Knn) - rn_T0
+ zs = pts (ji,jj,jk,jp_sal,Knn) - rn_S0
zh = gdept(ji,jj,jk,Knn)
ztm = tmask(ji,jj,jk)
!
@@ -290,20 +310,265 @@ CONTAINS
!
IF( ln_timing ) CALL timing_stop('eos-insitu')
!
- END SUBROUTINE eos_insitu_New
+ END SUBROUTINE eos_insitu_New_t
+
+
+ SUBROUTINE eos_fzp_3d_New( pts, Knn, ptf, kbnd )
+ !!
+ INTEGER , INTENT(in ) :: Knn
+ REAL(wp), DIMENSION(:,:,:,:,:), INTENT(in ) :: pts ! temperature and salinity
+ REAL(wp), DIMENSION(:,:,:) , INTENT( out) :: ptf ! freezing temperature [Celsius]
+ INTEGER , INTENT(in ), OPTIONAL :: kbnd ! number of halo points to calculate
+ !
+ INTEGER :: ibnd
+ !!
+ ibnd = nn_hls
+ IF( PRESENT(kbnd) ) ibnd = kbnd
+ CALL eos_fzp_3d_New_t( pts, lbnd_ij(pts), Knn, ptf, lbnd_ij(ptf), ibnd )
+ END SUBROUTINE eos_fzp_3d_New
+
+
+ SUBROUTINE eos_fzp_3d_New_t( pts, ktts, Knn, ptf, kttf, kbnd )
+ !!----------------------------------------------------------------------
+ !! *** ROUTINE eos_fzp ***
+ !!
+ !! ** Purpose : Compute the freezing point temperature [Celsius]
+ !!
+ !! ** Method : UNESCO freezing point (ptf) in Celsius is given by
+ !! ptf(t,z) = (-.0575+1.710523e-3*sqrt(abs(s))-2.154996e-4*s)*s - 7.53e-4*z
+ !! checkvalue: tf=-2.588567 Celsius for s=40psu, z=500m
+ !!
+ !! Reference : UNESCO tech. papers in the marine science no. 28. 1978
+ !!----------------------------------------------------------------------
+ INTEGER, DIMENSION(2) , INTENT(in ) :: ktts, kttf
+ INTEGER , INTENT(in ) :: kbnd ! number of halo points to calculate
+ INTEGER , INTENT(in ) :: Knn
+ REAL(wp), DIMENSION(AB2D(ktts),JPK,JPTS,JPT), INTENT(in ) :: pts ! temperature and salinity
+ REAL(wp), DIMENSION(AB2D(kttf),JPK ), INTENT( out) :: ptf ! freezing temperature [Celsius]
+ !
+ INTEGER :: ji, jj, jk ! dummy loop indices
+ REAL(wp) :: zt, zs, z1_S0 ! local scalars
+ !!----------------------------------------------------------------------
+ !
+ ptf(:,:,jpk) = 0._wp
+ !
+ SELECT CASE ( neos )
+ !
+ CASE ( np_teos10, np_seos ) !== CT,SA (TEOS-10 and S-EOS formulations) ==!
+ !
+ z1_S0 = 1._wp / 35.16504_wp
+ DO_3D( kbnd, kbnd, kbnd, kbnd, 1, jpkm1 )
+ zs= SQRT( ABS( pts(ji,jj,jk,jp_sal,Knn) ) * z1_S0 ) ! square root salinity
+ ptf(ji,jj,jk) = ((((1.46873e-03_wp*zs-9.64972e-03_wp)*zs+2.28348e-02_wp)*zs &
+ & -3.12775e-02_wp)*zs+2.07679e-02_wp)*zs-5.87701e-02_wp &
+ & * pts(ji,jj,jk,jp_sal,Knn) - 7.53e-4 * gdept(ji,jj,jk,Knn)
+ END_3D
+ !
+ CASE ( np_eos80 ) !== PT,SP (UNESCO formulation) ==!
+ !
+ DO_3D( kbnd, kbnd, kbnd, kbnd, 1, jpkm1 )
+ ptf(ji,jj,jk) = ( - 0.0575_wp + 1.710523e-3_wp * SQRT( pts(ji,jj,jk,jp_sal,Knn) ) &
+ & - 2.154996e-4_wp * pts(ji,jj,jk,jp_sal,Knn) ) * pts(ji,jj,jk,jp_sal,Knn) &
+ & - 7.53e-4 * gdept(ji,jj,jk,Knn)
+ END_3D
+ !
+ CASE DEFAULT
+ WRITE(ctmp1,*) ' bad flag value for neos = ', neos
+ CALL ctl_stop( 'eos_fzp_3d_New:', ctmp1 )
+ !
+ END SELECT
+ !
+ END SUBROUTINE eos_fzp_3d_New_t
+
+
+ SUBROUTINE eos_insitu_pot_New( pts, Knn, prd, prhop, kbnd )
+ !!
+ REAL(wp), DIMENSION(:,:,:,:,:), INTENT(in ) :: pts ! temperature salinity
+ INTEGER , INTENT(in ) :: Knn
+ REAL(wp), DIMENSION(:,:,:) , INTENT( out) :: prd ! in situ density [-]
+ REAL(wp), DIMENSION(:,:,:) , INTENT( out) :: prhop ! potential density (surface referenced)
+ INTEGER , INTENT(in ), OPTIONAL :: kbnd ! number of halo points to calculate
+ !
+ INTEGER :: ibnd
+ !!
+ ibnd = nn_hls
+ IF( PRESENT(kbnd) ) ibnd = kbnd
+ CALL eos_insitu_pot_New_t( pts, lbnd_ij(pts), Knn, prd, lbnd_ij(prd), prhop, lbnd_ij(prhop), ibnd )
+ END SUBROUTINE eos_insitu_pot_New
+
+
+ SUBROUTINE eos_insitu_pot_New_t( pts, ktts, Knn, prd, ktrd, prhop, ktrhop, kbnd )
+ !!----------------------------------------------------------------------
+ !! *** ROUTINE eos_insitu_pot ***
+ !!
+ !! ** Purpose : Compute the in situ density (ratio rho/rho0) and the
+ !! potential volumic mass (Kg/m3) from potential temperature and
+ !! salinity fields using an equation of state selected in the
+ !! namelist.
+ !!
+ !! ** Action : - prd , the in situ density (no units)
+ !! - prhop, the potential volumic mass (Kg/m3)
+ !!
+ !!----------------------------------------------------------------------
+ INTEGER, DIMENSION(2) , INTENT(in ) :: ktts, ktrd, ktrhop
+ REAL(wp), DIMENSION(AB2D(ktts) ,JPK,JPTS,JPT), INTENT(in ) :: pts ! temperature salinity
+ INTEGER , INTENT(in ) :: kbnd ! number of halo points to calculate
+ INTEGER , INTENT(in ) :: Knn
+ REAL(wp), DIMENSION(AB2D(ktrd) ,JPK ), INTENT( out) :: prd ! in situ density [-]
+ REAL(wp), DIMENSION(AB2D(ktrhop),JPK ), INTENT( out) :: prhop ! potential density (surface referenced)
+ !
+ INTEGER :: ji, jj, jk, jsmp ! dummy loop indices
+ INTEGER :: jdof
+ REAL(wp) :: zt , zh , zstemp, zs , ztm ! local scalars
+ REAL(wp) :: zn , zn0, zn1, zn2, zn3 ! - -
+ REAL(wp), DIMENSION(:), ALLOCATABLE :: zn0_sto, zn_sto, zsign ! local vectors
+ !!----------------------------------------------------------------------
+ !
+ IF( ln_timing ) CALL timing_start('eos-pot')
+ !
+ SELECT CASE ( neos )
+ !
+ CASE( np_teos10, np_eos80 ) !== polynomial TEOS-10 / EOS-80 ==!
+ !
+ ! Stochastic equation of state
+ IF ( ln_sto_eos ) THEN
+ ALLOCATE(zn0_sto(1:2*nn_sto_eos))
+ ALLOCATE(zn_sto(1:2*nn_sto_eos))
+ ALLOCATE(zsign(1:2*nn_sto_eos))
+ DO jsmp = 1, 2*nn_sto_eos, 2
+ zsign(jsmp) = 1._wp
+ zsign(jsmp+1) = -1._wp
+ END DO
+ !
+ DO_3D( kbnd, kbnd, kbnd, kbnd, 1, jpkm1 )
+ !
+ ! compute density (2*nn_sto_eos) times:
+ ! (1) for t+dt, s+ds (with the random TS fluctutation computed in sto_pts)
+ ! (2) for t-dt, s-ds (with the opposite fluctuation)
+ DO jsmp = 1, nn_sto_eos*2
+ jdof = (jsmp + 1) / 2
+ zh = gdept(ji,jj,jk,Knn) * r1_Z0 ! depth
+ zt = (pts (ji,jj,jk,jp_tem,Knn) + pts_ran(ji,jj,jk,jp_tem,jdof) * zsign(jsmp)) * r1_T0 ! temperature
+ zstemp = pts (ji,jj,jk,jp_sal,Knn) + pts_ran(ji,jj,jk,jp_sal,jdof) * zsign(jsmp)
+ zs = SQRT( ABS( zstemp + rdeltaS ) * r1_S0 ) ! square root salinity
+ ztm = tmask(ji,jj,jk) ! tmask
+ !
+ zn3 = EOS013*zt &
+ & + EOS103*zs+EOS003
+ !
+ zn2 = (EOS022*zt &
+ & + EOS112*zs+EOS012)*zt &
+ & + (EOS202*zs+EOS102)*zs+EOS002
+ !
+ zn1 = (((EOS041*zt &
+ & + EOS131*zs+EOS031)*zt &
+ & + (EOS221*zs+EOS121)*zs+EOS021)*zt &
+ & + ((EOS311*zs+EOS211)*zs+EOS111)*zs+EOS011)*zt &
+ & + (((EOS401*zs+EOS301)*zs+EOS201)*zs+EOS101)*zs+EOS001
+ !
+ zn0_sto(jsmp) = (((((EOS060*zt &
+ & + EOS150*zs+EOS050)*zt &
+ & + (EOS240*zs+EOS140)*zs+EOS040)*zt &
+ & + ((EOS330*zs+EOS230)*zs+EOS130)*zs+EOS030)*zt &
+ & + (((EOS420*zs+EOS320)*zs+EOS220)*zs+EOS120)*zs+EOS020)*zt &
+ & + ((((EOS510*zs+EOS410)*zs+EOS310)*zs+EOS210)*zs+EOS110)*zs+EOS010)*zt &
+ & + (((((EOS600*zs+EOS500)*zs+EOS400)*zs+EOS300)*zs+EOS200)*zs+EOS100)*zs+EOS000
+ !
+ zn_sto(jsmp) = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0_sto(jsmp)
+ END DO
+ !
+ ! compute stochastic density as the mean of the (2*nn_sto_eos) densities
+ prhop(ji,jj,jk) = 0._wp ; prd(ji,jj,jk) = 0._wp
+ DO jsmp = 1, nn_sto_eos*2
+ prhop(ji,jj,jk) = prhop(ji,jj,jk) + zn0_sto(jsmp) ! potential density referenced at the surface
+ !
+ prd(ji,jj,jk) = prd(ji,jj,jk) + ( zn_sto(jsmp) * r1_rho0 - 1._wp ) ! density anomaly (masked)
+ END DO
+ prhop(ji,jj,jk) = 0.5_wp * prhop(ji,jj,jk) * ztm / nn_sto_eos
+ prd (ji,jj,jk) = 0.5_wp * prd (ji,jj,jk) * ztm / nn_sto_eos
+ END_3D
+ DEALLOCATE(zn0_sto,zn_sto,zsign)
+ ! Non-stochastic equation of state
+ ELSE
+ DO_3D( kbnd, kbnd, kbnd, kbnd, 1, jpkm1 )
+ !
+ zh = gdept(ji,jj,jk,Knn) * r1_Z0 ! depth
+ zt = pts (ji,jj,jk,jp_tem,Knn) * r1_T0 ! temperature
+ zs = SQRT( ABS( pts(ji,jj,jk,jp_sal,Knn) + rdeltaS ) * r1_S0 ) ! square root salinity
+ ztm = tmask(ji,jj,jk) ! tmask
+ !
+ zn3 = EOS013*zt &
+ & + EOS103*zs+EOS003
+ !
+ zn2 = (EOS022*zt &
+ & + EOS112*zs+EOS012)*zt &
+ & + (EOS202*zs+EOS102)*zs+EOS002
+ !
+ zn1 = (((EOS041*zt &
+ & + EOS131*zs+EOS031)*zt &
+ & + (EOS221*zs+EOS121)*zs+EOS021)*zt &
+ & + ((EOS311*zs+EOS211)*zs+EOS111)*zs+EOS011)*zt &
+ & + (((EOS401*zs+EOS301)*zs+EOS201)*zs+EOS101)*zs+EOS001
+ !
+ zn0 = (((((EOS060*zt &
+ & + EOS150*zs+EOS050)*zt &
+ & + (EOS240*zs+EOS140)*zs+EOS040)*zt &
+ & + ((EOS330*zs+EOS230)*zs+EOS130)*zs+EOS030)*zt &
+ & + (((EOS420*zs+EOS320)*zs+EOS220)*zs+EOS120)*zs+EOS020)*zt &
+ & + ((((EOS510*zs+EOS410)*zs+EOS310)*zs+EOS210)*zs+EOS110)*zs+EOS010)*zt &
+ & + (((((EOS600*zs+EOS500)*zs+EOS400)*zs+EOS300)*zs+EOS200)*zs+EOS100)*zs+EOS000
+ !
+ zn = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0
+ !
+ prhop(ji,jj,jk) = zn0 * ztm ! potential density referenced at the surface
+ !
+ prd(ji,jj,jk) = ( zn * r1_rho0 - 1._wp ) * ztm ! density anomaly (masked)
+ END_3D
+ ENDIF
+
+ CASE( np_seos ) !== simplified EOS ==!
+ !
+ DO_3D( kbnd, kbnd, kbnd, kbnd, 1, jpkm1 )
+ zt = pts (ji,jj,jk,jp_tem,Knn) - rn_T0
+ zs = pts (ji,jj,jk,jp_sal,Knn) - rn_S0
+ zh = gdept(ji,jj,jk,Knn)
+ ztm = tmask(ji,jj,jk)
+ ! ! potential density referenced at the surface
+ zn = - rn_a0 * ( 1._wp + 0.5_wp*rn_lambda1*zt ) * zt &
+ & + rn_b0 * ( 1._wp - 0.5_wp*rn_lambda2*zs ) * zs &
+ & - rn_nu * zt * zs
+ prhop(ji,jj,jk) = ( rho0 + zn ) * ztm
+ ! ! density anomaly (masked)
+ zn = zn - ( rn_a0 * rn_mu1 * zt + rn_b0 * rn_mu2 * zs ) * zh
+ prd(ji,jj,jk) = zn * r1_rho0 * ztm
+ !
+ END_3D
+ !
+ END SELECT
+ !
+ IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=prd, clinfo1=' eos-pot: ', tab3d_2=prhop, clinfo2=' pot : ' )
+ !
+ IF( ln_timing ) CALL timing_stop('eos-pot')
+ !
+ END SUBROUTINE eos_insitu_pot_New_t
- SUBROUTINE eos_insitu( pts, prd, pdep )
+ SUBROUTINE eos_insitu( pts, prd, pdep, kbnd )
!!
REAL(wp), DIMENSION(:,:,:,:), INTENT(in ) :: pts ! 1 : potential temperature [Celsius]
! ! 2 : salinity [psu]
REAL(wp), DIMENSION(:,:,:) , INTENT( out) :: prd ! in situ density [-]
REAL(wp), DIMENSION(:,:,:) , INTENT(in ) :: pdep ! depth [m]
+ INTEGER, OPTIONAL, INTENT(in ) :: kbnd ! number of halo points to calculate
+ !
+ INTEGER :: ibnd
!!
- CALL eos_insitu_t( pts, is_tile(pts), prd, is_tile(prd), pdep, is_tile(pdep) )
+ ibnd = nn_hls
+ IF( PRESENT(kbnd) ) ibnd = kbnd
+ CALL eos_insitu_t( pts, lbnd_ij(pts), prd, lbnd_ij(prd), pdep, lbnd_ij(pdep), ibnd )
END SUBROUTINE eos_insitu
- SUBROUTINE eos_insitu_t( pts, ktts, prd, ktrd, pdep, ktdep )
+ SUBROUTINE eos_insitu_t( pts, ktts, prd, ktrd, pdep, ktdep, kbnd )
!!----------------------------------------------------------------------
!! *** ROUTINE eos_insitu ***
!!
@@ -337,11 +602,12 @@ CONTAINS
!! Vallis, Atmospheric and Oceanic Fluid Dynamics, 2006
!! TEOS-10 Manual, 2010
!!----------------------------------------------------------------------
- INTEGER , INTENT(in ) :: ktts, ktrd, ktdep
- REAL(wp), DIMENSION(A2D_T(ktts) ,JPK,JPTS), INTENT(in ) :: pts ! 1 : potential temperature [Celsius]
- ! ! 2 : salinity [psu]
- REAL(wp), DIMENSION(A2D_T(ktrd) ,JPK ), INTENT( out) :: prd ! in situ density [-]
- REAL(wp), DIMENSION(A2D_T(ktdep),JPK ), INTENT(in ) :: pdep ! depth [m]
+ INTEGER, DIMENSION(2) , INTENT(in ) :: ktts, ktrd, ktdep
+ INTEGER , INTENT(in ) :: kbnd ! number of halo points to calculate
+ REAL(wp), DIMENSION(AB2D(ktts) ,JPK,JPTS), INTENT(in ) :: pts ! 1 : potential temperature [Celsius]
+ ! ! 2 : salinity [psu]
+ REAL(wp), DIMENSION(AB2D(ktrd) ,JPK ), INTENT( out) :: prd ! in situ density [-]
+ REAL(wp), DIMENSION(AB2D(ktdep),JPK ), INTENT(in ) :: pdep ! depth [m]
!
INTEGER :: ji, jj, jk ! dummy loop indices
REAL(wp) :: zt , zh , zs , ztm ! local scalars
@@ -354,7 +620,7 @@ CONTAINS
!
CASE( np_teos10, np_eos80 ) !== polynomial TEOS-10 / EOS-80 ==!
!
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 )
+ DO_3D( kbnd, kbnd, kbnd, kbnd, 1, jpkm1 )
!
zh = pdep(ji,jj,jk) * r1_Z0 ! depth
zt = pts (ji,jj,jk,jp_tem) * r1_T0 ! temperature
@@ -390,9 +656,9 @@ CONTAINS
!
CASE( np_seos ) !== simplified EOS ==!
!
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 )
- zt = pts (ji,jj,jk,jp_tem) - 10._wp
- zs = pts (ji,jj,jk,jp_sal) - 35._wp
+ DO_3D( kbnd, kbnd, kbnd, kbnd, 1, jpkm1 )
+ zt = pts (ji,jj,jk,jp_tem) - rn_T0
+ zs = pts (ji,jj,jk,jp_sal) - rn_S0
zh = pdep (ji,jj,jk)
ztm = tmask(ji,jj,jk)
!
@@ -412,19 +678,25 @@ CONTAINS
END SUBROUTINE eos_insitu_t
- SUBROUTINE eos_insitu_pot( pts, prd, prhop, pdep )
+ SUBROUTINE eos_insitu_pot( pts, prd, prhop, pdep, kbnd )
!!
REAL(wp), DIMENSION(:,:,:,:), INTENT(in ) :: pts ! 1 : potential temperature [Celsius]
! ! 2 : salinity [psu]
REAL(wp), DIMENSION(:,:,:) , INTENT( out) :: prd ! in situ density [-]
REAL(wp), DIMENSION(:,:,:) , INTENT( out) :: prhop ! potential density (surface referenced)
REAL(wp), DIMENSION(:,:,:) , INTENT(in ) :: pdep ! depth [m]
+ INTEGER, OPTIONAL, INTENT(in ) :: kbnd ! number of halo points to calculate
+ !
+ INTEGER :: ibnd
!!
- CALL eos_insitu_pot_t( pts, is_tile(pts), prd, is_tile(prd), prhop, is_tile(prhop), pdep, is_tile(pdep) )
+ ibnd = nn_hls
+ IF( PRESENT(kbnd) ) ibnd = kbnd
+ CALL eos_insitu_pot_t( pts, lbnd_ij(pts), prd, lbnd_ij(prd), &
+ & prhop, lbnd_ij(prhop), pdep, lbnd_ij(pdep), ibnd )
END SUBROUTINE eos_insitu_pot
- SUBROUTINE eos_insitu_pot_t( pts, ktts, prd, ktrd, prhop, ktrhop, pdep, ktdep )
+ SUBROUTINE eos_insitu_pot_t( pts, ktts, prd, ktrd, prhop, ktrhop, pdep, ktdep, kbnd )
!!----------------------------------------------------------------------
!! *** ROUTINE eos_insitu_pot ***
!!
@@ -437,12 +709,13 @@ CONTAINS
!! - prhop, the potential volumic mass (Kg/m3)
!!
!!----------------------------------------------------------------------
- INTEGER , INTENT(in ) :: ktts, ktrd, ktrhop, ktdep
- REAL(wp), DIMENSION(A2D_T(ktts) ,JPK,JPTS), INTENT(in ) :: pts ! 1 : potential temperature [Celsius]
+ INTEGER, DIMENSION(2) , INTENT(in ) :: ktts, ktrd, ktrhop, ktdep
+ INTEGER , INTENT(in ) :: kbnd ! number of halo points to calculate
+ REAL(wp), DIMENSION(AB2D(ktts) ,JPK,JPTS), INTENT(in ) :: pts ! 1 : potential temperature [Celsius]
! ! 2 : salinity [psu]
- REAL(wp), DIMENSION(A2D_T(ktrd) ,JPK ), INTENT( out) :: prd ! in situ density [-]
- REAL(wp), DIMENSION(A2D_T(ktrhop),JPK ), INTENT( out) :: prhop ! potential density (surface referenced)
- REAL(wp), DIMENSION(A2D_T(ktdep) ,JPK ), INTENT(in ) :: pdep ! depth [m]
+ REAL(wp), DIMENSION(AB2D(ktrd) ,JPK ), INTENT( out) :: prd ! in situ density [-]
+ REAL(wp), DIMENSION(AB2D(ktrhop),JPK ), INTENT( out) :: prhop ! potential density (surface referenced)
+ REAL(wp), DIMENSION(AB2D(ktdep) ,JPK ), INTENT(in ) :: pdep ! depth [m]
!
INTEGER :: ji, jj, jk, jsmp ! dummy loop indices
INTEGER :: jdof
@@ -467,7 +740,7 @@ CONTAINS
zsign(jsmp+1) = -1._wp
END DO
!
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 )
+ DO_3D( kbnd, kbnd, kbnd, kbnd, 1, jpkm1 )
!
! compute density (2*nn_sto_eos) times:
! (1) for t+dt, s+ds (with the random TS fluctutation computed in sto_pts)
@@ -517,7 +790,7 @@ CONTAINS
DEALLOCATE(zn0_sto,zn_sto,zsign)
! Non-stochastic equation of state
ELSE
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 )
+ DO_3D( kbnd, kbnd, kbnd, kbnd, 1, jpkm1 )
!
zh = pdep(ji,jj,jk) * r1_Z0 ! depth
zt = pts (ji,jj,jk,jp_tem) * r1_T0 ! temperature
@@ -555,9 +828,9 @@ CONTAINS
CASE( np_seos ) !== simplified EOS ==!
!
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 )
- zt = pts (ji,jj,jk,jp_tem) - 10._wp
- zs = pts (ji,jj,jk,jp_sal) - 35._wp
+ DO_3D( kbnd, kbnd, kbnd, kbnd, 1, jpkm1 )
+ zt = pts (ji,jj,jk,jp_tem) - rn_T0
+ zs = pts (ji,jj,jk,jp_sal) - rn_S0
zh = pdep (ji,jj,jk)
ztm = tmask(ji,jj,jk)
! ! potential density referenced at the surface
@@ -580,18 +853,23 @@ CONTAINS
END SUBROUTINE eos_insitu_pot_t
- SUBROUTINE eos_insitu_2d( pts, pdep, prd )
+ SUBROUTINE eos_insitu_2d( pts, pdep, prd, kbnd )
!!
REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: pts ! 1 : potential temperature [Celsius]
! ! 2 : salinity [psu]
REAL(wp), DIMENSION(:,:) , INTENT(in ) :: pdep ! depth [m]
REAL(wp), DIMENSION(:,:) , INTENT( out) :: prd ! in situ density
+ INTEGER, OPTIONAL, INTENT(in ) :: kbnd ! number of halo points to calculate
+ !
+ INTEGER :: ibnd
!!
- CALL eos_insitu_2d_t( pts, is_tile(pts), pdep, is_tile(pdep), prd, is_tile(prd) )
+ ibnd = nn_hls
+ IF( PRESENT(kbnd) ) ibnd = kbnd
+ CALL eos_insitu_2d_t( pts, lbnd_ij(pts), pdep, lbnd_ij(pdep), prd, lbnd_ij(prd), ibnd )
END SUBROUTINE eos_insitu_2d
- SUBROUTINE eos_insitu_2d_t( pts, ktts, pdep, ktdep, prd, ktrd )
+ SUBROUTINE eos_insitu_2d_t( pts, ktts, pdep, ktdep, prd, ktrd, kbnd )
!!----------------------------------------------------------------------
!! *** ROUTINE eos_insitu_2d ***
!!
@@ -602,11 +880,12 @@ CONTAINS
!! ** Action : - prd , the in situ density (no units) (unmasked)
!!
!!----------------------------------------------------------------------
- INTEGER , INTENT(in ) :: ktts, ktdep, ktrd
- REAL(wp), DIMENSION(A2D_T(ktts),JPTS), INTENT(in ) :: pts ! 1 : potential temperature [Celsius]
- ! ! 2 : salinity [psu]
- REAL(wp), DIMENSION(A2D_T(ktdep) ), INTENT(in ) :: pdep ! depth [m]
- REAL(wp), DIMENSION(A2D_T(ktrd) ), INTENT( out) :: prd ! in situ density
+ INTEGER, DIMENSION(2) , INTENT(in ) :: ktts, ktdep, ktrd
+ INTEGER , INTENT(in ) :: kbnd ! number of halo points to calculate
+ REAL(wp), DIMENSION(AB2D(ktts),JPTS), INTENT(in ) :: pts ! 1 : potential temperature [Celsius]
+ ! ! 2 : salinity [psu]
+ REAL(wp), DIMENSION(AB2D(ktdep) ), INTENT(in ) :: pdep ! depth [m]
+ REAL(wp), DIMENSION(AB2D(ktrd) ), INTENT( out) :: prd ! in situ density
!
INTEGER :: ji, jj, jk ! dummy loop indices
REAL(wp) :: zt , zh , zs ! local scalars
@@ -621,7 +900,7 @@ CONTAINS
!
CASE( np_teos10, np_eos80 ) !== polynomial TEOS-10 / EOS-80 ==!
!
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( kbnd, kbnd, kbnd, kbnd )
!
zh = pdep(ji,jj) * r1_Z0 ! depth
zt = pts (ji,jj,jp_tem) * r1_T0 ! temperature
@@ -656,10 +935,10 @@ CONTAINS
!
CASE( np_seos ) !== simplified EOS ==!
!
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( kbnd, kbnd, kbnd, kbnd )
!
- zt = pts (ji,jj,jp_tem) - 10._wp
- zs = pts (ji,jj,jp_sal) - 35._wp
+ zt = pts (ji,jj,jp_tem) - rn_T0
+ zs = pts (ji,jj,jp_sal) - rn_S0
zh = pdep (ji,jj) ! depth at the partial step level
!
zn = - rn_a0 * ( 1._wp + 0.5_wp*rn_lambda1*zt + rn_mu1*zh ) * zt &
@@ -679,17 +958,22 @@ CONTAINS
END SUBROUTINE eos_insitu_2d_t
- SUBROUTINE eos_insitu_pot_2d( pts, prhop )
+ SUBROUTINE eos_insitu_pot_2d( pts, prhop, kbnd )
!!
REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: pts ! 1 : potential temperature [Celsius]
! ! 2 : salinity [psu]
REAL(wp), DIMENSION(:,:) , INTENT( out) :: prhop ! potential density (surface referenced)
+ INTEGER, OPTIONAL, INTENT(in ) :: kbnd ! number of halo points to calculate
+ !
+ INTEGER :: ibnd
!!
- CALL eos_insitu_pot_2d_t( pts, is_tile(pts), prhop, is_tile(prhop) )
+ ibnd = nn_hls
+ IF( PRESENT(kbnd) ) ibnd = kbnd
+ CALL eos_insitu_pot_2d_t( pts, lbnd_ij(pts), prhop, lbnd_ij(prhop), ibnd )
END SUBROUTINE eos_insitu_pot_2d
- SUBROUTINE eos_insitu_pot_2d_t( pts, ktts, prhop, ktrhop )
+ SUBROUTINE eos_insitu_pot_2d_t( pts, ktts, prhop, ktrhop, kbnd )
!!----------------------------------------------------------------------
!! *** ROUTINE eos_insitu_pot ***
!!
@@ -702,10 +986,11 @@ CONTAINS
!! - prhop, the potential volumic mass (Kg/m3)
!!
!!----------------------------------------------------------------------
- INTEGER , INTENT(in ) :: ktts, ktrhop
- REAL(wp), DIMENSION(A2D_T(ktts),JPTS), INTENT(in ) :: pts ! 1 : potential temperature [Celsius]
- ! ! 2 : salinity [psu]
- REAL(wp), DIMENSION(A2D_T(ktrhop) ), INTENT( out) :: prhop ! potential density (surface referenced)
+ INTEGER, DIMENSION(2) , INTENT(in ) :: ktts, ktrhop
+ INTEGER , INTENT(in ) :: kbnd ! number of halo points to calculate
+ REAL(wp), DIMENSION(AB2D(ktts),JPTS), INTENT(in ) :: pts ! 1 : potential temperature [Celsius]
+ ! ! 2 : salinity [psu]
+ REAL(wp), DIMENSION(AB2D(ktrhop) ), INTENT( out) :: prhop ! potential density (surface referenced)
!
INTEGER :: ji, jj, jk, jsmp ! dummy loop indices
INTEGER :: jdof
@@ -720,7 +1005,7 @@ CONTAINS
!
CASE( np_teos10, np_eos80 ) !== polynomial TEOS-10 / EOS-80 ==!
!
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( kbnd, kbnd, kbnd, kbnd )
!
zt = pts (ji,jj,jp_tem) * r1_T0 ! temperature
zs = SQRT( ABS( pts(ji,jj,jp_sal) + rdeltaS ) * r1_S0 ) ! square root salinity
@@ -741,9 +1026,9 @@ CONTAINS
CASE( np_seos ) !== simplified EOS ==!
!
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
- zt = pts (ji,jj,jp_tem) - 10._wp
- zs = pts (ji,jj,jp_sal) - 35._wp
+ DO_2D( kbnd, kbnd, kbnd, kbnd )
+ zt = pts (ji,jj,jp_tem) - rn_T0
+ zs = pts (ji,jj,jp_sal) - rn_S0
ztm = tmask(ji,jj,1)
! ! potential density referenced at the surface
zn = - rn_a0 * ( 1._wp + 0.5_wp*rn_lambda1*zt ) * zt &
@@ -763,17 +1048,23 @@ CONTAINS
END SUBROUTINE eos_insitu_pot_2d_t
- SUBROUTINE rab_3d( pts, pab, Kmm )
+ SUBROUTINE rab_3d( pts, pab, Kmm, kbnd )
!!
- INTEGER , INTENT(in ) :: Kmm ! time level index
- REAL(wp), DIMENSION(:,:,:,:), INTENT(in ) :: pts ! pot. temperature & salinity
- REAL(wp), DIMENSION(:,:,:,:), INTENT( out) :: pab ! thermal/haline expansion ratio
+ INTEGER , INTENT(in ) :: Kmm ! time level index
+ REAL(wp), DIMENSION(:,:,:,:), INTENT(in ) :: pts ! pot. temperature & salinity
+ REAL(wp), DIMENSION(:,:,:,:), INTENT( out) :: pab ! thermal/haline expansion ratio
+ INTEGER, INTENT(in ), OPTIONAL :: kbnd ! number of halo points to calculate
+ !
+ INTEGER :: ibnd
!!
- CALL rab_3d_t( pts, is_tile(pts), pab, is_tile(pab), Kmm )
+ ibnd = nn_hls
+ IF( PRESENT(kbnd) ) ibnd = kbnd
+
+ CALL rab_3d_t( pts, lbnd_ij(pts), pab, lbnd_ij(pab), Kmm, ibnd )
END SUBROUTINE rab_3d
- SUBROUTINE rab_3d_t( pts, ktts, pab, ktab, Kmm )
+ SUBROUTINE rab_3d_t( pts, ktts, pab, ktab, Kmm, kbnd )
!!----------------------------------------------------------------------
!! *** ROUTINE rab_3d ***
!!
@@ -783,10 +1074,11 @@ CONTAINS
!!
!! ** Action : - pab : thermal/haline expansion ratio at T-points
!!----------------------------------------------------------------------
- INTEGER , INTENT(in ) :: Kmm ! time level index
- INTEGER , INTENT(in ) :: ktts, ktab
- REAL(wp), DIMENSION(A2D_T(ktts),JPK,JPTS), INTENT(in ) :: pts ! pot. temperature & salinity
- REAL(wp), DIMENSION(A2D_T(ktab),JPK,JPTS), INTENT( out) :: pab ! thermal/haline expansion ratio
+ INTEGER , INTENT(in ) :: Kmm ! time level index
+ INTEGER, DIMENSION(2) , INTENT(in ) :: ktts, ktab
+ INTEGER, INTENT(in ) :: kbnd ! number of halo points to calculate
+ REAL(wp), DIMENSION(AB2D(ktts),JPK,JPTS), INTENT(in ) :: pts ! pot. temperature & salinity
+ REAL(wp), DIMENSION(AB2D(ktab),JPK,JPTS), INTENT( out) :: pab ! thermal/haline expansion ratio
!
INTEGER :: ji, jj, jk ! dummy loop indices
REAL(wp) :: zt , zh , zs , ztm ! local scalars
@@ -799,7 +1091,7 @@ CONTAINS
!
CASE( np_teos10, np_eos80 ) !== polynomial TEOS-10 / EOS-80 ==!
!
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 )
+ DO_3D( kbnd, kbnd, kbnd, kbnd, 1, jpkm1 )
!
zh = gdept(ji,jj,jk,Kmm) * r1_Z0 ! depth
zt = pts (ji,jj,jk,jp_tem) * r1_T0 ! temperature
@@ -852,9 +1144,9 @@ CONTAINS
!
CASE( np_seos ) !== simplified EOS ==!
!
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 )
- zt = pts (ji,jj,jk,jp_tem) - 10._wp ! pot. temperature anomaly (t-T0)
- zs = pts (ji,jj,jk,jp_sal) - 35._wp ! abs. salinity anomaly (s-S0)
+ DO_3D( kbnd, kbnd, kbnd, kbnd, 1, jpkm1 )
+ zt = pts (ji,jj,jk,jp_tem) - rn_T0 ! pot. temperature anomaly (t-T0)
+ zs = pts (ji,jj,jk,jp_sal) - rn_S0 ! abs. salinity anomaly (s-S0)
zh = gdept(ji,jj,jk,Kmm) ! depth in meters at t-point
ztm = tmask(ji,jj,jk) ! land/sea bottom mask = surf. mask
!
@@ -880,18 +1172,24 @@ CONTAINS
END SUBROUTINE rab_3d_t
- SUBROUTINE rab_2d( pts, pdep, pab, Kmm )
+ SUBROUTINE rab_2d( pts, pdep, pab, Kmm, kbnd )
!!
- INTEGER , INTENT(in ) :: Kmm ! time level index
- REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: pts ! pot. temperature & salinity
- REAL(wp), DIMENSION(:,:) , INTENT(in ) :: pdep ! depth [m]
- REAL(wp), DIMENSION(:,:,:), INTENT( out) :: pab ! thermal/haline expansion ratio
+ INTEGER , INTENT(in ) :: Kmm ! time level index
+ REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: pts ! pot. temperature & salinity
+ REAL(wp), DIMENSION(:,:) , INTENT(in ) :: pdep ! depth [m]
+ REAL(wp), DIMENSION(:,:,:), INTENT( out) :: pab ! thermal/haline expansion ratio
+ INTEGER, INTENT(in ), OPTIONAL :: kbnd ! number of halo points to calculate
+ !
+ INTEGER :: ibnd
!!
- CALL rab_2d_t(pts, is_tile(pts), pdep, is_tile(pdep), pab, is_tile(pab), Kmm)
+ ibnd = nn_hls
+ IF( PRESENT(kbnd) ) ibnd = kbnd
+
+ CALL rab_2d_t( pts, lbnd_ij(pts), pdep, lbnd_ij(pdep), pab, lbnd_ij(pab), Kmm, ibnd )
END SUBROUTINE rab_2d
- SUBROUTINE rab_2d_t( pts, ktts, pdep, ktdep, pab, ktab, Kmm )
+ SUBROUTINE rab_2d_t( pts, ktts, pdep, ktdep, pab, ktab, Kmm, kbnd )
!!----------------------------------------------------------------------
!! *** ROUTINE rab_2d ***
!!
@@ -899,11 +1197,12 @@ CONTAINS
!!
!! ** Action : - pab : thermal/haline expansion ratio at T-points
!!----------------------------------------------------------------------
- INTEGER , INTENT(in ) :: Kmm ! time level index
- INTEGER , INTENT(in ) :: ktts, ktdep, ktab
- REAL(wp), DIMENSION(A2D_T(ktts),JPTS), INTENT(in ) :: pts ! pot. temperature & salinity
- REAL(wp), DIMENSION(A2D_T(ktdep) ), INTENT(in ) :: pdep ! depth [m]
- REAL(wp), DIMENSION(A2D_T(ktab),JPTS), INTENT( out) :: pab ! thermal/haline expansion ratio
+ INTEGER , INTENT(in ) :: Kmm ! time level index
+ INTEGER, DIMENSION(2) , INTENT(in ) :: ktts, ktdep, ktab
+ INTEGER, INTENT(in ) :: kbnd ! number of halo points to calculate
+ REAL(wp), DIMENSION(AB2D(ktts),JPTS), INTENT(in ) :: pts ! pot. temperature & salinity
+ REAL(wp), DIMENSION(AB2D(ktdep) ), INTENT(in ) :: pdep ! depth [m]
+ REAL(wp), DIMENSION(AB2D(ktab),JPTS), INTENT( out) :: pab ! thermal/haline expansion ratio
!
INTEGER :: ji, jj, jk ! dummy loop indices
REAL(wp) :: zt , zh , zs ! local scalars
@@ -918,7 +1217,7 @@ CONTAINS
!
CASE( np_teos10, np_eos80 ) !== polynomial TEOS-10 / EOS-80 ==!
!
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( kbnd, kbnd, kbnd, kbnd )
!
zh = pdep(ji,jj) * r1_Z0 ! depth
zt = pts (ji,jj,jp_tem) * r1_T0 ! temperature
@@ -971,11 +1270,11 @@ CONTAINS
!
CASE( np_seos ) !== simplified EOS ==!
!
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( kbnd, kbnd, kbnd, kbnd )
!
- zt = pts (ji,jj,jp_tem) - 10._wp ! pot. temperature anomaly (t-T0)
- zs = pts (ji,jj,jp_sal) - 35._wp ! abs. salinity anomaly (s-S0)
- zh = pdep (ji,jj) ! depth at the partial step level
+ zt = pts (ji,jj,jp_tem) - rn_T0 ! pot. temperature anomaly (t-T0)
+ zs = pts (ji,jj,jp_sal) - rn_S0 ! abs. salinity anomaly (s-S0)
+ zh = pdep (ji,jj) ! depth at the partial step level
!
zn = rn_a0 * ( 1._wp + rn_lambda1*zt + rn_mu1*zh ) + rn_nu*zs
pab(ji,jj,jp_tem) = zn * r1_rho0 ! alpha
@@ -1075,9 +1374,9 @@ CONTAINS
!
CASE( np_seos ) !== simplified EOS ==!
!
- zt = pts(jp_tem) - 10._wp ! pot. temperature anomaly (t-T0)
- zs = pts(jp_sal) - 35._wp ! abs. salinity anomaly (s-S0)
- zh = pdep ! depth at the partial step level
+ zt = pts(jp_tem) - rn_T0 ! pot. temperature anomaly (t-T0)
+ zs = pts(jp_sal) - rn_S0 ! abs. salinity anomaly (s-S0)
+ zh = pdep ! depth at the partial step level
!
zn = rn_a0 * ( 1._wp + rn_lambda1*zt + rn_mu1*zh ) + rn_nu*zs
pab(jp_tem) = zn * r1_rho0 ! alpha
@@ -1096,18 +1395,24 @@ CONTAINS
END SUBROUTINE rab_0d
- SUBROUTINE bn2( pts, pab, pn2, Kmm )
+ SUBROUTINE bn2( pts, pab, pn2, Kmm, kbnd )
!!
- INTEGER , INTENT(in ) :: Kmm ! time level index
- REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in ) :: pts ! pot. temperature and salinity [Celsius,psu]
- REAL(wp), DIMENSION(:,:,:,:) , INTENT(in ) :: pab ! thermal/haline expansion coef. [Celsius-1,psu-1]
- REAL(wp), DIMENSION(:,:,:) , INTENT( out) :: pn2 ! Brunt-Vaisala frequency squared [1/s^2]
+ INTEGER , INTENT(in ) :: Kmm ! time level index
+ REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in ) :: pts ! pot. temperature and salinity [Celsius,psu]
+ REAL(wp), DIMENSION(:,:,:,:) , INTENT(in ) :: pab ! thermal/haline expansion coef. [Celsius-1,psu-1]
+ REAL(wp), DIMENSION(:,:,:) , INTENT( out) :: pn2 ! Brunt-Vaisala frequency squared [1/s^2]
+ INTEGER, INTENT(in ), OPTIONAL :: kbnd ! number of halo points to calculate
+ !
+ INTEGER :: ibnd
!!
- CALL bn2_t( pts, pab, is_tile(pab), pn2, is_tile(pn2), Kmm )
+ ibnd = nn_hls
+ IF( PRESENT(kbnd) ) ibnd = kbnd
+
+ CALL bn2_t( pts, pab, lbnd_ij(pab), pn2, lbnd_ij(pn2), Kmm, ibnd )
END SUBROUTINE bn2
- SUBROUTINE bn2_t( pts, pab, ktab, pn2, ktn2, Kmm )
+ SUBROUTINE bn2_t( pts, pab, ktab, pn2, ktn2, Kmm, kbnd )
!!----------------------------------------------------------------------
!! *** ROUTINE bn2 ***
!!
@@ -1121,11 +1426,12 @@ CONTAINS
!! ** Action : pn2 : square of the brunt-vaisala frequency at w-point
!!
!!----------------------------------------------------------------------
- INTEGER , INTENT(in ) :: Kmm ! time level index
- INTEGER , INTENT(in ) :: ktab, ktn2
- REAL(wp), DIMENSION(jpi,jpj, jpk,jpts), INTENT(in ) :: pts ! pot. temperature and salinity [Celsius,psu]
- REAL(wp), DIMENSION(A2D_T(ktab),JPK,JPTS), INTENT(in ) :: pab ! thermal/haline expansion coef. [Celsius-1,psu-1]
- REAL(wp), DIMENSION(A2D_T(ktn2),JPK ), INTENT( out) :: pn2 ! Brunt-Vaisala frequency squared [1/s^2]
+ INTEGER , INTENT(in ) :: Kmm ! time level index
+ INTEGER, DIMENSION(2) , INTENT(in ) :: ktab, ktn2
+ INTEGER, INTENT(in ) :: kbnd ! number of halo points to calculate
+ REAL(wp), DIMENSION(jpi,jpj,jpk,jpts) , INTENT(in ) :: pts ! pot. temperature and salinity [Celsius,psu]
+ REAL(wp), DIMENSION(AB2D(ktab),JPK,JPTS), INTENT(in ) :: pab ! thermal/haline expansion coef. [Celsius-1,psu-1]
+ REAL(wp), DIMENSION(AB2D(ktn2),JPK ), INTENT( out) :: pn2 ! Brunt-Vaisala frequency squared [1/s^2]
!
INTEGER :: ji, jj, jk ! dummy loop indices
REAL(wp) :: zaw, zbw, zrw ! local scalars
@@ -1133,7 +1439,7 @@ CONTAINS
!
IF( ln_timing ) CALL timing_start('bn2')
!
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 2, jpkm1 ) ! interior points only (2=< jk =< jpkm1 ); surface and bottom value set to zero one for all in istate.F90
+ DO_3D( kbnd, kbnd, kbnd, kbnd, 2, jpkm1 ) ! interior points only (2=< jk =< jpkm1 ); surface and bottom value set to zero one for all in istate.F90
zrw = ( gdepw(ji,jj,jk ,Kmm) - gdept(ji,jj,jk,Kmm) ) &
& / ( gdept(ji,jj,jk-1,Kmm) - gdept(ji,jj,jk,Kmm) )
!
@@ -1152,7 +1458,23 @@ CONTAINS
END SUBROUTINE bn2_t
- FUNCTION eos_pt_from_ct( ctmp, psal ) RESULT( ptmp )
+ SUBROUTINE eos_pt_from_ct( ctmp, psal, ptmp, kbnd )
+ !!
+ REAL(wp), DIMENSION(:,:), INTENT(in ) :: ctmp ! Cons. Temp [Celsius]
+ REAL(wp), DIMENSION(:,:), INTENT(in ) :: psal ! salinity [psu]
+ REAL(wp), DIMENSION(:,:), INTENT(out) :: ptmp ! Pot. Temp [Celsius]
+ INTEGER, INTENT(in ), OPTIONAL :: kbnd ! number of halo points to calculate
+ !
+ INTEGER :: ibnd
+ !!
+ ibnd = nn_hls
+ IF( PRESENT(kbnd) ) ibnd = kbnd
+
+ CALL eos_pt_from_ct_t( ctmp, psal, lbnd_ij(psal), ptmp, lbnd_ij(ptmp), ibnd )
+ END SUBROUTINE eos_pt_from_ct
+
+
+ SUBROUTINE eos_pt_from_ct_t( ctmp, psal, ktpsal, ptmp, ktptmp, kbnd )
!!----------------------------------------------------------------------
!! *** ROUTINE eos_pt_from_ct ***
!!
@@ -1164,10 +1486,11 @@ CONTAINS
!! Reference : TEOS-10, UNESCO
!! Rational approximation to TEOS10 algorithm (rms error on WOA13 values: 4.0e-5 degC)
!!----------------------------------------------------------------------
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: ctmp ! Cons. Temp [Celsius]
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: psal ! salinity [psu]
- ! Leave result array automatic rather than making explicitly allocated
- REAL(wp), DIMENSION(jpi,jpj) :: ptmp ! potential temperature [Celsius]
+ INTEGER, DIMENSION(2), INTENT(in ) :: ktpsal, ktptmp
+ INTEGER, INTENT(in ) :: kbnd ! number of halo points to calculate
+ REAL(wp), DIMENSION(AB2D(ktpsal)), INTENT(in ) :: ctmp ! Cons. Temp [Celsius]
+ REAL(wp), DIMENSION(AB2D(ktpsal)), INTENT(in ) :: psal ! salinity [psu]
+ REAL(wp), DIMENSION(AB2D(ktptmp)), INTENT(out) :: ptmp ! Pot. Temp [Celsius]
!
INTEGER :: ji, jj ! dummy loop indices
REAL(wp) :: zt , zs , ztm ! local scalars
@@ -1181,7 +1504,7 @@ CONTAINS
z1_S0 = 0.875_wp/35.16504_wp
z1_T0 = 1._wp/40._wp
!
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( kbnd, kbnd, kbnd, kbnd )
!
zt = ctmp (ji,jj) * z1_T0
zs = SQRT( ABS( psal(ji,jj) + zdeltaS ) * z1_S0 )
@@ -1206,20 +1529,109 @@ CONTAINS
!
IF( ln_timing ) CALL timing_stop('eos_pt_from_ct')
!
- END FUNCTION eos_pt_from_ct
+ END SUBROUTINE eos_pt_from_ct_t
- SUBROUTINE eos_fzp_2d( psal, ptf, pdep )
+ SUBROUTINE eos_fzp_3d( psal, ptf, pdep, kbnd )
!!
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: psal ! salinity [psu]
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in ), OPTIONAL :: pdep ! depth [m]
- REAL(wp), DIMENSION(:,:) , INTENT(out ) :: ptf ! freezing temperature [Celsius]
+ REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: psal ! salinity [psu]
+ REAL(wp), DIMENSION(:,:,:), INTENT(in ), OPTIONAL :: pdep ! depth [m]
+ REAL(wp), DIMENSION(:,:,:), INTENT( out) :: ptf ! freezing temperature [Celsius]
+ INTEGER, INTENT(in ), OPTIONAL :: kbnd ! number of halo points to calculate
+ !
+ INTEGER :: ibnd
+ INTEGER, DIMENSION(2) :: itdep
!!
- CALL eos_fzp_2d_t( psal, ptf, is_tile(ptf), pdep )
+ ibnd = nn_hls
+ IF( PRESENT(kbnd) ) ibnd = kbnd
+ IF( PRESENT(pdep) ) THEN ; itdep = lbnd_ij(pdep) ; ELSE ; itdep(:) = 1 ; ENDIF
+
+ CALL eos_fzp_3d_t( psal, lbnd_ij(psal), ptf, lbnd_ij(ptf), pdep, itdep, ibnd )
+ END SUBROUTINE eos_fzp_3d
+
+
+ SUBROUTINE eos_fzp_3d_t( psal, ktsal, ptf, kttf, pdep, ktdep, kbnd )
+ !!----------------------------------------------------------------------
+ !! *** ROUTINE eos_fzp ***
+ !!
+ !! ** Purpose : Compute the freezing point temperature [Celsius]
+ !!
+ !! ** Method : UNESCO freezing point (ptf) in Celsius is given by
+ !! ptf(t,z) = (-.0575+1.710523e-3*sqrt(abs(s))-2.154996e-4*s)*s - 7.53e-4*z
+ !! checkvalue: tf=-2.588567 Celsius for s=40psu, z=500m
+ !!
+ !! Reference : UNESCO tech. papers in the marine science no. 28. 1978
+ !!----------------------------------------------------------------------
+ INTEGER, DIMENSION(2), INTENT(in ) :: ktsal, kttf, ktdep
+ INTEGER, INTENT(in ) :: kbnd ! number of halo points to calculate
+ REAL(wp), DIMENSION(AB2D(ktsal),JPK), INTENT(in ) :: psal ! salinity [psu]
+ REAL(wp), DIMENSION(AB2D(ktdep),JPK), INTENT(in ), OPTIONAL :: pdep ! depth [m]
+ REAL(wp), DIMENSION(AB2D(kttf ),JPK), INTENT( out) :: ptf ! freezing temperature [Celsius]
+ !
+ INTEGER :: ji, jj, jk ! dummy loop indices
+ REAL(wp) :: zs, z1_S0 ! local scalars
+ !!----------------------------------------------------------------------
+ !
+ SELECT CASE ( neos )
+ !
+ CASE ( np_teos10, np_seos ) !== CT,SA (TEOS-10 and S-EOS formulations) ==!
+ !
+ z1_S0 = 1._wp / 35.16504_wp
+ DO_3D( kbnd, kbnd, kbnd, kbnd, 1, jpk )
+ zs= SQRT( ABS( psal(ji,jj,jk) ) * z1_S0 ) ! square root salinity
+ ptf(ji,jj,jk) = ((((1.46873e-03_wp * zs - 9.64972e-03_wp) &
+ & * zs + 2.28348e-02_wp) * zs - 3.12775e-02_wp) &
+ & * zs + 2.07679e-02_wp) * zs - 5.87701e-02_wp
+ ptf(ji,jj,jk) = ptf(ji,jj,jk) * psal(ji,jj,jk)
+ END_3D
+ !
+ IF( PRESENT( pdep ) ) THEN
+ DO_3D( kbnd, kbnd, kbnd, kbnd, 1, jpk )
+ ptf(ji,jj,jk) = ptf(ji,jj,jk) - 7.53e-4 * pdep(ji,jj,jk)
+ END_3D
+ ENDIF
+ !
+ CASE ( np_eos80 ) !== PT,SP (UNESCO formulation) ==!
+ !
+ DO_3D( kbnd, kbnd, kbnd, kbnd, 1, jpk )
+ ptf(ji,jj,jk) = ( - 0.0575_wp + 1.710523e-3_wp * SQRT( psal(ji,jj,jk) ) &
+ & - 2.154996e-4_wp * psal(ji,jj,jk) ) * psal(ji,jj,jk)
+ END_3D
+ !
+ IF( PRESENT( pdep ) ) THEN
+ DO_3D( kbnd, kbnd, kbnd, kbnd, 1, jpk )
+ ptf(ji,jj,jk) = ptf(ji,jj,jk) - 7.53e-4 * pdep(ji,jj,jk)
+ END_3D
+ ENDIF
+ !
+ CASE DEFAULT
+ WRITE(ctmp1,*) ' bad flag value for neos = ', neos
+ CALL ctl_stop( 'eos_fzp_3d:', ctmp1 )
+ !
+ END SELECT
+ !
+ END SUBROUTINE eos_fzp_3d_t
+
+
+ SUBROUTINE eos_fzp_2d( psal, ptf, pdep, kbnd )
+ !!
+ REAL(wp), DIMENSION(:,:), INTENT(in ) :: psal ! salinity [psu]
+ REAL(wp), DIMENSION(:,:), INTENT(in ), OPTIONAL :: pdep ! depth [m]
+ REAL(wp), DIMENSION(:,:), INTENT( out) :: ptf ! freezing temperature [Celsius]
+ INTEGER, INTENT(in ), OPTIONAL :: kbnd ! number of halo points to calculate
+ !
+ INTEGER :: ibnd
+ INTEGER, DIMENSION(2) :: itdep
+ !!
+ ibnd = nn_hls
+ IF( PRESENT(kbnd) ) ibnd = kbnd
+ IF( PRESENT(pdep) ) THEN ; itdep = lbnd_ij(pdep) ; ELSE ; itdep(:) = 1 ; ENDIF
+
+ CALL eos_fzp_2d_t( psal, lbnd_ij(psal), ptf, lbnd_ij(ptf), pdep, itdep, ibnd )
END SUBROUTINE eos_fzp_2d
- SUBROUTINE eos_fzp_2d_t( psal, ptf, kttf, pdep )
+ SUBROUTINE eos_fzp_2d_t( psal, ktsal, ptf, kttf, pdep, ktdep, kbnd )
!!----------------------------------------------------------------------
!! *** ROUTINE eos_fzp ***
!!
@@ -1231,13 +1643,14 @@ CONTAINS
!!
!! Reference : UNESCO tech. papers in the marine science no. 28. 1978
!!----------------------------------------------------------------------
- INTEGER , INTENT(in ) :: kttf
- REAL(wp), DIMENSION(jpi,jpj) , INTENT(in ) :: psal ! salinity [psu]
- REAL(wp), DIMENSION(jpi,jpj) , INTENT(in ), OPTIONAL :: pdep ! depth [m]
- REAL(wp), DIMENSION(A2D_T(kttf)), INTENT(out ) :: ptf ! freezing temperature [Celsius]
+ INTEGER, DIMENSION(2), INTENT(in ) :: ktsal, kttf, ktdep
+ INTEGER, INTENT(in ) :: kbnd ! number of halo points to calculate
+ REAL(wp), DIMENSION(AB2D(ktsal)), INTENT(in ) :: psal ! salinity [psu]
+ REAL(wp), DIMENSION(AB2D(ktdep)), INTENT(in ), OPTIONAL :: pdep ! depth [m]
+ REAL(wp), DIMENSION(AB2D(kttf)), INTENT( out) :: ptf ! freezing temperature [Celsius]
!
INTEGER :: ji, jj ! dummy loop indices
- REAL(wp) :: zt, zs, z1_S0 ! local scalars
+ REAL(wp) :: zs, z1_S0 ! local scalars
!!----------------------------------------------------------------------
!
SELECT CASE ( neos )
@@ -1245,21 +1658,32 @@ CONTAINS
CASE ( np_teos10, np_seos ) !== CT,SA (TEOS-10 and S-EOS formulations) ==!
!
z1_S0 = 1._wp / 35.16504_wp
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
- zs= SQRT( ABS( psal(ji,jj) ) * z1_S0 ) ! square root salinity
- ptf(ji,jj) = ((((1.46873e-03_wp*zs-9.64972e-03_wp)*zs+2.28348e-02_wp)*zs &
- & - 3.12775e-02_wp)*zs+2.07679e-02_wp)*zs-5.87701e-02_wp
+ DO_2D( kbnd, kbnd, kbnd, kbnd )
+ zs = SQRT( ABS( psal(ji,jj) ) * z1_S0 ) ! square root salinity
+ ptf(ji,jj) = ((((1.46873e-03_wp * zs - 9.64972e-03_wp) &
+ & * zs + 2.28348e-02_wp) * zs - 3.12775e-02_wp) &
+ & * zs + 2.07679e-02_wp) * zs - 5.87701e-02_wp
+ ptf(ji,jj) = ptf(ji,jj) * psal(ji,jj)
END_2D
- ptf(:,:) = ptf(:,:) * psal(:,:)
!
- IF( PRESENT( pdep ) ) ptf(:,:) = ptf(:,:) - 7.53e-4 * pdep(:,:)
+ IF( PRESENT( pdep ) ) THEN
+ DO_2D( kbnd, kbnd, kbnd, kbnd )
+ ptf(ji,jj) = ptf(ji,jj) - 7.53e-4 * pdep(ji,jj)
+ END_2D
+ ENDIF
!
CASE ( np_eos80 ) !== PT,SP (UNESCO formulation) ==!
!
- ptf(:,:) = ( - 0.0575_wp + 1.710523e-3_wp * SQRT( psal(:,:) ) &
- & - 2.154996e-4_wp * psal(:,:) ) * psal(:,:)
- !
- IF( PRESENT( pdep ) ) ptf(:,:) = ptf(:,:) - 7.53e-4 * pdep(:,:)
+ DO_2D( kbnd, kbnd, kbnd, kbnd )
+ ptf(ji,jj) = ( - 0.0575_wp + 1.710523e-3_wp * SQRT( psal(ji,jj) ) &
+ & - 2.154996e-4_wp * psal(ji,jj) ) * psal(ji,jj)
+ END_2D
+ !
+ IF( PRESENT( pdep ) ) THEN
+ DO_2D( kbnd, kbnd, kbnd, kbnd )
+ ptf(ji,jj) = ptf(ji,jj) - 7.53e-4 * pdep(ji,jj)
+ END_2D
+ ENDIF
!
CASE DEFAULT
WRITE(ctmp1,*) ' bad flag value for neos = ', neos
@@ -1267,10 +1691,10 @@ CONTAINS
!
END SELECT
!
- END SUBROUTINE eos_fzp_2d_t
+ END SUBROUTINE eos_fzp_2d_t
- SUBROUTINE eos_fzp_0d( psal, ptf, pdep )
+ SUBROUTINE eos_fzp_0d( psal, ptf, pdep )
!!----------------------------------------------------------------------
!! *** ROUTINE eos_fzp ***
!!
@@ -1336,10 +1760,10 @@ CONTAINS
!! pab_pe(:,:,:,jp_tem) is alpha_pe
!! pab_pe(:,:,:,jp_sal) is beta_pe
!!----------------------------------------------------------------------
- INTEGER , INTENT(in ) :: Kmm ! time level index
+ INTEGER , INTENT(in ) :: Kmm ! time level index
REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in ) :: pts ! pot. temperature & salinity
- REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT( out) :: pab_pe ! alpha_pe and beta_pe
- REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT( out) :: ppen ! potential energy anomaly
+ REAL(wp), DIMENSION(T2D(0),jpk,jpts) , INTENT( out) :: pab_pe ! alpha_pe and beta_pe
+ REAL(wp), DIMENSION(T2D(0),jpk) , INTENT( out) :: ppen ! potential energy anomaly
!
INTEGER :: ji, jj, jk ! dummy loop indices
REAL(wp) :: zt , zh , zs , ztm ! local scalars
@@ -1352,7 +1776,7 @@ CONTAINS
!
CASE( np_teos10, np_eos80 ) !== polynomial TEOS-10 / EOS-80 ==!
!
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
!
zh = gdept(ji,jj,jk,Kmm) * r1_Z0 ! depth
zt = pts (ji,jj,jk,jp_tem) * r1_T0 ! temperature
@@ -1411,11 +1835,11 @@ CONTAINS
!
CASE( np_seos ) !== Vallis (2006) simplified EOS ==!
!
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 )
- zt = pts(ji,jj,jk,jp_tem) - 10._wp ! temperature anomaly (t-T0)
- zs = pts (ji,jj,jk,jp_sal) - 35._wp ! abs. salinity anomaly (s-S0)
- zh = gdept(ji,jj,jk,Kmm) ! depth in meters at t-point
- ztm = tmask(ji,jj,jk) ! tmask
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
+ zt = pts (ji,jj,jk,jp_tem) - rn_T0 ! temperature anomaly (t-T0)
+ zs = pts (ji,jj,jk,jp_sal) - rn_S0 ! abs. salinity anomaly (s-S0)
+ zh = gdept(ji,jj,jk,Kmm) ! depth in meters at t-point
+ ztm = tmask(ji,jj,jk) ! tmask
zn = 0.5_wp * zh * r1_rho0 * ztm
! ! Potential Energy
ppen(ji,jj,jk) = ( rn_a0 * rn_mu1 * zt + rn_b0 * rn_mu2 * zs ) * zn
@@ -1447,8 +1871,8 @@ CONTAINS
INTEGER :: ios ! local integer
INTEGER :: ioptio ! local integer
!!
- NAMELIST/nameos/ ln_TEOS10, ln_EOS80, ln_SEOS, rn_a0, rn_b0, rn_lambda1, rn_mu1, &
- & rn_lambda2, rn_mu2, rn_nu
+ NAMELIST/nameos/ ln_TEOS10, ln_EOS80, ln_SEOS, rn_T0, rn_S0, rn_a0, rn_b0, rn_lambda1, rn_mu1, &
+ & rn_lambda2, rn_mu2, rn_nu
!!----------------------------------------------------------------------
!
READ ( numnam_ref, nameos, IOSTAT = ios, ERR = 901 )
@@ -1869,9 +2293,11 @@ CONTAINS
IF(lwp) THEN
WRITE(numout,*)
WRITE(numout,*) ' ==>>> use of simplified eos: '
- WRITE(numout,*) ' rhd(dT=T-10,dS=S-35,Z) = [-a0*(1+lambda1/2*dT+mu1*Z)*dT '
- WRITE(numout,*) ' + b0*(1+lambda2/2*dT+mu2*Z)*dS - nu*dT*dS] / rho0'
+ WRITE(numout,*) ' rhd(dT=T-rn_T0,dS=S-rn_S0,Z) = [-a0*(1+lambda1/2*dT+mu1*Z)*dT '
+ WRITE(numout,*) ' + b0*(1+lambda2/2*dT+mu2*Z)*dS - nu*dT*dS] / rho0'
WRITE(numout,*) ' with the following coefficients :'
+ WRITE(numout,*) ' reference temperature rn_T0 = ', rn_T0
+ WRITE(numout,*) ' reference salinity rn_S0 = ', rn_S0
WRITE(numout,*) ' thermal exp. coef. rn_a0 = ', rn_a0
WRITE(numout,*) ' saline cont. coef. rn_b0 = ', rn_b0
WRITE(numout,*) ' cabbeling coef. rn_lambda1 = ', rn_lambda1
diff --git a/src/OCE/TRA/traadv.F90 b/src/OCE/TRA/traadv.F90
index d8bd85cb4e67bf7833e899dd34de65448ff0d181..1c7e49d67fa59f8db9e2df46e5a131da11cd7f60 100644
--- a/src/OCE/TRA/traadv.F90
+++ b/src/OCE/TRA/traadv.F90
@@ -10,6 +10,7 @@ MODULE traadv
!! - ! 2014-12 (G. Madec) suppression of cross land advection option
!! 3.6 ! 2015-06 (E. Clementi) Addition of Stokes drift in case of wave coupling
!! 4.5 ! 2021-04 (G. Madec, S. Techene) add advective velocities as optional arguments
+ !! 4.5 ! 2022-06 (S. Techene, G, Madec) refactorization to reduce local memory usage
!!----------------------------------------------------------------------
!!----------------------------------------------------------------------
@@ -20,7 +21,6 @@ MODULE traadv
USE dom_oce ! ocean space and time domain
! TEMP: [tiling] This change not necessary after all lbc_lnks removed in the nn_hls = 2 case in tra_adv_fct
USE domtile
- USE domvvl ! variable vertical scale factors
USE sbcwave ! wave module
USE sbc_oce ! surface boundary condition: ocean
USE traadv_cen ! centered scheme (tra_adv_cen routine)
@@ -93,9 +93,8 @@ CONTAINS
!
INTEGER :: ji, jj, jk ! dummy loop index
REAL(wp), DIMENSION(:,:,:), POINTER :: zptu, zptv, zptw
- ! TEMP: [tiling] This change not necessary and can be A2D(nn_hls) after all lbc_lnks removed in the nn_hls = 2 case in tra_adv_fct
- REAL(wp), DIMENSION(:,:,:), ALLOCATABLE, SAVE :: zuu, zvv, zww ! 3D workspace
- REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: ztrdt, ztrds
+ REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zuu, zvv, zww ! 3D workspace
+ REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: ztrdt, ztrds
! TEMP: [tiling] This change not necessary after all lbc_lnks removed in the nn_hls = 2 case in tra_adv_fct
LOGICAL :: lskip
!!----------------------------------------------------------------------
@@ -104,11 +103,6 @@ CONTAINS
!
lskip = .FALSE.
- ! TEMP: [tiling] These changes not necessary after all lbc_lnks removed in the nn_hls = 2 case in tra_adv_fct
- IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile
- ALLOCATE( zuu(jpi,jpj,jpk), zvv(jpi,jpj,jpk), zww(jpi,jpj,jpk) )
- ENDIF
-
! TEMP: [tiling] These changes not necessary after all lbc_lnks removed in the nn_hls = 2 case in tra_adv_fct
IF( ln_tile .AND. nadv == np_FCT ) THEN
IF( ntile == 1 ) THEN
@@ -119,6 +113,7 @@ CONTAINS
ENDIF
!
IF( .NOT. lskip ) THEN
+ ALLOCATE( zuu(T2D(nn_hls),jpk), zvv(T2D(nn_hls),jpk), zww(T2D(nn_hls),jpk) )
! !== effective advective transport ==!
!
IF( PRESENT( pau ) ) THEN ! RK3: advective velocity (pau,pav,paw) /= advected velocity (uu,vv,ww)
@@ -132,31 +127,24 @@ CONTAINS
ENDIF
!
IF( ln_wave .AND. ln_sdw ) THEN
- DO_3D_OVR( nn_hls, nn_hls-1, nn_hls, nn_hls-1, 1, jpkm1 )
+ DO_3D( nn_hls, nn_hls-1, nn_hls, nn_hls-1, 1, jpkm1 )
zuu(ji,jj,jk) = e2u (ji,jj) * e3u(ji,jj,jk,Kmm) * ( zptu(ji,jj,jk) + usd(ji,jj,jk) )
zvv(ji,jj,jk) = e1v (ji,jj) * e3v(ji,jj,jk,Kmm) * ( zptv(ji,jj,jk) + vsd(ji,jj,jk) )
END_3D
- DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpkm1 )
+ DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpkm1 )
zww(ji,jj,jk) = e1e2t(ji,jj) * ( zptw(ji,jj,jk) + wsd(ji,jj,jk) )
END_3D
ELSE
- DO_3D_OVR( nn_hls, nn_hls-1, nn_hls, nn_hls-1, 1, jpkm1 )
+ DO_3D( nn_hls, nn_hls-1, nn_hls, nn_hls-1, 1, jpkm1 )
zuu(ji,jj,jk) = e2u (ji,jj) * e3u(ji,jj,jk,Kmm) * zptu(ji,jj,jk) ! eulerian transport only
zvv(ji,jj,jk) = e1v (ji,jj) * e3v(ji,jj,jk,Kmm) * zptv(ji,jj,jk)
END_3D
- DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpkm1 )
+ DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpkm1 )
zww(ji,jj,jk) = e1e2t(ji,jj) * zptw(ji,jj,jk)
END_3D
ENDIF
!
- IF( ln_vvl_ztilde .OR. ln_vvl_layer ) THEN ! add z-tilde and/or vvl corrections
- DO_3D_OVR( nn_hls, nn_hls-1, nn_hls, nn_hls-1, 1, jpkm1 )
- zuu(ji,jj,jk) = zuu(ji,jj,jk) + un_td(ji,jj,jk)
- zvv(ji,jj,jk) = zvv(ji,jj,jk) + vn_td(ji,jj,jk)
- END_3D
- ENDIF
- !
- DO_2D_OVR( nn_hls, nn_hls-1, nn_hls, nn_hls-1 )
+ DO_2D( nn_hls, nn_hls-1, nn_hls, nn_hls-1 )
zuu(ji,jj,jpk) = 0._wp ! no transport trough the bottom
zvv(ji,jj,jpk) = 0._wp
zww(ji,jj,jpk) = 0._wp
@@ -167,18 +155,14 @@ CONTAINS
!
IF( ln_mle ) CALL tra_mle_trp( kt, nit000, zuu, zvv, zww, 'TRA', Kmm ) ! add the mle transport (if necessary)
!
- ! TEMP: [tiling] This change not necessary after all lbc_lnks removed in the nn_hls = 2 case in tra_adv_fct
IF( l_iom ) THEN
- IF( .NOT. l_istiled .OR. ntile == nijtile ) THEN ! Do only on the last tile
- CALL iom_put( "uocetr_eff", zuu ) ! output effective transport
- CALL iom_put( "vocetr_eff", zvv )
- CALL iom_put( "wocetr_eff", zww )
- ENDIF
+ CALL iom_put( "uocetr_eff", zuu ) ! output effective transport
+ CALL iom_put( "vocetr_eff", zvv )
+ CALL iom_put( "wocetr_eff", zww )
ENDIF
!
!!gm ???
- ! TEMP: [tiling] This copy-in not necessary after all lbc_lnks removed in the nn_hls = 2 case in tra_adv_fct
- IF( l_diaptr ) CALL dia_ptr( kt, Kmm, zvv(A2D(nn_hls),:) ) ! diagnose the effective MSF
+ IF( l_diaptr ) CALL dia_ptr( kt, Kmm, zvv(:,:,:) ) ! diagnose the effective MSF
!!gm ???
!
@@ -191,15 +175,15 @@ CONTAINS
SELECT CASE ( nadv ) !== compute advection trend and add it to general trend ==!
!
CASE ( np_CEN ) ! Centered scheme : 2nd / 4th order
- CALL tra_adv_cen ( kt, nit000, 'TRA', zuu, zvv, zww, Kmm, pts, jpts, Krhs, nn_cen_h, nn_cen_v )
+ CALL tra_adv_cen( kt, nit000, 'TRA', zuu, zvv, zww, Kmm, pts, jpts, Krhs, nn_cen_h, nn_cen_v )
CASE ( np_FCT ) ! FCT scheme : 2nd / 4th order
- CALL tra_adv_fct ( kt, nit000, 'TRA', rDt, zuu, zvv, zww, Kbb, Kmm, Kaa, pts, jpts, Krhs, nn_fct_h, nn_fct_v )
+ CALL tra_adv_fct( kt, nit000, 'TRA', rDt, zuu, zvv, zww, Kbb, Kmm, Kaa, pts, jpts, Krhs, nn_fct_h, nn_fct_v )
CASE ( np_MUS ) ! MUSCL
- CALL tra_adv_mus( kt, nit000, 'TRA', rDt, zuu, zvv, zww, Kbb, Kmm, pts, jpts, Krhs, ln_mus_ups )
+ CALL tra_adv_mus( kt, nit000, 'TRA', rDt, zuu, zvv, zww, Kbb, Kmm, pts, jpts, Krhs, ln_mus_ups )
CASE ( np_UBS ) ! UBS
- CALL tra_adv_ubs ( kt, nit000, 'TRA', rDt, zuu, zvv, zww, Kbb, Kmm, pts, jpts, Krhs, nn_ubs_v )
+ CALL tra_adv_ubs( kt, nit000, 'TRA', rDt, zuu, zvv, zww, Kbb, Kmm, pts, jpts, Krhs, nn_ubs_v )
CASE ( np_QCK ) ! QUICKEST
- CALL tra_adv_qck ( kt, nit000, 'TRA', rDt, zuu, zvv, zww, Kbb, Kmm, pts, jpts, Krhs )
+ CALL tra_adv_qck( kt, nit000, 'TRA', rDt, zuu, zvv, zww, Kbb, Kmm, pts, jpts, Krhs )
!
END SELECT
!
@@ -215,15 +199,12 @@ CONTAINS
! TEMP: [tiling] This change not necessary after all lbc_lnks removed in the nn_hls = 2 case in tra_adv_fct
IF( ln_tile .AND. .NOT. l_istiled ) CALL dom_tile_start( ldhold=.TRUE. )
+
+ DEALLOCATE( zuu, zvv, zww )
ENDIF
! ! print mean trends (used for debugging)
IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=pts(:,:,:,jp_tem,Krhs), clinfo1=' adv - Ta: ', mask1=tmask, &
& tab3d_2=pts(:,:,:,jp_sal,Krhs), clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' )
-
- ! TEMP: [tiling] This change not necessary after all lbc_lnks removed in the nn_hls = 2 case in tra_adv_fct
- IF( .NOT. l_istiled .OR. ntile == nijtile ) THEN ! Do only for the full domain
- DEALLOCATE( zuu, zvv, zww )
- ENDIF
!
IF( ln_timing ) CALL timing_stop( 'tra_adv' )
!
diff --git a/src/OCE/TRA/traadv_cen.F90 b/src/OCE/TRA/traadv_cen.F90
index 3351e1935a5503648b2e9e0ca590bb5a7813c037..e55956f238555c0064a98f900bbaaf70af40f822 100644
--- a/src/OCE/TRA/traadv_cen.F90
+++ b/src/OCE/TRA/traadv_cen.F90
@@ -4,6 +4,7 @@ MODULE traadv_cen
!! Ocean tracers: advective trend (2nd/4th order centered)
!!======================================================================
!! History : 3.7 ! 2014-05 (G. Madec) original code
+ !! 4.5 ! 2022-06 (S. Techene, G, Madec) refactorization to reduce local memory usage
!!----------------------------------------------------------------------
!!----------------------------------------------------------------------
@@ -22,14 +23,11 @@ MODULE traadv_cen
USE iom ! IOM library
USE trc_oce ! share passive tracers/Ocean variables
USE lib_mpp ! MPP library
-#if defined key_loop_fusion
- USE traadv_cen_lf ! centered scheme (tra_adv_cen routine - loop fusion version)
-#endif
IMPLICIT NONE
PRIVATE
- PUBLIC tra_adv_cen ! called by traadv.F90
+ PUBLIC tra_adv_cen ! called by traadv.F90
REAL(wp) :: r1_6 = 1._wp / 6._wp ! =1/6
@@ -73,20 +71,19 @@ CONTAINS
INTEGER , INTENT(in ) :: kjpt ! number of tracers
INTEGER , INTENT(in ) :: kn_cen_h ! =2/4 (2nd or 4th order scheme)
INTEGER , INTENT(in ) :: kn_cen_v ! =2/4 (2nd or 4th order scheme)
- ! TEMP: [tiling] This can be A2D(nn_hls) after all lbc_lnks removed in the nn_hls = 2 case in tra_adv_fct
- REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pU, pV, pW ! 3 ocean volume flux components
+ REAL(wp), DIMENSION(T2D(nn_hls),jpk ), INTENT(in ) :: pU, pV, pW ! 3 ocean volume flux components
REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) :: pt ! tracers and RHS of tracer equation
!
INTEGER :: ji, jj, jk, jn ! dummy loop indices
INTEGER :: ierr ! local integer
REAL(wp) :: zC2t_u, zC4t_u ! local scalars
REAL(wp) :: zC2t_v, zC4t_v ! - -
- REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zwx, zwy, zwz, ztu, ztv, ztw
+ REAL(wp) :: zftw_kp1
+ REAL(wp), DIMENSION(T2D(1)) :: zft_u, zft_v
+ REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: zdt_u, zdt_v
+ REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE :: ztw
!!----------------------------------------------------------------------
!
-#if defined key_loop_fusion
- CALL tra_adv_cen_lf ( kt, nit000, cdtype, pU, pV, pW, Kmm, pt, kjpt, Krhs, kn_cen_h, kn_cen_v )
-#else
IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile
IF( kt == kit000 ) THEN
IF(lwp) WRITE(numout,*)
@@ -103,93 +100,132 @@ CONTAINS
& iom_use("uadv_salttr") .OR. iom_use("vadv_salttr") ) ) l_hst = .TRUE.
ENDIF
!
- !
- zwz(:,:, 1 ) = 0._wp ! surface & bottom vertical flux set to zero for all tracers
- zwz(:,:,jpk) = 0._wp
+ IF( kn_cen_h == 4 ) ALLOCATE( zdt_u(T2D(2)) , zdt_v(T2D(2)) ) ! horizontal 4th order only
+ IF( kn_cen_v == 4 ) ALLOCATE( ztw(T2D(nn_hls),jpk) ) ! vertical 4th order only
!
DO jn = 1, kjpt !== loop over the tracers ==!
!
- SELECT CASE( kn_cen_h ) !-- Horizontal fluxes --!
+ SELECT CASE( kn_cen_h ) !-- Horizontal divergence of advective fluxes --!
!
+!!st limitation : does not take into acccount iceshelf specificity
+!! in case of linssh
CASE( 2 ) !* 2nd order centered
- DO_3D( 1, 0, 1, 0, 1, jpkm1 )
- zwx(ji,jj,jk) = 0.5_wp * pU(ji,jj,jk) * ( pt(ji,jj,jk,jn,Kmm) + pt(ji+1,jj ,jk,jn,Kmm) )
- zwy(ji,jj,jk) = 0.5_wp * pV(ji,jj,jk) * ( pt(ji,jj,jk,jn,Kmm) + pt(ji ,jj+1,jk,jn,Kmm) )
- END_3D
+ DO jk = 1, jpkm1
+ !
+ DO_2D( 1, 0, 1, 0 ) ! Horizontal fluxes at layer jk
+ zft_u(ji,jj) = 0.5_wp * pU(ji,jj,jk) * ( pt(ji,jj,jk,jn,Kmm) + pt(ji+1,jj ,jk,jn,Kmm) )
+ zft_v(ji,jj) = 0.5_wp * pV(ji,jj,jk) * ( pt(ji,jj,jk,jn,Kmm) + pt(ji ,jj+1,jk,jn,Kmm) )
+ END_2D
+ !
+ DO_2D( 0, 0, 0, 0 ) ! Horizontal divergence of advective fluxes
+ pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) - ( ( zft_u(ji,jj) - zft_u(ji-1,jj ) ) & ! add () for NP repro
+ & + ( zft_v(ji,jj) - zft_v(ji ,jj-1) ) ) * r1_e1e2t(ji,jj) &
+ & / e3t(ji,jj,jk,Kmm)
+ END_2D
+ END DO
!
CASE( 4 ) !* 4th order centered
- ztu(:,:,jpk) = 0._wp ! Bottom value : flux set to zero
- ztv(:,:,jpk) = 0._wp
- DO_3D( nn_hls, nn_hls-1, nn_hls, nn_hls-1, 1, jpkm1 ) ! masked gradient
- ztu(ji,jj,jk) = ( pt(ji+1,jj ,jk,jn,Kmm) - pt(ji,jj,jk,jn,Kmm) ) * umask(ji,jj,jk)
- ztv(ji,jj,jk) = ( pt(ji ,jj+1,jk,jn,Kmm) - pt(ji,jj,jk,jn,Kmm) ) * vmask(ji,jj,jk)
- END_3D
- IF (nn_hls==1) CALL lbc_lnk( 'traadv_cen', ztu, 'U', -1.0_wp , ztv, 'V', -1.0_wp, ld4only= .TRUE. ) ! Lateral boundary cond.
- !
- DO_3D( nn_hls-1, 0, nn_hls-1, 0, 1, jpkm1 ) ! Horizontal advective fluxes
- zC2t_u = pt(ji,jj,jk,jn,Kmm) + pt(ji+1,jj ,jk,jn,Kmm) ! C2 interpolation of T at u- & v-points (x2)
- zC2t_v = pt(ji,jj,jk,jn,Kmm) + pt(ji ,jj+1,jk,jn,Kmm)
- ! ! C4 interpolation of T at u- & v-points (x2)
- zC4t_u = zC2t_u + r1_6 * ( ztu(ji-1,jj,jk) - ztu(ji+1,jj,jk) )
- zC4t_v = zC2t_v + r1_6 * ( ztv(ji,jj-1,jk) - ztv(ji,jj+1,jk) )
- ! ! C4 fluxes
- zwx(ji,jj,jk) = 0.5_wp * pU(ji,jj,jk) * zC4t_u
- zwy(ji,jj,jk) = 0.5_wp * pV(ji,jj,jk) * zC4t_v
- END_3D
- IF (nn_hls==1) CALL lbc_lnk( 'traadv_cen', zwx, 'U', -1. , zwy, 'V', -1. )
+ DO jk = 1, jpkm1
+ DO_2D( 2, 1, 2, 1 ) ! masked gradient
+ zdt_u(ji,jj) = ( pt(ji+1,jj ,jk,jn,Kmm) - pt(ji,jj,jk,jn,Kmm) ) * umask(ji,jj,jk)
+ zdt_v(ji,jj) = ( pt(ji ,jj+1,jk,jn,Kmm) - pt(ji,jj,jk,jn,Kmm) ) * vmask(ji,jj,jk)
+ END_2D
+ !
+ DO_2D( 1, 0, 1, 0 ) ! Horizontal advective fluxes
+ zC2t_u = pt(ji,jj,jk,jn,Kmm) + pt(ji+1,jj ,jk,jn,Kmm) ! C2 interpolation of T at u- & v-points (x2)
+ zC2t_v = pt(ji,jj,jk,jn,Kmm) + pt(ji ,jj+1,jk,jn,Kmm)
+ ! ! C4 interpolation of T at u- & v-points (x2)
+ zC4t_u = zC2t_u + r1_6 * ( zdt_u(ji-1,jj ) - zdt_u(ji+1,jj ) )
+ zC4t_v = zC2t_v + r1_6 * ( zdt_v(ji ,jj-1) - zdt_v(ji ,jj+1) )
+ ! ! C4 fluxes
+ zft_u(ji,jj) = 0.5_wp * pU(ji,jj,jk) * zC4t_u
+ zft_v(ji,jj) = 0.5_wp * pV(ji,jj,jk) * zC4t_v
+ END_2D
+ !
+ DO_2D( 0, 0, 0, 0 ) ! Horizontal divergence of advective fluxes
+ pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) - ( ( zft_u(ji,jj) - zft_u(ji-1,jj ) ) & ! add () for NP repro
+ & + ( zft_v(ji,jj) - zft_v(ji ,jj-1) ) ) * r1_e1e2t(ji,jj) &
+ & / e3t(ji,jj,jk,Kmm)
+ END_2D
+ END DO
!
CASE DEFAULT
CALL ctl_stop( 'traadv_cen: wrong value for nn_cen' )
END SELECT
!
- SELECT CASE( kn_cen_v ) !-- Vertical fluxes --! (interior)
+#define zft_w zft_u
+ !
+ IF( ln_linssh ) THEN !* top value (linear free surf. only as zwz is multiplied by wmask)
+ DO_2D( 0, 0, 0, 0 )
+ zft_w(ji,jj) = pW(ji,jj,1) * pt(ji,jj,1,jn,Kmm)
+ END_2D
+ ELSE
+ DO_2D( 0, 0, 0, 0 )
+ zft_w(ji,jj) = 0._wp
+ END_2D
+ ENDIF
+ !
+ SELECT CASE( kn_cen_v ) !-- Vertical divergence of advective fluxes --! (interior)
!
CASE( 2 ) !* 2nd order centered
- DO_3D( 0, 0, 0, 0, 2, jpk )
- zwz(ji,jj,jk) = 0.5 * pW(ji,jj,jk) * ( pt(ji,jj,jk,jn,Kmm) + pt(ji,jj,jk-1,jn,Kmm) ) * wmask(ji,jj,jk)
- END_3D
+ DO jk = 1, jpk-2
+ DO_2D( 0, 0, 0, 0 ) ! Vertical fluxes
+ zftw_kp1 = 0.5 * pW(ji,jj,jk+1) * ( pt(ji,jj,jk+1,jn,Kmm) + pt(ji,jj,jk,jn,Kmm) ) * wmask(ji,jj,jk+1)
+ !
+ pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) - ( zft_w(ji,jj) - zftw_kp1 ) * r1_e1e2t(ji,jj) &
+ & / e3t(ji,jj,jk,Kmm)
+ zft_w(ji,jj) = zftw_kp1
+ END_2D
+ END DO
+ jk = jpkm1 ! bottom vertical flux set to zero for all tracers
+ DO_2D( 0, 0, 0, 0 )
+ pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) - zft_w(ji,jj) * r1_e1e2t(ji,jj) &
+ & / e3t(ji,jj,jk,Kmm)
+ END_2D
!
CASE( 4 ) !* 4th order compact
CALL interp_4th_cpt( pt(:,:,:,jn,Kmm) , ztw ) ! ztw = interpolated value of T at w-point
- DO_3D( 0, 0, 0, 0, 2, jpkm1 )
- zwz(ji,jj,jk) = pW(ji,jj,jk) * ztw(ji,jj,jk) * wmask(ji,jj,jk)
- END_3D
!
- END SELECT
- !
- IF( ln_linssh ) THEN !* top value (linear free surf. only as zwz is multiplied by wmask)
- IF( ln_isfcav ) THEN ! ice-shelf cavities (top of the ocean)
- DO_2D( 1, 1, 1, 1 )
- zwz(ji,jj, mikt(ji,jj) ) = pW(ji,jj,mikt(ji,jj)) * pt(ji,jj,mikt(ji,jj),jn,Kmm)
- END_2D
- ELSE ! no ice-shelf cavities (only ocean surface)
- DO_2D( 1, 1, 1, 1 )
- zwz(ji,jj,1) = pW(ji,jj,1) * pt(ji,jj,1,jn,Kmm)
+ DO jk = 1, jpk-2
+ !
+ DO_2D( 0, 0, 0, 0 )
+ zftw_kp1 = pW(ji,jj,jk+1) * ztw(ji,jj,jk+1) * wmask(ji,jj,jk+1)
+ ! ! Divergence of advective fluxes
+ pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) - ( zft_w(ji,jj) - zftw_kp1 ) * r1_e1e2t(ji,jj) &
+ & / e3t(ji,jj,jk,Kmm)
+ ! ! update
+ zft_w(ji,jj) = zftw_kp1
END_2D
- ENDIF
- ENDIF
+ !
+ END DO
+ !
+ jk = jpkm1 ! bottom vertical flux set to zero for all tracers
+ DO_2D( 0, 0, 0, 0 )
+ pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) - zft_w(ji,jj) * r1_e1e2t(ji,jj) &
+ & / e3t(ji,jj,jk,Kmm)
+ END_2D
+ !
+ END SELECT
!
- DO_3D( 0, 0, 0, 0, 1, jpkm1 ) !-- Divergence of advective fluxes --!
- pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) &
- & - ( zwx(ji,jj,jk) - zwx(ji-1,jj ,jk ) &
- & + zwy(ji,jj,jk) - zwy(ji ,jj-1,jk ) &
- & + zwz(ji,jj,jk) - zwz(ji ,jj ,jk+1) ) &
- & * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm)
- END_3D
+#undef zft_w
! ! trend diagnostics
- IF( l_trd ) THEN
- CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_xad, zwx, pU, pt(:,:,:,jn,Kmm) )
- CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_yad, zwy, pV, pt(:,:,:,jn,Kmm) )
- CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_zad, zwz, pW, pt(:,:,:,jn,Kmm) )
- ENDIF
- ! ! "Poleward" heat and salt transports
- IF( l_ptr ) CALL dia_ptr_hst( jn, 'adv', zwy(:,:,:) )
- ! ! heat and salt transport
- IF( l_hst ) CALL dia_ar5_hst( jn, 'adv', zwx(:,:,:), zwy(:,:,:) )
+!!gm + !!st to be done with the whole rewritting of trd
+!! trd routine arguments MUST be changed adding jk and zwx, zwy in 2D
+!! IF( l_trd ) THEN
+!! CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_xad, zwx, pU, pt(:,:,:,jn,Kmm) )
+!! CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_yad, zwy, pV, pt(:,:,:,jn,Kmm) )
+!! CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_zad, zwz, pW, pt(:,:,:,jn,Kmm) )
+!! ENDIF
+!! ! ! "Poleward" heat and salt transports
+!! IF( l_ptr ) CALL dia_ptr_hst( jn, 'adv', zwy(:,:,:) )
+!! ! ! heat and salt transport
+!! IF( l_hst ) CALL dia_ar5_hst( jn, 'adv', zwx(:,:,:), zwy(:,:,:) )
!
END DO
!
-#endif
+ IF( kn_cen_h == 4 ) DEALLOCATE( zdt_u , zdt_v ) ! horizontal 4th order only
+ IF( kn_cen_v == 4 ) DEALLOCATE( ztw ) ! vertical 4th order only
+ !
END SUBROUTINE tra_adv_cen
!!======================================================================
diff --git a/src/OCE/TRA/traadv_cen_lf.F90 b/src/OCE/TRA/traadv_cen_lf.F90
index 6d1f08fb9aaafc6fbc9f7f6c7077d1328c9b958f..f7b0e0f1f724d2adbe25b088de1ddc7c314b2bc0 100644
--- a/src/OCE/TRA/traadv_cen_lf.F90
+++ b/src/OCE/TRA/traadv_cen_lf.F90
@@ -70,8 +70,7 @@ CONTAINS
INTEGER , INTENT(in ) :: kjpt ! number of tracers
INTEGER , INTENT(in ) :: kn_cen_h ! =2/4 (2nd or 4th order scheme)
INTEGER , INTENT(in ) :: kn_cen_v ! =2/4 (2nd or 4th order scheme)
- ! TEMP: [tiling] This can be A2D(nn_hls) if using XIOS (subdomain support)
- REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pU, pV, pW ! 3 ocean volume flux components
+ REAL(wp), DIMENSION(T2D(nn_hls),jpk ), INTENT(in ) :: pU, pV, pW ! 3 ocean volume flux components
REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) :: pt ! tracers and RHS of tracer equation
!
INTEGER :: ji, jj, jk, jn ! dummy loop indices
@@ -80,7 +79,7 @@ CONTAINS
REAL(wp) :: zC2t_v, zC4t_v ! - -
REAL(wp) :: ztu_im1, ztu_ip1 ! - -
REAL(wp) :: ztv_jm1, ztv_jp1 ! - -
- REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zwx, zwy, zwz, ztw
+ REAL(wp), DIMENSION(T2D(nn_hls),jpk) :: zwx, zwy, zwz, ztw
!!----------------------------------------------------------------------
!
IF( ntile == 0 .OR. ntile == 1 ) THEN ! Do only on the first tile
diff --git a/src/OCE/TRA/traadv_fct.F90 b/src/OCE/TRA/traadv_fct.F90
index 541e61e0807e9ca2b06efd377efa84c283270744..95b3255d225294f0c140b2813804f1c89a8d19f8 100644
--- a/src/OCE/TRA/traadv_fct.F90
+++ b/src/OCE/TRA/traadv_fct.F90
@@ -78,23 +78,19 @@ CONTAINS
INTEGER , INTENT(in ) :: kn_fct_h ! order of the FCT scheme (=2 or 4)
INTEGER , INTENT(in ) :: kn_fct_v ! order of the FCT scheme (=2 or 4)
REAL(wp) , INTENT(in ) :: p2dt ! tracer time-step
- ! TEMP: [tiling] This can be A2D(nn_hls) after all lbc_lnks removed in the nn_hls = 2 case
- REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pU, pV, pW ! 3 ocean volume flux components
+ REAL(wp), DIMENSION(T2D(nn_hls),jpk ), INTENT(in ) :: pU, pV, pW ! 3 ocean volume flux components
REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) :: pt ! tracers and RHS of tracer equation
!
INTEGER :: ji, jj, jk, jn ! dummy loop indices
REAL(wp) :: ztra ! local scalar
REAL(wp) :: zfp_ui, zfp_vj, zfp_wk, zC2t_u, zC4t_u ! - -
REAL(wp) :: zfm_ui, zfm_vj, zfm_wk, zC2t_v, zC4t_v ! - -
- REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zwi, zwx, zwy, zwz, ztu, ztv, zltu, zltv, ztw
+ REAL(wp), DIMENSION(T2D(nn_hls),jpk) :: zwi, zwx, zwy, zwz, ztu, ztv, zltu, zltv, ztw
REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: ztrdx, ztrdy, ztrdz, zptry
REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zwinf, zwdia, zwsup
LOGICAL :: ll_zAimp ! flag to apply adaptive implicit vertical advection
!!----------------------------------------------------------------------
!
-#if defined key_loop_fusion
- CALL tra_adv_fct_lf ( kt, nit000, cdtype, p2dt, pU, pV, pW, Kbb, Kmm, Kaa, pt, kjpt, Krhs, kn_fct_h, kn_fct_v )
-#else
IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile
IF( kt == kit000 ) THEN
IF(lwp) WRITE(numout,*)
@@ -125,22 +121,22 @@ CONTAINS
ztw(:,:,:) = 0._wp
!
IF( l_trd .OR. l_hst ) THEN
- ALLOCATE( ztrdx(A2D(nn_hls),jpk), ztrdy(A2D(nn_hls),jpk), ztrdz(A2D(nn_hls),jpk) )
+ ALLOCATE( ztrdx(T2D(nn_hls),jpk), ztrdy(T2D(nn_hls),jpk), ztrdz(T2D(nn_hls),jpk) )
ztrdx(:,:,:) = 0._wp ; ztrdy(:,:,:) = 0._wp ; ztrdz(:,:,:) = 0._wp
ENDIF
!
IF( l_ptr ) THEN
- ALLOCATE( zptry(A2D(nn_hls),jpk) )
+ ALLOCATE( zptry(T2D(0),jpk) )
zptry(:,:,:) = 0._wp
ENDIF
!
! If adaptive vertical advection, check if it is needed on this PE at this time
IF( ln_zad_Aimp ) THEN
- IF( MAXVAL( ABS( wi(A2D(1),:) ) ) > 0._wp ) ll_zAimp = .TRUE.
+ IF( MAXVAL( ABS( wi(T2D(1),:) ) ) > 0._wp ) ll_zAimp = .TRUE.
END IF
! If active adaptive vertical advection, build tridiagonal matrix
IF( ll_zAimp ) THEN
- ALLOCATE(zwdia(A2D(nn_hls),jpk), zwinf(A2D(nn_hls),jpk), zwsup(A2D(nn_hls),jpk))
+ ALLOCATE(zwdia(T2D(nn_hls),jpk), zwinf(T2D(nn_hls),jpk), zwsup(T2D(nn_hls),jpk))
DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpkm1 )
zwdia(ji,jj,jk) = 1._wp + p2dt * ( MAX( wi(ji,jj,jk) , 0._wp ) - MIN( wi(ji,jj,jk+1) , 0._wp ) ) &
& / e3t(ji,jj,jk,Kaa)
@@ -182,9 +178,9 @@ CONTAINS
!
DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpkm1 ) !* trend and after field with monotonic scheme
! ! total intermediate advective trends
- ztra = - ( zwx(ji,jj,jk) - zwx(ji-1,jj ,jk ) &
- & + zwy(ji,jj,jk) - zwy(ji ,jj-1,jk ) &
- & + zwz(ji,jj,jk) - zwz(ji ,jj ,jk+1) ) * r1_e1e2t(ji,jj)
+ ztra = - ( ( zwx(ji,jj,jk) - zwx(ji-1,jj ,jk ) ) & ! add () for NP reproducibility
+ & + ( zwy(ji,jj,jk) - zwy(ji ,jj-1,jk ) ) &
+ & + ( zwz(ji,jj,jk) - zwz(ji ,jj ,jk+1) ) ) * r1_e1e2t(ji,jj)
! ! update and guess with monotonic sheme
pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) + ztra &
& / e3t(ji,jj,jk,Kmm ) * tmask(ji,jj,jk)
@@ -213,7 +209,7 @@ CONTAINS
ztrdx(:,:,:) = zwx(:,:,:) ; ztrdy(:,:,:) = zwy(:,:,:) ; ztrdz(:,:,:) = zwz(:,:,:)
END IF
! ! "Poleward" heat and salt transports (contribution of upstream fluxes)
- IF( l_ptr ) zptry(:,:,:) = zwy(:,:,:)
+ IF( l_ptr ) zptry(:,:,:) = zwy(T2D(0),:)
!
! !== anti-diffusive flux : high order minus low order ==!
!
@@ -246,13 +242,9 @@ CONTAINS
zC2t_v = pt(ji,jj,jk,jn,Kmm) + pt(ji ,jj+1,jk,jn,Kmm)
! ! C4 minus upstream advective fluxes
! round brackets added to fix the order of floating point operations
- ! needed to ensure halo 1 - halo 2 compatibility
- zwx(ji,jj,jk) = 0.5_wp * pU(ji,jj,jk) * ( zC2t_u + ( zltu(ji,jj,jk) - zltu(ji+1,jj,jk) &
- & ) & ! bracket for halo 1 - halo 2 compatibility
- & ) - zwx(ji,jj,jk)
- zwy(ji,jj,jk) = 0.5_wp * pV(ji,jj,jk) * ( zC2t_v + ( zltv(ji,jj,jk) - zltv(ji,jj+1,jk) &
- & ) & ! bracket for halo 1 - halo 2 compatibility
- & ) - zwy(ji,jj,jk)
+ ! needed to ensure the North Pole reproducibility
+ zwx(ji,jj,jk) = 0.5_wp * pU(ji,jj,jk) * ( zC2t_u + ( zltu(ji,jj,jk) - zltu(ji+1,jj,jk) ) ) - zwx(ji,jj,jk)
+ zwy(ji,jj,jk) = 0.5_wp * pV(ji,jj,jk) * ( zC2t_v + ( zltv(ji,jj,jk) - zltv(ji,jj+1,jk) ) ) - zwy(ji,jj,jk)
END_3D
!
CASE( 41 ) !- 4th order centered ==>> !!gm coding attempt need to be tested
@@ -306,9 +298,9 @@ CONTAINS
IF ( ll_zAimp ) THEN
DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpkm1 ) !* trend and after field with monotonic scheme
! ! total intermediate advective trends
- ztra = - ( zwx(ji,jj,jk) - zwx(ji-1,jj ,jk ) &
- & + zwy(ji,jj,jk) - zwy(ji ,jj-1,jk ) &
- & + zwz(ji,jj,jk) - zwz(ji ,jj ,jk+1) ) * r1_e1e2t(ji,jj)
+ ztra = - ( ( zwx(ji,jj,jk) - zwx(ji-1,jj ,jk ) ) & ! add () NP halo
+ & + ( zwy(ji,jj,jk) - zwy(ji ,jj-1,jk ) ) &
+ & + ( zwz(ji,jj,jk) - zwz(ji ,jj ,jk+1) ) ) * r1_e1e2t(ji,jj)
ztw(ji,jj,jk) = zwi(ji,jj,jk) + p2dt * ztra / e3t(ji,jj,jk,Kaa) * tmask(ji,jj,jk)
END_3D
!
@@ -328,9 +320,9 @@ CONTAINS
! !== final trend with corrected fluxes ==!
!
DO_3D( 0, 0, 0, 0, 1, jpkm1 )
- ztra = - ( zwx(ji,jj,jk) - zwx(ji-1,jj ,jk ) &
- & + zwy(ji,jj,jk) - zwy(ji ,jj-1,jk ) &
- & + zwz(ji,jj,jk) - zwz(ji ,jj ,jk+1) ) * r1_e1e2t(ji,jj)
+ ztra = - ( ( zwx(ji,jj,jk) - zwx(ji-1,jj ,jk ) ) & ! add () for NP reproducibility
+ & + ( zwy(ji,jj,jk) - zwy(ji ,jj-1,jk ) ) &
+ & + ( zwz(ji,jj,jk) - zwz(ji ,jj ,jk+1) ) ) * r1_e1e2t(ji,jj)
pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) + ztra / e3t(ji,jj,jk,Kmm)
zwi(ji,jj,jk) = zwi(ji,jj,jk) + p2dt * ztra / e3t(ji,jj,jk,Kaa) * tmask(ji,jj,jk)
END_3D
@@ -364,7 +356,7 @@ CONTAINS
!
ENDIF
IF( l_ptr ) THEN ! "Poleward" transports
- zptry(:,:,:) = zptry(:,:,:) + zwy(:,:,:) ! <<< add anti-diffusive fluxes
+ zptry(:,:,:) = zptry(:,:,:) + zwy(T2D(0),:) ! <<< add anti-diffusive fluxes
CALL dia_ptr_hst( jn, 'adv', zptry(:,:,:) )
ENDIF
!
@@ -380,7 +372,6 @@ CONTAINS
DEALLOCATE( zptry )
ENDIF
!
-#endif
END SUBROUTINE tra_adv_fct
@@ -400,14 +391,14 @@ CONTAINS
INTEGER , INTENT(in ) :: Kaa ! time level index
REAL(wp) , INTENT(in ) :: p2dt ! tracer time-step
REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in ) :: pbef ! before field
- REAL(wp), DIMENSION(A2D(nn_hls) ,jpk), INTENT(in ) :: paft ! after field
- REAL(wp), DIMENSION(A2D(nn_hls) ,jpk), INTENT(inout) :: paa, pbb, pcc ! monotonic fluxes in the 3 directions
+ REAL(wp), DIMENSION(T2D(nn_hls) ,jpk), INTENT(in ) :: paft ! after field
+ REAL(wp), DIMENSION(T2D(nn_hls) ,jpk), INTENT(inout) :: paa, pbb, pcc ! monotonic fluxes in the 3 directions
!
INTEGER :: ji, jj, jk ! dummy loop indices
INTEGER :: ikm1 ! local integer
REAL(dp) :: zpos, zneg, zbt, za, zb, zc, zbig, zrtrn ! local scalars
REAL(dp) :: zau, zbu, zcu, zav, zbv, zcv, zup, zdo ! - -
- REAL(dp), DIMENSION(A2D(nn_hls),jpk) :: zbetup, zbetdo, zbup, zbdo
+ REAL(dp), DIMENSION(T2D(nn_hls),jpk) :: zbetup, zbetdo, zbup, zbdo
!!----------------------------------------------------------------------
!
zbig = 1.e+40_dp
@@ -553,11 +544,11 @@ CONTAINS
!! ** Method : 4th order compact interpolation
!!----------------------------------------------------------------------
REAL(wp),DIMENSION(jpi,jpj,jpk), INTENT(in ) :: pt_in ! field at t-point
- REAL(wp),DIMENSION(A2D(nn_hls) ,jpk), INTENT( out) :: pt_out ! field interpolated at w-point
+ REAL(wp),DIMENSION(T2D(nn_hls) ,jpk), INTENT( out) :: pt_out ! field interpolated at w-point
!
INTEGER :: ji, jj, jk ! dummy loop integers
INTEGER :: ikt, ikb ! local integers
- REAL(wp),DIMENSION(A2D(nn_hls),jpk) :: zwd, zwi, zws, zwrm, zwt
+ REAL(wp),DIMENSION(T2D(nn_hls),jpk) :: zwd, zwi, zws, zwrm, zwt
!!----------------------------------------------------------------------
!
! !== build the three diagonal matrix & the RHS ==!
@@ -642,14 +633,14 @@ CONTAINS
!! The solution is pta.
!! The 3d array zwt is used as a work space array.
!!----------------------------------------------------------------------
- REAL(wp),DIMENSION(A2D(nn_hls),jpk), INTENT(in ) :: pD, pU, PL ! 3-diagonal matrix
- REAL(wp),DIMENSION(A2D(nn_hls),jpk), INTENT(in ) :: pRHS ! Right-Hand-Side
- REAL(wp),DIMENSION(A2D(nn_hls),jpk), INTENT( out) :: pt_out !!gm field at level=F(klev)
+ REAL(wp),DIMENSION(T2D(nn_hls),jpk), INTENT(in ) :: pD, pU, PL ! 3-diagonal matrix
+ REAL(wp),DIMENSION(T2D(nn_hls),jpk), INTENT(in ) :: pRHS ! Right-Hand-Side
+ REAL(wp),DIMENSION(T2D(nn_hls),jpk), INTENT( out) :: pt_out !!gm field at level=F(klev)
INTEGER , INTENT(in ) :: klev ! =1 pt_out at w-level
! ! =0 pt at t-level
INTEGER :: ji, jj, jk ! dummy loop integers
INTEGER :: kstart ! local indices
- REAL(wp),DIMENSION(A2D(nn_hls),jpk) :: zwt ! 3D work array
+ REAL(wp),DIMENSION(T2D(nn_hls),jpk) :: zwt ! 3D work array
!!----------------------------------------------------------------------
!
kstart = 1 + klev
@@ -677,332 +668,5 @@ CONTAINS
!
END SUBROUTINE tridia_solver
-#if defined key_loop_fusion
-#define tracer_flux_i(out,zfp,zfm,ji,jj,jk) \
- zfp = pU(ji,jj,jk) + ABS( pU(ji,jj,jk) ) ; \
- zfm = pU(ji,jj,jk) - ABS( pU(ji,jj,jk) ) ; \
- out = 0.5 * ( zfp * pt(ji,jj,jk,jn,Kbb) + zfm * pt(ji+1,jj,jk,jn,Kbb) )
-
-#define tracer_flux_j(out,zfp,zfm,ji,jj,jk) \
- zfp = pV(ji,jj,jk) + ABS( pV(ji,jj,jk) ) ; \
- zfm = pV(ji,jj,jk) - ABS( pV(ji,jj,jk) ) ; \
- out = 0.5 * ( zfp * pt(ji,jj,jk,jn,Kbb) + zfm * pt(ji,jj+1,jk,jn,Kbb) )
-
- SUBROUTINE tra_adv_fct_lf( kt, kit000, cdtype, p2dt, pU, pV, pW, &
- & Kbb, Kmm, Kaa, pt, kjpt, Krhs, kn_fct_h, kn_fct_v )
- !!----------------------------------------------------------------------
- !! *** ROUTINE tra_adv_fct ***
- !!
- !! ** Purpose : Compute the now trend due to total advection of tracers
- !! and add it to the general trend of tracer equations
- !!
- !! ** Method : - 2nd or 4th FCT scheme on the horizontal direction
- !! (choice through the value of kn_fct)
- !! - on the vertical the 4th order is a compact scheme
- !! - corrected flux (monotonic correction)
- !!
- !! ** Action : - update pt(:,:,:,:,Krhs) with the now advective tracer trends
- !! - send trends to trdtra module for further diagnostics (l_trdtra=T)
- !! - poleward advective heat and salt transport (ln_diaptr=T)
- !!----------------------------------------------------------------------
- INTEGER , INTENT(in ) :: kt ! ocean time-step index
- INTEGER , INTENT(in ) :: Kbb, Kmm, Kaa, Krhs ! ocean time level indices
- INTEGER , INTENT(in ) :: kit000 ! first time step index
- CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator)
- INTEGER , INTENT(in ) :: kjpt ! number of tracers
- INTEGER , INTENT(in ) :: kn_fct_h ! order of the FCT scheme (=2 or 4)
- INTEGER , INTENT(in ) :: kn_fct_v ! order of the FCT scheme (=2 or 4)
- REAL(wp) , INTENT(in ) :: p2dt ! tracer time-step
- REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pU, pV, pW ! 3 ocean volume flux components
- REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) :: pt ! tracers and RHS of tracer equation
- !
- INTEGER :: ji, jj, jk, jn ! dummy loop indices
- REAL(wp) :: ztra ! local scalar
- REAL(wp) :: zwx_im1, zfp_ui, zfp_ui_m1, zfp_vj, zfp_vj_m1, zfp_wk, zC2t_u, zC4t_u ! - -
- REAL(wp) :: zwy_jm1, zfm_ui, zfm_ui_m1, zfm_vj, zfm_vj_m1, zfm_wk, zC2t_v, zC4t_v ! - -
- REAL(wp) :: ztu, ztv, ztu_im1, ztu_ip1, ztv_jm1, ztv_jp1
- REAL(wp), DIMENSION(jpi,jpj,jpk) :: zwi, zwx_3d, zwy_3d, zwz, ztw, zltu_3d, zltv_3d
- REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: ztrdx, ztrdy, ztrdz, zptry
- REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zwinf, zwdia, zwsup
- LOGICAL :: ll_zAimp ! flag to apply adaptive implicit vertical advection
- !!----------------------------------------------------------------------
- !
- IF( kt == kit000 ) THEN
- IF(lwp) WRITE(numout,*)
- IF(lwp) WRITE(numout,*) 'tra_adv_fct_lf : FCT advection scheme on ', cdtype
- IF(lwp) WRITE(numout,*) '~~~~~~~~~~~'
- ENDIF
- !! -- init to 0
- zwx_3d(:,:,:) = 0._wp
- zwy_3d(:,:,:) = 0._wp
- zwz(:,:,:) = 0._wp
- zwi(:,:,:) = 0._wp
- !
- l_trd = .FALSE. ! set local switches
- l_hst = .FALSE.
- l_ptr = .FALSE.
- ll_zAimp = .FALSE.
- IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype =='TRC' .AND. l_trdtrc ) ) l_trd = .TRUE.
- IF( cdtype == 'TRA' .AND. ( iom_use( 'sophtadv' ) .OR. iom_use( 'sophtadv' ) ) ) l_ptr = .TRUE.
- IF( cdtype == 'TRA' .AND. ( iom_use("uadv_heattr") .OR. iom_use("vadv_heattr") .OR. &
- & iom_use("uadv_salttr") .OR. iom_use("vadv_salttr") ) ) l_hst = .TRUE.
- !
- IF( l_trd .OR. l_hst ) THEN
- ALLOCATE( ztrdx(jpi,jpj,jpk), ztrdy(jpi,jpj,jpk), ztrdz(jpi,jpj,jpk) )
- ztrdx(:,:,:) = 0._wp ; ztrdy(:,:,:) = 0._wp ; ztrdz(:,:,:) = 0._wp
- ENDIF
- !
- IF( l_ptr ) THEN
- ALLOCATE( zptry(jpi,jpj,jpk) )
- zptry(:,:,:) = 0._wp
- ENDIF
- !
- ! If adaptive vertical advection, check if it is needed on this PE at this time
- IF( ln_zad_Aimp ) THEN
- IF( MAXVAL( ABS( wi(:,:,:) ) ) > 0._wp ) ll_zAimp = .TRUE.
- END IF
- ! If active adaptive vertical advection, build tridiagonal matrix
- IF( ll_zAimp ) THEN
- ALLOCATE(zwdia(jpi,jpj,jpk), zwinf(jpi,jpj,jpk),zwsup(jpi,jpj,jpk))
- DO_3D( 1, 1, 1, 1, 1, jpkm1 )
- zwdia(ji,jj,jk) = 1._wp + p2dt * ( MAX( wi(ji,jj,jk) , 0._wp ) - MIN( wi(ji,jj,jk+1) , 0._wp ) ) &
- & / e3t(ji,jj,jk,Kaa)
- zwinf(ji,jj,jk) = p2dt * MIN( wi(ji,jj,jk ) , 0._wp ) / e3t(ji,jj,jk,Kaa)
- zwsup(ji,jj,jk) = -p2dt * MAX( wi(ji,jj,jk+1) , 0._wp ) / e3t(ji,jj,jk,Kaa)
- END_3D
- END IF
- !
- DO jn = 1, kjpt !== loop over the tracers ==!
- !
- ! !== upstream advection with initial mass fluxes & intermediate update ==!
- ! !* upstream tracer flux in the k direction *!
- DO_3D( 1, 1, 1, 1, 2, jpkm1 ) ! Interior value ( multiplied by wmask)
- zfp_wk = pW(ji,jj,jk) + ABS( pW(ji,jj,jk) )
- zfm_wk = pW(ji,jj,jk) - ABS( pW(ji,jj,jk) )
- zwz(ji,jj,jk) = 0.5 * ( zfp_wk * pt(ji,jj,jk,jn,Kbb) + zfm_wk * pt(ji,jj,jk-1,jn,Kbb) ) * wmask(ji,jj,jk)
- END_3D
- IF( ln_linssh ) THEN ! top ocean value (only in linear free surface as zwz has been w-masked)
- IF( ln_isfcav ) THEN ! top of the ice-shelf cavities and at the ocean surface
- DO_2D( 1, 1, 1, 1 )
- zwz(ji,jj, mikt(ji,jj) ) = pW(ji,jj,mikt(ji,jj)) * pt(ji,jj,mikt(ji,jj),jn,Kbb) ! linear free surface
- END_2D
- ELSE ! no cavities: only at the ocean surface
- DO_2D( 1, 1, 1, 1 )
- zwz(ji,jj,1) = pW(ji,jj,1) * pt(ji,jj,1,jn,Kbb)
- END_2D
- ENDIF
- ENDIF
- !
- ! !* upstream tracer flux in the i and j direction
- DO jk = 1, jpkm1
- DO jj = 1, jpj-1
- tracer_flux_i(zwx_3d(1,jj,jk),zfp_ui,zfm_ui,1,jj,jk)
- tracer_flux_j(zwy_3d(1,jj,jk),zfp_vj,zfm_vj,1,jj,jk)
- END DO
- DO ji = 1, jpi-1
- tracer_flux_i(zwx_3d(ji,1,jk),zfp_ui,zfm_ui,ji,1,jk)
- tracer_flux_j(zwy_3d(ji,1,jk),zfp_vj,zfm_vj,ji,1,jk)
- END DO
- DO_2D( 1, 1, 1, 1 )
- tracer_flux_i(zwx_3d(ji,jj,jk),zfp_ui,zfm_ui,ji,jj,jk)
- tracer_flux_i(zwx_im1,zfp_ui_m1,zfm_ui_m1,ji-1,jj,jk)
- tracer_flux_j(zwy_3d(ji,jj,jk),zfp_vj,zfm_vj,ji,jj,jk)
- tracer_flux_j(zwy_jm1,zfp_vj_m1,zfm_vj_m1,ji,jj-1,jk)
- ztra = - ( zwx_3d(ji,jj,jk) - zwx_im1 + zwy_3d(ji,jj,jk) - zwy_jm1 + zwz(ji,jj,jk) - zwz(ji,jj,jk+1) ) * r1_e1e2t(ji,jj)
- ! ! update and guess with monotonic sheme
- pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) + ztra &
- & / e3t(ji,jj,jk,Kmm ) * tmask(ji,jj,jk)
- zwi(ji,jj,jk) = ( e3t(ji,jj,jk,Kbb) * pt(ji,jj,jk,jn,Kbb) + p2dt * ztra ) &
- & / e3t(ji,jj,jk,Kaa ) * tmask(ji,jj,jk)
- END_2D
- END DO
-
- IF ( ll_zAimp ) THEN
- CALL tridia_solver( zwdia, zwsup, zwinf, zwi, zwi , 0 )
- !
- ztw(:,:,1) = 0._wp ; ztw(:,:,jpk) = 0._wp ;
- DO_3D( 1, 1, 1, 1, 2, jpkm1 ) ! Interior value ( multiplied by wmask)
- zfp_wk = wi(ji,jj,jk) + ABS( wi(ji,jj,jk) )
- zfm_wk = wi(ji,jj,jk) - ABS( wi(ji,jj,jk) )
- ztw(ji,jj,jk) = 0.5 * e1e2t(ji,jj) * ( zfp_wk * zwi(ji,jj,jk) + zfm_wk * zwi(ji,jj,jk-1) ) * wmask(ji,jj,jk)
- zwz(ji,jj,jk) = zwz(ji,jj,jk) + ztw(ji,jj,jk) ! update vertical fluxes
- END_3D
- DO_3D( 0, 0, 0, 0, 1, jpkm1 )
- pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) - ( ztw(ji,jj,jk) - ztw(ji ,jj ,jk+1) ) &
- & * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm)
- END_3D
- !
- END IF
- !
- IF( l_trd .OR. l_hst ) THEN ! trend diagnostics (contribution of upstream fluxes)
- ztrdx(:,:,:) = zwx_3d(:,:,:) ; ztrdy(:,:,:) = zwy_3d(:,:,:) ; ztrdz(:,:,:) = zwz(:,:,:)
- END IF
- ! ! "Poleward" heat and salt transports (contribution of upstream fluxes)
- IF( l_ptr ) zptry(:,:,:) = zwy_3d(:,:,:)
- !
- ! !== anti-diffusive flux : high order minus low order ==!
- !
- SELECT CASE( kn_fct_h ) !* horizontal anti-diffusive fluxes
- !
- CASE( 2 ) !- 2nd order centered
- DO_3D( 2, 1, 2, 1, 1, jpkm1 )
- zwx_3d(ji,jj,jk) = 0.5_wp * pU(ji,jj,jk) * ( pt(ji,jj,jk,jn,Kmm) + pt(ji+1,jj,jk,jn,Kmm) ) - zwx_3d(ji,jj,jk)
- zwy_3d(ji,jj,jk) = 0.5_wp * pV(ji,jj,jk) * ( pt(ji,jj,jk,jn,Kmm) + pt(ji,jj+1,jk,jn,Kmm) ) - zwy_3d(ji,jj,jk)
- END_3D
- !
- CASE( 4 ) !- 4th order centered
- zltu_3d(:,:,jpk) = 0._wp ! Bottom value : flux set to zero
- zltv_3d(:,:,jpk) = 0._wp
- ! ! Laplacian
- DO_3D( 0, 0, 0, 0, 1, jpkm1 ) ! 2nd derivative * 1/ 6
- ! ! 1st derivative (gradient)
- ztu = ( pt(ji+1,jj,jk,jn,Kmm) - pt(ji,jj,jk,jn,Kmm) ) * umask(ji,jj,jk)
- ztu_im1 = ( pt(ji,jj,jk,jn,Kmm) - pt(ji-1,jj,jk,jn,Kmm) ) * umask(ji-1,jj,jk)
- ztv = ( pt(ji,jj+1,jk,jn,Kmm) - pt(ji,jj,jk,jn,Kmm) ) * vmask(ji,jj,jk)
- ztv_jm1 = ( pt(ji,jj,jk,jn,Kmm) - pt(ji,jj-1,jk,jn,Kmm) ) * vmask(ji,jj-1,jk)
- ! ! 2nd derivative * 1/ 6
- zltu_3d(ji,jj,jk) = ( ztu + ztu_im1 ) * r1_6
- zltv_3d(ji,jj,jk) = ( ztv + ztv_jm1 ) * r1_6
- END_2D
- END DO
- ! NOTE [ comm_cleanup ] : need to change sign to ensure halo 1 - halo 2 compatibility
- CALL lbc_lnk( 'traadv_fct', zltu_3d, 'T', -1.0_wp , zltv_3d, 'T', -1.0_wp ) ! Lateral boundary cond. (unchanged sgn)
- !
- DO_3D( 2, 1, 2, 1, 1, jpkm1 )
- zC2t_u = pt(ji,jj,jk,jn,Kmm) + pt(ji+1,jj ,jk,jn,Kmm) ! 2 x C2 interpolation of T at u- & v-points
- zC2t_v = pt(ji,jj,jk,jn,Kmm) + pt(ji ,jj+1,jk,jn,Kmm)
- ! ! C4 minus upstream advective fluxes
- ! round brackets added to fix the order of floating point operations
- ! needed to ensure halo 1 - halo 2 compatibility
- zwx_3d(ji,jj,jk) = 0.5_wp * pU(ji,jj,jk) * ( zC2t_u + ( zltu_3d(ji,jj,jk) - zltu_3d(ji+1,jj,jk) &
- & ) & ! bracket for halo 1 - halo 2 compatibility
- & ) - zwx_3d(ji,jj,jk)
- zwy_3d(ji,jj,jk) = 0.5_wp * pV(ji,jj,jk) * ( zC2t_v + ( zltv_3d(ji,jj,jk) - zltv_3d(ji,jj+1,jk) &
- & ) & ! bracket for halo 1 - halo 2 compatibility
- & ) - zwy_3d(ji,jj,jk)
- END_3D
- !
- CASE( 41 ) !- 4th order centered ==>> !!gm coding attempt need to be tested
- DO_3D( 0, 0, 0, 0, 1, jpkm1 ) ! Horizontal advective fluxes
- ztu_im1 = ( pt(ji ,jj ,jk,jn,Kmm) - pt(ji-1,jj,jk,jn,Kmm) ) * umask(ji-1,jj,jk)
- ztu_ip1 = ( pt(ji+2,jj ,jk,jn,Kmm) - pt(ji+1,jj,jk,jn,Kmm) ) * umask(ji+1,jj,jk)
-
- ztv_jm1 = ( pt(ji,jj ,jk,jn,Kmm) - pt(ji,jj-1,jk,jn,Kmm) ) * vmask(ji,jj-1,jk)
- ztv_jp1 = ( pt(ji,jj+2,jk,jn,Kmm) - pt(ji,jj+1,jk,jn,Kmm) ) * vmask(ji,jj+1,jk)
- zC2t_u = pt(ji,jj,jk,jn,Kmm) + pt(ji+1,jj ,jk,jn,Kmm) ! 2 x C2 interpolation of T at u- & v-points (x2)
- zC2t_v = pt(ji,jj,jk,jn,Kmm) + pt(ji ,jj+1,jk,jn,Kmm)
- ! ! C4 interpolation of T at u- & v-points (x2)
- zC4t_u = zC2t_u + r1_6 * ( ztu_im1 - ztu_ip1 )
- zC4t_v = zC2t_v + r1_6 * ( ztv_jm1 - ztv_jp1 )
- ! ! C4 minus upstream advective fluxes
- zwx_3d(ji,jj,jk) = 0.5_wp * pU(ji,jj,jk) * zC4t_u - zwx_3d(ji,jj,jk)
- zwy_3d(ji,jj,jk) = 0.5_wp * pV(ji,jj,jk) * zC4t_v - zwy_3d(ji,jj,jk)
- END_3D
- CALL lbc_lnk( 'traadv_fct', zwx_3d, 'U', -1.0_wp , zwy_3d, 'V', -1.0_wp ) ! Lateral boundary cond. (unchanged sgn)
- !
- END SELECT
- !
- SELECT CASE( kn_fct_v ) !* vertical anti-diffusive fluxes (w-masked interior values)
- !
- CASE( 2 ) !- 2nd order centered
- DO_3D( 1, 1, 1, 1, 2, jpkm1 )
- zwz(ji,jj,jk) = ( pW(ji,jj,jk) * 0.5_wp * ( pt(ji,jj,jk,jn,Kmm) + pt(ji,jj,jk-1,jn,Kmm) ) &
- & - zwz(ji,jj,jk) ) * wmask(ji,jj,jk)
- END_3D
- !
- CASE( 4 ) !- 4th order COMPACT
- CALL interp_4th_cpt( pt(:,:,:,jn,Kmm) , ztw ) ! zwt = COMPACT interpolation of T at w-point
- DO_3D( 1, 1, 1, 1, 2, jpkm1 )
- zwz(ji,jj,jk) = ( pW(ji,jj,jk) * ztw(ji,jj,jk) - zwz(ji,jj,jk) ) * wmask(ji,jj,jk)
- END_3D
- !
- END SELECT
- IF( ln_linssh ) THEN ! top ocean value: high order = upstream ==>> zwz=0
- zwz(:,:,1) = 0._wp ! only ocean surface as interior zwz values have been w-masked
- ENDIF
- !
- CALL lbc_lnk( 'traadv_fct', zwi, 'T', 1.0_wp)
- !
- IF ( ll_zAimp ) THEN
- DO_3D( 1, 1, 1, 1, 1, jpkm1 ) !* trend and after field with monotonic scheme
- ! ! total intermediate advective trends
- ztra = - ( zwx_3d(ji,jj,jk) - zwx_3d(ji-1,jj ,jk ) &
- & + zwy_3d(ji,jj,jk) - zwy_3d(ji ,jj-1,jk ) &
- & + zwz(ji,jj,jk) - zwz(ji ,jj ,jk+1) ) * r1_e1e2t(ji,jj)
- ztw(ji,jj,jk) = zwi(ji,jj,jk) + p2dt * ztra / e3t(ji,jj,jk,Kaa) * tmask(ji,jj,jk)
- END_3D
- !
- CALL tridia_solver( zwdia, zwsup, zwinf, ztw, ztw , 0 )
- !
- DO_3D( 1, 1, 1, 1, 2, jpkm1 ) ! Interior value ( multiplied by wmask)
- zfp_wk = wi(ji,jj,jk) + ABS( wi(ji,jj,jk) )
- zfm_wk = wi(ji,jj,jk) - ABS( wi(ji,jj,jk) )
- zwz(ji,jj,jk) = zwz(ji,jj,jk) + 0.5 * e1e2t(ji,jj) * ( zfp_wk * ztw(ji,jj,jk) + zfm_wk * ztw(ji,jj,jk-1) ) * wmask(ji,jj,jk)
- END_3D
- END IF
- !
- ! !== monotonicity algorithm ==!
- !
- CALL nonosc( Kaa, pt(:,:,:,jn,Kbb), zwx_3d, zwy_3d, zwz, zwi, p2dt )
- !
- ! !== final trend with corrected fluxes ==!
- !
- DO_3D( 0, 0, 0, 0, 1, jpkm1 )
- ztra = - ( zwx_3d(ji,jj,jk) - zwx_3d(ji-1,jj ,jk ) &
- & + zwy_3d(ji,jj,jk) - zwy_3d(ji ,jj-1,jk ) &
- & + zwz(ji,jj,jk) - zwz(ji ,jj ,jk+1) ) * r1_e1e2t(ji,jj)
- pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) + ztra / e3t(ji,jj,jk,Kmm)
- zwi(ji,jj,jk) = zwi(ji,jj,jk) + p2dt * ztra / e3t(ji,jj,jk,Kaa) * tmask(ji,jj,jk)
- END_3D
- !
- IF ( ll_zAimp ) THEN
- !
- ztw(:,:,1) = 0._wp ; ztw(:,:,jpk) = 0._wp
- DO_3D( 0, 0, 0, 0, 2, jpkm1 ) ! Interior value ( multiplied by wmask)
- zfp_wk = wi(ji,jj,jk) + ABS( wi(ji,jj,jk) )
- zfm_wk = wi(ji,jj,jk) - ABS( wi(ji,jj,jk) )
- ztw(ji,jj,jk) = - 0.5 * e1e2t(ji,jj) * ( zfp_wk * zwi(ji,jj,jk) + zfm_wk * zwi(ji,jj,jk-1) ) * wmask(ji,jj,jk)
- zwz(ji,jj,jk) = zwz(ji,jj,jk) + ztw(ji,jj,jk) ! Update vertical fluxes for trend diagnostic
- END_3D
- DO_3D( 0, 0, 0, 0, 1, jpkm1 )
- pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) - ( ztw(ji,jj,jk) - ztw(ji ,jj ,jk+1) ) &
- & * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm)
- END_3D
- END IF
- ! NOT TESTED - NEED l_trd OR l_hst TRUE
- IF( l_trd .OR. l_hst ) THEN ! trend diagnostics // heat/salt transport
- ztrdx(:,:,:) = ztrdx(:,:,:) + zwx_3d(:,:,:) ! <<< add anti-diffusive fluxes
- ztrdy(:,:,:) = ztrdy(:,:,:) + zwy_3d(:,:,:) ! to upstream fluxes
- ztrdz(:,:,:) = ztrdz(:,:,:) + zwz(:,:,:) !
- !
- IF( l_trd ) THEN ! trend diagnostics
- CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_xad, ztrdx, pU, pt(:,:,:,jn,Kmm) )
- CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_yad, ztrdy, pV, pt(:,:,:,jn,Kmm) )
- CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_zad, ztrdz, pW, pt(:,:,:,jn,Kmm) )
- ENDIF
- ! ! heat/salt transport
- IF( l_hst ) CALL dia_ar5_hst( jn, 'adv', ztrdx(:,:,:), ztrdy(:,:,:) )
- !
- ENDIF
- ! NOT TESTED - NEED l_ptr TRUE
- IF( l_ptr ) THEN ! "Poleward" transports
- zptry(:,:,:) = zptry(:,:,:) + zwy_3d(:,:,:) ! <<< add anti-diffusive fluxes
- CALL dia_ptr_hst( jn, 'adv', zptry(:,:,:) )
- ENDIF
- !
- END DO ! end of tracer loop
- !
- IF ( ll_zAimp ) THEN
- DEALLOCATE( zwdia, zwinf, zwsup )
- ENDIF
- IF( l_trd .OR. l_hst ) THEN
- DEALLOCATE( ztrdx, ztrdy, ztrdz )
- ENDIF
- IF( l_ptr ) THEN
- DEALLOCATE( zptry )
- ENDIF
- !
- END SUBROUTINE tra_adv_fct_lf
-#endif
!!======================================================================
END MODULE traadv_fct
diff --git a/src/OCE/TRA/traadv_mus.F90 b/src/OCE/TRA/traadv_mus.F90
index 4c4b0437ca01cb250cf6f560527e8b0b5a632803..f49d6fae47c2a58e31c040c75558f97d95481236 100644
--- a/src/OCE/TRA/traadv_mus.F90
+++ b/src/OCE/TRA/traadv_mus.F90
@@ -9,6 +9,7 @@ MODULE traadv_mus
!! 3.2 ! 2010-05 (C. Ethe, G. Madec) merge TRC-TRA + switch from velocity to transport
!! 3.4 ! 2012-06 (P. Oddo, M. Vichi) include the upstream where needed
!! 3.7 ! 2015-09 (G. Madec) add the ice-shelf cavities boundary condition
+ !! 4.5 ! 2022-06 (S. Techene, G, Madec) refactorization to reduce local memory usage
!!----------------------------------------------------------------------
!!----------------------------------------------------------------------
@@ -34,7 +35,8 @@ MODULE traadv_mus
IMPLICIT NONE
PRIVATE
- PUBLIC tra_adv_mus ! routine called by traadv.F90
+ PUBLIC tra_adv_mus ! routine called by traadv.F90
+
REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: upsmsk !: mixed upstream/centered scheme near some straits
! ! and in closed seas (orca 2 and 1 configurations)
@@ -80,16 +82,17 @@ CONTAINS
INTEGER , INTENT(in ) :: kjpt ! number of tracers
LOGICAL , INTENT(in ) :: ld_msc_ups ! use upstream scheme within muscl
REAL(wp) , INTENT(in ) :: p2dt ! tracer time-step
- ! TEMP: [tiling] This can be A2D(nn_hls) after all lbc_lnks removed in the nn_hls = 2 case in tra_adv_fct
- REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pU, pV, pW ! 3 ocean volume flux components
+ REAL(wp), DIMENSION(T2D(nn_hls),jpk ), INTENT(in ) :: pU, pV, pW ! 3 ocean volume flux components
REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) :: pt ! tracers and RHS of tracer equation
!
INTEGER :: ji, jj, jk, jn ! dummy loop indices
INTEGER :: ierr ! local integer
- REAL(wp) :: zu, z0u, zzwx, zw , zalpha ! local scalars
- REAL(wp) :: zv, z0v, zzwy, z0w ! - -
- REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zwx, zslpx ! 3D workspace
- REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zwy, zslpy ! - -
+ INTEGER :: ik
+ REAL(wp) :: zu, z0u, zzslpx, zzwx, zw , zalpha ! local scalars
+ REAL(wp) :: zv, z0v, zzslpy, zzwy, z0w ! - -
+ REAL(wp) :: zdzt_kp2, zslpz_kp1, zfW_kp1
+ REAL(wp), DIMENSION(T2D(2)) :: zdxt, zslpx, zwx ! 2D workspace
+ REAL(wp), DIMENSION(T2D(2)) :: zdyt, zslpy, zwy ! - -
!!----------------------------------------------------------------------
!
IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile
@@ -104,15 +107,10 @@ CONTAINS
!
ALLOCATE( xind(jpi,jpj,jpk), STAT=ierr )
xind(:,:,:) = 1._wp ! set equal to 1 where up-stream is not needed
- !
IF( ld_msc_ups ) THEN ! define the upstream indicator (if asked)
- ALLOCATE( upsmsk(jpi,jpj), STAT=ierr )
- upsmsk(:,:) = 0._wp ! not upstream by default
- !
DO jk = 1, jpkm1
xind(:,:,jk) = 1._wp & ! =>1 where up-stream is not needed
- & - MAX ( rnfmsk(:,:) * rnfmsk_z(jk), & ! =>0 near runoff mouths (& closed sea outflows)
- & upsmsk(:,:) ) * tmask(:,:,jk) ! =>0 in some user defined area
+ & - rnfmsk(:,:) * rnfmsk_z(jk) * tmask(:,:,jk) ! =>0 near runoff mouths (& closed sea outflows)
END DO
ENDIF
!
@@ -127,115 +125,141 @@ CONTAINS
& iom_use("uadv_salttr") .OR. iom_use("vadv_salttr") ) ) l_hst = .TRUE.
ENDIF
!
+ !
DO jn = 1, kjpt !== loop over the tracers ==!
!
- ! !* Horizontal advective fluxes
- !
- ! !-- first guess of the slopes
- zwx(:,:,jpk) = 0._wp ! bottom values
- zwy(:,:,jpk) = 0._wp
- DO_3D( nn_hls, nn_hls-1, nn_hls, nn_hls-1, 1, jpkm1 )
- zwx(ji,jj,jk) = umask(ji,jj,jk) * ( pt(ji+1,jj,jk,jn,Kbb) - pt(ji,jj,jk,jn,Kbb) )
- zwy(ji,jj,jk) = vmask(ji,jj,jk) * ( pt(ji,jj+1,jk,jn,Kbb) - pt(ji,jj,jk,jn,Kbb) )
- END_3D
- ! !-- Slopes of tracer
- zslpx(:,:,jpk) = 0._wp ! bottom values
- zslpy(:,:,jpk) = 0._wp
- DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpkm1 )
- zslpx(ji,jj,jk) = ( zwx(ji,jj,jk) + zwx(ji-1,jj ,jk) ) &
- & * ( 0.25 + SIGN( 0.25_wp, zwx(ji,jj,jk) * zwx(ji-1,jj ,jk) ) )
- zslpy(ji,jj,jk) = ( zwy(ji,jj,jk) + zwy(ji ,jj-1,jk) ) &
- & * ( 0.25 + SIGN( 0.25_wp, zwy(ji,jj,jk) * zwy(ji ,jj-1,jk) ) )
- END_3D
- !
- DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpkm1 ) !-- Slopes limitation
- zslpx(ji,jj,jk) = SIGN( 1.0_wp, zslpx(ji,jj,jk) ) * MIN( ABS( zslpx(ji ,jj,jk) ), &
- & 2.*ABS( zwx (ji-1,jj,jk) ), &
- & 2.*ABS( zwx (ji ,jj,jk) ) )
- zslpy(ji,jj,jk) = SIGN( 1.0_wp, zslpy(ji,jj,jk) ) * MIN( ABS( zslpy(ji,jj ,jk) ), &
- & 2.*ABS( zwy (ji,jj-1,jk) ), &
- & 2.*ABS( zwy (ji,jj ,jk) ) )
- END_3D
- ! NOTE [ comm_cleanup ] : need to change sign to ensure halo 1 - halo 2 compatibility
- IF ( nn_hls==1 ) CALL lbc_lnk( 'traadv_mus', zslpx, 'T', -1.0_wp , zslpy, 'T', -1.0_wp ) ! lateral boundary conditions (changed sign)
- !
- DO_3D( 1, 0, 1, 0, 1, jpkm1 ) !-- MUSCL horizontal advective fluxes
- ! MUSCL fluxes
- z0u = SIGN( 0.5_wp, pU(ji,jj,jk) )
- zalpha = 0.5 - z0u
- zu = z0u - 0.5 * pU(ji,jj,jk) * p2dt * r1_e1e2u(ji,jj) / e3u(ji,jj,jk,Kmm)
- zzwx = pt(ji+1,jj,jk,jn,Kbb) + xind(ji,jj,jk) * zu * zslpx(ji+1,jj,jk)
- zzwy = pt(ji ,jj,jk,jn,Kbb) + xind(ji,jj,jk) * zu * zslpx(ji ,jj,jk)
- zwx(ji,jj,jk) = pU(ji,jj,jk) * ( zalpha * zzwx + (1.-zalpha) * zzwy )
+ DO jk = 1, jpkm1
+ ! !* Horizontal advective fluxes
!
- z0v = SIGN( 0.5_wp, pV(ji,jj,jk) )
- zalpha = 0.5 - z0v
- zv = z0v - 0.5 * pV(ji,jj,jk) * p2dt * r1_e1e2v(ji,jj) / e3v(ji,jj,jk,Kmm)
- zzwx = pt(ji,jj+1,jk,jn,Kbb) + xind(ji,jj,jk) * zv * zslpy(ji,jj+1,jk)
- zzwy = pt(ji,jj ,jk,jn,Kbb) + xind(ji,jj,jk) * zv * zslpy(ji,jj ,jk)
- zwy(ji,jj,jk) = pV(ji,jj,jk) * ( zalpha * zzwx + (1.-zalpha) * zzwy )
- END_3D
- !
- DO_3D( 0, 0, 0, 0, 1, jpkm1 ) !-- Tracer advective trend
- pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) - ( zwx(ji,jj,jk) - zwx(ji-1,jj ,jk ) &
- & + zwy(ji,jj,jk) - zwy(ji ,jj-1,jk ) ) &
- & * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm)
- END_3D
- ! ! trend diagnostics
- IF( l_trd ) THEN
- CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_xad, zwx, pU, pt(:,:,:,jn,Kbb) )
- CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_yad, zwy, pV, pt(:,:,:,jn,Kbb) )
- END IF
- ! ! "Poleward" heat and salt transports
- IF( l_ptr ) CALL dia_ptr_hst( jn, 'adv', zwy(:,:,:) )
- ! ! heat transport
- IF( l_hst ) CALL dia_ar5_hst( jn, 'adv', zwx(:,:,:), zwy(:,:,:) )
+ ! !-- first guess of the slopes
+ DO_2D( 2, 1, 2, 1 )
+ zdxt(ji,jj) = ( pt(ji+1,jj ,jk,jn,Kbb) - pt(ji,jj,jk,jn,Kbb) ) * umask(ji,jj,jk)
+ zdyt(ji,jj) = ( pt(ji ,jj+1,jk,jn,Kbb) - pt(ji,jj,jk,jn,Kbb) ) * vmask(ji,jj,jk)
+ END_2D
+ ! !-- Slopes of tracer
+ DO_2D( 1, 1, 1, 1 )
+ ! ! 1/2 Slopes at T-point (set to 0 if adjectent slopes are of opposite sign)
+ zzslpx = ( zdxt(ji,jj) + zdxt(ji-1,jj ) ) &
+ & * ( 0.25_wp + SIGN( 0.25_wp, zdxt(ji,jj) * zdxt(ji-1,jj ) ) )
+ zzslpy = ( zdyt(ji,jj) + zdyt(ji ,jj-1) ) &
+ & * ( 0.25_wp + SIGN( 0.25_wp, zdyt(ji,jj) * zdyt(ji ,jj-1) ) )
+ ! ! Slopes limitation
+ zslpx(ji,jj) = SIGN( 1.0_wp, zzslpx ) * MIN( ABS( zzslpx ), &
+ & 2._wp*ABS( zdxt (ji-1,jj) ), &
+ & 2._wp*ABS( zdxt (ji ,jj) ) )
+ zslpy(ji,jj) = SIGN( 1.0_wp, zzslpy ) * MIN( ABS( zzslpy ), &
+ & 2._wp*ABS( zdyt (ji,jj-1) ), &
+ & 2._wp*ABS( zdyt (ji,jj ) ) )
+ END_2D
+!!gm + !!st ticket ? comparaison pommes et carrottes ABS(zzslpx) et 2._wp*ABS( zdxt (ji-1,jj) )
+ !
+ DO_2D( 1, 0, 1, 0 ) !-- MUSCL horizontal advective fluxes
+ z0u = SIGN( 0.5_wp, pU(ji,jj,jk) )
+ zalpha = 0.5_wp - z0u
+ zu = z0u - 0.5_wp * pU(ji,jj,jk) * p2dt * r1_e1e2u(ji,jj) / e3u(ji,jj,jk,Kmm)
+ zzwx = pt(ji+1,jj,jk,jn,Kbb) + xind(ji,jj,jk) * zu * zslpx(ji+1,jj)
+ zzwy = pt(ji ,jj,jk,jn,Kbb) + xind(ji,jj,jk) * zu * zslpx(ji ,jj)
+ zwx(ji,jj) = pU(ji,jj,jk) * ( zalpha * zzwx + (1._wp-zalpha) * zzwy )
+ !
+ z0v = SIGN( 0.5_wp, pV(ji,jj,jk) )
+ zalpha = 0.5_wp - z0v
+ zv = z0v - 0.5_wp * pV(ji,jj,jk) * p2dt * r1_e1e2v(ji,jj) / e3v(ji,jj,jk,Kmm)
+ zzwx = pt(ji,jj+1,jk,jn,Kbb) + xind(ji,jj,jk) * zv * zslpy(ji,jj+1)
+ zzwy = pt(ji,jj ,jk,jn,Kbb) + xind(ji,jj,jk) * zv * zslpy(ji,jj )
+ zwy(ji,jj) = pV(ji,jj,jk) * ( zalpha * zzwx + (1._wp-zalpha) * zzwy )
+ END_2D
+ !
+ DO_2D( 0, 0, 0, 0 ) !-- Tracer advective trend
+ pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) - ( ( zwx(ji,jj) - zwx(ji-1,jj ) ) & ! ad () for NP repro
+ & + ( zwy(ji,jj) - zwy(ji ,jj-1) ) ) &
+ & * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm)
+ END_2D
+ END DO
+!!gm + !!st to be done with the whole rewritting of trd
+!! trd routine arguments MUST be changed adding jk and zwx, zwy in 2D
+!!
+!! ! ! trend diagnostics
+!! IF( l_trd ) THEN
+!! CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jk, jptra_xad, zwx(:,:), pU, pt(:,:,:,jn,Kbb) )
+!! CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jk, jptra_yad, zwy(:,:), pV, pt(:,:,:,jn,Kbb) )
+!! END IF
+!! ! ! "Poleward" heat and salt transports
+!! IF( l_ptr ) CALL dia_ptr_hst( jn, jk, 'adv', zwy(:,:) )
+!! ! ! heat transport
+!! IF( l_hst ) CALL dia_ar5_hst( jn, jk, 'adv', zwx(:,:), zwy(:,:) )
!
! !* Vertical advective fluxes
!
- ! !-- first guess of the slopes
- zwx(:,:, 1 ) = 0._wp ! surface & bottom boundary conditions
- zwx(:,:,jpk) = 0._wp
- DO_3D( 0, 0, 0, 0, 2, jpkm1 ) ! interior values
- zwx(ji,jj,jk) = tmask(ji,jj,jk) * ( pt(ji,jj,jk-1,jn,Kbb) - pt(ji,jj,jk,jn,Kbb) )
- END_3D
- ! !-- Slopes of tracer
- zslpx(:,:,1) = 0._wp ! surface values
- DO_3D( 0, 0, 0, 0, 2, jpkm1 )
- zslpx(ji,jj,jk) = ( zwx(ji,jj,jk) + zwx(ji,jj,jk+1) ) &
- & * ( 0.25 + SIGN( 0.25_wp, zwx(ji,jj,jk) * zwx(ji,jj,jk+1) ) )
- END_3D
- DO_3D( 0, 0, 0, 0, 2, jpkm1 ) !-- Slopes limitation
- zslpx(ji,jj,jk) = SIGN( 1.0_wp, zslpx(ji,jj,jk) ) * MIN( ABS( zslpx(ji,jj,jk ) ), &
- & 2.*ABS( zwx (ji,jj,jk+1) ), &
- & 2.*ABS( zwx (ji,jj,jk ) ) )
- END_3D
- DO_3D( 0, 0, 0, 0, 1, jpk-2 ) !-- vertical advective flux
- z0w = SIGN( 0.5_wp, pW(ji,jj,jk+1) )
- zalpha = 0.5 + z0w
- zw = z0w - 0.5 * pW(ji,jj,jk+1) * p2dt * r1_e1e2t(ji,jj) / e3w(ji,jj,jk+1,Kmm)
- zzwx = pt(ji,jj,jk+1,jn,Kbb) + xind(ji,jj,jk) * zw * zslpx(ji,jj,jk+1)
- zzwy = pt(ji,jj,jk ,jn,Kbb) + xind(ji,jj,jk) * zw * zslpx(ji,jj,jk )
- zwx(ji,jj,jk+1) = pW(ji,jj,jk+1) * ( zalpha * zzwx + (1.-zalpha) * zzwy ) * wmask(ji,jj,jk)
- END_3D
- IF( ln_linssh ) THEN ! top values, linear free surface only
+#define zdzt_kp1 zdxt
+#define zslpz zslpx
+#define zfW zwx
+
+ zfW (T2D(0)) = 0._wp ! anciennement zwx at jk = 1
+ ! ! anciennement zwx at jk = 2
+ DO_2D( 0, 0, 0, 0 )
+ zdzt_kp1(ji,jj) = tmask(ji,jj,2) * ( pt(ji,jj,1,jn,Kbb) - pt(ji,jj,2,jn,Kbb) )
+ END_2D
+ zslpz (T2D(0)) = 0._wp ! anciennement zslpx at jk = 1
+ !
+ IF( ln_linssh ) THEN !-- linear ssh : non zero top values
+ DO_2D( 0, 0, 0, 0 ) ! at the ocean surface
+ zfW(ji,jj) = pW(ji,jj,1) * pt(ji,jj,1,jn,Kbb) ! surface flux
+ END_2D
IF( ln_isfcav ) THEN ! ice-shelf cavities (top of the ocean)
+ DO_2D( 0, 0, 0, 0 ) ! update pt(Krhs) under the ice-shelf
+ ik = mikt(ji,jj) ! the flux at ik-1 is zero ( inside ice-shelf )
+ IF( ik > 1 ) THEN
+ pt(ji,jj,ik,jn,Krhs) = pt(ji,jj,ik,jn,Krhs) - pW(ji,jj,ik) * pt(ji,jj,ik,jn,Kbb) &
+ & * r1_e1e2t(ji,jj) / e3t(ji,jj,ik,Kmm)
+ ENDIF
+ END_2D
+ ENDIF
+ ENDIF
+ !
+ ! wmask usage for computing zw and zwk is needed in isf case and linear ssh
+ !
+ !
+ DO jk = 1, jpkm1
+ IF( jk < jpkm1 ) THEN
DO_2D( 0, 0, 0, 0 )
- zwx(ji,jj, mikt(ji,jj) ) = pW(ji,jj,mikt(ji,jj)) * pt(ji,jj,mikt(ji,jj),jn,Kbb)
+ ! !-- Slopes of tracer
+ ! ! masked vertical gradient at jk+2
+ zdzt_kp2 = ( pt(ji,jj,jk+1,jn,Kbb) - pt(ji,jj,jk+2,jn,Kbb) ) * tmask(ji,jj,jk+2) !!st wmask(ji,jj,jk+2)
+ ! ! vertical slope at jk+1
+ zslpz_kp1 = ( zdzt_kp1(ji,jj) + zdzt_kp2 ) &
+ & * ( 0.25_wp + SIGN( 0.25_wp, zdzt_kp1(ji,jj) * zdzt_kp2 ) )
+ ! ! slope limitation
+ zslpz_kp1 = SIGN( 1.0_wp, zslpz_kp1 ) * MIN( ABS( zslpz_kp1 ), &
+ & 2.*ABS( zdzt_kp2 ), &
+ & 2.*ABS( zdzt_kp1(ji,jj) ) )
+ ! !-- vertical advective flux at jk+1
+ ! ! caution: zfW_kp1 is masked for ice-shelf cavities
+ ! ! since top fluxes already added to pt(Krhs) before the vertical loop
+ z0w = SIGN( 0.5_wp, pW(ji,jj,jk+1) )
+ zalpha = 0.5_wp + z0w
+ zw = z0w - 0.5_wp * pW(ji,jj,jk+1) * p2dt * r1_e1e2t(ji,jj) / e3w(ji,jj,jk+1,Kmm)
+ zzwx = pt(ji,jj,jk+1,jn,Kbb) + xind(ji,jj,jk) * zw * zslpz_kp1
+ zzwy = pt(ji,jj,jk ,jn,Kbb) + xind(ji,jj,jk) * zw * zslpz(ji,jj)
+ zfW_kp1 = pW(ji,jj,jk+1) * ( zalpha * zzwx + (1.-zalpha) * zzwy ) * wmask(ji,jj,jk)!!st * wmask(ji,jj,jk+1)
+ ! !-- vertical advective trend at jk
+ pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) - ( zfW(ji,jj) - zfW_kp1 ) &
+ & * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm)
+ ! ! updates for next level
+ zdzt_kp1(ji,jj) = zdzt_kp2
+ zslpz (ji,jj) = zslpz_kp1
+ zfW (ji,jj) = zfW_kp1
END_2D
- ELSE ! no cavities: only at the ocean surface
- DO_2D( 0, 0, 0, 0 )
- zwx(ji,jj,1) = pW(ji,jj,1) * pt(ji,jj,1,jn,Kbb)
+ ELSE
+ DO_2D( 0, 0, 0, 0 ) !-- vertical advective trend at jpkm1
+ pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) - zfW(ji,jj) &
+ & * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm)
END_2D
ENDIF
- ENDIF
+ END DO ! end of jk loop
!
- DO_3D( 0, 0, 0, 0, 1, jpkm1 ) !-- vertical advective trend
- pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) - ( zwx(ji,jj,jk) - zwx(ji,jj,jk+1) ) &
- & * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm)
- END_3D
- ! ! send trends for diagnostic
- IF( l_trd ) CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_zad, zwx, pW, pt(:,:,:,jn,Kbb) )
+!!gm + !!st idem see above
+!! ! ! send trends for diagnostic
+!! IF( l_trd ) CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_zad, zwx, pW, pt(:,:,:,jn,Kbb) )
!
END DO ! end of tracer loop
!
diff --git a/src/OCE/TRA/traadv_qck.F90 b/src/OCE/TRA/traadv_qck.F90
index cdb96902b43fea6bb976a8b0f55b4b4cad5bb74a..a12d399498288f0faf8118753ee26599fc8b5b80 100644
--- a/src/OCE/TRA/traadv_qck.F90
+++ b/src/OCE/TRA/traadv_qck.F90
@@ -26,9 +26,6 @@ MODULE traadv_qck
USE lib_mpp ! distribued memory computing
USE lbclnk ! ocean lateral boundary condition (or mpp link)
USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined)
-#if defined key_loop_fusion
- USE traadv_qck_lf ! QCK scheme (tra_adv_qck routine - loop fusion version)
-#endif
IMPLICIT NONE
PRIVATE
@@ -93,14 +90,10 @@ CONTAINS
CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator)
INTEGER , INTENT(in ) :: kjpt ! number of tracers
REAL(wp) , INTENT(in ) :: p2dt ! tracer time-step
- ! TEMP: [tiling] This can be A2D(nn_hls) after all lbc_lnks removed in the nn_hls = 2 case in tra_adv_fct
- REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pU, pV, pW ! 3 ocean volume transport components
+ REAL(wp), DIMENSION(T2D(nn_hls),jpk ), INTENT(in ) :: pU, pV, pW ! 3 ocean volume transport components
REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) :: pt ! tracers and RHS of tracer equation
!!----------------------------------------------------------------------
!
-#if defined key_loop_fusion
- CALL tra_adv_qck_lf ( kt, kit000, cdtype, p2dt, pU, pV, pW, Kbb, Kmm, pt, kjpt, Krhs )
-#else
IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile
IF( kt == kit000 ) THEN
IF(lwp) WRITE(numout,*)
@@ -122,7 +115,6 @@ CONTAINS
! ! vertical fluxes are computed with the 2nd order centered scheme
CALL tra_adv_cen2_k( kt, cdtype, pW, Kmm, pt, kjpt, Krhs )
!
-#endif
END SUBROUTINE tra_adv_qck
@@ -130,18 +122,17 @@ CONTAINS
!!----------------------------------------------------------------------
!!
!!----------------------------------------------------------------------
- INTEGER , INTENT(in ) :: kt ! ocean time-step index
+ INTEGER , INTENT(in ) :: kt ! ocean time-step index
INTEGER , INTENT(in ) :: Kbb, Kmm, Krhs ! ocean time level indices
- CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator)
- INTEGER , INTENT(in ) :: kjpt ! number of tracers
- REAL(wp) , INTENT(in ) :: p2dt ! tracer time-step
- ! TEMP: [tiling] This can be A2D(nn_hls) after all lbc_lnks removed in the nn_hls = 2 case in tra_adv_fct
- REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pU ! i-velocity components
+ CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator)
+ INTEGER , INTENT(in ) :: kjpt ! number of tracers
+ REAL(wp) , INTENT(in ) :: p2dt ! tracer time-step
+ REAL(wp), DIMENSION(T2D(nn_hls),jpk ), INTENT(in ) :: pU ! i-velocity components
REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) :: pt ! active tracers and RHS of tracer equation
!!
INTEGER :: ji, jj, jk, jn ! dummy loop indices
REAL(wp) :: ztra, zbtr, zdir, zdx, zmsk ! local scalars
- REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zwx, zfu, zfc, zfd
+ REAL(wp), DIMENSION(T2D(nn_hls),jpk) :: zwx, zfu, zfc, zfd
!----------------------------------------------------------------------
!
! ! ===========
@@ -215,18 +206,17 @@ CONTAINS
!!----------------------------------------------------------------------
!!
!!----------------------------------------------------------------------
- INTEGER , INTENT(in ) :: kt ! ocean time-step index
+ INTEGER , INTENT(in ) :: kt ! ocean time-step index
INTEGER , INTENT(in ) :: Kbb, Kmm, Krhs ! ocean time level indices
- CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator)
- INTEGER , INTENT(in ) :: kjpt ! number of tracers
- REAL(wp) , INTENT(in ) :: p2dt ! tracer time-step
- ! TEMP: [tiling] This can be A2D(nn_hls) after all lbc_lnks removed in the nn_hls = 2 case in tra_adv_fct
- REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pV ! j-velocity components
+ CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator)
+ INTEGER , INTENT(in ) :: kjpt ! number of tracers
+ REAL(wp) , INTENT(in ) :: p2dt ! tracer time-step
+ REAL(wp), DIMENSION(T2D(nn_hls),jpk ), INTENT(in ) :: pV ! j-velocity components
REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) :: pt ! active tracers and RHS of tracer equation
!!
INTEGER :: ji, jj, jk, jn ! dummy loop indices
REAL(wp) :: ztra, zbtr, zdir, zdx, zmsk ! local scalars
- REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zwy, zfu, zfc, zfd ! 3D workspace
+ REAL(wp), DIMENSION(T2D(nn_hls),jpk) :: zwy, zfu, zfc, zfd ! 3D workspace
!----------------------------------------------------------------------
!
! ! ===========
@@ -312,16 +302,15 @@ CONTAINS
!!----------------------------------------------------------------------
!!
!!----------------------------------------------------------------------
- INTEGER , INTENT(in ) :: kt ! ocean time-step index
+ INTEGER , INTENT(in ) :: kt ! ocean time-step index
INTEGER , INTENT(in ) :: Kmm, Krhs ! ocean time level indices
- CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator)
- INTEGER , INTENT(in ) :: kjpt ! number of tracers
- ! TEMP: [tiling] This can be A2D(nn_hls) after all lbc_lnks removed in the nn_hls = 2 case in tra_adv_fct
- REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pW ! vertical velocity
- REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) :: pt ! active tracers and RHS of tracer equation
+ CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator)
+ INTEGER , INTENT(in ) :: kjpt ! number of tracers
+ REAL(wp), DIMENSION(T2D(nn_hls),jpk ), INTENT(in ) :: pW ! vertical velocity
+ REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) :: pt ! active tracers and RHS of tracer equation
!
INTEGER :: ji, jj, jk, jn ! dummy loop indices
- REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zwz ! 3D workspace
+ REAL(wp), DIMENSION(T2D(nn_hls),jpk) :: zwz ! 3D workspace
!!----------------------------------------------------------------------
!
zwz(:,:, 1 ) = 0._wp ! surface & bottom values set to zero for all tracers
@@ -365,10 +354,10 @@ CONTAINS
!!
!! ** Method :
!!----------------------------------------------------------------------
- REAL(wp), DIMENSION(A2D(nn_hls),jpk), INTENT(in ) :: pfu ! second upwind point
- REAL(wp), DIMENSION(A2D(nn_hls),jpk), INTENT(in ) :: pfd ! first douwning point
- REAL(wp), DIMENSION(A2D(nn_hls),jpk), INTENT(in ) :: pfc ! the central point (or the first upwind point)
- REAL(wp), DIMENSION(A2D(nn_hls),jpk), INTENT(inout) :: puc ! input as Courant number ; output as flux
+ REAL(wp), DIMENSION(T2D(nn_hls),jpk), INTENT(in ) :: pfu ! second upwind point
+ REAL(wp), DIMENSION(T2D(nn_hls),jpk), INTENT(in ) :: pfd ! first douwning point
+ REAL(wp), DIMENSION(T2D(nn_hls),jpk), INTENT(in ) :: pfc ! the central point (or the first upwind point)
+ REAL(wp), DIMENSION(T2D(nn_hls),jpk), INTENT(inout) :: puc ! input as Courant number ; output as flux
!!
INTEGER :: ji, jj, jk ! dummy loop indices
REAL(wp) :: zcoef1, zcoef2, zcoef3 ! local scalars
diff --git a/src/OCE/TRA/traadv_qck_lf.F90 b/src/OCE/TRA/traadv_qck_lf.F90
index e866bd80944f4aef98bc4cafd829acda452d085e..dfca3032d3e670d636b80e6e1143260281a1dc3b 100644
--- a/src/OCE/TRA/traadv_qck_lf.F90
+++ b/src/OCE/TRA/traadv_qck_lf.F90
@@ -90,8 +90,7 @@ CONTAINS
CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator)
INTEGER , INTENT(in ) :: kjpt ! number of tracers
REAL(wp) , INTENT(in ) :: p2dt ! tracer time-step
- ! TEMP: [tiling] This can be A2D(nn_hls) if using XIOS (subdomain support)
- REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pU, pV, pW ! 3 ocean volume transport components
+ REAL(wp), DIMENSION(T2D(nn_hls),jpk ), INTENT(in ) :: pU, pV, pW ! 3 ocean volume transport components
REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) :: pt ! tracers and RHS of tracer equation
!!----------------------------------------------------------------------
!
@@ -123,19 +122,18 @@ CONTAINS
!!----------------------------------------------------------------------
!!
!!----------------------------------------------------------------------
- INTEGER , INTENT(in ) :: kt ! ocean time-step index
+ INTEGER , INTENT(in ) :: kt ! ocean time-step index
INTEGER , INTENT(in ) :: Kbb, Kmm, Krhs ! ocean time level indices
- CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator)
- INTEGER , INTENT(in ) :: kjpt ! number of tracers
- REAL(wp) , INTENT(in ) :: p2dt ! tracer time-step
- ! TEMP: [tiling] This can be A2D(nn_hls) if using XIOS (subdomain support)
- REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pU ! i-velocity components
+ CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator)
+ INTEGER , INTENT(in ) :: kjpt ! number of tracers
+ REAL(wp) , INTENT(in ) :: p2dt ! tracer time-step
+ REAL(wp), DIMENSION(T2D(nn_hls),jpk ), INTENT(in ) :: pU ! i-velocity components
REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) :: pt ! active tracers and RHS of tracer equation
!!
INTEGER :: ji, jj, jk, jn ! dummy loop indices
REAL(wp) :: ztra, zbtr, zdir, zdx, zmsk ! local scalars
REAL(wp) :: zzfc, zzfd, zzfu, zzfu_ip1 ! - -
- REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zwx, zfu, zfc, zfd
+ REAL(wp), DIMENSION(T2D(nn_hls),jpk) :: zwx, zfu, zfc, zfd
!----------------------------------------------------------------------
!
! ! ===========
@@ -199,19 +197,18 @@ CONTAINS
!!----------------------------------------------------------------------
!!
!!----------------------------------------------------------------------
- INTEGER , INTENT(in ) :: kt ! ocean time-step index
+ INTEGER , INTENT(in ) :: kt ! ocean time-step index
INTEGER , INTENT(in ) :: Kbb, Kmm, Krhs ! ocean time level indices
- CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator)
- INTEGER , INTENT(in ) :: kjpt ! number of tracers
- REAL(wp) , INTENT(in ) :: p2dt ! tracer time-step
- ! TEMP: [tiling] This can be A2D(nn_hls) if using XIOS (subdomain support)
- REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pV ! j-velocity components
+ CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator)
+ INTEGER , INTENT(in ) :: kjpt ! number of tracers
+ REAL(wp) , INTENT(in ) :: p2dt ! tracer time-step
+ REAL(wp), DIMENSION(T2D(nn_hls),jpk ), INTENT(in ) :: pV ! j-velocity components
REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) :: pt ! active tracers and RHS of tracer equation
!!
INTEGER :: ji, jj, jk, jn ! dummy loop indices
REAL(wp) :: ztra, zbtr, zdir, zdx, zmsk ! local scalars
REAL(wp) :: zzfc, zzfd, zzfu, zzfu_jp1 ! - -
- REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zwy, zfu, zfc, zfd ! 3D workspace
+ REAL(wp), DIMENSION(T2D(nn_hls),jpk) :: zwy, zfu, zfc, zfd ! 3D workspace
!----------------------------------------------------------------------
!
! ! ===========
@@ -279,16 +276,15 @@ CONTAINS
!!----------------------------------------------------------------------
!!
!!----------------------------------------------------------------------
- INTEGER , INTENT(in ) :: kt ! ocean time-step index
+ INTEGER , INTENT(in ) :: kt ! ocean time-step index
INTEGER , INTENT(in ) :: Kmm, Krhs ! ocean time level indices
- CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator)
- INTEGER , INTENT(in ) :: kjpt ! number of tracers
- ! TEMP: [tiling] This can be A2D(nn_hls) if using XIOS (subdomain support)
- REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pW ! vertical velocity
- REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) :: pt ! active tracers and RHS of tracer equation
+ CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator)
+ INTEGER , INTENT(in ) :: kjpt ! number of tracers
+ REAL(wp), DIMENSION(T2D(nn_hls),jpk ), INTENT(in ) :: pW ! vertical velocity
+ REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) :: pt ! active tracers and RHS of tracer equation
!
INTEGER :: ji, jj, jk, jn ! dummy loop indices
- REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zwz ! 3D workspace
+ REAL(wp), DIMENSION(T2D(nn_hls),jpk) :: zwz ! 3D workspace
!!----------------------------------------------------------------------
!
zwz(:,:, 1 ) = 0._wp ! surface & bottom values set to zero for all tracers
@@ -332,10 +328,10 @@ CONTAINS
!!
!! ** Method :
!!----------------------------------------------------------------------
- REAL(wp), DIMENSION(A2D(nn_hls),jpk), INTENT(in ) :: pfu ! second upwind point
- REAL(wp), DIMENSION(A2D(nn_hls),jpk), INTENT(in ) :: pfd ! first douwning point
- REAL(wp), DIMENSION(A2D(nn_hls),jpk), INTENT(in ) :: pfc ! the central point (or the first upwind point)
- REAL(wp), DIMENSION(A2D(nn_hls),jpk), INTENT(inout) :: puc ! input as Courant number ; output as flux
+ REAL(wp), DIMENSION(T2D(nn_hls),jpk), INTENT(in ) :: pfu ! second upwind point
+ REAL(wp), DIMENSION(T2D(nn_hls),jpk), INTENT(in ) :: pfd ! first douwning point
+ REAL(wp), DIMENSION(T2D(nn_hls),jpk), INTENT(in ) :: pfc ! the central point (or the first upwind point)
+ REAL(wp), DIMENSION(T2D(nn_hls),jpk), INTENT(inout) :: puc ! input as Courant number ; output as flux
!!
INTEGER :: ji, jj, jk ! dummy loop indices
REAL(wp) :: zcoef1, zcoef2, zcoef3 ! local scalars
diff --git a/src/OCE/TRA/traadv_ubs.F90 b/src/OCE/TRA/traadv_ubs.F90
index 6d65af219fcdad959749963efcf98ad20d3c42e1..3c83aa9c7f70b82033ab12c0e16688d992937035 100644
--- a/src/OCE/TRA/traadv_ubs.F90
+++ b/src/OCE/TRA/traadv_ubs.F90
@@ -25,9 +25,6 @@ MODULE traadv_ubs
USE lib_mpp ! massively parallel library
USE lbclnk ! ocean lateral boundary condition (or mpp link)
USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined)
-#if defined key_loop_fusion
- USE traadv_ubs_lf ! UBS scheme (tra_adv_ubs routine - loop fusion version)
-#endif
IMPLICIT NONE
PRIVATE
@@ -94,20 +91,16 @@ CONTAINS
INTEGER , INTENT(in ) :: kjpt ! number of tracers
INTEGER , INTENT(in ) :: kn_ubs_v ! number of tracers
REAL(wp) , INTENT(in ) :: p2dt ! tracer time-step
- ! TEMP: [tiling] This can be A2D(nn_hls) after all lbc_lnks removed in the nn_hls = 2 case in tra_adv_fct
- REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pU, pV, pW ! 3 ocean volume transport components
+ REAL(wp), DIMENSION(T2D(nn_hls),jpk ), INTENT(in ) :: pU, pV, pW ! 3 ocean volume transport components
REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) :: pt ! tracers and RHS of tracer equation
!
INTEGER :: ji, jj, jk, jn ! dummy loop indices
REAL(wp) :: ztra, zbtr, zcoef ! local scalars
REAL(wp) :: zfp_ui, zfm_ui, zcenut, ztak, zfp_wk, zfm_wk ! - -
REAL(wp) :: zfp_vj, zfm_vj, zcenvt, zeeu, zeev, z_hdivn ! - -
- REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: ztu, ztv, zltu, zltv, zti, ztw ! 3D workspace
+ REAL(wp), DIMENSION(T2D(nn_hls),jpk) :: ztu, ztv, zltu, zltv, zti, ztw ! 3D workspace
!!----------------------------------------------------------------------
!
-#if defined key_loop_fusion
- CALL tra_adv_ubs_lf ( kt, kit000, cdtype, p2dt, pU, pV, pW, Kbb, Kmm, pt, kjpt, Krhs, kn_ubs_v )
-#else
IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile
IF( kt == kit000 ) THEN
IF(lwp) WRITE(numout,*)
@@ -156,8 +149,8 @@ CONTAINS
zcenut = pU(ji,jj,jk) * ( pt(ji,jj,jk,jn,Kmm) + pt(ji+1,jj ,jk,jn,Kmm) )
zcenvt = pV(ji,jj,jk) * ( pt(ji,jj,jk,jn,Kmm) + pt(ji ,jj+1,jk,jn,Kmm) )
! ! UBS advective fluxes
- ztu(ji,jj,jk) = 0.5 * ( zcenut - zfp_ui * zltu(ji,jj,jk) - zfm_ui * zltu(ji+1,jj,jk) )
- ztv(ji,jj,jk) = 0.5 * ( zcenvt - zfp_vj * zltv(ji,jj,jk) - zfm_vj * zltv(ji,jj+1,jk) )
+ ztu(ji,jj,jk) = 0.5 * ( zcenut - ( zfp_ui * zltu(ji,jj,jk) + zfm_ui * zltu(ji+1,jj,jk) ) ) ! add () for NP repro
+ ztv(ji,jj,jk) = 0.5 * ( zcenvt - ( zfp_vj * zltv(ji,jj,jk) + zfm_vj * zltv(ji,jj+1,jk) ) )
END_3D
!
DO_3D( 0, 0, 0, 0, 1, jpk )
@@ -166,9 +159,9 @@ CONTAINS
!
DO jk = 1, jpkm1 !== add the horizontal advective trend ==!
DO_2D( 0, 0, 0, 0 )
- pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) &
- & - ( ztu(ji,jj,jk) - ztu(ji-1,jj ,jk) &
- & + ztv(ji,jj,jk) - ztv(ji ,jj-1,jk) ) &
+ pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) &
+ & - ( ( ztu(ji,jj,jk) - ztu(ji-1,jj ,jk) ) & ! add () for NP repro
+ & + ( ztv(ji,jj,jk) - ztv(ji ,jj-1,jk) ) ) &
& * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm)
END_2D
!
@@ -265,7 +258,6 @@ CONTAINS
!
END DO
!
-#endif
END SUBROUTINE tra_adv_ubs
@@ -285,13 +277,13 @@ CONTAINS
INTEGER , INTENT(in ) :: Kmm ! time level index
REAL(wp), INTENT(in ) :: p2dt ! tracer time-step
REAL(wp), DIMENSION(jpi,jpj,jpk) :: pbef ! before field
- REAL(wp), INTENT(inout), DIMENSION(A2D(nn_hls) ,jpk) :: paft ! after field
- REAL(wp), INTENT(inout), DIMENSION(A2D(nn_hls) ,jpk) :: pcc ! monotonic flux in the k direction
+ REAL(wp), INTENT(inout), DIMENSION(T2D(nn_hls) ,jpk) :: paft ! after field
+ REAL(wp), INTENT(inout), DIMENSION(T2D(nn_hls) ,jpk) :: pcc ! monotonic flux in the k direction
!
INTEGER :: ji, jj, jk ! dummy loop indices
INTEGER :: ikm1 ! local integer
REAL(wp) :: zpos, zneg, zbt, za, zb, zc, zbig, zrtrn ! local scalars
- REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zbetup, zbetdo ! 3D workspace
+ REAL(wp), DIMENSION(T2D(nn_hls),jpk) :: zbetup, zbetdo ! 3D workspace
!!----------------------------------------------------------------------
!
zbig = 1.e+38_wp
diff --git a/src/OCE/TRA/traadv_ubs_lf.F90 b/src/OCE/TRA/traadv_ubs_lf.F90
index ee8acfe2922ef27a36be5c6a0372ae0ea083b20a..4a2b696c755c35e9ca862ab4c7eb6522102a6d9b 100644
--- a/src/OCE/TRA/traadv_ubs_lf.F90
+++ b/src/OCE/TRA/traadv_ubs_lf.F90
@@ -91,8 +91,7 @@ CONTAINS
INTEGER , INTENT(in ) :: kjpt ! number of tracers
INTEGER , INTENT(in ) :: kn_ubs_v ! number of tracers
REAL(wp) , INTENT(in ) :: p2dt ! tracer time-step
- ! TEMP: [tiling] This can be A2D(nn_hls) if using XIOS (subdomain support)
- REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pU, pV, pW ! 3 ocean volume transport components
+ REAL(wp), DIMENSION(T2D(nn_hls),jpk ), INTENT(in ) :: pU, pV, pW ! 3 ocean volume transport components
REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) :: pt ! tracers and RHS of tracer equation
!
INTEGER :: ji, jj, jk, jn ! dummy loop indices
@@ -103,7 +102,7 @@ CONTAINS
REAL(wp) :: zztu, zztu_im1, zztu_ip1
REAL(wp) :: zztv, zztv_jm1, zztv_jp1
REAL(wp) :: zzltu, zzltu_ip1, zzltv, zzltv_jp1
- REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: ztu, ztv, zltu, zltv, zti, ztw ! 3D workspace
+ REAL(wp), DIMENSION(T2D(nn_hls),jpk) :: ztu, ztv, zltu, zltv, zti, ztw ! 3D workspace
!!----------------------------------------------------------------------
!
IF( ntile == 0 .OR. ntile == 1 ) THEN ! Do only on the first tile
@@ -290,13 +289,13 @@ CONTAINS
INTEGER , INTENT(in ) :: Kmm ! time level index
REAL(wp), INTENT(in ) :: p2dt ! tracer time-step
REAL(wp), DIMENSION(jpi,jpj,jpk) :: pbef ! before field
- REAL(wp), INTENT(inout), DIMENSION(A2D(nn_hls) ,jpk) :: paft ! after field
- REAL(wp), INTENT(inout), DIMENSION(A2D(nn_hls) ,jpk) :: pcc ! monotonic flux in the k direction
+ REAL(wp), INTENT(inout), DIMENSION(T2D(nn_hls) ,jpk) :: paft ! after field
+ REAL(wp), INTENT(inout), DIMENSION(T2D(nn_hls) ,jpk) :: pcc ! monotonic flux in the k direction
!
INTEGER :: ji, jj, jk ! dummy loop indices
INTEGER :: ikm1 ! local integer
REAL(wp) :: zpos, zneg, zbt, za, zb, zc, zbig, zrtrn ! local scalars
- REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zbetup, zbetdo ! 3D workspace
+ REAL(wp), DIMENSION(T2D(nn_hls),jpk) :: zbetup, zbetdo ! 3D workspace
!!----------------------------------------------------------------------
!
zbig = 1.e+38_wp
diff --git a/src/OCE/TRA/traatf.F90 b/src/OCE/TRA/traatf.F90
deleted file mode 100644
index 57a9ca0a47851146bcfd09c7a769c70ad6a69663..0000000000000000000000000000000000000000
--- a/src/OCE/TRA/traatf.F90
+++ /dev/null
@@ -1,389 +0,0 @@
-MODULE traatf
- !!======================================================================
- !! *** MODULE traatf ***
- !! Ocean active tracers: Asselin time filtering for temperature and salinity
- !!======================================================================
- !! History : OPA ! 1991-11 (G. Madec) Original code
- !! 7.0 ! 1993-03 (M. Guyon) symetrical conditions
- !! 8.0 ! 1996-02 (G. Madec & M. Imbard) opa release 8.0
- !! - ! 1996-04 (A. Weaver) Euler forward step
- !! 8.2 ! 1999-02 (G. Madec, N. Grima) semi-implicit pressure grad.
- !! NEMO 1.0 ! 2002-08 (G. Madec) F90: Free form and module
- !! - ! 2002-11 (C. Talandier, A-M Treguier) Open boundaries
- !! - ! 2005-04 (C. Deltel) Add Asselin trend in the ML budget
- !! 2.0 ! 2006-02 (L. Debreu, C. Mazauric) Agrif implementation
- !! 3.0 ! 2008-06 (G. Madec) time stepping always done in trazdf
- !! 3.1 ! 2009-02 (G. Madec, R. Benshila) re-introduce the vvl option
- !! 3.3 ! 2010-04 (M. Leclair, G. Madec) semi-implicit hpg with asselin filter + modified LF-RA
- !! - ! 2010-05 (C. Ethe, G. Madec) merge TRC-TRA
- !! 4.1 ! 2019-08 (A. Coward, D. Storkey) rename tranxt.F90 -> traatf.F90. Now only does time filtering.
- !!----------------------------------------------------------------------
-
- !!----------------------------------------------------------------------
- !! tra_atf : time filtering on tracers
- !! tra_atf_fix : time filtering on tracers : fixed volume case
- !! tra_atf_vvl : time filtering on tracers : variable volume case
- !!----------------------------------------------------------------------
- USE oce ! ocean dynamics and tracers variables
- USE dom_oce ! ocean space and time domain variables
- USE sbc_oce ! surface boundary condition: ocean
- USE sbcrnf ! river runoffs
- USE isf_oce ! ice shelf melting
- USE zdf_oce ! ocean vertical mixing
- USE domvvl ! variable volume
- USE trd_oce ! trends: ocean variables
- USE trdtra ! trends manager: tracers
- USE traqsr ! penetrative solar radiation (needed for nksr)
- USE phycst ! physical constant
- USE ldftra ! lateral physics : tracers
- USE ldfslp ! lateral physics : slopes
- USE bdy_oce , ONLY : ln_bdy
- USE bdytra ! open boundary condition (bdy_tra routine)
- !
- USE in_out_manager ! I/O manager
- USE lbclnk ! ocean lateral boundary conditions (or mpp link)
- USE prtctl ! Print control
- USE timing ! Timing
-#if defined key_agrif
- USE agrif_oce_interp
-#endif
-
- IMPLICIT NONE
- PRIVATE
-
- PUBLIC tra_atf ! routine called by step.F90
- PUBLIC tra_atf_fix ! to be used in trcnxt
- PUBLIC tra_atf_vvl ! to be used in trcnxt
-
- !! * Substitutions
-# include "do_loop_substitute.h90"
-# include "domzgr_substitute.h90"
- !!----------------------------------------------------------------------
- !! NEMO/OCE 4.0 , NEMO Consortium (2018)
- !! $Id: traatf.F90 14800 2021-05-06 15:42:46Z jchanut $
- !! Software governed by the CeCILL license (see ./LICENSE)
- !!----------------------------------------------------------------------
-CONTAINS
-
- SUBROUTINE tra_atf( kt, Kbb, Kmm, Kaa, pts )
- !!----------------------------------------------------------------------
- !! *** ROUTINE traatf ***
- !!
- !! ** Purpose : Apply the boundary condition on the after temperature
- !! and salinity fields and add the Asselin time filter on now fields.
- !!
- !! ** Method : At this stage of the computation, ta and sa are the
- !! after temperature and salinity as the time stepping has
- !! been performed in trazdf_imp or trazdf_exp module.
- !!
- !! - Apply lateral boundary conditions on (ta,sa)
- !! at the local domain boundaries through lbc_lnk call,
- !! at the one-way open boundaries (ln_bdy=T),
- !! at the AGRIF zoom boundaries (lk_agrif=T)
- !!
- !! - Update lateral boundary conditions on AGRIF children
- !! domains (lk_agrif=T)
- !!
- !! ** Action : - ts(Kmm) time filtered
- !!----------------------------------------------------------------------
- INTEGER , INTENT(in ) :: kt ! ocean time-step index
- INTEGER , INTENT(in ) :: Kbb, Kmm, Kaa ! time level indices
- REAL(wp), DIMENSION(jpi,jpj,jpk,jpts,jpt), INTENT(inout) :: pts ! active tracers
- !!
- INTEGER :: ji, jj, jk, jn ! dummy loop indices
- REAL(wp) :: zfact ! local scalars
- REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: ztrdt, ztrds
- !!----------------------------------------------------------------------
- !
- IF( ln_timing ) CALL timing_start( 'tra_atf')
- !
- IF( kt == nit000 ) THEN
- IF(lwp) WRITE(numout,*)
- IF(lwp) WRITE(numout,*) 'tra_atf : apply Asselin time filter to "now" fields'
- IF(lwp) WRITE(numout,*) '~~~~~~~'
- ENDIF
-
- ! Update after tracer on domain lateral boundaries
- !
-#if defined key_agrif
- CALL Agrif_tra( kt ) ! AGRIF zoom boundaries
-#endif
- ! ! local domain boundaries (T-point, unchanged sign)
- CALL lbc_lnk( 'traatf', pts(:,:,:,jp_tem,Kaa), 'T', 1.0_wp, pts(:,:,:,jp_sal,Kaa), 'T', 1.0_wp )
- !
- IF( ln_bdy ) CALL bdy_tra( kt, Kbb, pts, Kaa ) ! BDY open boundaries
-
- ! trends computation initialisation
- IF( l_trdtra ) THEN
- ALLOCATE( ztrdt(jpi,jpj,jpk) , ztrds(jpi,jpj,jpk) )
- ztrdt(:,:,:) = 0._wp
- ztrds(:,:,:) = 0._wp
- IF( ln_traldf_iso ) THEN ! diagnose the "pure" Kz diffusive trend
- CALL trd_tra( kt, Kmm, Kaa, 'TRA', jp_tem, jptra_zdfp, ztrdt )
- CALL trd_tra( kt, Kmm, Kaa, 'TRA', jp_sal, jptra_zdfp, ztrds )
- ENDIF
- ! total trend for the non-time-filtered variables.
- zfact = 1.0 / rn_Dt
- ! G Nurser 23 Mar 2017. Recalculate trend as Delta(e3t*T)/e3tn; e3tn cancel from pts(Kmm) terms
- DO jk = 1, jpkm1
- ztrdt(:,:,jk) = ( pts(:,:,jk,jp_tem,Kaa)*e3t(:,:,jk,Kaa) / e3t(:,:,jk,Kmm) - pts(:,:,jk,jp_tem,Kmm)) * zfact
- ztrds(:,:,jk) = ( pts(:,:,jk,jp_sal,Kaa)*e3t(:,:,jk,Kaa) / e3t(:,:,jk,Kmm) - pts(:,:,jk,jp_sal,Kmm)) * zfact
- END DO
- CALL trd_tra( kt, Kmm, Kaa, 'TRA', jp_tem, jptra_tot, ztrdt )
- CALL trd_tra( kt, Kmm, Kaa, 'TRA', jp_sal, jptra_tot, ztrds )
- IF( ln_linssh ) THEN ! linear sea surface height only
- ! Store now fields before applying the Asselin filter
- ! in order to calculate Asselin filter trend later.
- ztrdt(:,:,:) = pts(:,:,:,jp_tem,Kmm)
- ztrds(:,:,:) = pts(:,:,:,jp_sal,Kmm)
- ENDIF
- ENDIF
-
- IF( l_1st_euler ) THEN ! Euler time-stepping
- !
- IF (l_trdtra .AND. .NOT. ln_linssh ) THEN ! Zero Asselin filter contribution must be explicitly written out since for vvl
- ! ! Asselin filter is output by tra_atf_vvl that is not called on this time step
- ztrdt(:,:,:) = 0._wp
- ztrds(:,:,:) = 0._wp
- CALL trd_tra( kt, Kmm, Kaa, 'TRA', jp_tem, jptra_atf, ztrdt )
- CALL trd_tra( kt, Kmm, Kaa, 'TRA', jp_sal, jptra_atf, ztrds )
- END IF
- !
- ELSE ! Leap-Frog + Asselin filter time stepping
- !
- IF( ln_linssh ) THEN ; CALL tra_atf_fix( kt, Kbb, Kmm, Kaa, nit000, 'TRA', pts, jpts ) ! linear free surface
- ELSE ; CALL tra_atf_vvl( kt, Kbb, Kmm, Kaa, nit000, rn_Dt, 'TRA', pts, sbc_tsc, sbc_tsc_b, jpts ) ! non-linear free surface
- ENDIF
- !
- CALL lbc_lnk( 'traatf', pts(:,:,:,jp_tem,Kmm) , 'T', 1.0_wp, pts(:,:,:,jp_sal,Kmm) , 'T', 1.0_wp )
-
- ENDIF
- !
- IF( l_trdtra .AND. ln_linssh ) THEN ! trend of the Asselin filter (tb filtered - tb)/dt
- DO jk = 1, jpkm1
- ztrdt(:,:,jk) = ( pts(:,:,jk,jp_tem,Kmm) - ztrdt(:,:,jk) ) * r1_Dt
- ztrds(:,:,jk) = ( pts(:,:,jk,jp_sal,Kmm) - ztrds(:,:,jk) ) * r1_Dt
- END DO
- CALL trd_tra( kt, Kmm, Kaa, 'TRA', jp_tem, jptra_atf, ztrdt )
- CALL trd_tra( kt, Kmm, Kaa, 'TRA', jp_sal, jptra_atf, ztrds )
- END IF
- IF( l_trdtra ) DEALLOCATE( ztrdt , ztrds )
- !
- ! ! control print
- IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=pts(:,:,:,jp_tem,Kmm), clinfo1=' nxt - Tn: ', mask1=tmask, &
- & tab3d_2=pts(:,:,:,jp_sal,Kmm), clinfo2= ' Sn: ', mask2=tmask )
- !
- IF( ln_timing ) CALL timing_stop('tra_atf')
- !
- END SUBROUTINE tra_atf
-
-
- SUBROUTINE tra_atf_fix( kt, Kbb, Kmm, Kaa, kit000, cdtype, pt, kjpt )
- !!----------------------------------------------------------------------
- !! *** ROUTINE tra_atf_fix ***
- !!
- !! ** Purpose : fixed volume: apply the Asselin time filter to the "now" field
- !!
- !! ** Method : - Apply a Asselin time filter on now fields.
- !!
- !! ** Action : - pt(Kmm) ready for the next time step
- !!----------------------------------------------------------------------
- INTEGER , INTENT(in ) :: kt ! ocean time-step index
- INTEGER , INTENT(in ) :: Kbb, Kmm, Kaa ! time level indices
- INTEGER , INTENT(in ) :: kit000 ! first time step index
- CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator)
- INTEGER , INTENT(in ) :: kjpt ! number of tracers
- REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) :: pt ! tracer fields
- !
- INTEGER :: ji, jj, jk, jn ! dummy loop indices
- REAL(wp) :: ztn, ztd ! local scalars
- !!----------------------------------------------------------------------
- !
- IF( kt == kit000 ) THEN
- IF(lwp) WRITE(numout,*)
- IF(lwp) WRITE(numout,*) 'tra_atf_fix : time filtering', cdtype
- IF(lwp) WRITE(numout,*) '~~~~~~~~~~~'
- ENDIF
- !
- DO jn = 1, kjpt
- !
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 )
- ztn = pt(ji,jj,jk,jn,Kmm)
- ztd = pt(ji,jj,jk,jn,Kaa) - 2._wp * ztn + pt(ji,jj,jk,jn,Kbb) ! time laplacian on tracers
- !
- pt(ji,jj,jk,jn,Kmm) = ztn + rn_atfp * ztd ! pt <-- filtered pt
- END_3D
- !
- END DO
- !
- END SUBROUTINE tra_atf_fix
-
-
- SUBROUTINE tra_atf_vvl( kt, Kbb, Kmm, Kaa, kit000, p2dt, cdtype, pt, psbc_tc, psbc_tc_b, kjpt )
- !!----------------------------------------------------------------------
- !! *** ROUTINE tra_atf_vvl ***
- !!
- !! ** Purpose : Time varying volume: apply the Asselin time filter
- !!
- !! ** Method : - Apply a thickness weighted Asselin time filter on now fields.
- !! pt(Kmm) = ( e3t_Kmm*pt(Kmm) + rn_atfp*[ e3t_Kbb*pt(Kbb) - 2 e3t_Kmm*pt(Kmm) + e3t_Kaa*pt(Kaa) ] )
- !! /( e3t_Kmm + rn_atfp*[ e3t_Kbb - 2 e3t_Kmm + e3t_Kaa ] )
- !!
- !! ** Action : - pt(Kmm) ready for the next time step
- !!----------------------------------------------------------------------
- INTEGER , INTENT(in ) :: kt ! ocean time-step index
- INTEGER , INTENT(in ) :: Kbb, Kmm, Kaa ! time level indices
- INTEGER , INTENT(in ) :: kit000 ! first time step index
- REAL(wp) , INTENT(in ) :: p2dt ! time-step
- CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator)
- INTEGER , INTENT(in ) :: kjpt ! number of tracers
- REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) :: pt ! tracer fields
- REAL(wp), DIMENSION(jpi,jpj ,kjpt) , INTENT(in ) :: psbc_tc ! surface tracer content
- REAL(wp), DIMENSION(jpi,jpj ,kjpt) , INTENT(in ) :: psbc_tc_b ! before surface tracer content
- !
- LOGICAL :: ll_traqsr, ll_rnf, ll_isf ! local logical
- INTEGER :: ji, jj, jk, jn ! dummy loop indices
- REAL(wp) :: zfact, zfact1, ztc_a , ztc_n , ztc_b , ztc_f , ztc_d ! local scalar
- REAL(wp) :: zfact2, ze3t_b, ze3t_n, ze3t_a, ze3t_f, ze3t_d, zscale ! - -
- REAL(wp), ALLOCATABLE, DIMENSION(:,:,:,:) :: ztrd_atf
- !!----------------------------------------------------------------------
- !
- IF( kt == kit000 ) THEN
- IF(lwp) WRITE(numout,*)
- IF(lwp) WRITE(numout,*) 'tra_atf_vvl : time filtering', cdtype
- IF(lwp) WRITE(numout,*) '~~~~~~~~~~~'
- ENDIF
- !
- IF( cdtype == 'TRA' ) THEN
- ll_traqsr = ln_traqsr ! active tracers case and solar penetration
- ll_rnf = ln_rnf ! active tracers case and river runoffs
- ll_isf = ln_isf ! active tracers case and ice shelf melting
- ELSE ! passive tracers case
- ll_traqsr = .FALSE. ! NO solar penetration
- ll_rnf = .FALSE. ! NO river runoffs ???? !!gm BUG ?
- ll_isf = .FALSE. ! NO ice shelf melting/freezing !!gm BUG ??
- ENDIF
- !
- IF( ( l_trdtra .AND. cdtype == 'TRA' ) .OR. ( l_trdtrc .AND. cdtype == 'TRC' ) ) THEN
- ALLOCATE( ztrd_atf(jpi,jpj,jpk,kjpt) )
- ztrd_atf(:,:,:,:) = 0.0_wp
- ENDIF
- !
-!!st variables only computed in the interior by traqsr
- IF( ll_traqsr ) CALL lbc_lnk( 'traatf', qsr_hc_b(:,:,:) , 'T', 1.0_wp, qsr_hc(:,:,:) , 'T', 1.0_wp )
- !
- zfact = 1._wp / p2dt
- zfact1 = rn_atfp * p2dt
- zfact2 = zfact1 * r1_rho0
- DO jn = 1, kjpt
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 )
- ze3t_b = e3t(ji,jj,jk,Kbb)
- ze3t_n = e3t(ji,jj,jk,Kmm)
- ze3t_a = e3t(ji,jj,jk,Kaa)
- ! ! tracer content at Before, now and after
- ztc_b = pt(ji,jj,jk,jn,Kbb) * ze3t_b
- ztc_n = pt(ji,jj,jk,jn,Kmm) * ze3t_n
- ztc_a = pt(ji,jj,jk,jn,Kaa) * ze3t_a
- !
- ze3t_d = ze3t_a - 2. * ze3t_n + ze3t_b
- ztc_d = ztc_a - 2. * ztc_n + ztc_b
- !
- ze3t_f = ze3t_n + rn_atfp * ze3t_d
- ztc_f = ztc_n + rn_atfp * ztc_d
- !
- ! Add asselin correction on scale factors:
- zscale = tmask(ji,jj,jk) * e3t(ji,jj,jk,Kmm) / ( ht(ji,jj) + 1._wp - ssmask(ji,jj) )
- ze3t_f = ze3t_f - zfact2 * zscale * ( emp_b(ji,jj) - emp(ji,jj) )
- IF ( ll_rnf ) ze3t_f = ze3t_f + zfact2 * zscale * ( rnf_b(ji,jj) - rnf(ji,jj) )
- IF ( ll_isf ) THEN
- IF ( ln_isfcav_mlt ) ze3t_f = ze3t_f + zfact2 * zscale * ( fwfisf_cav_b(ji,jj) - fwfisf_cav(ji,jj) )
- IF ( ln_isfpar_mlt ) ze3t_f = ze3t_f + zfact2 * zscale * ( fwfisf_par_b(ji,jj) - fwfisf_par(ji,jj) )
- ENDIF
- !
- IF( jk == mikt(ji,jj) ) THEN ! first level
- ztc_f = ztc_f - zfact1 * ( psbc_tc(ji,jj,jn) - psbc_tc_b(ji,jj,jn) )
- ENDIF
- !
- ! solar penetration (temperature only)
- IF( ll_traqsr .AND. jn == jp_tem .AND. jk <= nksr ) &
- & ztc_f = ztc_f - zfact1 * ( qsr_hc(ji,jj,jk) - qsr_hc_b(ji,jj,jk) )
- !
- !
- IF( ll_rnf .AND. jk <= nk_rnf(ji,jj) ) &
- & ztc_f = ztc_f - zfact1 * ( rnf_tsc(ji,jj,jn) - rnf_tsc_b(ji,jj,jn) ) &
- & * e3t(ji,jj,jk,Kmm) / h_rnf(ji,jj)
-
- !
- ! ice shelf
- IF( ll_isf ) THEN
- !
- ! melt in the cavity
- IF ( ln_isfcav_mlt ) THEN
- ! level fully include in the Losch_2008 ice shelf boundary layer
- IF ( jk >= misfkt_cav(ji,jj) .AND. jk < misfkb_cav(ji,jj) ) THEN
- ztc_f = ztc_f - zfact1 * ( risf_cav_tsc(ji,jj,jn) - risf_cav_tsc_b(ji,jj,jn) ) &
- & * e3t(ji,jj,jk,Kmm) / rhisf_tbl_cav(ji,jj)
- END IF
- ! level partially include in Losch_2008 ice shelf boundary layer
- IF ( jk == misfkb_cav(ji,jj) ) THEN
- ztc_f = ztc_f - zfact1 * ( risf_cav_tsc(ji,jj,jn) - risf_cav_tsc_b(ji,jj,jn) ) &
- & * e3t(ji,jj,jk,Kmm) / rhisf_tbl_cav(ji,jj) * rfrac_tbl_cav(ji,jj)
- END IF
- END IF
- !
- ! parametrised melt (cavity closed)
- IF ( ln_isfpar_mlt ) THEN
- ! level fully include in the Losch_2008 ice shelf boundary layer
- IF ( jk >= misfkt_par(ji,jj) .AND. jk < misfkb_par(ji,jj) ) THEN
- ztc_f = ztc_f - zfact1 * ( risf_par_tsc(ji,jj,jn) - risf_par_tsc_b(ji,jj,jn) ) &
- & * e3t(ji,jj,jk,Kmm) / rhisf_tbl_par(ji,jj)
- END IF
- ! level partially include in Losch_2008 ice shelf boundary layer
- IF ( jk == misfkb_par(ji,jj) ) THEN
- ztc_f = ztc_f - zfact1 * ( risf_par_tsc(ji,jj,jn) - risf_par_tsc_b(ji,jj,jn) ) &
- & * e3t(ji,jj,jk,Kmm) / rhisf_tbl_par(ji,jj) * rfrac_tbl_par(ji,jj)
- END IF
- END IF
- !
- ! ice sheet coupling correction
- IF ( ln_isfcpl ) THEN
- !
- ! at kt = nit000, risfcpl_vol_n = 0 and risfcpl_vol_b = risfcpl_vol so contribution nul
- IF ( ln_rstart .AND. kt == nit000+1 ) THEN
- ztc_f = ztc_f + zfact1 * risfcpl_tsc(ji,jj,jk,jn) * r1_e1e2t(ji,jj)
- ! Shouldn't volume increment be spread according thanks to zscale ?
- ze3t_f = ze3t_f - zfact1 * risfcpl_vol(ji,jj,jk ) * r1_e1e2t(ji,jj)
- END IF
- !
- END IF
- !
- END IF
- !
- ze3t_f = 1.e0 / ze3t_f
- pt(ji,jj,jk,jn,Kmm) = ztc_f * ze3t_f ! time filtered "now" field
- !
- IF( ( l_trdtra .and. cdtype == 'TRA' ) .OR. ( l_trdtrc .and. cdtype == 'TRC' ) ) THEN
- ztrd_atf(ji,jj,jk,jn) = (ztc_f - ztc_n) * zfact/ze3t_n
- ENDIF
- !
- END_3D
- !
- END DO
- !
- IF( ( l_trdtra .AND. cdtype == 'TRA' ) .OR. ( l_trdtrc .AND. cdtype == 'TRC' ) ) THEN
- IF( l_trdtra .AND. cdtype == 'TRA' ) THEN
- CALL trd_tra( kt, Kmm, Kaa, cdtype, jp_tem, jptra_atf, ztrd_atf(:,:,:,jp_tem) )
- CALL trd_tra( kt, Kmm, Kaa, cdtype, jp_sal, jptra_atf, ztrd_atf(:,:,:,jp_sal) )
- ENDIF
- IF( l_trdtrc .AND. cdtype == 'TRC' ) THEN
- DO jn = 1, kjpt
- CALL trd_tra( kt, Kmm, Kaa, cdtype, jn, jptra_atf, ztrd_atf(:,:,:,jn) )
- END DO
- ENDIF
- DEALLOCATE( ztrd_atf )
- ENDIF
- !
- END SUBROUTINE tra_atf_vvl
-
- !!======================================================================
-END MODULE traatf
diff --git a/src/OCE/TRA/traatf_qco.F90 b/src/OCE/TRA/traatf_qco.F90
index 57034bd06088f54863e35898473f9a6c64f2323a..256eb6018b5b6a61a9ea9b2fe39e1cbaaa6e29b0 100644
--- a/src/OCE/TRA/traatf_qco.F90
+++ b/src/OCE/TRA/traatf_qco.F90
@@ -27,7 +27,7 @@ MODULE traatf_qco
!!----------------------------------------------------------------------
!! tra_atf : time filtering on tracers
!! tra_atf_fix : time filtering on tracers : fixed volume case
- !! tra_atf_vvl : time filtering on tracers : variable volume case
+ !! tra_atf_qco : time filtering on tracers : variable volume case
!!----------------------------------------------------------------------
USE oce ! ocean dynamics and tracers variables
USE dom_oce ! ocean space and time domain variables
@@ -35,7 +35,6 @@ MODULE traatf_qco
USE sbcrnf ! river runoffs
USE isf_oce ! ice shelf melting
USE zdf_oce ! ocean vertical mixing
- USE domvvl ! variable volume
USE trd_oce ! trends: ocean variables
USE trdtra ! trends manager: tracers
USE traqsr ! penetrative solar radiation (needed for nksr)
@@ -136,8 +135,8 @@ CONTAINS
IF( l_1st_euler ) THEN ! Euler time-stepping
!
- IF (l_trdtra .AND. .NOT. ln_linssh ) THEN ! Zero Asselin filter contribution must be explicitly written out since for vvl
- ! ! Asselin filter is output by tra_atf_vvl that is not called on this time step
+ IF (l_trdtra .AND. .NOT. ln_linssh ) THEN ! Zero Asselin filter contribution must be explicitly written out since for quasi-Eulerian
+ ! ! Asselin filter is output by tra_atf_qco that is not called on this time step
ztrdt(:,:,:) = 0._wp
ztrds(:,:,:) = 0._wp
CALL trd_tra( kt, Kmm, Kaa, 'TRA', jp_tem, jptra_atf, ztrdt )
@@ -150,7 +149,7 @@ CONTAINS
ELSE ; CALL tra_atf_qco_lf( kt, Kbb, Kmm, Kaa, nit000, rn_Dt, 'TRA', pts, sbc_tsc, sbc_tsc_b, jpts ) ! non-linear free surface
ENDIF
!
- CALL lbc_lnk( 'traatfqco', pts(:,:,:,jp_tem,Kmm) , 'T', 1._wp, pts(:,:,:,jp_sal,Kmm) , 'T', 1._wp )
+ CALL lbc_lnk( 'traatf_qco', pts(:,:,:,jp_tem,Kmm) , 'T', 1._wp, pts(:,:,:,jp_sal,Kmm) , 'T', 1._wp )
!
ENDIF
!
@@ -203,7 +202,6 @@ CONTAINS
DO jn = 1, kjpt
!
DO_3D( 0, 0, 0, 0, 1, jpkm1 )
-!!st DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 )
ztn = pt(ji,jj,jk,jn,Kmm)
ztd = pt(ji,jj,jk,jn,Kaa) - 2._wp * ztn + pt(ji,jj,jk,jn,Kbb) ! time laplacian on tracers
!
@@ -217,7 +215,7 @@ CONTAINS
SUBROUTINE tra_atf_qco_lf( kt, Kbb, Kmm, Kaa, kit000, p2dt, cdtype, pt, psbc_tc, psbc_tc_b, kjpt )
!!----------------------------------------------------------------------
- !! *** ROUTINE tra_atf_vvl ***
+ !! *** ROUTINE tra_atf_qco ***
!!
!! ** Purpose : Time varying volume: apply the Asselin time filter
!!
@@ -234,8 +232,8 @@ CONTAINS
CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator)
INTEGER , INTENT(in ) :: kjpt ! number of tracers
REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) :: pt ! tracer fields
- REAL(wp), DIMENSION(jpi,jpj ,kjpt) , INTENT(in ) :: psbc_tc ! surface tracer content
- REAL(wp), DIMENSION(jpi,jpj ,kjpt) , INTENT(in ) :: psbc_tc_b ! before surface tracer content
+ REAL(wp), DIMENSION(A2D(0) ,kjpt) , INTENT(in ) :: psbc_tc ! surface tracer content
+ REAL(wp), DIMENSION(A2D(0) ,kjpt) , INTENT(in ) :: psbc_tc_b ! before surface tracer content
!
LOGICAL :: ll_traqsr, ll_rnf, ll_isf ! local logical
INTEGER :: ji, jj, jk, jn ! dummy loop indices
@@ -264,12 +262,12 @@ CONTAINS
ALLOCATE( ztrd_atf(jpi,jpj,jpk,kjpt) )
ztrd_atf(:,:,:,:) = 0._wp
ENDIF
+ !
zfact = 1._wp / p2dt
zfact1 = rn_atfp * p2dt
zfact2 = zfact1 * r1_rho0
DO jn = 1, kjpt
DO_3D( 0, 0, 0, 0, 1, jpkm1 )
-!!st DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 )
ze3t_b = e3t(ji,jj,jk,Kbb)
ze3t_n = e3t(ji,jj,jk,Kmm)
ze3t_a = e3t(ji,jj,jk,Kaa)
diff --git a/src/OCE/TRA/trabbl.F90 b/src/OCE/TRA/trabbl.F90
index df82587f2f2e87d32267a669f0d5b5b9cc356bed..06da86293c5baa6bde4e88872787c557ba93ce68 100644
--- a/src/OCE/TRA/trabbl.F90
+++ b/src/OCE/TRA/trabbl.F90
@@ -183,7 +183,7 @@ CONTAINS
INTEGER :: ji, jj, jn ! dummy loop indices
INTEGER :: ik ! local integers
REAL(wp) :: zbtr ! local scalars
- REAL(wp), DIMENSION(A2D(nn_hls)) :: zptb ! workspace
+ REAL(wp), DIMENSION(T2D(1)) :: zptb ! workspace
!!----------------------------------------------------------------------
!
DO jn = 1, kjpt ! tracer loop
@@ -196,10 +196,10 @@ CONTAINS
DO_2D( 0, 0, 0, 0 ) ! Compute the trend
ik = mbkt(ji,jj) ! bottom T-level index
pt_rhs(ji,jj,ik,jn) = pt_rhs(ji,jj,ik,jn) &
- & + ( ahu_bbl(ji ,jj ) * ( zptb(ji+1,jj ) - zptb(ji ,jj ) ) &
- & - ahu_bbl(ji-1,jj ) * ( zptb(ji ,jj ) - zptb(ji-1,jj ) ) &
- & + ahv_bbl(ji ,jj ) * ( zptb(ji ,jj+1) - zptb(ji ,jj ) ) &
- & - ahv_bbl(ji ,jj-1) * ( zptb(ji ,jj ) - zptb(ji ,jj-1) ) ) &
+ & + ( ( ahu_bbl(ji ,jj ) * ( zptb(ji+1,jj ) - zptb(ji ,jj ) ) & ! add () for NP repro
+ & - ahu_bbl(ji-1,jj ) * ( zptb(ji ,jj ) - zptb(ji-1,jj ) ) ) &
+ & + ( ahv_bbl(ji ,jj ) * ( zptb(ji ,jj+1) - zptb(ji ,jj ) ) &
+ & - ahv_bbl(ji ,jj-1) * ( zptb(ji ,jj ) - zptb(ji ,jj-1) ) ) ) &
& * r1_e1e2t(ji,jj) / e3t(ji,jj,ik,Kmm)
END_2D
! ! ===========
@@ -326,8 +326,8 @@ CONTAINS
INTEGER :: ijs, ijd, ikvs, ikvd ! - -
REAL(wp) :: za, zb, zgdrho ! local scalars
REAL(wp) :: zsign, zsigna, zgbbl ! - -
- REAL(wp), DIMENSION(A2D(nn_hls),jpts) :: zts, zab ! 3D workspace
- REAL(wp), DIMENSION(A2D(nn_hls)) :: zub, zvb, zdep ! 2D workspace
+ REAL(wp), DIMENSION(T2D(nn_hls),jpts) :: zts, zab ! 3D workspace
+ REAL(wp), DIMENSION(T2D(nn_hls)) :: zub, zvb, zdep ! 2D workspace
!!----------------------------------------------------------------------
!
IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile
@@ -527,7 +527,7 @@ CONTAINS
ENDIF
END_2D
!
- DO_2D( 1, 0, 1, 0 ) !* bbl thickness at u- (v-) point; minimum of top & bottom e3u_0 (e3v_0)
+ DO_2D( 1, 0, 1, 0 ) !* bbl thickness at u- or v- point; minimum of top & bottom e3u_0 or e3v_0
e3u_bbl_0(ji,jj) = MIN( e3u_0(ji,jj,mbkt(ji+1,jj )), e3u_0(ji,jj,mbkt(ji,jj)) )
e3v_bbl_0(ji,jj) = MIN( e3v_0(ji,jj,mbkt(ji ,jj+1)), e3v_0(ji,jj,mbkt(ji,jj)) )
END_2D
diff --git a/src/OCE/TRA/tradmp.F90 b/src/OCE/TRA/tradmp.F90
index 16cab127eece4aed8c9dd7378ce67a2090acccc2..2643c58ae30d43b24d6afb5f43c481e1689675eb 100644
--- a/src/OCE/TRA/tradmp.F90
+++ b/src/OCE/TRA/tradmp.F90
@@ -94,7 +94,7 @@ CONTAINS
REAL(wp), DIMENSION(jpi,jpj,jpk,jpts,jpt), INTENT(inout) :: pts ! active tracers and RHS of tracer equation
!
INTEGER :: ji, jj, jk, jn ! dummy loop indices
- REAL(wp), DIMENSION(A2D(nn_hls),jpk,jpts) :: zts_dta
+ REAL(wp), DIMENSION(T2D(nn_hls),jpk,jpts) :: zts_dta
REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE :: zwrk
REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: ztrdts
!!----------------------------------------------------------------------
@@ -102,7 +102,7 @@ CONTAINS
IF( ln_timing ) CALL timing_start('tra_dmp')
!
IF( l_trdtra .OR. iom_use('hflx_dmp_cea') .OR. iom_use('sflx_dmp_cea') ) THEN !* Save ta and sa trends
- ALLOCATE( ztrdts(A2D(nn_hls),jpk,jpts) )
+ ALLOCATE( ztrdts(T2D(nn_hls),jpk,jpts) )
DO jn = 1, jpts
DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpk )
ztrdts(ji,jj,jk,jn) = pts(ji,jj,jk,jn,Krhs)
@@ -146,7 +146,7 @@ CONTAINS
!
! outputs (clem trunk)
IF( iom_use('hflx_dmp_cea') .OR. iom_use('sflx_dmp_cea') ) THEN
- ALLOCATE( zwrk(A2D(nn_hls),jpk) ) ! Needed to handle expressions containing e3t when using key_qco or key_linssh
+ ALLOCATE( zwrk(T2D(0),jpk) ) ! Needed to handle expressions containing e3t when using key_qco or key_linssh
zwrk(:,:,:) = 0._wp
IF( iom_use('hflx_dmp_cea') ) THEN
diff --git a/src/OCE/TRA/traisf.F90 b/src/OCE/TRA/traisf.F90
index 610f9064fbc521e687d705142b872881426350cb..2ddc45da64ea8a8fa02d20c3b67e1580a1d206af 100644
--- a/src/OCE/TRA/traisf.F90
+++ b/src/OCE/TRA/traisf.F90
@@ -113,39 +113,34 @@ CONTAINS
!! *** Action :: Update pts(:,:,:,:,Krhs) with the surface boundary condition trend
!!
!!----------------------------------------------------------------------
- REAL(wp), DIMENSION(jpi,jpj,jpk,jpts) , INTENT(inout) :: pts
- INTEGER , DIMENSION(jpi,jpj) , INTENT(in ) :: ktop , kbot
- REAL(wp), DIMENSION(jpi,jpj) , INTENT(in ) :: phtbl, pfrac
- REAL(wp), DIMENSION(jpi,jpj,jpts) , INTENT(in ) :: ptsc
- REAL(wp), DIMENSION(:,:,:) , OPTIONAL, INTENT(in ) :: ptsc_b
+ REAL(wp), DIMENSION(A2D(nn_hls),jpk,jpts) , INTENT(inout) :: pts
+ INTEGER , DIMENSION(A2D(0)) , INTENT(in ) :: ktop , kbot
+ REAL(wp), DIMENSION(A2D(0)) , INTENT(in ) :: phtbl, pfrac
+ REAL(wp), DIMENSION(A2D(0),jpts) , INTENT(in ) :: ptsc
+ REAL(wp), DIMENSION(A2D(0),jpts) , OPTIONAL, INTENT(in ) :: ptsc_b
!!
- INTEGER :: ji,jj,jk ! dummy loop index
- INTEGER :: ikt, ikb ! top and bottom level of the tbl
- REAL(wp), DIMENSION(A2D(nn_hls)) :: ztc ! total ice shelf tracer trend
+ INTEGER :: ji, jj, jk ! dummy loop index
+ INTEGER :: ikt, ikb ! top and bottom level of the tbl
+ REAL(wp) :: ztc ! total ice shelf tracer trend
!!----------------------------------------------------------------------
!
- ! compute 2d total trend due to isf
+ ! update pts(:,:,:,:,Krhs)
DO_2D( 0, 0, 0, 0 )
+ !
#if defined key_RK3
- ztc(ji,jj) = ptsc(ji,jj,jp_tem) / phtbl(ji,jj)
+ ztc = ptsc(ji,jj,jp_tem) / phtbl(ji,jj)
#else
- ztc(ji,jj) = 0.5_wp * ( ptsc(ji,jj,jp_tem) + ptsc_b(ji,jj,jp_tem) ) / phtbl(ji,jj)
+ ztc = 0.5_wp * ( ptsc(ji,jj,jp_tem) + ptsc_b(ji,jj,jp_tem) ) / phtbl(ji,jj)
#endif
- END_2D
- !
- ! update pts(:,:,:,:,Krhs)
- DO_2D( 0, 0, 0, 0 )
- !
+ ! level fully include in the ice shelf boundary layer
ikt = ktop(ji,jj)
ikb = kbot(ji,jj)
- !
- ! level fully include in the ice shelf boundary layer
DO jk = ikt, ikb - 1
- pts(ji,jj,jk,jp_tem) = pts(ji,jj,jk,jp_tem) + ztc(ji,jj)
+ pts(ji,jj,jk,jp_tem) = pts(ji,jj,jk,jp_tem) + ztc
END DO
!
! level partially include in ice shelf boundary layer
- pts(ji,jj,ikb,jp_tem) = pts(ji,jj,ikb,jp_tem) + ztc(ji,jj) * pfrac(ji,jj)
+ pts(ji,jj,ikb,jp_tem) = pts(ji,jj,ikb,jp_tem) + ztc * pfrac(ji,jj)
!
END_2D
!
@@ -159,9 +154,9 @@ CONTAINS
!! *** Action :: Update pts(:,:,:,:,Krhs) with the ice shelf coupling trend
!!
!!----------------------------------------------------------------------
- INTEGER , INTENT(in ) :: Kmm ! ocean time-level index
- REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in ) :: ptsc
- REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(inout) :: ptsa
+ INTEGER , INTENT(in ) :: Kmm ! ocean time-level index
+ REAL(wp), DIMENSION(A2D(0),jpk,jpts) , INTENT(in ) :: ptsc
+ REAL(wp), DIMENSION(A2D(nn_hls),jpk,jpts), INTENT(inout) :: ptsa
!!
INTEGER :: ji, jj, jk ! dummy loop index
!!----------------------------------------------------------------------
diff --git a/src/OCE/TRA/traldf.F90 b/src/OCE/TRA/traldf.F90
index fc22984261f8e975db9c86a92e92d20bb83d0227..4ca392acc2fb88e0d725294cc3f3ad1e5c5bfc24 100644
--- a/src/OCE/TRA/traldf.F90
+++ b/src/OCE/TRA/traldf.F90
@@ -8,6 +8,8 @@ MODULE traldf
!! 3.7 ! 2013-12 (G. Madec) remove the optional computation from T & S anomaly profiles and traldf_bilapg
!! - ! 2013-12 (F. Lemarie, G. Madec) triad operator (Griffies) + Method of Stabilizing Correction
!! - ! 2014-01 (G. Madec, S. Masson) restructuration/simplification of lateral diffusive operators
+ !! 4.5 ! 2022-08 (G, Madec, S. Techene) refactorization to reduce local memory usage
+ !! ! + add tra_ldf_iso_a33 routine and traldf_iso_h/z.h90 files
!!----------------------------------------------------------------------
!!----------------------------------------------------------------------
@@ -19,14 +21,15 @@ MODULE traldf
USE phycst ! physical constants
USE ldftra ! lateral diffusion: eddy diffusivity & EIV coeff.
USE ldfslp ! lateral diffusion: iso-neutral slope
- USE traldf_lap_blp ! lateral diffusion: laplacian iso-level operator (tra_ldf_lap/_blp routines)
- USE traldf_iso ! lateral diffusion: laplacian iso-neutral standard operator (tra_ldf_iso routine )
- USE traldf_triad ! lateral diffusion: laplacian iso-neutral triad operator (tra_ldf_triad routine )
+ USE traldf_iso ! lateral diffusion: laplacian iso-neutral standard operator (traldf_iso_lap/_blp routines)
+ USE traldf_lev ! lateral diffusion: laplacian iso-level operator (traldf_lap/_blp routines)
+ USE traldf_triad ! lateral diffusion: laplacian iso-neutral triad operator (tra_ldf_triad(_blp) routines)
USE trd_oce ! trends: ocean variables
USE trdtra ! ocean active tracers trends
!
USE prtctl ! Print control
USE in_out_manager ! I/O manager
+ USE iom ! I/O library
USE lib_mpp ! distribued memory computing library
USE lbclnk ! ocean lateral boundary conditions (or mpp link)
USE timing ! Timing
@@ -37,6 +40,9 @@ MODULE traldf
PUBLIC tra_ldf ! called by step.F90
PUBLIC tra_ldf_init ! called by nemogcm.F90
+ LOGICAL :: l_ptr ! flag to compute the diffusive part of poleward heat & salt transport
+ LOGICAL :: l_hst ! flag to compute the diffusive part of heat and salt transport
+
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
!! $Id: traldf.F90 14834 2021-05-11 09:24:44Z hadcv $
@@ -54,34 +60,57 @@ CONTAINS
INTEGER, INTENT(in ) :: Kbb, Kmm, Krhs ! ocean time level indices
REAL(wp), DIMENSION(jpi,jpj,jpk,jpts,jpt), INTENT(inout) :: pts ! active tracers and RHS of tracer equation
!!
- REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: ztrdt, ztrds
+ REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zTtrd, zStrd
!!----------------------------------------------------------------------
!
+ IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile
+ IF( kt == nit000 .AND. lwp ) THEN
+ WRITE(numout,*)
+ SELECT CASE ( nldf_tra ) !* compute lateral mixing trend and add it to the general trend
+ CASE ( np_lap ) ; WRITE(numout,*) 'traldf_lev_lap : iso-level laplacian diffusive operator'
+ CASE ( np_lap_i ) ; WRITE(numout,*) 'traldf_iso_lap : iso-neutral standard laplacian diffusive operator'
+ CASE ( np_lap_it ) ; WRITE(numout,*) 'traldf_triad_lap : iso-neutral triad laplacian diffusive operator'
+ CASE ( np_blp ) ; WRITE(numout,*) 'traldf_lev_blp : iso-level bilaplacian diffusive operator'
+ CASE ( np_blp_i ) ; WRITE(numout,*) 'traldf_iso_blp : iso-neutral bilaplacian diffusive operator'
+ CASE ( np_blp_it ) ; WRITE(numout,*) 'traldf_triad_blp : iso-neutral triad bilaplacian diffusive operator'
+ END SELECT
+ WRITE(numout,*) '~~~~~~~~~~~~~~~~ '
+ ENDIF
+ ENDIF
+ !
IF( ln_timing ) CALL timing_start('tra_ldf')
!
IF( l_trdtra ) THEN !* Save ta and sa trends
- ALLOCATE( ztrdt(jpi,jpj,jpk) , ztrds(jpi,jpj,jpk) )
- ztrdt(:,:,:) = pts(:,:,:,jp_tem,Krhs)
- ztrds(:,:,:) = pts(:,:,:,jp_sal,Krhs)
+ ALLOCATE( zTtrd(jpi,jpj,jpk) , zStrd(jpi,jpj,jpk) )
+ zTtrd(:,:,:) = pts(:,:,:,jp_tem,Krhs)
+ zStrd(:,:,:) = pts(:,:,:,jp_sal,Krhs)
ENDIF
!
- SELECT CASE ( nldf_tra ) !* compute lateral mixing trend and add it to the general trend
- CASE ( np_lap ) ! laplacian: iso-level operator
- CALL tra_ldf_lap ( kt, Kmm, nit000,'TRA', ahtu, ahtv, gtsu, gtsv, gtui, gtvi, pts(:,:,:,:,Kbb), pts(:,:,:,:,Krhs), jpts, 1 )
- CASE ( np_lap_i ) ! laplacian: standard iso-neutral operator (Madec)
- CALL tra_ldf_iso ( kt, Kmm, nit000,'TRA', ahtu, ahtv, gtsu, gtsv, gtui, gtvi, pts(:,:,:,:,Kbb), pts(:,:,:,:,Kbb), pts(:,:,:,:,Krhs), jpts, 1 )
- CASE ( np_lap_it ) ! laplacian: triad iso-neutral operator (griffies)
- CALL tra_ldf_triad( kt, Kmm, nit000,'TRA', ahtu, ahtv, gtsu, gtsv, gtui, gtvi, pts(:,:,:,:,Kbb), pts(:,:,:,:,Kbb), pts(:,:,:,:,Krhs), jpts, 1 )
- CASE ( np_blp , np_blp_i , np_blp_it ) ! bilaplacian: iso-level & iso-neutral operators
- CALL tra_ldf_blp ( kt, Kmm, nit000,'TRA', ahtu, ahtv, gtsu, gtsv, gtui, gtvi, pts(:,:,:,:,Kbb), pts(:,:,:,:,Krhs), jpts, nldf_tra )
+ SELECT CASE ( nldf_tra ) !* compute lateral mixing trend and add it to the general trend
+ ! !- laplacian - !
+ CASE ( np_lap ) ! level operator
+ CALL traldf_lev_lap ( kt, Kbb, Kmm, pts, Krhs, l_ptr, l_hst )
+ CASE ( np_lap_i ) ! standard iso-neutral operator
+ CALL traldf_iso_lap ( kt, Kbb, Kmm, pts, Krhs, l_ptr, l_hst )
+ CASE ( np_lap_it ) ! laplacian: triad iso-neutral operator
+ CALL traldf_triad_lap( kt, Kmm, nit000,'TRA', ahtu, ahtv, pts(:,:,:,:,Kbb), &
+ & pts(:,:,:,:,Kbb), pts(:,:,:,:,Krhs), jpts, 1 )
+ ! !- bilaplacian - !
+ CASE ( np_blp ) ! iso-level operators
+ CALL traldf_lev_blp ( kt, Kbb, Kmm, pts, Krhs, l_ptr, l_hst )
+ CASE ( np_blp_i ) ! standard iso-neutral operator
+ CALL traldf_iso_blp ( kt, Kbb, Kmm, pts, Krhs, l_ptr, l_hst )
+ CASE ( np_blp_it ) ! bilaplacian: iso-level & iso-neutral operators
+ CALL traldf_triad_blp( kt, Kmm, nit000,'TRA', ahtu, ahtv, pts(:,:,:,:,Kbb), &
+ & pts(:,:,:,:,Krhs), jpts )
END SELECT
!
IF( l_trdtra ) THEN !* save the horizontal diffusive trends for further diagnostics
- ztrdt(:,:,:) = pts(:,:,:,jp_tem,Krhs) - ztrdt(:,:,:)
- ztrds(:,:,:) = pts(:,:,:,jp_sal,Krhs) - ztrds(:,:,:)
- CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_tem, jptra_ldf, ztrdt )
- CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_sal, jptra_ldf, ztrds )
- DEALLOCATE( ztrdt, ztrds )
+ zTtrd(:,:,:) = pts(:,:,:,jp_tem,Krhs) - zTtrd(:,:,:)
+ zStrd(:,:,:) = pts(:,:,:,jp_sal,Krhs) - zStrd(:,:,:)
+ CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_tem, jptra_ldf, zTtrd )
+ CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_sal, jptra_ldf, zStrd )
+ DEALLOCATE( zTtrd, zStrd )
ENDIF
! !* print mean trends (used for debugging)
IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=pts(:,:,:,jp_tem,Krhs), clinfo1=' ldf - Ta: ', mask1=tmask, &
@@ -122,6 +151,12 @@ CONTAINS
END SELECT
ENDIF
!
+ l_ptr = .FALSE. ! set flag for heat & salt diffusive diagnostics
+ l_hst = .FALSE.
+ IF( ( iom_use( 'sophtldf' ) .OR. iom_use( 'sopstldf' ) ) ) l_ptr = .TRUE. ! diffusive poleward transport
+ IF( ( iom_use("uadv_heattr") .OR. iom_use("vadv_heattr") .OR. &
+ & iom_use("uadv_salttr") .OR. iom_use("vadv_salttr") ) ) l_hst = .TRUE. ! vertically cumulated diffusive fluxes
+ !
END SUBROUTINE tra_ldf_init
!!======================================================================
diff --git a/src/OCE/TRA/traldf_iso.F90 b/src/OCE/TRA/traldf_iso.F90
index 8d84e76891bb958dec0bd0c1b561d7e8cb894f66..6ed2242eb23c26977a23367dc47e859f235f6584 100644
--- a/src/OCE/TRA/traldf_iso.F90
+++ b/src/OCE/TRA/traldf_iso.F90
@@ -9,7 +9,9 @@ MODULE traldf_iso
!! 1.0 ! 2005-11 (G. Madec) merge traldf and trazdf :-)
!! 3.3 ! 2010-09 (C. Ethe, G. Madec) Merge TRA-TRC
!! 3.7 ! 2014-01 (G. Madec, S. Masson) restructuration/simplification of aht/aeiv specification
- !! - ! 2014-02 (F. Lemarie, G. Madec) triad operator (Griffies) + Method of Stabilizing Correction
+ !! - ! 2014-02 (F. Lemarie, G. Madec) Standard and triad operator with Method of Stabilizing Correction
+ !! 4.5 ! 2022-06 (S. Techene, G, Madec) refactorization to reduce local memory usage + add tra_ldf_iso_a33 &
+ !! ! traldf_iso_blp routines and traldf_iso_scheme.h90 file
!!----------------------------------------------------------------------
!!----------------------------------------------------------------------
@@ -18,7 +20,7 @@ MODULE traldf_iso
!!----------------------------------------------------------------------
USE oce ! ocean dynamics and active tracers
USE dom_oce ! ocean space and time domain
- USE domutl, ONLY : is_tile
+ USE domutl, ONLY : lbnd_ij
USE trc_oce ! share passive tracers/Ocean variables
USE zdf_oce ! ocean vertical physics
USE ldftra ! lateral diffusion: tracer eddy coefficients
@@ -34,10 +36,10 @@ MODULE traldf_iso
IMPLICIT NONE
PRIVATE
- PUBLIC tra_ldf_iso ! routine called by step.F90
-
- LOGICAL :: l_ptr ! flag to compute poleward transport
- LOGICAL :: l_hst ! flag to compute heat transport
+ PUBLIC traldf_iso_lap ! routine called by traadv.F90
+ PUBLIC traldf_iso_blp ! routine called by traadv.F90
+ PUBLIC traldf_iso_a33 ! routine called by traldf_iso.F90 !!gm: to be move in traadv.F90 ???
+!!gm !!gm: to be extended to 13 and 23 ???)
!! * Substitutions
# include "do_loop_substitute.h90"
@@ -49,34 +51,11 @@ MODULE traldf_iso
!!----------------------------------------------------------------------
CONTAINS
- SUBROUTINE tra_ldf_iso( kt, Kmm, kit000, cdtype, pahu, pahv, &
- & pgu , pgv , pgui, pgvi, &
- & pt, pt2, pt_rhs, kjpt, kpass )
- !!
- INTEGER , INTENT(in ) :: kt ! ocean time-step index
- INTEGER , INTENT(in ) :: kit000 ! first time step index
- CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator)
- INTEGER , INTENT(in ) :: kjpt ! number of tracers
- INTEGER , INTENT(in ) :: kpass ! =1/2 first or second passage
- INTEGER , INTENT(in ) :: Kmm ! ocean time level index
- REAL(wp), DIMENSION(:,:,:) , INTENT(in ) :: pahu, pahv ! eddy diffusivity at u- and v-points [m2/s]
- REAL(wp), DIMENSION(:,:,:) , INTENT(in ) :: pgu, pgv ! tracer gradient at pstep levels
- REAL(wp), DIMENSION(:,:,:) , INTENT(in ) :: pgui, pgvi ! tracer gradient at top levels
- REAL(wp), DIMENSION(:,:,:,:), INTENT(in ) :: pt ! tracer (kpass=1) or laplacian of tracer (kpass=2)
- REAL(wp), DIMENSION(:,:,:,:), INTENT(in ) :: pt2 ! tracer (only used in kpass=2)
- REAL(wp), DIMENSION(:,:,:,:), INTENT(inout) :: pt_rhs ! tracer trend
- !!
- CALL tra_ldf_iso_t( kt, Kmm, kit000, cdtype, pahu, pahv, is_tile(pahu), &
- & pgu , pgv , is_tile(pgu) , pgui, pgvi, is_tile(pgui), &
- & pt, is_tile(pt), pt2, is_tile(pt2), pt_rhs, is_tile(pt_rhs), kjpt, kpass )
- END SUBROUTINE tra_ldf_iso
-
-
- SUBROUTINE tra_ldf_iso_t( kt, Kmm, kit000, cdtype, pahu, pahv, ktah, &
- & pgu , pgv , ktg , pgui, pgvi, ktgi, &
- & pt, ktt, pt2, ktt2, pt_rhs, ktt_rhs, kjpt, kpass )
+ SUBROUTINE traldf_iso_lap( kt, Kbb, Kmm, pt, Krhs, ld_ptr, ld_hst )
!!----------------------------------------------------------------------
- !! *** ROUTINE tra_ldf_iso ***
+ !! *** ROUTINE traldf_iso_iso ***
+ !!
+ !! —— nn_hls =2 or more ——
!!
!! ** Purpose : Compute the before horizontal tracer (t & s) diffusive
!! trend for a laplacian tensor (ezxcept the dz[ dz[.] ] term) and
@@ -88,316 +67,348 @@ CONTAINS
!! It is computed using before fields (forward in time) and isopyc-
!! nal or geopotential slopes computed in routine ldfslp.
!!
- !! 1st part : masked horizontal derivative of T ( di[ t ] )
- !! ======== with partial cell update if ln_zps=T
- !! with top cell update if ln_isfcav
+ !! ( A11 0 A13 )
+ !! rotation matrix = ( 0 A22 A23 )
+ !! ( A31 A32 A33 )
!!
- !! 2nd part : horizontal fluxes of the lateral mixing operator
- !! ========
- !! zftu = pahu e2u*e3u/e1u di[ tb ]
- !! - pahu e2u*uslp dk[ mi(mk(tb)) ]
- !! zftv = pahv e1v*e3v/e2v dj[ tb ]
- !! - pahv e2u*vslp dk[ mj(mk(tb)) ]
+ !! • masked horizontal derivative of T ( di[ t ] )
+ !!
+ !! • horizontal fluxes of the lateral mixing operator
+ !! zfu = A11 di[ tb ] + A13 dk[ mi(mk(tb)) ]
+ !! zfv = ahtv e1v*e3v/e2v dj[ tb ]
+ !! - ahtv e2u*vslp dk[ mj(mk(tb)) ]
+ !! with A11 = ahtu e2u*e3u/e1u ; A13 = - ahtu e2u*uslp
+ !! A22 = ahtv e1v*e3v/e1v ; A23 = - ahtv e1v*vslp
!! take the horizontal divergence of the fluxes:
- !! difft = 1/(e1e2t*e3t) { di-1[ zftu ] + dj-1[ zftv ] }
+ !! difft = 1/(e1e2t*e3t) { di-1[ zfu ] + dj-1[ zfv ] }
!! Add this trend to the general trend (ta,sa):
!! ta = ta + difft
!!
- !! 3rd part: vertical trends of the lateral mixing operator
- !! ======== (excluding the vertical flux proportional to dk[t] )
+ !! • vertical trends of the lateral mixing operator
+ !! (excluding the implicit part of vertical flux proportional to dk[t] )
!! vertical fluxes associated with the rotated lateral mixing:
- !! zftw = - { mi(mk(pahu)) * e2t*wslpi di[ mi(mk(tb)) ]
- !! + mj(mk(pahv)) * e1t*wslpj dj[ mj(mk(tb)) ] }
+ !! zfw = - { mi(mk(ahtu)) * e2t*wslpi di[ mi(mk(tb)) ]
+ !! + mj(mk(ahtv)) * e1t*wslpj dj[ mj(mk(tb)) ] }
!! take the horizontal divergence of the fluxes:
- !! difft = 1/(e1e2t*e3t) dk[ zftw ]
+ !! difft = 1/(e1e2t*e3t) dk[ zfw ]
!! Add this trend to the general trend (ta,sa):
!! pt_rhs = pt_rhs + difft
!!
!! ** Action : Update pt_rhs arrays with the before rotated diffusion
!!----------------------------------------------------------------------
- INTEGER , INTENT(in ) :: kt ! ocean time-step index
- INTEGER , INTENT(in ) :: kit000 ! first time step index
- CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator)
- INTEGER , INTENT(in ) :: kjpt ! number of tracers
- INTEGER , INTENT(in ) :: kpass ! =1/2 first or second passage
- INTEGER , INTENT(in ) :: Kmm ! ocean time level index
- INTEGER , INTENT(in ) :: ktah, ktg, ktgi, ktt, ktt2, ktt_rhs
- REAL(wp), DIMENSION(A2D_T(ktah) ,JPK) , INTENT(in ) :: pahu, pahv ! eddy diffusivity at u- and v-points [m2/s]
- REAL(wp), DIMENSION(A2D_T(ktg) ,KJPT), INTENT(in ) :: pgu, pgv ! tracer gradient at pstep levels
- REAL(wp), DIMENSION(A2D_T(ktgi) ,KJPT), INTENT(in ) :: pgui, pgvi ! tracer gradient at top levels
- REAL(wp), DIMENSION(A2D_T(ktt) ,JPK,KJPT), INTENT(in ) :: pt ! tracer (kpass=1) or laplacian of tracer (kpass=2)
- REAL(wp), DIMENSION(A2D_T(ktt2) ,JPK,KJPT), INTENT(in ) :: pt2 ! tracer (only used in kpass=2)
- REAL(wp), DIMENSION(A2D_T(ktt_rhs),JPK,KJPT), INTENT(inout) :: pt_rhs ! tracer trend
+ INTEGER , INTENT(in ) :: kt, Kbb, Kmm, Krhs ! ocean time-step and time-level indices
+ LOGICAL , OPTIONAL , INTENT(in ) :: ld_hst, ld_ptr ! T-S diagnostic flags
+ REAL(wp), DIMENSION(:,:,:,:,:), INTENT(inout) :: pt ! tracers, in: at kbb ; out: at Krhs
+ !!
+ INTEGER :: ji, jj, jk, jn ! dummy loop indices
+ INTEGER :: inn ! inner domain index
+ INTEGER :: itra ! number of tracers
+ INTEGER :: ik, ikp1, iis ! swap indices
+ !
+ REAL(wp) :: zmsku, zahu_w ! local scalars
+ REAL(wp) :: zmskv, zahv_w ! - -
+ REAL(wp) :: zfw_kp1 ! - -
+ REAL(wp) :: zA11 , zA13 !)
+ REAL(wp) :: zA22, zA23 !) elements of the rotation matrix
+ REAL(wp) :: zA31, zA32, zA33 !)
!
- INTEGER :: ji, jj, jk, jn ! dummy loop indices
- INTEGER :: ikt
- INTEGER :: ierr, iij ! local integer
- REAL(wp) :: zmsku, zahu_w, zabe1, zcof1, zcoef3 ! local scalars
- REAL(wp) :: zmskv, zahv_w, zabe2, zcof2, zcoef4 ! - -
- REAL(wp) :: zcoef0, ze3w_2, zsign ! - -
- REAL(wp), DIMENSION(A2D(nn_hls)) :: zdkt, zdk1t, z2d
- REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zdit, zdjt, zftu, zftv, ztfw
+ REAL(wp), DIMENSION(T2D(1),0:1) :: zdit, zdjt ! INNER + 1 domain at level jk and jk+1
+ REAL(wp), DIMENSION(T2D(1),0:1) :: zdkt ! INNER + 1 domain at level jk and jk+1
+ REAL(wp), DIMENSION(T2D(1) ) :: zfu , zfv ! INNER + 1 domain
+ REAL(wp), DIMENSION(T2D(0) ) :: zfw ! INNER domain
+ !
+!!gm ld_ptr,ld_hst: require changes in the dia_ptr/dia_ar5 <<<=== comment for the moment
+! REAL(wp), DIMENSION(:,:), ALLOCATABLE :: zdia_i , zdia_j ! used for some diagnostics
+!!!gm end
+ REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zdia_i , zdia_j ! used for some diagnostics
!!----------------------------------------------------------------------
!
- IF( kpass == 1 .AND. kt == kit000 ) THEN
- IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile
- IF(lwp) WRITE(numout,*)
- IF(lwp) WRITE(numout,*) 'tra_ldf_iso : rotated laplacian diffusion operator on ', cdtype
- IF(lwp) WRITE(numout,*) '~~~~~~~~~~~'
+!!gm OPTIMIZATION : This part does not depends on tracer ===>>> put in a routine
+!! possibility of moving it in tra_ldf routine (shared between TRA and TRC at least in RK3 case).
+!!gm idea: define A13 and A23 as 2D arrays that do not depends on tracers in tra_ldf_iso_a33 routine which
+!!gm will be renamed : tra_ldf_iso_a13_23_33 ===>> 2x3D additional arrays but much less calculation...
+!!gm idea 2 : even better: explore the possibility to compute matrix element instead of slopes in ldfslp ....
+!!gm ===>> same memory print but much less calculation !!
+!! caution: the gm velocity have also to be calculated as they use the slopes....
+!!gm idea
+ !
+ CALL traldf_iso_a33( Kmm, ah_wslp2, akz ) ! calculate a33 element (ah_wslp2 and akz)
+ !
+!!gm ld_ptr,ld_hst: require changes in the dia_ptr/dia_ar5 <<<=== comment for the moment
+! IF( ld_ptr .OR. ld_hst ) THEN
+! ALLOCATE( zdia_i(A2D(0)) , zdia_j(A2D(0)) )
+! ENDIF
+ IF( PRESENT(ld_ptr) .OR. PRESENT(ld_hst) ) THEN
+ IF( ld_ptr .OR. ld_hst ) THEN
+ ALLOCATE( zdia_i(T2D(0),jpk) , zdia_j(T2D(0),jpk) )
+ zdia_i(:,:,jpk) = 0._wp ; zdia_j(:,:,jpk) = 0._wp
ENDIF
ENDIF
+!!gm end
!
- IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile
- l_hst = .FALSE.
- l_ptr = .FALSE.
- IF( l_diaptr .AND. cdtype == 'TRA' .AND. ( iom_use( 'sophtldf' ) .OR. iom_use( 'sopstldf' ) ) ) l_ptr = .TRUE.
- IF( l_iom .AND. cdtype == 'TRA' .AND. ( iom_use("uadv_heattr") .OR. iom_use("vadv_heattr") .OR. &
- & iom_use("uadv_salttr") .OR. iom_use("vadv_salttr") ) ) l_hst = .TRUE.
- ENDIF
+ itra = SIZE( pt, dim = 4 ) ! number of tracers
!
- ! Define pt_rhs halo points for multi-point haloes in bilaplacian case
- IF( nldf_tra == np_blp_i .AND. kpass == 1 ) THEN ; iij = nn_hls
- ELSE ; iij = 1
- ENDIF
+ DO jn = 1, itra !== tracer loop ==!
+ !
+!!gm ld_ptr,ld_hst: require changes in the dia_ptr/dia_ar5 <<<=== comment for the moment
+! IF( ld_ptr .OR. ld_hst ) THEN
+! zdia_i(:,:) = 0._wp ; zdia_j(:,:) = 0._wp
+! ENDIF
+!!gm end
+
+ DO jk = 1, jpkm1 != ij slab =!
+ !
+ ! !* iso-neutral laplacian applied on pt over the INNER domain
+# define iso_lap
+# define INN 0
+# define pt_in(i,j,k,n,t) pt(i,j,k,n,t)
+# include "traldf_iso_scheme.h90"
+
+# undef iso_lap
+# undef INN
+# undef pt_in
+!!gm ld_ptr,ld_hst:
+! IF( ld_ptr .OR. ld_hst ) THEN ! vertically cumulated fluxes (minus sign by convention in the output)
+! zdia_i(:,:) = zdia_i(:,:) - zfu(A2D(0))
+! zdia_j(:,:) = zdia_j(:,:) - zfv(A2D(0))
+! ENDIF
+ IF( PRESENT(ld_ptr) .OR. PRESENT(ld_hst) ) THEN ! store fluxes for diagnostics (minus sign by convention in the output)
+ IF( ld_ptr .OR. ld_hst ) THEN
+ zdia_i(:,:,jk) = - zfu(T2D(0))
+ zdia_j(:,:,jk) = - zfv(T2D(0))
+ ENDIF
+ ENDIF
+!!gm end
+ !
+ END DO != end ij slab =!
+ !
+ ! != "Poleward" diffusive heat or salt transports =!
+ IF( PRESENT(ld_ptr) ) THEN
+ IF( ld_ptr) CALL dia_ptr_hst( jn, 'ldf' , zdia_j )
+ ENDIF
+ IF( PRESENT(ld_hst) ) THEN
+ IF( ld_hst) CALL dia_ar5_hst( jn, 'ldf', zdia_i, zdia_j )
+ ENDIF
+ !
+ END DO !== end tracer loop ==!
!
- IF( kpass == 1 ) THEN ; zsign = 1._wp ! bilaplacian operator require a minus sign (eddy diffusivity >0)
- ELSE ; zsign = -1._wp
- ENDIF
+ END SUBROUTINE traldf_iso_lap
+
+ SUBROUTINE traldf_iso_blp( kt, Kbb, Kmm, pt, Krhs, ld_ptr, ld_hst )
!!----------------------------------------------------------------------
- !! 0 - calculate ah_wslp2 and akz
+ !! *** ROUTINE tra_ldf_iso_blp ***
+ !!
+ !! —— nn_hls =2 or more ——
+ !!
!!----------------------------------------------------------------------
+ INTEGER , INTENT(in ) :: kt, Kbb, Kmm, Krhs ! ocean time-step and time-level indices
+ LOGICAL , OPTIONAL , INTENT(in ) :: ld_hst, ld_ptr ! T-S diagnostic flags
+ REAL(wp), DIMENSION(:,:,:,:,:), INTENT(inout) :: pt ! tracers, in: at kbb ; out: at Krhs
+ !!
+ INTEGER :: ji, jj, jk, jn ! dummy loop indices
+ INTEGER :: inn ! inner domain index
+ INTEGER :: itra ! number of tracers
+ INTEGER :: ik, ikp1, iis ! swap indices
!
- IF( kpass == 1 ) THEN !== first pass only ==!
- !
- DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 )
- !
- zmsku = wmask(ji,jj,jk) / MAX( umask(ji ,jj,jk-1) + umask(ji-1,jj,jk) &
- & + umask(ji-1,jj,jk-1) + umask(ji ,jj,jk) , 1._wp )
- zmskv = wmask(ji,jj,jk) / MAX( vmask(ji,jj ,jk-1) + vmask(ji,jj-1,jk) &
- & + vmask(ji,jj-1,jk-1) + vmask(ji,jj ,jk) , 1._wp )
- !
- ! round brackets added to fix the order of floating point operations
- ! needed to ensure halo 1 - halo 2 compatibility
- zahu_w = ( ( pahu(ji ,jj,jk-1) + pahu(ji-1,jj,jk) &
- & ) & ! bracket for halo 1 - halo 2 compatibility
- & + ( pahu(ji-1,jj,jk-1) + pahu(ji ,jj,jk) &
- & ) & ! bracket for halo 1 - halo 2 compatibility
- & ) * zmsku
- zahv_w = ( ( pahv(ji,jj ,jk-1) + pahv(ji,jj-1,jk) &
- & ) & ! bracket for halo 1 - halo 2 compatibility
- & + ( pahv(ji,jj-1,jk-1) + pahv(ji,jj ,jk) &
- & ) & ! bracket for halo 1 - halo 2 compatibility
- & ) * zmskv
- !
- ah_wslp2(ji,jj,jk) = zahu_w * wslpi(ji,jj,jk) * wslpi(ji,jj,jk) &
- & + zahv_w * wslpj(ji,jj,jk) * wslpj(ji,jj,jk)
- END_3D
- !
- IF( ln_traldf_msc ) THEN ! stabilizing vertical diffusivity coefficient
- DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 )
- ! round brackets added to fix the order of floating point operations
- ! needed to ensure halo 1 - halo 2 compatibility
- akz(ji,jj,jk) = 0.25_wp * ( &
- & ( ( pahu(ji ,jj,jk) + pahu(ji ,jj,jk-1) ) / ( e1u(ji ,jj) * e1u(ji ,jj) ) &
- & + ( pahu(ji-1,jj,jk) + pahu(ji-1,jj,jk-1) ) / ( e1u(ji-1,jj) * e1u(ji-1,jj) ) &
- & ) & ! bracket for halo 1 - halo 2 compatibility
- & + ( ( pahv(ji,jj ,jk) + pahv(ji,jj ,jk-1) ) / ( e2v(ji,jj ) * e2v(ji,jj ) ) &
- & + ( pahv(ji,jj-1,jk) + pahv(ji,jj-1,jk-1) ) / ( e2v(ji,jj-1) * e2v(ji,jj-1) ) &
- & ) & ! bracket for halo 1 - halo 2 compatibility
- & )
- END_3D
- !
- IF( ln_traldf_blp ) THEN ! bilaplacian operator
- DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 )
- akz(ji,jj,jk) = 16._wp &
- & * ah_wslp2 (ji,jj,jk) &
- & * ( akz (ji,jj,jk) &
- & + ah_wslp2(ji,jj,jk) &
- & / ( e3w(ji,jj,jk,Kmm) * e3w(ji,jj,jk,Kmm) ) )
- END_3D
- ELSEIF( ln_traldf_lap ) THEN ! laplacian operator
- DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 )
- ze3w_2 = e3w(ji,jj,jk,Kmm) * e3w(ji,jj,jk,Kmm)
- zcoef0 = rDt * ( akz(ji,jj,jk) + ah_wslp2(ji,jj,jk) / ze3w_2 )
- akz(ji,jj,jk) = MAX( zcoef0 - 0.5_wp , 0._wp ) * ze3w_2 * r1_Dt
- END_3D
- ENDIF
- !
- ELSE ! 33 flux set to zero with akz=ah_wslp2 ==>> computed in full implicit
- DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpk )
- akz(ji,jj,jk) = ah_wslp2(ji,jj,jk)
- END_3D
+ REAL(wp) :: zmsku, zahu_w ! local scalars
+ REAL(wp) :: zmskv, zahv_w ! - -
+ REAL(wp) :: zfw_kp1 ! - -
+ REAL(wp) :: zA11 , zA13 !)
+ REAL(wp) :: zA22, zA23 !) elements of the rotation matrix
+ REAL(wp) :: zA31, zA32, zA33 !)
+ !
+ REAL(wp), DIMENSION(T2D(2),0:1) :: zdit, zdjt ! INNER + 2 domain at level jk and jk+1
+ REAL(wp), DIMENSION(T2D(2),0:1) :: zdkt ! INNER + 2 domain at level jk and jk+1
+ REAL(wp), DIMENSION(T2D(2) ) :: zfu , zfv ! INNER + 2 domain
+ REAL(wp), DIMENSION(T2D(1) ) :: zfw ! INNER + 1 domain
+ REAL(wp), DIMENSION(T2D(1),jpkm1) :: zlap ! INNER + 1 doamin (3D laplacian at t-point)
+ !
+!!gm ld_ptr,ld_hst: require changes in the dia_ptr/dia_ar5 <<<=== comment for the moment
+! REAL(wp), DIMENSION(:,:), ALLOCATABLE :: zdia_i , zdia_j ! used for some diagnostics
+!!!gm end
+ REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zdia_i , zdia_j ! used for some diagnostics
+ !!----------------------------------------------------------------------
+ !
+ CALL traldf_iso_a33( Kmm, ah_wslp2, akz ) ! calculate a33 element (ah_wslp2 and akz)
+ !
+ itra = SIZE( pt, dim = 4 ) ! number of tracers
+ !
+!!gm ld_ptr,ld_hst: require changes in the dia_ptr/dia_ar5 <<<=== comment for the moment
+! IF( ld_ptr .OR. ld_hst ) THEN
+! ALLOCATE( zdia_i(A2D(0)) , zdia_j(A2D(0)) )
+! ENDIF
+ IF( PRESENT(ld_ptr) .OR. PRESENT(ld_hst) ) THEN
+ IF( ld_ptr .OR. ld_hst ) THEN
+ ALLOCATE( zdia_i(T2D(0),jpk) , zdia_j(T2D(0),jpk) )
+ zdia_i(:,:,jpk) = 0._wp ; zdia_j(:,:,jpk) = 0._wp
ENDIF
ENDIF
+!!gm end
!
- ! ! ===========
- DO jn = 1, kjpt ! tracer loop
- ! ! ===========
+ DO jn = 1, itra !== tracer loop ==!
+ ! !
+!!gm ld_ptr,ld_hst: require changes in the dia_ptr/dia_ar5 <<<=== comment for the moment
+! IF( ld_ptr .OR. ld_hst ) THEN
+! zdia_i(:,:) = 0._wp ; zdia_j(:,:) = 0._wp
+! ENDIF
+!!gm end
!
- !!----------------------------------------------------------------------
- !! I - masked horizontal derivative
- !!----------------------------------------------------------------------
- zdit(:,:,:) = 0._wp
- zdjt(:,:,:) = 0._wp
-
- ! Horizontal tracer gradient
- DO_3D( iij, iij-1, iij, iij-1, 1, jpkm1 )
- zdit(ji,jj,jk) = ( pt(ji+1,jj ,jk,jn) - pt(ji,jj,jk,jn) ) * umask(ji,jj,jk)
- zdjt(ji,jj,jk) = ( pt(ji ,jj+1,jk,jn) - pt(ji,jj,jk,jn) ) * vmask(ji,jj,jk)
- END_3D
- IF( ln_zps ) THEN ! botton and surface ocean correction of the horizontal gradient
- DO_2D( iij, iij-1, iij, iij-1 ) ! bottom correction (partial bottom cell)
- zdit(ji,jj,mbku(ji,jj)) = pgu(ji,jj,jn)
- zdjt(ji,jj,mbkv(ji,jj)) = pgv(ji,jj,jn)
- END_2D
- IF( ln_isfcav ) THEN ! first wet level beneath a cavity
- DO_2D( iij, iij-1, iij, iij-1 )
- IF( miku(ji,jj) > 1 ) zdit(ji,jj,miku(ji,jj)) = pgui(ji,jj,jn)
- IF( mikv(ji,jj) > 1 ) zdjt(ji,jj,mikv(ji,jj)) = pgvi(ji,jj,jn)
- END_2D
+ DO jk = 1, jpkm1 != ij slab =!
+ !
+ ! !* 1st pass : iso-neutral laplacian of pt
+ ! computed over the INNER + 1 domain
+# define iso_blp_p1
+# define INN 1
+# define pt_in(i,j,k,n,t) pt(i,j,k,n,t)
+!
+# include "traldf_iso_scheme.h90"
+!
+# undef iso_blp_p1
+# undef INN
+# undef pt_in
+ !
+ ! !* 2nd pass : bilaplacian = laplacian of 1st pass (zlap)
+ ! computed over the INNER domain
+# define iso_blp_p2
+# define INN 0
+# define pt_in(i,j,k,n,t) zlap(i,j,k)
+!
+# include "traldf_iso_scheme.h90"
+!
+# undef iso_blp_p2
+# undef INN
+# undef pt_in
+ !
+!!gm ld_ptr,ld_hst:
+! IF( ld_ptr .OR. ld_hst ) THEN ! vertically cumulated fluxes (minus sign by convention in the output)
+! zdia_i(:,:) = zdia_i(:,:) - zfu(A2D(0))
+! zdia_j(:,:) = zdia_j(:,:) - zfv(A2D(0))
+! ENDIF
+ IF( PRESENT(ld_ptr) .OR. PRESENT(ld_hst) ) THEN
+ IF( ld_ptr .OR. ld_hst ) THEN ! store fluxes for diagnostics (minus sign by convention in the output)
+ zdia_i(:,:,jk) = - zfu(T2D(0))
+ zdia_j(:,:,jk) = - zfv(T2D(0))
+ ENDIF
ENDIF
+!!gm end
+ !
+ END DO != end ij slab =!
+ !
+ ! != "Poleward" diffusive heat or salt transports =!
+ IF( PRESENT(ld_ptr) ) THEN
+ IF( ld_ptr ) CALL dia_ptr_hst( jn, 'ldf' , zdia_j )
+ ENDIF
+ IF( PRESENT(ld_hst) ) THEN
+ IF( ld_hst ) CALL dia_ar5_hst( jn, 'ldf', zdia_i, zdia_j )
ENDIF
!
- !!----------------------------------------------------------------------
- !! II - horizontal trend (full)
- !!----------------------------------------------------------------------
+ END DO !== end tracer loop ==!
+ !
+ END SUBROUTINE traldf_iso_blp
+
+
+ SUBROUTINE traldf_iso_a33( Kmm, pah_wslp2, pakz )
+ !!----------------------------------------------------------------------
+ !! *** ROUTINE traldf_iso_a33 ***
+ !!
+ !! —— nn_hls =2 or more ——
+ !!
+ !! ** Purpose : Compute the a33 element of the rotation matrix and,
+ !! if ln_traldf_msc=T, its split into explicit and implicit
+ !! time-integration.
+ !!
+ !! ** Method :
+ !!
+ !! ** Action : pah_wslp2, pakz
+ !!----------------------------------------------------------------------
+ INTEGER , INTENT(in ) :: Kmm ! ocean time level index
+ REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: pah_wslp2 ! implicit a33 element (ln_traldf_msc= false)
+ REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: pakz ! implicit a33 element (ln_traldf_msc= true )
+ !
+ INTEGER :: ji, jj, jk ! dummy loop indices
+ INTEGER :: inn ! local integer
+ REAL(wp) :: zmsku, zahu_w ! local scalars
+ REAL(wp) :: zmskv, zahv_w ! - -
+ REAL(wp) :: zcoef0, ze3w_2 ! - -
+ !!----------------------------------------------------------------------
+ !
+ SELECT CASE( nldf_tra ) ! set inner domain index
+ CASE( np_lap_i ) ; inn = 0
+ CASE( np_blp_i ) ; inn = 1
+ CASE DEFAULT ; CALL ctl_stop( 'STOP', 'traldf_iso_a33 routine should not be called ' )
+ END SELECT
+ !
+ ! CAUTION: round brackets are required for halo size and north fold compatibility
+ !
+ !
+ DO_3D( inn , inn , inn , inn , 2, jpkm1 )
!
- DO jk = 1, jpkm1 ! Horizontal slab
- !
- DO_2D( iij, iij, iij, iij )
- ! !== Vertical tracer gradient
- zdk1t(ji,jj) = ( pt(ji,jj,jk,jn) - pt(ji,jj,jk+1,jn) ) * wmask(ji,jj,jk+1) ! level jk+1
- !
- IF( jk == 1 ) THEN ; zdkt(ji,jj) = zdk1t(ji,jj) ! surface: zdkt(jk=1)=zdkt(jk=2)
- ELSE ; zdkt(ji,jj) = ( pt(ji,jj,jk-1,jn) - pt(ji,jj,jk,jn) ) * wmask(ji,jj,jk)
- ENDIF
- END_2D
+ zmsku = wmask(ji,jj,jk) / MAX( ( umask(ji ,jj,jk-1) + umask(ji-1,jj,jk) ) &
+ & + ( umask(ji-1,jj,jk-1) + umask(ji ,jj,jk) ) , 1._wp )
+ zmskv = wmask(ji,jj,jk) / MAX( ( vmask(ji,jj ,jk-1) + vmask(ji,jj-1,jk) ) &
+ & + ( vmask(ji,jj-1,jk-1) + vmask(ji,jj ,jk) ) , 1._wp )
!
- DO_2D( iij, iij-1, iij, iij-1 ) !== Horizontal fluxes
- zabe1 = pahu(ji,jj,jk) * e2_e1u(ji,jj) * e3u(ji,jj,jk,Kmm)
- zabe2 = pahv(ji,jj,jk) * e1_e2v(ji,jj) * e3v(ji,jj,jk,Kmm)
- !
- zmsku = 1. / MAX( wmask(ji+1,jj,jk ) + wmask(ji,jj,jk+1) &
- & + wmask(ji+1,jj,jk+1) + wmask(ji,jj,jk ), 1. )
- !
- zmskv = 1. / MAX( wmask(ji,jj+1,jk ) + wmask(ji,jj,jk+1) &
- & + wmask(ji,jj+1,jk+1) + wmask(ji,jj,jk ), 1. )
- !
- zcof1 = - pahu(ji,jj,jk) * e2u(ji,jj) * uslp(ji,jj,jk) * zmsku
- zcof2 = - pahv(ji,jj,jk) * e1v(ji,jj) * vslp(ji,jj,jk) * zmskv
- !
- ! round brackets added to fix the order of floating point operations
- ! needed to ensure halo 1 - halo 2 compatibility
- zftu(ji,jj,jk ) = ( zabe1 * zdit(ji,jj,jk) &
- & + zcof1 * ( ( zdkt (ji+1,jj) + zdk1t(ji,jj) &
- & ) & ! bracket for halo 1 - halo 2 compatibility
- & + ( zdk1t(ji+1,jj) + zdkt (ji,jj) &
- & ) & ! bracket for halo 1 - halo 2 compatibility
- & ) ) * umask(ji,jj,jk)
- zftv(ji,jj,jk) = ( zabe2 * zdjt(ji,jj,jk) &
- & + zcof2 * ( ( zdkt (ji,jj+1) + zdk1t(ji,jj) &
- & ) & ! bracket for halo 1 - halo 2 compatibility
- & + ( zdk1t(ji,jj+1) + zdkt (ji,jj) &
- & ) & ! bracket for halo 1 - halo 2 compatibility
- & ) ) * vmask(ji,jj,jk)
- END_2D
+ ! ! round brackets required to ensure halo size compatibility with north fold boundary condition
+ zahu_w = ( ( ahtu(ji ,jj,jk-1) + ahtu(ji-1,jj,jk) ) &
+ & + ( ahtu(ji-1,jj,jk-1) + ahtu(ji ,jj,jk) ) ) * zmsku
+ zahv_w = ( ( ahtv(ji,jj ,jk-1) + ahtv(ji,jj-1,jk) ) &
+ & + ( ahtv(ji,jj-1,jk-1) + ahtv(ji,jj ,jk) ) ) * zmskv
+!!st need to do something for dia...
+!!st ! ! "Poleward" diffusive heat or salt transports (T-S case only)
+!!st ! note sign is reversed to give down-gradient diffusive transports )
+!!st IF( l_ptr ) CALL dia_ptr_hst( jn, 'ldf', -zftv(A2D(0),:) )
+!!st ! ! Diffusive heat transports
+!!st IF( l_hst ) CALL dia_ar5_hst( jn, 'ldf', -zftu(:,:,:), -zftv(:,:,:) )
!
- DO_2D( iij-1, iij-1, iij-1, iij-1 ) !== horizontal divergence and add to pta
- ! round brackets added to fix the order of floating point operations
- ! needed to ensure halo 1 - halo 2 compatibility
- pt_rhs(ji,jj,jk,jn) = pt_rhs(ji,jj,jk,jn) &
- & + zsign * ( ( zftu(ji,jj,jk) - zftu(ji-1,jj,jk) &
- & ) & ! bracket for halo 1 - halo 2 compatibility
- & + ( zftv(ji,jj,jk) - zftv(ji,jj-1,jk) &
- & ) & ! bracket for halo 1 - halo 2 compatibility
- & ) * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm)
- END_2D
- END DO ! End of slab
+ pah_wslp2(ji,jj,jk) = zahu_w * wslpi(ji,jj,jk) * wslpi(ji,jj,jk) &
+ & + zahv_w * wslpj(ji,jj,jk) * wslpj(ji,jj,jk)
+ END_3D
+ !
+!!gm size allocate for ah_wslp2 and akz should be A2D(0) in lap case and A2D(1) in bilap case
- !!----------------------------------------------------------------------
- !! III - vertical trend (full)
- !!----------------------------------------------------------------------
- !
- ! Vertical fluxes
- ! ---------------
- ! ! Surface and bottom vertical fluxes set to zero
- ztfw(:,:, 1 ) = 0._wp ; ztfw(:,:,jpk) = 0._wp
- DO_3D( iij-1, iij-1, iij-1, iij-1, 2, jpkm1 ) ! interior (2=<jk=<jpk-1)
- !
- zmsku = wmask(ji,jj,jk) / MAX( umask(ji ,jj,jk-1) + umask(ji-1,jj,jk) &
- & + umask(ji-1,jj,jk-1) + umask(ji ,jj,jk) , 1._wp )
- zmskv = wmask(ji,jj,jk) / MAX( vmask(ji,jj ,jk-1) + vmask(ji,jj-1,jk) &
- & + vmask(ji,jj-1,jk-1) + vmask(ji,jj ,jk) , 1._wp )
- !
- zahu_w = ( pahu(ji ,jj,jk-1) + pahu(ji-1,jj,jk) &
- & + pahu(ji-1,jj,jk-1) + pahu(ji ,jj,jk) ) * zmsku
- zahv_w = ( pahv(ji,jj ,jk-1) + pahv(ji,jj-1,jk) &
- & + pahv(ji,jj-1,jk-1) + pahv(ji,jj ,jk) ) * zmskv
- !
- zcoef3 = - zahu_w * e2t(ji,jj) * zmsku * wslpi (ji,jj,jk) !wslpi & j are already w-masked
- zcoef4 = - zahv_w * e1t(ji,jj) * zmskv * wslpj (ji,jj,jk)
- !
- ! round brackets added to fix the order of floating point operations
- ! needed to ensure halo 1 - halo 2 compatibility
- ztfw(ji,jj,jk) = zcoef3 * ( ( zdit(ji ,jj ,jk-1) + zdit(ji-1,jj ,jk) &
- & ) & ! bracket for halo 1 - halo 2 compatibility
- & + ( zdit(ji-1,jj ,jk-1) + zdit(ji ,jj ,jk) &
- & ) & ! bracket for halo 1 - halo 2 compatibility
- & ) &
- & + zcoef4 * ( ( zdjt(ji ,jj ,jk-1) + zdjt(ji ,jj-1,jk) &
- & ) & ! bracket for halo 1 - halo 2 compatibility
- & + ( zdjt(ji ,jj-1,jk-1) + zdjt(ji ,jj ,jk) &
- & ) & ! bracket for halo 1 - halo 2 compatibility
- & )
+!!gm NB: ah_wslp2 and akz can be defined on A2D(0) or A2D(1) (lap, or bilap) and aver 2:jpkm1 in all cases
+!!gm moreover, without ln_traldf_msc=T only ah_wslp2 is required + akz can be set as a local array
+!!gm if ah_wslp2 is set to a proper value at the end of tra_ldf in iso case
+
+
+!!gm Question: here is it really Kmm that should be used and not Kbb ?
+
+
+!!gm BUG ?: below akz calculation should use zmsku/v instead of * 0.25_wp
+!!gm ===>>> introduce ah_wspl2 calculation in all cases !
+
+ IF( ln_traldf_msc ) THEN ! stabilizing vertical diffusivity coefficient (compute akz)
+ DO_3D( inn , inn , inn , inn , 2, jpkm1 )
+ ! ! round brackets required to ensure halo size compatibility with north fold boundary condition
+ pakz(ji,jj,jk) = ( ( ( ahtu(ji ,jj,jk) + ahtu(ji ,jj,jk-1) ) / ( e1u(ji ,jj) * e1u(ji ,jj) ) &
+ & + ( ahtu(ji-1,jj,jk) + ahtu(ji-1,jj,jk-1) ) / ( e1u(ji-1,jj) * e1u(ji-1,jj) ) ) &
+ & + ( ( ahtv(ji,jj ,jk) + ahtv(ji,jj ,jk-1) ) / ( e2v(ji,jj ) * e2v(ji,jj ) ) &
+ & + ( ahtv(ji,jj-1,jk) + ahtv(ji,jj-1,jk-1) ) / ( e2v(ji,jj-1) * e2v(ji,jj-1) ) ) ) * 0.25_wp
END_3D
- ! !== add the vertical 33 flux ==!
- IF( ln_traldf_lap ) THEN ! laplacian case: eddy coef = ah_wslp2 - akz
- DO_3D( iij-1, iij-1, iij-1, iij-1, 2, jpkm1 )
- ztfw(ji,jj,jk) = ztfw(ji,jj,jk) + e1e2t(ji,jj) / e3w(ji,jj,jk,Kmm) * wmask(ji,jj,jk) &
- & * ( ah_wslp2(ji,jj,jk) - akz(ji,jj,jk) ) &
- & * ( pt(ji,jj,jk-1,jn) - pt(ji,jj,jk,jn) )
- END_3D
- !
- ELSE ! bilaplacian
- SELECT CASE( kpass )
- CASE( 1 ) ! 1st pass : eddy coef = ah_wslp2
- DO_3D( iij-1, iij-1, iij-1, iij-1, 2, jpkm1 )
- ztfw(ji,jj,jk) = &
- & ztfw(ji,jj,jk) + ah_wslp2(ji,jj,jk) * e1e2t(ji,jj) &
- & * ( pt(ji,jj,jk-1,jn) - pt(ji,jj,jk,jn) ) / e3w(ji,jj,jk,Kmm) * wmask(ji,jj,jk)
- END_3D
- CASE( 2 ) ! 2nd pass : eddy flux = ah_wslp2 and akz applied on pt and pt2 gradients, resp.
- DO_3D( 0, 0, 0, 0, 2, jpkm1 )
- ztfw(ji,jj,jk) = ztfw(ji,jj,jk) + e1e2t(ji,jj) / e3w(ji,jj,jk,Kmm) * wmask(ji,jj,jk) &
- & * ( ah_wslp2(ji,jj,jk) * ( pt (ji,jj,jk-1,jn) - pt (ji,jj,jk,jn) ) &
- & + akz(ji,jj,jk) * ( pt2(ji,jj,jk-1,jn) - pt2(ji,jj,jk,jn) ) )
- END_3D
- END SELECT
- ENDIF
!
- DO_3D( iij-1, iij-1, iij-1, iij-1, 1, jpkm1 ) !== Divergence of vertical fluxes added to pta ==!
- pt_rhs(ji,jj,jk,jn) = pt_rhs(ji,jj,jk,jn) + zsign * ( ztfw (ji,jj,jk) - ztfw(ji,jj,jk+1) ) * r1_e1e2t(ji,jj) &
- & / e3t(ji,jj,jk,Kmm)
+ IF( ln_traldf_blp ) THEN ! bilaplacian operator
+ DO_3D( inn , inn , inn , inn , 2, jpkm1 )
+ ze3w_2 = e3w(ji,jj,jk,Kmm) * e3w(ji,jj,jk,Kmm)
+ pakz(ji,jj,jk) = 16._wp * ah_wslp2(ji,jj,jk) * ( akz(ji,jj,jk) + ah_wslp2(ji,jj,jk) / ze3w_2 )
+ END_3D
+ ELSEIF( ln_traldf_lap ) THEN ! laplacian operator
+ DO_3D( inn , inn , inn , inn , 2, jpkm1 )
+ ze3w_2 = e3w(ji,jj,jk,Kmm) * e3w(ji,jj,jk,Kmm)
+ zcoef0 = rDt * ( akz(ji,jj,jk) + ah_wslp2(ji,jj,jk) / ze3w_2 )
+ pakz(ji,jj,jk) = MAX( zcoef0 - 0.5_wp , 0._wp ) * ze3w_2 * r1_Dt
+ END_3D
+ ENDIF
+ !
+ ELSE ! A33 flux set to zero with akz=ah_wslp2 ==>> computed in full implicit
+ DO_3D( inn , inn , inn , inn , 1, jpk )
+ pakz(ji,jj,jk) = pah_wslp2(ji,jj,jk)
END_3D
- !
- IF( ( kpass == 1 .AND. ln_traldf_lap ) .OR. & !== first pass only ( laplacian) ==!
- ( kpass == 2 .AND. ln_traldf_blp ) ) THEN !== 2nd pass (bilaplacian) ==!
- !
- ! ! "Poleward" diffusive heat or salt transports (T-S case only)
- ! note sign is reversed to give down-gradient diffusive transports )
- IF( l_ptr ) CALL dia_ptr_hst( jn, 'ldf', -zftv(:,:,:) )
- ! ! Diffusive heat transports
- IF( l_hst ) CALL dia_ar5_hst( jn, 'ldf', -zftu(:,:,:), -zftv(:,:,:) )
- !
- ENDIF !== end pass selection ==!
- !
- ! ! ===============
- END DO ! end tracer loop
+ ENDIF
!
- END SUBROUTINE tra_ldf_iso_t
+ END SUBROUTINE traldf_iso_a33
!!==============================================================================
END MODULE traldf_iso
diff --git a/src/OCE/TRA/traldf_iso_scheme.h90 b/src/OCE/TRA/traldf_iso_scheme.h90
new file mode 100644
index 0000000000000000000000000000000000000000..818474f4319833fa1fec596ffc8756fe4e357dfe
--- /dev/null
+++ b/src/OCE/TRA/traldf_iso_scheme.h90
@@ -0,0 +1,195 @@
+ !!======================================================================
+ !! *** traldf_iso_scheme.h90 ***
+ !! tra_ldf: divergence the lateral iso-neutral fluxes
+#if defined iso_lap
+ !! laplacian
+#elif defined iso_blp_p1
+ !! bilaplacian: 1st pass
+#elif defined iso_blp_p2
+ !! bilaplacian: 2nd pass
+#endif
+ !!======================================================================
+ !! History : 4.5 ! 2022-08 (S. Techene, G, Madec) refactorization to reduce local memory usage
+ !! + no more re-entering lap with traldf_iso_blp creation
+ !!----------------------------------------------------------------------
+
+
+ !!======================================================================
+ !! masked tracer gradient : (zdit, zdjt, zdkt) at both jk and jk+1
+ !!======================================================================
+ !
+ IF( jk == 1 ) THEN != surface level =! compute level 1 and 2
+ !
+ ik = 0 ; ikp1 = 1 ! ik-index initialisation
+ !
+ DO_2D( INN+1, INN , INN+1, INN )
+ zdit(ji,jj,ik ) = ( pt_in(ji+1,jj,jk ,jn,Kbb) - pt_in(ji,jj,jk ,jn,Kbb) ) * umask(ji,jj,jk )
+ zdit(ji,jj,ikp1) = ( pt_in(ji+1,jj,jk+1,jn,Kbb) - pt_in(ji,jj,jk+1,jn,Kbb) ) * umask(ji,jj,jk+1)
+ !
+ zdjt(ji,jj,ik ) = ( pt_in(ji,jj+1,jk ,jn,Kbb) - pt_in(ji,jj,jk ,jn,Kbb) ) * vmask(ji,jj,jk )
+ zdjt(ji,jj,ikp1) = ( pt_in(ji,jj+1,jk+1,jn,Kbb) - pt_in(ji,jj,jk+1,jn,Kbb) ) * vmask(ji,jj,jk+1)
+ END_2D
+ !
+ DO_2D( INN+1, INN+1, INN+1, INN+1 )
+ zdkt(ji,jj,ik ) = 0._wp ! level 1 (=0)
+ zdkt(ji,jj,ikp1) = ( pt_in(ji,jj,jk,jn,Kbb) - pt_in(ji,jj,jk+1,jn,Kbb) ) * wmask(ji,jj,jk+1) ! level 2
+ END_2D
+ !
+ ELSEIF( 2 <= jk .AND. jk <= jpk-2 ) THEN != deeper level =! compute level jk+1 only
+ !
+ iis = ik ; ik = ikp1 ; ikp1 = iis ! swap ik-index
+ !
+ DO_2D( INN+1, INN , INN+1, INN )
+ zdit(ji,jj,ikp1) = ( pt_in(ji+1,jj ,jk+1,jn,Kbb) - pt_in(ji,jj,jk+1,jn,Kbb) ) * umask(ji,jj,jk+1)
+ zdjt(ji,jj,ikp1) = ( pt_in(ji ,jj+1,jk+1,jn,Kbb) - pt_in(ji,jj,jk+1,jn,Kbb) ) * vmask(ji,jj,jk+1)
+ END_2D
+ DO_2D( INN+1, INN+1, INN+1, INN+1 )
+ zdkt(ji,jj,ikp1) = ( pt_in(ji,jj,jk,jn,Kbb) - pt_in(ji,jj,jk+1,jn,Kbb) ) * wmask(ji,jj,jk+1) ! w-level jk+1
+ END_2D
+ !
+ ELSEIF( jk == jpkm1 ) THEN != jpk-1 level =! zdit, zdjt not used ; zdkt(jpk) always 0 as wmask(jpk)=0
+ !
+ iis = ik ; ik = ikp1 ; ikp1 = iis ! swap ik-index
+ !
+ DO_2D( INN+1, INN+1, INN+1, INN+1 )
+ zdkt(ji,jj,ikp1) = 0._wp ! w-level jpk
+ END_2D
+ ENDIF
+ !
+ !!----------------------------------------------------------------------
+ ! ( A11 0 A13 )
+ ! rotation matrix A = ( 0 A22 A23 )
+ ! ( A31 A32 A33 )
+ !!----------------------------------------------------------------------
+
+ !!======================================================================
+ !! HORIZONTAL iso-neutral fluxes
+ !!======================================================================
+ ! CAUTION: round brackets are required for halo size and north fold compatibility
+ !
+ DO_2D( INN+1, INN , INN+1, INN ) !== Horizontal fluxes ==! used elements: ( A11 - A13 )
+ ! ( - A22 A23 )
+ !
+ zA11 = e2_e1u(ji,jj) * e3u(ji,jj,jk,Kmm)
+ zA22 = e1_e2v(ji,jj) * e3v(ji,jj,jk,Kmm)
+ !
+ zmsku = 1._wp / MAX( ( wmask(ji+1,jj,jk ) + wmask(ji,jj,jk+1) ) &
+ & + ( wmask(ji+1,jj,jk+1) + wmask(ji,jj,jk ) ) , 1._wp )
+ zmskv = 1._wp / MAX( ( wmask(ji,jj+1,jk ) + wmask(ji,jj,jk+1) ) &
+ & + ( wmask(ji,jj+1,jk+1) + wmask(ji,jj,jk ) ) , 1._wp )
+ !
+ zA13 = - e2u(ji,jj) * uslp(ji,jj,jk) * zmsku
+ zA23 = - e1v(ji,jj) * vslp(ji,jj,jk) * zmskv
+ !
+ zfu(ji,jj) = ahtu(ji,jj,jk) & ! u-masked
+ & * ( zA11 * zdit(ji,jj,ik) + zA13 * ( ( zdkt(ji+1,jj,ik ) + zdkt(ji,jj,ikp1) ) &
+ & + ( zdkt(ji+1,jj,ikp1) + zdkt(ji,jj,ik ) ) ) )
+ zfv(ji,jj) = ahtv(ji,jj,jk) & ! v-masked
+ & * ( zA22 * zdjt(ji,jj,ik) + zA23 * ( ( zdkt(ji,jj+1,ik ) + zdkt(ji,jj,ikp1) ) &
+ & + ( zdkt(ji,jj+1,ikp1) + zdkt(ji,jj,ik ) ) ) )
+ END_2D
+!!gm
+!!gm OPTIM??? also verify the usage of akz ah_wslp2 in trazdf !!!
+!!gm
+ !
+ !!======================================================================
+ !! VERTICAL iso-neutral fluxes and 3D DIVERGENCE of fluxes
+ !!======================================================================
+ ! CAUTION: round brackets are required for halo size and north fold compatibility
+ !
+ ! used elements : ( A31 A32 explicit part of A33 ) (ln_traldf_msc=F ==> ah_wslp2 = akz : full explicit)
+ !
+ IF( jk ==1 ) zfw(T2D(INN)) = 0._wp ! set surface vertical flux to zero
+ !
+ IF( 1 <= jk .AND. jk <= jpk-2 ) THEN ! ocean level except the deepest one (jpkm1)
+ !
+ DO_2D( INN, INN, INN, INN )
+ ! !== Vertical fluxes at jpk+1 ==! used elements: ( A31 A32 and explicit part of A33 )
+ !
+ zmsku = wmask(ji,jj,jk) / MAX( ( umask(ji ,jj,jk) + umask(ji-1,jj,jk+1) ) &
+ & + ( umask(ji-1,jj,jk) + umask(ji ,jj,jk+1) ) , 1._wp )
+ zmskv = wmask(ji,jj,jk) / MAX( ( vmask(ji,jj ,jk) + vmask(ji,jj-1,jk+1) ) &
+ & + ( vmask(ji,jj-1,jk) + vmask(ji,jj ,jk+1) ) , 1._wp )
+ !
+ zahu_w = ( ( ahtu(ji ,jj,jk) + ahtu(ji-1,jj,jk+1) ) &
+ & + ( ahtu(ji-1,jj,jk) + ahtu(ji ,jj,jk+1) ) ) * zmsku
+ zahv_w = ( ( ahtv(ji,jj ,jk) + ahtv(ji,jj-1,jk+1) ) &
+ & + ( ahtv(ji,jj-1,jk) + ahtv(ji,jj ,jk+1) ) ) * zmskv
+ !
+ zA31 = - zahu_w * e2t(ji,jj) * zmsku * wslpi(ji,jj,jk+1) ! NB: wslpi & j are already w-masked
+ zA32 = - zahv_w * e1t(ji,jj) * zmskv * wslpj(ji,jj,jk+1) ! and * zmsk for zd.t averaging
+ !
+ zfw_kp1 = zA31 * ( ( zdit(ji ,jj,ik) + zdit(ji-1,jj,ikp1) ) & ! round brackets required for halo size
+ & + ( zdit(ji-1,jj,ik) + zdit(ji ,jj,ikp1) ) ) & ! and north fold compatibility
+ & + zA32 * ( ( zdjt(ji,jj ,ik) + zdjt(ji,jj-1,ikp1) ) &
+ & + ( zdjt(ji,jj-1,ik) + zdjt(ji,jj ,ikp1) ) ) &
+ & + e1e2t(ji,jj) / e3w(ji,jj,jk+1,Kmm) * wmask(ji,jj,jk+1) & ! vertical A33 flux :
+#if defined iso_lap
+ & * ( ah_wslp2(ji,jj,jk+1) - akz(ji,jj,jk+1) ) & ! laplacian : ah_wslp2 - akz
+ & * ( pt (ji,jj,jk ,jn,Kbb) - pt (ji,jj,jk+1,jn,Kbb) ) ! NB = 0 if ln_traldf_msc=F
+#elif defined iso_blp_p1
+ & * ah_wslp2(ji,jj,jk+1) & ! bilaplacian, 1st pass: ah_wslp2
+ & * ( pt (ji,jj,jk ,jn,Kbb) - pt (ji,jj,jk+1,jn,Kbb) )
+#elif defined iso_blp_p2
+ ! ! bilaplacian, 2nd pass:
+ & * ( ah_wslp2(ji,jj,jk+1) * ( pt (ji,jj,jk,jn,Kbb) - pt (ji,jj,jk+1,jn,Kbb) ) & ! ah_wslp2 on pt
+ & + akz(ji,jj,jk+1) * ( pt_in(ji,jj,jk,jn,Kbb) - pt_in(ji,jj,jk+1,jn,Kbb) ) ) ! akz on pt in
+#endif
+ ! !== Divergence of vertical fluxes ==!
+#if defined iso_lap
+ pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) + & ! added to RHS with PLUS sign (lap)
+#elif defined iso_blp_p1
+ zlap(ji,jj,jk) = & ! store in zlap
+#elif defined iso_blp_p2
+ pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) - & ! added to RHS with MINUS sign (blp)
+#endif
+ & ( ( zfu(ji,jj) - zfu(ji-1,jj) ) &
+ & + ( zfv(ji,jj) - zfv(ji,jj-1) ) &
+ & + ( zfw(ji,jj) - zfw_kp1 ) ) &
+ & * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm)
+ !
+ zfw(ji,jj) = zfw_kp1 !== Store zfw for next level calculation ==!
+ !
+ END_2D
+ !
+ ELSEIF( jk == jpkm1 ) THEN ! level jpkm1 (zfw_kp1 at jpk always zero)
+ !
+ DO_2D( INN, INN, INN, INN )
+#if defined iso_lap
+ pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) + & ! added to RHS with PLUS sign (lap)
+#elif defined iso_blp_p1
+ zlap(ji,jj,jk) = & ! store in zlap
+#elif defined iso_blp_p2
+ pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) - & ! added to RHS with MINUS sign (blp)
+#endif
+ & ( ( zfu(ji,jj) - zfu(ji-1,jj) ) &
+ & + ( zfv(ji,jj) - zfv(ji,jj-1) ) &
+ & + ( zfw(ji,jj) ) ) &
+ & * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm)
+ END_2D
+ !
+ ENDIF
+ !
+
+!!gm note for futur improvements :
+!
+!!gm suggestion or more compact writing for a 3 time duplicated part
+!
+! ! ! averaging of u- and v-point values at w-point (i-k and j-k averaging)
+! ! ! NB: round brackets required for halo size and north fold compatibility
+! define Au_2_w(A3D,k) ( ( A3D(ji ,jj,k) + A3D(ji-1,jj,k+1) ) & \
+! & + ( A3D(ji-1,jj,k) + A3D(ji ,jj,k+1) ) )
+! define Av_2_w(A3D,k) ( ( A3D(ji,jj ,k) + A3D(ji,jj-1,k+1) ) & \
+! & + ( A3D(ji,jj-1,k) + A3D(ji,jj ,k+1) ) )
+!! then :
+! zmsku = wmask(ji,jj,jk) / MAX( Au_2_w( umask, k ) , 1._wp )
+! zmskv = wmask(ji,jj,jk) / MAX( Av_2_w( vmask, k ) , 1._wp )
+! zahu_w = Au_2_w( ahtu, k ) * zmsku
+! zahv_w = Av_2_w( ahtv, k ) * zmskv
+! zA31 = - zahu_w * e2t(ji,jj) * zmsku * wslpi(ji,jj,jk+1) ! NB: wslpi & j are already w-masked
+! zA32 = - zahv_w * e1t(ji,jj) * zmskv * wslpj(ji,jj,jk+1)
+! !
+! ztfw_kp1 = zA31 * Au_2_w( zdit, 0 ) & ! 3rd indice is ik,ikp1 ==>> 0 in argument
+! & + zA32 * Aw_2_v( zdjt, 0 ) &
+! !
+!!gm end
\ No newline at end of file
diff --git a/src/OCE/TRA/traldf_lap_blp.F90 b/src/OCE/TRA/traldf_lap_blp.F90
deleted file mode 100644
index 16e5df16cdfb7ca8c542f8fc40d6061a84979c13..0000000000000000000000000000000000000000
--- a/src/OCE/TRA/traldf_lap_blp.F90
+++ /dev/null
@@ -1,260 +0,0 @@
-MODULE traldf_lap_blp
- !!==============================================================================
- !! *** MODULE traldf_lap_blp ***
- !! Ocean tracers: lateral diffusivity trend (laplacian and bilaplacian)
- !!==============================================================================
- !! History : 3.7 ! 2014-01 (G. Madec, S. Masson) Original code, re-entrant laplacian
- !!----------------------------------------------------------------------
-
- !!----------------------------------------------------------------------
- !! tra_ldf_lap : tracer trend update with iso-level laplacian diffusive operator
- !! tra_ldf_blp : tracer trend update with iso-level or iso-neutral bilaplacian operator
- !!----------------------------------------------------------------------
- USE oce ! ocean dynamics and active tracers
- USE dom_oce ! ocean space and time domain
- USE domutl, ONLY : is_tile
- USE ldftra ! lateral physics: eddy diffusivity
- USE traldf_iso ! iso-neutral lateral diffusion (standard operator) (tra_ldf_iso routine)
- USE traldf_triad ! iso-neutral lateral diffusion (triad operator) (tra_ldf_triad routine)
- USE diaptr ! poleward transport diagnostics
- USE diaar5 ! AR5 diagnostics
- USE trc_oce ! share passive tracers/Ocean variables
- USE zpshde ! partial step: hor. derivative (zps_hde routine)
- !
- USE in_out_manager ! I/O manager
- USE iom ! I/O library
- USE lbclnk ! ocean lateral boundary conditions (or mpp link)
- USE lib_mpp ! distribued memory computing library
- USE timing ! Timing
-
- IMPLICIT NONE
- PRIVATE
-
- PUBLIC tra_ldf_lap ! called by traldf.F90
- PUBLIC tra_ldf_blp ! called by traldf.F90
-
- LOGICAL :: l_ptr ! flag to compute poleward transport
- LOGICAL :: l_hst ! flag to compute heat transport
-
- !! * Substitutions
-# include "do_loop_substitute.h90"
-# include "domzgr_substitute.h90"
- !!----------------------------------------------------------------------
- !! NEMO/OCE 4.0 , NEMO Consortium (2018)
- !! $Id: traldf_lap_blp.F90 14834 2021-05-11 09:24:44Z hadcv $
- !! Software governed by the CeCILL license (see ./LICENSE)
- !!----------------------------------------------------------------------
-CONTAINS
-
- SUBROUTINE tra_ldf_lap( kt, Kmm, kit000, cdtype, pahu, pahv, &
- & pgu , pgv , pgui, pgvi, &
- & pt, pt_rhs, kjpt, kpass )
- !!
- INTEGER , INTENT(in ) :: kt ! ocean time-step index
- INTEGER , INTENT(in ) :: kit000 ! first time step index
- CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator)
- INTEGER , INTENT(in ) :: kjpt ! number of tracers
- INTEGER , INTENT(in ) :: kpass ! =1/2 first or second passage
- INTEGER , INTENT(in ) :: Kmm ! ocean time level index
- REAL(wp), DIMENSION(:,:,:) , INTENT(in ) :: pahu, pahv ! eddy diffusivity at u- and v-points [m2/s]
- REAL(wp), DIMENSION(:,:,:) , INTENT(in ) :: pgu, pgv ! tracer gradient at pstep levels
- REAL(wp), DIMENSION(:,:,:) , INTENT(in ) :: pgui, pgvi ! tracer gradient at top levels
- REAL(wp), DIMENSION(:,:,:,:), INTENT(in ) :: pt ! before tracer fields
- REAL(wp), DIMENSION(:,:,:,:), INTENT(inout) :: pt_rhs ! tracer trend
- !!
- CALL tra_ldf_lap_t( kt, Kmm, kit000, cdtype, pahu, pahv, is_tile(pahu), &
- & pgu , pgv , is_tile(pgu) , pgui, pgvi, is_tile(pgui), &
- & pt, is_tile(pt), pt_rhs, is_tile(pt_rhs), kjpt, kpass )
- END SUBROUTINE tra_ldf_lap
-
-
- SUBROUTINE tra_ldf_lap_t( kt, Kmm, kit000, cdtype, pahu, pahv, ktah, &
- & pgu , pgv , ktg , pgui, pgvi, ktgi, &
- & pt, ktt, pt_rhs, ktt_rhs, kjpt, kpass )
- !!----------------------------------------------------------------------
- !! *** ROUTINE tra_ldf_lap ***
- !!
- !! ** Purpose : Compute the before horizontal tracer (t & s) diffusive
- !! trend and add it to the general trend of tracer equation.
- !!
- !! ** Method : Second order diffusive operator evaluated using before
- !! fields (forward time scheme). The horizontal diffusive trends of
- !! the tracer is given by:
- !! difft = 1/(e1e2t*e3t) { di-1[ pahu e2u*e3u/e1u di(tb) ]
- !! + dj-1[ pahv e1v*e3v/e2v dj(tb) ] }
- !! Add this trend to the general tracer trend pt_rhs :
- !! pt_rhs = pt_rhs + difft
- !!
- !! ** Action : - Update pt_rhs arrays with the before iso-level
- !! harmonic mixing trend.
- !!----------------------------------------------------------------------
- INTEGER , INTENT(in ) :: kt ! ocean time-step index
- INTEGER , INTENT(in ) :: kit000 ! first time step index
- CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator)
- INTEGER , INTENT(in ) :: kjpt ! number of tracers
- INTEGER , INTENT(in ) :: kpass ! =1/2 first or second passage
- INTEGER , INTENT(in ) :: Kmm ! ocean time level index
- INTEGER , INTENT(in ) :: ktah, ktg, ktgi, ktt, ktt_rhs
- REAL(wp), DIMENSION(A2D_T(ktah), JPK) , INTENT(in ) :: pahu, pahv ! eddy diffusivity at u- and v-points [m2/s]
- REAL(wp), DIMENSION(A2D_T(ktg), KJPT), INTENT(in ) :: pgu, pgv ! tracer gradient at pstep levels
- REAL(wp), DIMENSION(A2D_T(ktgi), KJPT), INTENT(in ) :: pgui, pgvi ! tracer gradient at top levels
- REAL(wp), DIMENSION(A2D_T(ktt), JPK,KJPT), INTENT(in ) :: pt ! before tracer fields
- REAL(wp), DIMENSION(A2D_T(ktt_rhs),JPK,KJPT), INTENT(inout) :: pt_rhs ! tracer trend
- !
- INTEGER :: ji, jj, jk, jn ! dummy loop indices
- INTEGER :: iij
- REAL(wp) :: zsign ! local scalars
- REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: ztu, ztv, zaheeu, zaheev
- !!----------------------------------------------------------------------
- !
- IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile
- IF( kt == nit000 .AND. lwp ) THEN
- WRITE(numout,*)
- WRITE(numout,*) 'tra_ldf_lap : iso-level laplacian diffusion on ', cdtype, ', pass=', kpass
- WRITE(numout,*) '~~~~~~~~~~~ '
- ENDIF
- !
- l_hst = .FALSE.
- l_ptr = .FALSE.
- IF( cdtype == 'TRA' .AND. ( iom_use( 'sophtldf' ) .OR. iom_use( 'sopstldf' ) ) ) l_ptr = .TRUE.
- IF( cdtype == 'TRA' .AND. ( iom_use("uadv_heattr") .OR. iom_use("vadv_heattr") .OR. &
- & iom_use("uadv_salttr") .OR. iom_use("vadv_salttr") ) ) l_hst = .TRUE.
- ENDIF
- !
- ! Define pt_rhs halo points for multi-point haloes in bilaplacian case
- IF( nldf_tra == np_blp .AND. kpass == 1 ) THEN ; iij = nn_hls
- ELSE ; iij = 1
- ENDIF
-
- ! !== Initialization of metric arrays used for all tracers ==!
- IF( kpass == 1 ) THEN ; zsign = 1._wp ! bilaplacian operator require a minus sign (eddy diffusivity >0)
- ELSE ; zsign = -1._wp
- ENDIF
-
- DO_3D( iij, iij-1, iij, iij-1, 1, jpkm1 ) !== First derivative (gradient) ==!
- zaheeu(ji,jj,jk) = zsign * pahu(ji,jj,jk) * e2_e1u(ji,jj) * e3u(ji,jj,jk,Kmm) !!gm * umask(ji,jj,jk) pah masked!
- zaheev(ji,jj,jk) = zsign * pahv(ji,jj,jk) * e1_e2v(ji,jj) * e3v(ji,jj,jk,Kmm) !!gm * vmask(ji,jj,jk)
- END_3D
- !
- ! ! =========== !
- DO jn = 1, kjpt ! tracer loop !
- ! ! =========== !
- !
- DO_3D( iij, iij-1, iij, iij-1, 1, jpkm1 ) !== First derivative (gradient) ==!
- ztu(ji,jj,jk) = zaheeu(ji,jj,jk) * ( pt(ji+1,jj ,jk,jn) - pt(ji,jj,jk,jn) )
- ztv(ji,jj,jk) = zaheev(ji,jj,jk) * ( pt(ji ,jj+1,jk,jn) - pt(ji,jj,jk,jn) )
- END_3D
- IF( ln_zps ) THEN ! set gradient at bottom/top ocean level
- DO_2D( iij, iij-1, iij, iij-1 ) ! bottom
- ztu(ji,jj,mbku(ji,jj)) = zaheeu(ji,jj,mbku(ji,jj)) * pgu(ji,jj,jn)
- ztv(ji,jj,mbkv(ji,jj)) = zaheev(ji,jj,mbkv(ji,jj)) * pgv(ji,jj,jn)
- END_2D
- IF( ln_isfcav ) THEN ! top in ocean cavities only
- DO_2D( iij, iij-1, iij, iij-1 )
- IF( miku(ji,jj) > 1 ) ztu(ji,jj,miku(ji,jj)) = zaheeu(ji,jj,miku(ji,jj)) * pgui(ji,jj,jn)
- IF( mikv(ji,jj) > 1 ) ztv(ji,jj,mikv(ji,jj)) = zaheev(ji,jj,mikv(ji,jj)) * pgvi(ji,jj,jn)
- END_2D
- ENDIF
- ENDIF
- !
- DO_3D( iij-1, iij-1, iij-1, iij-1, 1, jpkm1 ) !== Second derivative (divergence) added to the general tracer trends ==!
- ! round brackets added to fix the order of floating point operations
- ! needed to ensure halo 1 - halo 2 compatibility
- pt_rhs(ji,jj,jk,jn) = pt_rhs(ji,jj,jk,jn) + ( ( ztu(ji,jj,jk) - ztu(ji-1,jj,jk) &
- & ) & ! bracket for halo 1 - halo 2 compatibility
- & + ( ztv(ji,jj,jk) - ztv(ji,jj-1,jk) &
- & ) & ! bracket for halo 1 - halo 2 compatibility
- & ) / ( e1e2t(ji,jj) * e3t(ji,jj,jk,Kmm) )
- END_3D
- !
- ! !== "Poleward" diffusive heat or salt transports ==!
- IF( ( kpass == 1 .AND. .NOT.ln_traldf_blp ) .OR. & !== first pass only ( laplacian) ==!
- ( kpass == 2 .AND. ln_traldf_blp ) ) THEN !== 2nd pass only (bilaplacian) ==!
-
- IF( l_ptr ) CALL dia_ptr_hst( jn, 'ldf', -ztv(:,:,:) )
- IF( l_hst ) CALL dia_ar5_hst( jn, 'ldf', -ztu(:,:,:), -ztv(:,:,:) )
- ENDIF
- ! ! ==================
- END DO ! end of tracer loop
- ! ! ==================
- !
- END SUBROUTINE tra_ldf_lap_t
-
-
- SUBROUTINE tra_ldf_blp( kt, Kmm, kit000, cdtype, pahu, pahv , &
- & pgu , pgv , pgui, pgvi, &
- & pt , pt_rhs, kjpt, kldf )
- !!----------------------------------------------------------------------
- !! *** ROUTINE tra_ldf_blp ***
- !!
- !! ** Purpose : Compute the before lateral tracer diffusive
- !! trend and add it to the general trend of tracer equation.
- !!
- !! ** Method : The lateral diffusive trends is provided by a bilaplacian
- !! operator applied to before field (forward in time).
- !! It is computed by two successive calls to laplacian routine
- !!
- !! ** Action : pta updated with the before rotated bilaplacian diffusion
- !!----------------------------------------------------------------------
- INTEGER , INTENT(in ) :: kt ! ocean time-step index
- INTEGER , INTENT(in ) :: kit000 ! first time step index
- CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator)
- INTEGER , INTENT(in ) :: kjpt ! number of tracers
- INTEGER , INTENT(in ) :: kldf ! type of operator used
- INTEGER , INTENT(in ) :: Kmm ! ocean time level indices
- REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT(in ) :: pahu, pahv ! eddy diffusivity at u- and v-points [m2/s]
- REAL(wp), DIMENSION(jpi,jpj ,kjpt), INTENT(in ) :: pgu, pgv ! tracer gradient at pstep levels
- REAL(wp), DIMENSION(jpi,jpj, kjpt), INTENT(in ) :: pgui, pgvi ! tracer gradient at top levels
- REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in ) :: pt ! before and now tracer fields
- REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) :: pt_rhs ! tracer trend
- !
- INTEGER :: ji, jj, jk, jn ! dummy loop indices
- REAL(wp), DIMENSION(A2D(nn_hls),jpk,kjpt) :: zlap ! laplacian at t-point
- REAL(wp), DIMENSION(A2D(nn_hls), kjpt) :: zglu, zglv ! bottom GRADh of the laplacian (u- and v-points)
- REAL(wp), DIMENSION(A2D(nn_hls), kjpt) :: zgui, zgvi ! top GRADh of the laplacian (u- and v-points)
- !!---------------------------------------------------------------------
- !
- IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile
- IF( kt == kit000 .AND. lwp ) THEN
- WRITE(numout,*)
- SELECT CASE ( kldf )
- CASE ( np_blp ) ; WRITE(numout,*) 'tra_ldf_blp : iso-level bilaplacian operator on ', cdtype
- CASE ( np_blp_i ) ; WRITE(numout,*) 'tra_ldf_blp : iso-neutral bilaplacian operator on ', cdtype, ' (Standard)'
- CASE ( np_blp_it ) ; WRITE(numout,*) 'tra_ldf_blp : iso-neutral bilaplacian operator on ', cdtype, ' (triad)'
- END SELECT
- WRITE(numout,*) '~~~~~~~~~~~'
- ENDIF
- ENDIF
-
- zlap(:,:,:,:) = 0._wp
- !
- SELECT CASE ( kldf ) !== 1st laplacian applied to pt (output in zlap) ==!
- !
- CASE ( np_blp ) ! iso-level bilaplacian
- CALL tra_ldf_lap ( kt, Kmm, kit000, cdtype, pahu, pahv, pgu, pgv, pgui, pgvi, pt, zlap, kjpt, 1 )
- CASE ( np_blp_i ) ! rotated bilaplacian : standard operator (Madec)
- CALL tra_ldf_iso ( kt, Kmm, kit000, cdtype, pahu, pahv, pgu, pgv, pgui, pgvi, pt, pt, zlap, kjpt, 1 )
- CASE ( np_blp_it ) ! rotated bilaplacian : triad operator (griffies)
- CALL tra_ldf_triad( kt, Kmm, kit000, cdtype, pahu, pahv, pgu, pgv, pgui, pgvi, pt, pt, zlap, kjpt, 1 )
- END SELECT
- !
- IF (nn_hls==1) CALL lbc_lnk( 'traldf_lap_blp', zlap(:,:,:,:) , 'T', 1.0_wp ) ! Lateral boundary conditions (unchanged sign)
- ! ! Partial top/bottom cell: GRADh( zlap )
- IF( ln_isfcav .AND. ln_zps ) THEN ; CALL zps_hde_isf( kt, kjpt, zlap, zglu, zglv, zgui, zgvi ) ! both top & bottom
- ELSEIF( ln_zps ) THEN ; CALL zps_hde ( kt, kjpt, zlap, zglu, zglv ) ! only bottom
- ENDIF
- !
- SELECT CASE ( kldf ) !== 2nd laplacian applied to zlap (output in pt_rhs) ==!
- !
- CASE ( np_blp ) ! iso-level bilaplacian
- CALL tra_ldf_lap ( kt, Kmm, kit000, cdtype, pahu, pahv, zglu, zglv, zgui, zgvi, zlap, pt_rhs, kjpt, 2 )
- CASE ( np_blp_i ) ! rotated bilaplacian : standard operator (Madec)
- CALL tra_ldf_iso ( kt, Kmm, kit000, cdtype, pahu, pahv, zglu, zglv, zgui, zgvi, zlap, pt , pt_rhs, kjpt, 2 )
- CASE ( np_blp_it ) ! rotated bilaplacian : triad operator (griffies)
- CALL tra_ldf_triad( kt, Kmm, kit000, cdtype, pahu, pahv, zglu, zglv, zgui, zgvi, zlap, pt , pt_rhs, kjpt, 2 )
- END SELECT
- !
- END SUBROUTINE tra_ldf_blp
-
- !!==============================================================================
-END MODULE traldf_lap_blp
diff --git a/src/OCE/TRA/traldf_lev.F90 b/src/OCE/TRA/traldf_lev.F90
new file mode 100644
index 0000000000000000000000000000000000000000..3d554e33394629b4f69bbdfcc89af8110f4f03ff
--- /dev/null
+++ b/src/OCE/TRA/traldf_lev.F90
@@ -0,0 +1,253 @@
+MODULE traldf_lev
+ !!==============================================================================
+ !! *** MODULE traldf_lev ***
+ !! Ocean tracers: iso-level diffusive tracer trend (laplacian and bilaplacian)
+ !!==============================================================================
+ !! History : 3.7 ! 2014-01 (G. Madec, S. Masson) Original code, re-entrant laplacian (traldf_lap_blp module)
+ !! 4.5 ! 2022-06 (S. Techene, G, Madec) refactorization to reduce local memory usage
+ !! ! + removal of old partial-step treatment
+ !!----------------------------------------------------------------------
+
+ !!----------------------------------------------------------------------
+ !! traldf_lev_lap : tracer trend update using an iso-level laplacian diffusive operator
+ !! traldf_lev_blp : - - - - an iso-level bilaplacian - -
+ !!----------------------------------------------------------------------
+ USE oce ! ocean dynamics and active tracers
+ USE dom_oce ! ocean space and time domain
+ USE domutl , ONLY : is_tile
+ USE ldftra , ONLY : ahtu, ahtv ! lateral physics: eddy diffusivity coefficients
+ USE diaptr ! poleward transport diagnostics
+ USE diaar5 ! AR5 diagnostics
+!!gm this is useless I guess since trc is passed in argument with pt
+! USE trc_oce ! share passive tracers/Ocean variables
+!!gm end
+ !
+ USE in_out_manager ! I/O manager
+!!gm USE iom ! I/O library
+!!gm USE lbclnk ! ocean lateral boundary conditions (or mpp link)
+!!gm USE lib_mpp ! distribued memory computing library
+!!gm USE timing ! Timing
+
+ IMPLICIT NONE
+ PRIVATE
+
+ PUBLIC traldf_lev_lap ! called by traldf.F90
+ PUBLIC traldf_lev_blp ! called by traldf.F90
+
+ !! * Substitutions
+# include "do_loop_substitute.h90"
+# include "domzgr_substitute.h90"
+ !!----------------------------------------------------------------------
+ !! NEMO/OCE 4.0 , NEMO Consortium (2018)
+ !! $Id: traldf_lap_blp.F90 14834 2021-05-11 09:24:44Z hadcv $
+ !! Software governed by the CeCILL license (see ./LICENSE)
+ !!----------------------------------------------------------------------
+CONTAINS
+
+ SUBROUTINE traldf_lev_lap( kt, Kbb, Kmm, pt, Krhs, ld_ptr, ld_hst )
+ !!----------------------------------------------------------------------
+ !! *** ROUTINE tra_ldf_lap ***
+ !!
+ !! ** Purpose : Compute the before horizontal tracer (t & s) diffusive
+ !! trend and add it to the general trend of tracer equation.
+ !!
+ !! ** Method : iso-level laplacian diffusive operator evaluated using
+ !! Kbb fields (forward time integration). The horizontal diffusive
+ !! trends of the tracer is given by:
+ !! difft = 1/(e1e2t*e3t_Kmm) { di-1[ ahtu e2u*e3u_Kmm/e1u di(t(Kbb)) ]
+ !! + dj-1[ ahtv e1v*e3v_Kmm/e2v dj(t(Kbb)) ] }
+ !! Add this trend to the general tracer trend pt_rhs :
+ !! pt_rhs = pt_rhs + difft
+ !!
+ !! ** Action : pt(Krhs) increased by the laplacian diffusive trend
+ !!----------------------------------------------------------------------
+ INTEGER , INTENT(in ) :: kt, Kbb, Kmm, Krhs ! ocean time-step and time-level indices
+ LOGICAL , OPTIONAL , INTENT(in ) :: ld_hst, ld_ptr ! T-S diagnostic flags
+ REAL(wp), DIMENSION(:,:,:,:,:), INTENT(inout) :: pt ! tracers, in: at kbb ; out: at Krhs
+ !
+ INTEGER :: ji, jj, jk, jn ! dummy loop indices
+ INTEGER :: itra ! number of tracers
+ REAL(wp) :: zaheeu, zaheev ! local scalar
+ REAL(wp), DIMENSION(T2D(1)) :: zfu, zfv
+!!gm ld_ptr,ld_hst: require changes in the dia_ptr/dia_ar5 <<<=== comment for the moment
+! REAL(wp), DIMENSION(:,:), ALLOCATABLE :: zdia_i , zdia_j ! used for some diagnostics
+!!!gm end
+ REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zdia_i , zdia_j
+ !!----------------------------------------------------------------------
+ !
+!!gm ld_ptr,ld_hst: require changes in the dia_ptr/dia_ar5 <<<=== comment for the moment
+! and to be duplicated in traldf_lev_blp (2nd pass only)
+! IF( ld_ptr .OR. ld_hst ) THEN
+! ALLOCATE( zdia_i(A2D(0)) , zdia_j(A2D(0)) )
+! ENDIF
+ !!gm end
+ IF( PRESENT(ld_ptr) .OR. PRESENT(ld_hst) ) THEN
+ IF( ld_ptr .OR. ld_hst ) THEN
+ ALLOCATE( zdia_i(T2D(0),jpk) , zdia_j(T2D(0),jpk) )
+ zdia_i(:,:,jpk) = 0._wp ; zdia_j(:,:,jpk) = 0._wp
+ ENDIF
+ ENDIF
+ !
+ itra = SIZE( pt, dim=4 ) ! number of tracers
+ !
+ !
+ ! ! =========== !
+ DO jn = 1, itra ! tracer loop !
+ ! ! =========== !
+ !
+ DO jk = 1, jpkm1 ! horizontal slab
+ !
+ DO_2D( 1, 0, 1, 0 ) !- 1st derivative (masked as ahtu/v are masked)
+ zaheeu = ahtu(ji,jj,jk) * e2_e1u(ji,jj) * e3u(ji,jj,jk,Kmm)
+ zaheev = ahtv(ji,jj,jk) * e1_e2v(ji,jj) * e3v(ji,jj,jk,Kmm)
+ zfu(ji,jj) = zaheeu * ( pt(ji+1,jj ,jk,jn,Kbb) - pt(ji,jj,jk,jn,Kbb) )
+ zfv(ji,jj) = zaheev * ( pt(ji ,jj+1,jk,jn,Kbb) - pt(ji,jj,jk,jn,Kbb) )
+ END_2D
+ DO_2D( 0, 0, 0, 0 ) !- 2nd derivative added to the general tracer trends (with PLUS sign)
+ pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) &
+ & + ( ( zfu(ji,jj) - zfu(ji-1,jj) ) &
+ & + ( zfv(ji,jj) - zfv(ji,jj-1) ) ) &
+ & * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm)
+ END_2D
+ !
+!!gm ld_ptr,ld_hst:
+! IF( ld_ptr .OR. ld_hst ) THEN ! vertically cumulated fluxes (minus sign by convention in the output)
+! zdia_i(:,:) = zdia_i(:,:) - zfu(A2D(0))
+! zdia_j(:,:) = zdia_j(:,:) - zfv(A2D(0))
+! ENDIF
+ !!gm end
+ IF( PRESENT(ld_ptr) .OR. PRESENT(ld_hst) ) THEN
+ IF( ld_ptr .OR. ld_hst ) THEN ! store fluxes for diagnostics (minus sign by convention in the output)
+ zdia_i(:,:,jk) = - zfu(T2D(0))
+ zdia_j(:,:,jk) = - zfv(T2D(0))
+ ENDIF
+ ENDIF
+ !
+ END DO ! end horizontal slab
+ !
+ ! !== "Poleward" diffusive heat or salt transports ==!
+ IF( PRESENT(ld_ptr) ) THEN
+ IF( ld_ptr ) CALL dia_ptr_hst( jn, 'ldf' , zdia_j )
+ ENDIF
+ IF( PRESENT(ld_hst) ) THEN
+ IF( ld_hst ) CALL dia_ar5_hst( jn, 'ldf', zdia_i, zdia_j )
+ ENDIF
+ !
+ ! ! ==================
+ END DO ! end of tracer loop
+ ! ! ==================
+ !
+ END SUBROUTINE traldf_lev_lap
+
+
+ SUBROUTINE traldf_lev_blp( kt, Kbb, Kmm, pt, Krhs, ld_ptr, ld_hst )
+ !!----------------------------------------------------------------------
+ !! *** ROUTINE tra_ldf_blp ***
+ !!
+ !! nn_hls >= 2
+ !!
+ !! NO use of zps_hde ==>> New HPG calculation
+ !! ** *******
+ !!
+ !!
+ !! ** Purpose : Compute the before lateral tracer diffusive
+ !! trend and add it to the general trend of tracer equation.
+ !!
+ !! ** Method : The lateral diffusive trends is provided by a bilaplacian
+ !! iso-level operator applied to pt(Kbb) (forward time integration).
+ !!
+ !! ** Action : pt(Krhs) increased by the bilaplacian diffusive trend
+ !!----------------------------------------------------------------------
+ INTEGER , INTENT(in ) :: kt, Kbb, Kmm, Krhs ! ocean time-step and time-level indices
+ LOGICAL , OPTIONAL , INTENT(in ) :: ld_hst, ld_ptr ! T-S diagnostic flags
+ REAL(wp), DIMENSION(:,:,:,:,:), INTENT(inout) :: pt ! tracers, in: at kbb ; out: at Krhs
+ !
+ INTEGER :: ji, jj, jk, jn ! dummy loop indices
+ INTEGER :: itra ! number of tracers
+ REAL(wp), DIMENSION(T2D(2)) :: zaheeu, zfu
+ REAL(wp), DIMENSION(T2D(2)) :: zaheev, zfv
+ REAL(wp), DIMENSION(T2D(1)) :: zlap ! laplacian at t-point
+!!gm ld_ptr,ld_hst: require changes in the dia_ptr/dia_ar5 <<<=== comment for the moment
+! REAL(wp), DIMENSION(:,:), ALLOCATABLE :: zdia_i , zdia_j ! used for some diagnostics
+!!!gm end
+ REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zdia_i , zdia_j
+ !!---------------------------------------------------------------------
+ !
+!!gm ld_ptr,ld_hst: require changes in the dia_ptr/dia_ar5 <<<=== comment for the moment
+! IF( ld_ptr .OR. ld_hst ) THEN
+! ALLOCATE( zdia_i(A2D(0)) , zdia_j(A2D(0)) )
+! ENDIF
+ IF( ld_ptr .OR. ld_hst ) THEN
+ ALLOCATE( zdia_i(T2D(0),jpk) , zdia_j(T2D(0),jpk) )
+ zdia_i(:,:,jpk) = 0._wp ; zdia_j(:,:,jpk) = 0._wp
+ ENDIF
+!!gm end
+ !
+ itra = SIZE( pt, dim=4 ) ! number of tracers
+ !
+ ! ! =========== !
+ DO jn = 1, itra ! tracer loop !
+ ! ! =========== !
+ !
+!!gm ld_ptr,ld_hst: require changes in the dia_ptr/dia_ar5 <<<=== comment for the moment
+! IF( ld_ptr .OR. ld_hst ) THEN
+! zdia_i(:,:) = 0._wp ; zdia_j(:,:) = 0._wp
+! ENDIF
+!!gm end
+ !
+ DO jk = 1, jpkm1 ! horizontal slab
+ !
+ DO_2D( 2, 1, 2, 1 )
+ zaheeu(ji,jj) = ahtu(ji,jj,jk) * e2_e1u(ji,jj) * e3u(ji,jj,jk,Kmm)
+ zaheev(ji,jj) = ahtv(ji,jj,jk) * e1_e2v(ji,jj) * e3v(ji,jj,jk,Kmm)
+ END_2D
+ ! !- first derivative (masked as ahtu/v are masked)
+ DO_2D( 2, 1, 2, 1 )
+ zfu(ji,jj) = zaheeu(ji,jj) * ( pt(ji+1,jj ,jk,jn,Kbb) - pt(ji,jj,jk,jn,Kbb) )
+ zfv(ji,jj) = zaheev(ji,jj) * ( pt(ji ,jj+1,jk,jn,Kbb) - pt(ji,jj,jk,jn,Kbb) )
+ END_2D
+ ! !- Second derivative (divergence) (with PLUS sign)
+ DO_2D( 1, 1, 1, 1 )
+ zlap(ji,jj) = ( ( zfu(ji,jj) - zfu(ji-1,jj) ) & ! t-masked as fluxes are u/v-masked
+ & + ( zfv(ji,jj) - zfv(ji,jj-1) ) ) &
+ & * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm)
+ END_2D
+ ! !- 3rd derivative -! (masked as ahtu/v are masked)
+ DO_2D( 1, 0, 1, 0 )
+ zfu(ji,jj) = zaheeu(ji,jj) * ( zlap(ji+1,jj ) - zlap(ji,jj) )
+ zfv(ji,jj) = zaheev(ji,jj) * ( zlap(ji ,jj+1) - zlap(ji,jj) )
+ END_2D
+ !
+ DO_2D( 0, 0, 0, 0 ) !- 4th derivative added to the general tracer trends (with MINUS sign)
+ pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) &
+ & - ( ( zfu(ji,jj) - zfu(ji-1,jj) ) &
+ & + ( zfv(ji,jj) - zfv(ji,jj-1) ) ) &
+ & * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm)
+ END_2D
+ !
+!!gm ld_ptr,ld_hst:
+! IF( ld_ptr .OR. ld_hst ) THEN ! vertically cumulated fluxes (minus sign by convention in the output)
+! zdia_i(:,:) = zdia_i(:,:) - zfu(A2D(0))
+! zdia_j(:,:) = zdia_j(:,:) - zfv(A2D(0))
+! ENDIF
+!!gm end
+ IF( ld_ptr .OR. ld_hst ) THEN ! vertically cumulated fluxes (minus sign by convention in the output)
+ zdia_i(:,:,jk) = - zfu(T2D(0))
+ zdia_j(:,:,jk) = - zfv(T2D(0))
+ ENDIF
+ !
+ END DO ! end horizontal slab
+ !
+ ! !== "Poleward" diffusive heat or salt transports ==!
+ ! !== "Poleward" diffusive heat or salt transports ==!
+ IF( ld_ptr ) CALL dia_ptr_hst( jn, 'ldf' , zdia_j )
+ IF( ld_hst ) CALL dia_ar5_hst( jn, 'ldf', zdia_i, zdia_j )
+ !
+ ! ! ==================
+ END DO ! end of tracer loop
+ ! ! ==================
+ !
+ END SUBROUTINE traldf_lev_blp
+
+ !!==============================================================================
+END MODULE traldf_lev
diff --git a/src/OCE/TRA/traldf_triad.F90 b/src/OCE/TRA/traldf_triad.F90
index 19039b88c12d763f483faede1d5fa33ec2c9a10e..09a1e3469c5c3d0de9a606e7287aab286460ad7b 100644
--- a/src/OCE/TRA/traldf_triad.F90
+++ b/src/OCE/TRA/traldf_triad.F90
@@ -12,7 +12,7 @@ MODULE traldf_triad
!!----------------------------------------------------------------------
USE oce ! ocean dynamics and active tracers
USE dom_oce ! ocean space and time domain
- USE domutl, ONLY : is_tile
+ USE domutl, ONLY : lbnd_ij
USE phycst ! physical constants
USE trc_oce ! share passive tracers/Ocean variables
USE zdf_oce ! ocean vertical physics
@@ -30,7 +30,8 @@ MODULE traldf_triad
IMPLICIT NONE
PRIVATE
- PUBLIC tra_ldf_triad ! routine called by traldf.F90
+ PUBLIC traldf_triad_lap ! routine called by traldf.F90
+ PUBLIC traldf_triad_blp ! routine called by traldf.F90
LOGICAL :: l_ptr ! flag to compute poleward transport
LOGICAL :: l_hst ! flag to compute heat transport
@@ -46,9 +47,8 @@ MODULE traldf_triad
!!----------------------------------------------------------------------
CONTAINS
- SUBROUTINE tra_ldf_triad( kt, Kmm, kit000, cdtype, pahu, pahv, &
- & pgu , pgv , pgui, pgvi, &
- & pt, pt2, pt_rhs, kjpt, kpass )
+ SUBROUTINE traldf_triad_lap( kt, Kmm, kit000, cdtype, pahu, pahv, &
+ & pt, pt2, pt_rhs, kjpt, kpass )
!!
INTEGER , INTENT(in ) :: kt ! ocean time-step index
INTEGER , INTENT(in ) :: kit000 ! first time step index
@@ -57,21 +57,17 @@ CONTAINS
INTEGER , INTENT(in ) :: kpass ! =1/2 first or second passage
INTEGER , INTENT(in ) :: Kmm ! ocean time level indices
REAL(wp), DIMENSION(:,:,:) , INTENT(in ) :: pahu, pahv ! eddy diffusivity at u- and v-points [m2/s]
- REAL(wp), DIMENSION(:,:,:) , INTENT(in ) :: pgu , pgv ! tracer gradient at pstep levels
- REAL(wp), DIMENSION(:,:,:) , INTENT(in ) :: pgui, pgvi ! tracer gradient at top levels
REAL(wp), DIMENSION(:,:,:,:), INTENT(in ) :: pt ! tracer (kpass=1) or laplacian of tracer (kpass=2)
REAL(wp), DIMENSION(:,:,:,:), INTENT(in ) :: pt2 ! tracer (only used in kpass=2)
REAL(wp), DIMENSION(:,:,:,:), INTENT(inout) :: pt_rhs ! tracer trend
!!
- CALL tra_ldf_triad_t( kt, Kmm, kit000, cdtype, pahu, pahv, is_tile(pahu), &
- & pgu , pgv , is_tile(pgu) , pgui, pgvi, is_tile(pgui), &
- & pt, is_tile(pt), pt2, is_tile(pt2), pt_rhs, is_tile(pt_rhs), kjpt, kpass )
- END SUBROUTINE tra_ldf_triad
+ CALL traldf_triad_lap_t( kt, Kmm, kit000, cdtype, pahu, pahv, lbnd_ij(pahu), &
+ & pt, lbnd_ij(pt), pt2, lbnd_ij(pt2), pt_rhs, lbnd_ij(pt_rhs), kjpt, kpass )
+ END SUBROUTINE traldf_triad_lap
- SUBROUTINE tra_ldf_triad_t( kt, Kmm, kit000, cdtype, pahu, pahv, ktah, &
- & pgu , pgv , ktg , pgui, pgvi, ktgi, &
- & pt, ktt, pt2, ktt2, pt_rhs, ktt_rhs, kjpt, kpass )
+ SUBROUTINE traldf_triad_lap_t( kt, Kmm, kit000, cdtype, pahu, pahv, ktah, &
+ & pt, ktt, pt2, ktt2, pt_rhs, ktt_rhs, kjpt, kpass )
!!----------------------------------------------------------------------
!! *** ROUTINE tra_ldf_triad ***
!!
@@ -91,19 +87,17 @@ CONTAINS
!! ah_wslp2 ....
!! akz stabilizing vertical diffusivity coefficient (used in trazdf_imp)
!!----------------------------------------------------------------------
- INTEGER , INTENT(in ) :: kt ! ocean time-step index
- INTEGER , INTENT(in ) :: kit000 ! first time step index
- CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator)
- INTEGER , INTENT(in ) :: kjpt ! number of tracers
- INTEGER , INTENT(in ) :: kpass ! =1/2 first or second passage
- INTEGER , INTENT(in) :: Kmm ! ocean time level indices
- INTEGER , INTENT(in ) :: ktah, ktg, ktgi, ktt, ktt2, ktt_rhs
- REAL(wp), DIMENSION(A2D_T(ktah), JPK) , INTENT(in ) :: pahu, pahv ! eddy diffusivity at u- and v-points [m2/s]
- REAL(wp), DIMENSION(A2D_T(ktg), KJPT), INTENT(in ) :: pgu , pgv ! tracer gradient at pstep levels
- REAL(wp), DIMENSION(A2D_T(ktgi), KJPT), INTENT(in ) :: pgui, pgvi ! tracer gradient at top levels
- REAL(wp), DIMENSION(A2D_T(ktt), JPK,KJPT), INTENT(in ) :: pt ! tracer (kpass=1) or laplacian of tracer (kpass=2)
- REAL(wp), DIMENSION(A2D_T(ktt2), JPK,KJPT), INTENT(in ) :: pt2 ! tracer (only used in kpass=2)
- REAL(wp), DIMENSION(A2D_T(ktt_rhs),JPK,KJPT), INTENT(inout) :: pt_rhs ! tracer trend
+ INTEGER , INTENT(in ) :: kt ! ocean time-step index
+ INTEGER , INTENT(in ) :: kit000 ! first time step index
+ CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator)
+ INTEGER , INTENT(in ) :: kjpt ! number of tracers
+ INTEGER , INTENT(in ) :: kpass ! =1/2 first or second passage
+ INTEGER , INTENT(in ) :: Kmm ! ocean time level indices
+ INTEGER , DIMENSION(2) , INTENT(in ) :: ktah, ktt, ktt2, ktt_rhs
+ REAL(wp), DIMENSION(AB2D(ktah), JPK) , INTENT(in ) :: pahu, pahv ! eddy diffusivity at u- and v-points [m2/s]
+ REAL(wp), DIMENSION(AB2D(ktt), JPK,KJPT), INTENT(in ) :: pt ! tracer (kpass=1) or laplacian of tracer (kpass=2)
+ REAL(wp), DIMENSION(AB2D(ktt2), JPK,KJPT), INTENT(in ) :: pt2 ! tracer (only used in kpass=2)
+ REAL(wp), DIMENSION(AB2D(ktt_rhs),JPK,KJPT), INTENT(inout) :: pt_rhs ! tracer trend
!
INTEGER :: ji, jj, jk, jn, kp, iij ! dummy loop indices
REAL(wp) :: zcoef0, ze3w_2, zsign ! - -
@@ -111,9 +105,9 @@ CONTAINS
REAL(wp) :: zslope2, zbu, zbv, zbu1, zbv1, zslope21, zah, zah1, zah_ip1, zah_jp1, zbu_ip1, zbv_jp1
REAL(wp) :: ze1ur, ze2vr, ze3wr, zdxt, zdyt, zdzt, zdyt_jp1, ze3wr_jp1, zdzt_jp1, zah_slp1, zah_slp_jp1, zaei_slp_jp1
REAL(wp) :: zah_slp, zaei_slp, zdxt_ip1, ze3wr_ip1, zdzt_ip1, zah_slp_ip1, zaei_slp_ip1, zaei_slp1
- REAL(wp), DIMENSION(A2D(nn_hls),0:1) :: zdkt3d ! vertical tracer gradient at 2 levels
- REAL(wp), DIMENSION(A2D(nn_hls) ) :: z2d ! 2D workspace
- REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zdit, zdjt, zftu, zftv, ztfw, zpsi_uw, zpsi_vw ! 3D -
+ REAL(wp), DIMENSION(T2D(nn_hls),0:1) :: zdkt3d ! vertical tracer gradient at 2 levels
+ REAL(wp), DIMENSION(T2D(nn_hls) ) :: z2d ! 2D workspace
+ REAL(wp), DIMENSION(T2D(nn_hls),jpk) :: zdit, zdjt, zftu, zftv, ztfw, zpsi_uw, zpsi_vw ! 3D -
!!----------------------------------------------------------------------
!
IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile
@@ -147,6 +141,13 @@ CONTAINS
!!----------------------------------------------------------------------
!
IF( kpass == 1 ) THEN !== first pass only and whatever the tracer is ==!
+ !
+ IF( kt /= kit000 ) THEN ! Already zeroed on first timestep in ldf_slp_init
+ DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpk )
+ akz (ji,jj,jk) = 0._wp
+ ah_wslp2(ji,jj,jk) = 0._wp
+ END_3D
+ ENDIF
!
DO kp = 0, 1 ! i-k triads
DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpkm1 )
@@ -156,18 +157,18 @@ CONTAINS
zah = 0.25_wp * pahu(ji,jj,jk)
zah1 = 0.25_wp * pahu(ji-1,jj,jk)
! Subtract s-coordinate slope at t-points to give slope rel to s-surfaces (do this by *adding* gradient of depth)
- zslope2 = triadi_g(ji,jj,jk,1,kp) + ( gdept(ji+1,jj,jk,Kmm) - gdept(ji,jj,jk,Kmm) ) * r1_e1u(ji,jj) * umask(ji,jj,jk+kp)
+ zslope2 = triadi_g(ji,jj,jk,1,kp) + ( gdept(ji+1,jj,jk,Kmm) - gdept(ji,jj,jk,Kmm) ) &
+ & * r1_e1u(ji,jj) * umask(ji,jj,jk+kp)
zslope2 = zslope2 *zslope2
- zslope21 = triadi_g(ji,jj,jk,0,kp) + ( gdept(ji,jj,jk,Kmm) - gdept(ji-1,jj,jk,Kmm) ) * r1_e1u(ji-1,jj) * umask(ji-1,jj,jk+kp)
+ zslope21 = triadi_g(ji,jj,jk,0,kp) + ( gdept(ji,jj,jk,Kmm) - gdept(ji-1,jj,jk,Kmm) ) &
+ & * r1_e1u(ji-1,jj) * umask(ji-1,jj,jk+kp)
zslope21 = zslope21 *zslope21
! round brackets added to fix the order of floating point operations
- ! needed to ensure halo 1 - halo 2 compatibility
- ah_wslp2(ji,jj,jk+kp) = ah_wslp2(ji,jj,jk+kp) + ( zah * zbu * ze3wr * r1_e1e2t(ji,jj) * zslope2 &
- & + zah1 * zbu1 * ze3wr * r1_e1e2t(ji,jj) * zslope21 &
- & ) ! bracket for halo 1 - halo 2 compatibility
- akz (ji,jj,jk+kp) = akz (ji,jj,jk+kp) + ( zah * r1_e1u(ji,jj) * r1_e1u(ji,jj) * umask(ji,jj,jk+kp) &
- + zah1 * r1_e1u(ji-1,jj) * r1_e1u(ji-1,jj) * umask(ji-1,jj,jk+kp) &
- & ) ! bracket for halo 1 - halo 2 compatibility
+ ! needed to ensure the North Pole reproducibility
+ ah_wslp2(ji,jj,jk+kp) = ah_wslp2(ji,jj,jk+kp) + ( zah * zbu * ze3wr * r1_e1e2t(ji,jj) * zslope2 & ! () for NP
+ & + zah1 * zbu1 * ze3wr * r1_e1e2t(ji,jj) * zslope21 ) ! repro
+ akz (ji,jj,jk+kp) = akz (ji,jj,jk+kp) + ( zah * r1_e1u(ji ,jj) * r1_e1u(ji ,jj) * umask(ji ,jj,jk+kp) &
+ + zah1 * r1_e1u(ji-1,jj) * r1_e1u(ji-1,jj) * umask(ji-1,jj,jk+kp) )
END_3D
END DO
!
@@ -180,18 +181,18 @@ CONTAINS
zah1 = 0.25_wp * pahv(ji,jj-1,jk)
! Subtract s-coordinate slope at t-points to give slope rel to s surfaces
! (do this by *adding* gradient of depth)
- zslope2 = triadj_g(ji,jj,jk,1,kp) + ( gdept(ji,jj+1,jk,Kmm) - gdept(ji,jj,jk,Kmm) ) * r1_e2v(ji,jj) * vmask(ji,jj,jk+kp)
+ zslope2 = triadj_g(ji,jj,jk,1,kp) + ( gdept(ji,jj+1,jk,Kmm) - gdept(ji,jj,jk,Kmm) ) &
+ & * r1_e2v(ji,jj) * vmask(ji,jj,jk+kp)
zslope2 = zslope2 * zslope2
- zslope21 = triadj_g(ji,jj,jk,0,kp) + ( gdept(ji,jj,jk,Kmm) - gdept(ji,jj-1,jk,Kmm) ) * r1_e2v(ji,jj-1) * vmask(ji,jj-1,jk+kp)
+ zslope21 = triadj_g(ji,jj,jk,0,kp) + ( gdept(ji,jj,jk,Kmm) - gdept(ji,jj-1,jk,Kmm) ) &
+ & * r1_e2v(ji,jj-1) * vmask(ji,jj-1,jk+kp)
zslope21 = zslope21 * zslope21
! round brackets added to fix the order of floating point operations
- ! needed to ensure halo 1 - halo 2 compatibility
- ah_wslp2(ji,jj,jk+kp) = ah_wslp2(ji,jj,jk+kp) + ( zah * zbv * ze3wr * r1_e1e2t(ji,jj) * zslope2 &
- & + zah1 * zbv1 * ze3wr * r1_e1e2t(ji,jj) * zslope21 &
- & ) ! bracket for halo 1 - halo 2 compatibility
- akz (ji,jj,jk+kp) = akz (ji,jj,jk+kp) + ( zah * r1_e2v(ji,jj) * r1_e2v(ji,jj) * vmask(ji,jj,jk+kp) &
- & + zah1 * r1_e2v(ji,jj-1) * r1_e2v(ji,jj-1) * vmask(ji,jj-1,jk+kp) &
- & ) ! bracket for halo 1 - halo 2 compatibility
+ ! needed to ensure the North Pole reproducibility
+ ah_wslp2(ji,jj,jk+kp) = ah_wslp2(ji,jj,jk+kp) + ( zah * zbv * ze3wr * r1_e1e2t(ji,jj) * zslope2 & ! () for NP
+ & + zah1 * zbv1 * ze3wr * r1_e1e2t(ji,jj) * zslope21 ) ! repro
+ akz (ji,jj,jk+kp) = akz (ji,jj,jk+kp) + ( zah * r1_e2v(ji,jj ) * r1_e2v(ji,jj ) * vmask(ji,jj ,jk+kp) &
+ & + zah1 * r1_e2v(ji,jj-1) * r1_e2v(ji,jj-1) * vmask(ji,jj-1,jk+kp) )
END_3D
END DO
!
@@ -225,16 +226,12 @@ CONTAINS
DO kp = 0, 1
DO_3D( 1, 0, 1, 0, 1, jpkm1 )
- ! round brackets added to fix the order of floating point operations
- ! needed to ensure halo 1 - halo 2 compatibility
- zpsi_uw(ji,jj,jk+kp) = zpsi_uw(ji,jj,jk+kp) &
- & + ( 0.25_wp * aeiu(ji,jj,jk) * e2u(ji,jj) * triadi_g(ji,jj,jk,1,kp) &
- & + 0.25_wp * aeiu(ji,jj,jk) * e2u(ji,jj) * triadi_g(ji+1,jj,jk,0,kp) &
- & ) ! bracket for halo 1 - halo 2 compatibility
- zpsi_vw(ji,jj,jk+kp) = zpsi_vw(ji,jj,jk+kp) &
- & + ( 0.25_wp * aeiv(ji,jj,jk) * e1v(ji,jj) * triadj_g(ji,jj,jk,1,kp) &
- & + 0.25_wp * aeiv(ji,jj,jk) * e1v(ji,jj) * triadj_g(ji,jj+1,jk,0,kp) &
- & ) ! bracket for halo 1 - halo 2 compatibility
+ zpsi_uw(ji,jj,jk+kp) = zpsi_uw(ji,jj,jk+kp) &
+ & + ( 0.25_wp * aeiu(ji,jj,jk) * e2u(ji,jj) * triadi_g(ji ,jj,jk,1,kp) & ! () for NP reproducibility
+ & + 0.25_wp * aeiu(ji,jj,jk) * e2u(ji,jj) * triadi_g(ji+1,jj,jk,0,kp) )
+ zpsi_vw(ji,jj,jk+kp) = zpsi_vw(ji,jj,jk+kp) & ! () for NP reproducibility
+ & + ( 0.25_wp * aeiv(ji,jj,jk) * e1v(ji,jj) * triadj_g(ji,jj ,jk,1,kp) &
+ & + 0.25_wp * aeiv(ji,jj,jk) * e1v(ji,jj) * triadj_g(ji,jj+1,jk,0,kp) )
END_3D
END DO
CALL ldf_eiv_dia( zpsi_uw, zpsi_vw, Kmm )
@@ -257,18 +254,6 @@ CONTAINS
zdit(ji,jj,jk) = ( pt(ji+1,jj ,jk,jn) - pt(ji,jj,jk,jn) ) * umask(ji,jj,jk)
zdjt(ji,jj,jk) = ( pt(ji ,jj+1,jk,jn) - pt(ji,jj,jk,jn) ) * vmask(ji,jj,jk)
END_3D
- IF( ln_zps .AND. l_grad_zps ) THEN ! partial steps: correction at top/bottom ocean level
- DO_2D( iij, iij-1, iij, iij-1 ) ! bottom level
- zdit(ji,jj,mbku(ji,jj)) = pgu(ji,jj,jn)
- zdjt(ji,jj,mbkv(ji,jj)) = pgv(ji,jj,jn)
- END_2D
- IF( ln_isfcav ) THEN ! top level (ocean cavities only)
- DO_2D( iij, iij-1, iij, iij-1 )
- IF( miku(ji,jj) > 1 ) zdit(ji,jj,miku(ji,jj) ) = pgui(ji,jj,jn)
- IF( mikv(ji,jj) > 1 ) zdjt(ji,jj,mikv(ji,jj) ) = pgvi(ji,jj,jn)
- END_2D
- ENDIF
- ENDIF
!
!!----------------------------------------------------------------------
!! II - horizontal trend (full)
@@ -440,14 +425,10 @@ CONTAINS
ENDIF
! !== horizontal divergence and add to the general trend ==!
DO_2D( iij-1, iij-1, iij-1, iij-1 )
- ! round brackets added to fix the order of floating point operations
- ! needed to ensure halo 1 - halo 2 compatibility
- pt_rhs(ji,jj,jk,jn) = pt_rhs(ji,jj,jk,jn) &
- & + zsign * ( ( zftu(ji-1,jj ,jk) - zftu(ji,jj,jk) &
- & ) & ! bracket for halo 1 - halo 2 compatibility
- & + ( zftv(ji,jj-1,jk) - zftv(ji,jj,jk) &
- & ) & ! bracket for halo 1 - halo 2 compatibility
- & ) / ( e1e2t(ji,jj) * e3t(ji,jj,jk,Kmm) )
+ pt_rhs(ji,jj,jk,jn) = pt_rhs(ji,jj,jk,jn) &
+ & + zsign * ( ( zftu(ji-1,jj ,jk) - zftu(ji,jj,jk) ) & ! () for NP reproducibility
+ & + ( zftv(ji ,jj-1,jk) - zftv(ji,jj,jk) ) ) &
+ & / ( e1e2t(ji,jj) * e3t(ji,jj,jk,Kmm) )
END_2D
!
END DO
@@ -456,7 +437,7 @@ CONTAINS
IF( ln_traldf_lap ) THEN ! laplacian case: eddy coef = ah_wslp2 - akz
DO_3D( iij-1, iij-1, iij-1, iij-1, 2, jpkm1 )
ztfw(ji,jj,jk) = ztfw(ji,jj,jk) - e1e2t(ji,jj) / e3w(ji,jj,jk,Kmm) * tmask(ji,jj,jk) &
- & * ( ah_wslp2(ji,jj,jk) - akz(ji,jj,jk) ) &
+ & * ( ah_wslp2(ji,jj,jk) - akz(ji,jj,jk) ) &
& * ( pt(ji,jj,jk-1,jn) - pt(ji,jj,jk,jn) )
END_3D
ELSE ! bilaplacian
@@ -466,9 +447,9 @@ CONTAINS
ztfw(ji,jj,jk) = ztfw(ji,jj,jk) - e1e2t(ji,jj) / e3w(ji,jj,jk,Kmm) * tmask(ji,jj,jk) &
& * ah_wslp2(ji,jj,jk) * ( pt(ji,jj,jk-1,jn) - pt(ji,jj,jk,jn) )
END_3D
- CASE( 2 ) ! 2nd pass : eddy flux = ah_wslp2 and akz applied on pt and pt2 gradients, resp.
+ CASE( 2 ) ! 2nd pass : eddy flux = ah_wslp2 and akz applied on pt and pt2 gradients, resp.
DO_3D( 0, 0, 0, 0, 2, jpkm1 )
- ztfw(ji,jj,jk) = ztfw(ji,jj,jk) - e1e2t(ji,jj) / e3w(ji,jj,jk,Kmm) * tmask(ji,jj,jk) &
+ ztfw(ji,jj,jk) = ztfw(ji,jj,jk) - e1e2t(ji,jj) / e3w(ji,jj,jk,Kmm) * tmask(ji,jj,jk) &
& * ( ah_wslp2(ji,jj,jk) * ( pt (ji,jj,jk-1,jn) - pt (ji,jj,jk,jn) ) &
& + akz (ji,jj,jk) * ( pt2(ji,jj,jk-1,jn) - pt2(ji,jj,jk,jn) ) )
END_3D
@@ -494,7 +475,55 @@ CONTAINS
! ! ===============
END DO ! end tracer loop
! ! ===============
- END SUBROUTINE tra_ldf_triad_t
+ END SUBROUTINE traldf_triad_lap_t
+
+
+ SUBROUTINE traldf_triad_blp( kt, Kmm, kit000, cdtype, pahu, pahv , &
+ & pt , pt_rhs, kjpt )
+ !!----------------------------------------------------------------------
+ !! *** ROUTINE tra_ldf_blp ***
+ !!
+ !! ** Purpose : Compute the before lateral tracer diffusive
+ !! trend and add it to the general trend of tracer equation.
+ !!
+ !! ** Method : The lateral diffusive trends is provided by a bilaplacian
+ !! operator applied to before field (forward in time).
+ !! It is computed by two successive calls to laplacian routine
+ !!
+ !! ** Action : pta updated with the before rotated bilaplacian diffusion
+ !!----------------------------------------------------------------------
+ INTEGER , INTENT(in ) :: kt ! ocean time-step index
+ INTEGER , INTENT(in ) :: kit000 ! first time step index
+ CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator)
+ INTEGER , INTENT(in ) :: kjpt ! number of tracers
+ INTEGER , INTENT(in ) :: Kmm ! ocean time level indices
+ REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT(in ) :: pahu, pahv ! eddy diffusivity at u- and v-points [m2/s]
+ REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in ) :: pt ! before and now tracer fields
+ REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) :: pt_rhs ! tracer trend
+ !
+ INTEGER :: ji, jj, jk, jn ! dummy loop indices
+ REAL(wp), DIMENSION(T2D(nn_hls),jpk,kjpt) :: zlap ! laplacian at t-point
+ !!---------------------------------------------------------------------
+ !
+ IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile
+ IF( kt == kit000 .AND. lwp ) THEN
+ WRITE(numout,*)
+ WRITE(numout,*) 'tra_ldf_blp : iso-neutral bilaplacian operator on ', cdtype, ' (triad)'
+ WRITE(numout,*) '~~~~~~~~~~~'
+ ENDIF
+ ENDIF
+
+ zlap(:,:,:,:) = 0._wp
+ !
+ ! !== 1st laplacian applied to pt (output in zlap) ==!
+ CALL traldf_triad_lap( kt, Kmm, kit000, cdtype, pahu, pahv, pt, pt, zlap, kjpt, 1 )
+ !
+ IF (nn_hls==1) CALL lbc_lnk( 'traldf_lap_blp', zlap(:,:,:,:) , 'T', 1.0_wp ) ! Lateral boundary conditions (unchanged sign)
+ !
+ ! !== 2nd laplacian applied to zlap (output in pt_rhs) ==!
+ CALL traldf_triad_lap( kt, Kmm, kit000, cdtype, pahu, pahv, zlap, pt , pt_rhs, kjpt, 2 )
+ !
+ END SUBROUTINE traldf_triad_blp
!!==============================================================================
END MODULE traldf_triad
diff --git a/src/OCE/TRA/tramle.F90 b/src/OCE/TRA/tramle.F90
index a6f00b0bf72866c66e504760e7b3a4c00a1eae2e..83fb80b79840442f88427ef076ef9188015e360b 100644
--- a/src/OCE/TRA/tramle.F90
+++ b/src/OCE/TRA/tramle.F90
@@ -82,22 +82,21 @@ CONTAINS
!! References: Fox-Kemper et al., JPO, 38, 1145-1165, 2008
!! Fox-Kemper and Ferrari, JPO, 38, 1166-1179, 2008
!!----------------------------------------------------------------------
- INTEGER , INTENT(in ) :: kt ! ocean time-step index
- INTEGER , INTENT(in ) :: kit000 ! first time step index
- INTEGER , INTENT(in ) :: Kmm ! ocean time level index
- CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator)
- ! TEMP: [tiling] Can be A2D(nn_hls) after all lbc_lnks removed in the nn_hls = 2 case in tra_adv_fct
- REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pu ! in : 3 ocean transport components
- REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pv ! out: same 3 transport components
- REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pw ! increased by the MLE induced transport
+ INTEGER , INTENT(in ) :: kt ! ocean time-step index
+ INTEGER , INTENT(in ) :: kit000 ! first time step index
+ INTEGER , INTENT(in ) :: Kmm ! ocean time level index
+ CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator)
+ REAL(wp), DIMENSION(T2D(nn_hls),jpk), INTENT(inout) :: pu ! in : 3 ocean transport components
+ REAL(wp), DIMENSION(T2D(nn_hls),jpk), INTENT(inout) :: pv ! out: same 3 transport components
+ REAL(wp), DIMENSION(T2D(nn_hls),jpk), INTENT(inout) :: pw ! increased by the MLE induced transport
!
INTEGER :: ji, jj, jk ! dummy loop indices
INTEGER :: ii, ij, ik, ikmax ! local integers
REAL(wp) :: zcuw, zmuw, zc ! local scalar
REAL(wp) :: zcvw, zmvw ! - -
- INTEGER , DIMENSION(A2D(nn_hls)) :: inml_mle
- REAL(wp), DIMENSION(A2D(nn_hls)) :: zpsim_u, zpsim_v, zmld, zbm, zhu, zhv, zn2, zLf_NH, zLf_MH
- REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zpsi_uw, zpsi_vw
+ INTEGER , DIMENSION(T2D(nn_hls)) :: inml_mle
+ REAL(wp), DIMENSION(T2D(nn_hls)) :: zpsim_u, zpsim_v, zmld, zbm, zhu, zhv, zn2, zLf_NH, zLf_MH
+ REAL(wp), DIMENSION(T2D(nn_hls),jpk) :: zpsi_uw, zpsi_vw
!!----------------------------------------------------------------------
!
!
@@ -211,10 +210,10 @@ CONTAINS
ELSEIF( nn_mle == 1 ) THEN ! New formulation (Lf = 5km fo/ff with fo=Coriolis parameter at latitude rn_lat)
DO_2D( nn_hls, nn_hls-1, nn_hls, nn_hls-1 )
zpsim_u(ji,jj) = rc_f * zhu(ji,jj) * zhu(ji,jj) * e2_e1u(ji,jj) &
- & * ( zbm(ji+1,jj) - zbm(ji,jj) ) * MIN( 111.e3_wp , e1u(ji,jj) )
+ & * ( zbm(ji+1,jj) - zbm(ji,jj) ) * MIN( 111.e3_wp , e1u(ji,jj) )
!
zpsim_v(ji,jj) = rc_f * zhv(ji,jj) * zhv(ji,jj) * e1_e2v(ji,jj) &
- & * ( zbm(ji,jj+1) - zbm(ji,jj) ) * MIN( 111.e3_wp , e2v(ji,jj) )
+ & * ( zbm(ji,jj+1) - zbm(ji,jj) ) * MIN( 111.e3_wp , e2v(ji,jj) )
END_2D
ENDIF
!
@@ -250,13 +249,13 @@ CONTAINS
!
! !== transport increased by the MLE induced transport ==!
DO jk = 1, ikmax
- DO_2D_OVR( nn_hls, nn_hls-1, nn_hls, nn_hls-1 )
- pu(ji,jj,jk) = pu(ji,jj,jk) + ( zpsi_uw(ji,jj,jk) - zpsi_uw(ji,jj,jk+1) )
+ DO_2D( nn_hls, nn_hls-1, nn_hls, nn_hls-1 )
+ pu(ji,jj,jk) = pu(ji,jj,jk) + ( zpsi_uw(ji,jj,jk) - zpsi_uw(ji,jj,jk+1) ) ! add () for NO repro
pv(ji,jj,jk) = pv(ji,jj,jk) + ( zpsi_vw(ji,jj,jk) - zpsi_vw(ji,jj,jk+1) )
END_2D
- DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 )
- pw(ji,jj,jk) = pw(ji,jj,jk) - ( zpsi_uw(ji,jj,jk) - zpsi_uw(ji-1,jj,jk) &
- & + zpsi_vw(ji,jj,jk) - zpsi_vw(ji,jj-1,jk) ) * wmask(ji,jj,1)
+ DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 )
+ pw(ji,jj,jk) = pw(ji,jj,jk) - ( ( zpsi_uw(ji,jj,jk) - zpsi_uw(ji-1,jj,jk) ) & ! add () for NO repro
+ & + ( zpsi_vw(ji,jj,jk) - zpsi_vw(ji,jj-1,jk) ) ) * wmask(ji,jj,1)
END_2D
END DO
diff --git a/src/OCE/TRA/tranpc.F90 b/src/OCE/TRA/tranpc.F90
index 495ca30b1aafae613264477224694413d330121c..61d8c92758ba7719f7d244b1ff7be0f09237535d 100644
--- a/src/OCE/TRA/tranpc.F90
+++ b/src/OCE/TRA/tranpc.F90
@@ -70,10 +70,10 @@ CONTAINS
REAL(wp) :: zta, zalfa, zsum_temp, zsum_alfa, zaw, zdz, zsum_z
REAL(wp) :: zsa, zbeta, zsum_sali, zsum_beta, zbw, zrw
REAL(wp), PARAMETER :: zn2_zero = 1.e-14_wp ! acceptance criteria for neutrality (N2==0)
- REAL(wp), DIMENSION( jpk ) :: zvn2 ! vertical profile of N2 at 1 given point...
- REAL(wp), DIMENSION( jpk,jpts) :: zvts, zvab ! vertical profile of T & S , and alpha & betaat 1 given point
- REAL(wp), DIMENSION(A2D(nn_hls),jpk ) :: zn2 ! N^2
- REAL(wp), DIMENSION(A2D(nn_hls),jpk,jpts) :: zab ! alpha and beta
+ REAL(wp), DIMENSION( jpk ) :: zvn2 ! vertical profile of N2 at 1 given point...
+ REAL(wp), DIMENSION( jpk,jpts) :: zvts, zvab ! vertical profile of T & S , and alpha & betaat 1 given point
+ REAL(wp), DIMENSION(T2D(0),jpk ) :: zn2 ! N^2
+ REAL(wp), DIMENSION(T2D(0),jpk,jpts) :: zab ! alpha and beta
REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: ztrdt, ztrds ! 3D workspace
!
LOGICAL, PARAMETER :: l_LB_debug = .FALSE. ! set to true if you want to follow what is
@@ -98,12 +98,12 @@ CONTAINS
klc1 = mbkt(ilc1,jlc1) ! bottom of the ocean for debug point...
ENDIF
!
- CALL eos_rab( pts(:,:,:,:,Kaa), zab, Kmm ) ! after alpha and beta (given on T-points)
- CALL bn2 ( pts(:,:,:,:,Kaa), zab, zn2, Kmm ) ! after Brunt-Vaisala (given on W-points)
+ CALL eos_rab( pts(:,:,:,:,Kaa), zab, Kmm, kbnd=0 ) ! after alpha and beta (given on T-points)
+ CALL bn2 ( pts(:,:,:,:,Kaa), zab, zn2, Kmm, kbnd=0 ) ! after Brunt-Vaisala (given on W-points)
!
IF( .NOT. l_istiled .OR. ntile == 1 ) nnpcc = 0 ! Do only on the first tile
!
- DO_2D_OVR( 0, 0, 0, 0 ) ! interior column only
+ DO_2D( 0, 0, 0, 0 ) ! interior column only
!
IF( tmask(ji,jj,2) == 1 ) THEN ! At least 2 ocean points
! ! consider one ocean column
diff --git a/src/OCE/TRA/traqsr.F90 b/src/OCE/TRA/traqsr.F90
index 6db9892b78688d49b8350055519543e536756893..765d7313e72ffba4c2e9facd34b42e58e1af38c0 100644
--- a/src/OCE/TRA/traqsr.F90
+++ b/src/OCE/TRA/traqsr.F90
@@ -53,7 +53,7 @@ MODULE traqsr
LOGICAL , PUBLIC :: ln_qsr_rgb !: Red-Green-Blue light absorption flag
LOGICAL , PUBLIC :: ln_qsr_2bd !: 2 band light absorption flag
LOGICAL , PUBLIC :: ln_qsr_bio !: bio-model light absorption flag
- INTEGER , PUBLIC :: nn_chldta !: use Chlorophyll data (=1) or not (=0)
+ INTEGER , PUBLIC :: nn_chldta !: use Chlorophyll data 3D/Surface (=2/1) or not (=0)
REAL(wp), PUBLIC :: rn_abs !: fraction absorbed in the very near surface (RGB & 2 bands)
REAL(wp), PUBLIC :: rn_si0 !: very near surface depth of extinction (RGB & 2 bands)
REAL(wp), PUBLIC :: rn_si1 !: deepest depth of extinction (water type I) (2 bands)
@@ -145,13 +145,13 @@ CONTAINS
ENDIF
ELSE ! No restart or Euler forward at 1st time step
z1_2 = 1._wp
- DO_3D_OVR( 0, 0, 0, 0, 1, jpk )
+ DO_3D( 0, 0, 0, 0, 1, jpk )
qsr_hc_b(ji,jj,jk) = 0._wp
END_3D
ENDIF
ELSE !== Swap of qsr heat content ==!
z1_2 = 0.5_wp
- DO_3D_OVR( 0, 0, 0, 0, 1, jpk )
+ DO_3D( 0, 0, 0, 0, 1, jpk )
qsr_hc_b(ji,jj,jk) = qsr_hc(ji,jj,jk)
END_3D
ENDIF
@@ -179,8 +179,8 @@ CONTAINS
#endif
END_3D
! !- sea-ice : store the 1st level attenuation coefficient
- WHERE( etot3(A2D(0),1) /= 0._wp ) ; fraqsr_1lev(A2D(0)) = 1._wp - etot3(A2D(0),2) / etot3(A2D(0),1)
- ELSEWHERE ; fraqsr_1lev(A2D(0)) = 1._wp
+ WHERE( etot3(T2D(0),1) /= 0._wp ) ; fraqsr_1lev(T2D(0)) = 1._wp - etot3(T2D(0),2) / etot3(T2D(0),1)
+ ELSEWHERE ; fraqsr_1lev(T2D(0)) = 1._wp
END WHERE
!
END SELECT
@@ -215,7 +215,7 @@ CONTAINS
END_2D
!
IF( iom_use('qsr3d') ) THEN ! output the shortwave Radiation distribution
- ALLOCATE( zetot(A2D(nn_hls),jpk) )
+ ALLOCATE( zetot(T2D(nn_hls),jpk) )
zetot(:,:,nksr+1:jpk) = 0._wp ! below ~400m set to zero
DO_3DS(0, 0, 0, 0, nksr, 1, -1)
zetot(ji,jj,jk) = zetot(ji,jj,jk+1) + qsr_hc(ji,jj,jk) * rho0_rcp
@@ -273,17 +273,21 @@ CONTAINS
INTEGER, INTENT(in ) :: kt, Kmm, Krhs ! ocean time-step and time-level indices
REAL(wp), DIMENSION(jpi,jpj,jpk,jpts,jpt), INTENT(inout) :: pts ! active tracers and RHS of tracer equation
!!
- INTEGER :: ji, jj, jk ! dummy loop indices
- INTEGER :: irgb ! local integer
+ INTEGER :: ji, jj, jk, ik ! dummy loop indices
+ INTEGER :: ipk, irgb ! local integer
REAL(wp) :: zc1 , zc2 , zc3, zchl ! local scalars
REAL(wp) :: zze0, zzeR, zzeG, zzeB, zzeT ! - -
REAL(wp) :: zz0 , zz1 , ze3t ! - -
REAL(wp) :: zCb, zCmax, zpsi, zpsimax, zrdpsi, zCze ! - -
REAL(wp) :: zlogc, zlogze, zlogCtot, zlogCze ! - -
- REAL(wp), DIMENSION(A2D(0) ) :: ze0, zeR, zeG, zeB, zeT
- REAL(wp), DIMENSION(A2D(0),0:3) :: zc
+ !!
+ REAL(wp), DIMENSION(T2D(0)) :: ze0, zeR, zeG, zeB, zeT
+ REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: zc
!!----------------------------------------------------------------------
!
+ IF ( nn_chldta == 1 ) THEN ; ipk=1
+ ELSEIF( nn_chldta == 2 ) THEN ; ipk=jpk ; ENDIF
+ ALLOCATE( zc(T2D(0),ipk,0:3) )
!
! !===========================================!
! !== R-G-B fluxes using chlorophyll data ==! with Morel &Berthon (1989) vertical profile
@@ -297,18 +301,18 @@ CONTAINS
IF( ln_tile ) CALL dom_tile( ntsi, ntsj, ntei, ntej, ktile = 1 ) ! Revert to tile domain
ENDIF
!
- DO_2D( 0, 0, 0, 0 ) ! pre-calculated expensive coefficient
- zlogc = LOG( MAX( 0.03_wp, MIN( sf_chl(1)%fnow(ji,jj,1) ,10._wp ) ) ) ! zlogc = log(zchl) with 0.03 <= Chl >= 10.
- zc1 = 0.113328685307 + 0.803 * zlogc ! zc1 : log(zCze) = log (1.12 * zchl**0.803)
- zc2 = 3.703768066608 + 0.459 * zlogc ! zc2 : log(zCtot) = log(40.6 * zchl**0.459)
- zc3 = 6.34247346942 - 0.746 * zc2 ! zc3 : log(zze) = log(568.2 * zCtot**(-0.746))
- IF( zc3 > 4.62497281328 ) zc3 = 5.298317366548 - 0.293 * zc2 ! IF(log(zze)>log(102)) log(zze) = log(200*zCtot**(-0.293))
+ DO_3D( 0, 0, 0, 0, 1, ipk ) ! pre-calculated expensive coefficient
+ zlogc = LOG( MAX( 0.03_wp, MIN( sf_chl(1)%fnow(ji,jj,jk) ,10._wp ) ) ) ! zlogc = log(zchl) with 0.03 <= Chl >= 10.
+ zc1 = 0.113328685307 + 0.803 * zlogc ! zc1 : log(zCze) = log (1.12 * zchl**0.803)
+ zc2 = 3.703768066608 + 0.459 * zlogc ! zc2 : log(zCtot) = log(40.6 * zchl**0.459)
+ zc3 = 6.34247346942 - 0.746 * zc2 ! zc3 : log(zze) = log(568.2 * zCtot**(-0.746))
+ IF( zc3 > 4.62497281328 ) zc3 = 5.298317366548 - 0.293 * zc2 ! IF(log(zze)>log(102)) log(zze) = log(200*zCtot**(-0.293))
!
- zc(ji,jj,0) = zlogc ! ze(0) = log(zchl)
- zc(ji,jj,1) = EXP( zc1 ) ! ze(1) = zCze
- zc(ji,jj,2) = 1._wp / ( 0.710 + zlogc * ( 0.159 + zlogc * 0.021 ) ) ! ze(2) = 1/zdelpsi
- zc(ji,jj,3) = EXP( - zc3 ) ! ze(3) = 1/zze
- END_2D
+ zc(ji,jj,jk,0) = zlogc ! ze(0) = log(zchl)
+ zc(ji,jj,jk,1) = EXP( zc1 ) ! ze(1) = zCze
+ zc(ji,jj,jk,2) = 1._wp / ( 0.710 + zlogc * ( 0.159 + zlogc * 0.021 ) ) ! ze(2) = 1/zdelpsi
+ zc(ji,jj,jk,3) = EXP( - zc3 ) ! ze(3) = 1/zze
+ END_3D
!
! != surface light =!
!
@@ -324,17 +328,18 @@ CONTAINS
! != interior light =!
!
DO jk = 1, nk0 !* near surface layers *! (< ~12 meters : IR + RGB )
+ ik = MIN( jk , ipk )
DO_2D( 0, 0, 0, 0 )
! !- inverse of RGB attenuation lengths
- zlogc = zc(ji,jj,0)
+ zlogc = zc(ji,jj,ik,0)
zCb = 0.768 + zlogc * ( 0.087 - zlogc * ( 0.179 + zlogc * 0.025 ) )
zCmax = 0.299 - zlogc * ( 0.289 - zlogc * 0.579 )
zpsimax = 0.6 - zlogc * ( 0.640 - zlogc * ( 0.021 + zlogc * 0.115 ) )
! zdelpsi = 0.710 + zlogc * ( 0.159 + zlogc * 0.021 )
- zCze = zc(ji,jj,1)
- zrdpsi = zc(ji,jj,2) ! 1/zdelpsi
-!!st05 zpsi = zc(ji,jj,3) * gdepw(ji,jj,jk,Kmm) ! gdepw/zze
- zpsi = zc(ji,jj,3) * gdepw(ji,jj,jk+1,Kmm) ! gdepw/zze
+ zCze = zc(ji,jj,ik,1)
+ zrdpsi = zc(ji,jj,ik,2) ! 1/zdelpsi
+!!st05 zpsi = zc(ji,jj,ik,3) * gdepw(ji,jj,jk,Kmm) ! gdepw/zze
+ zpsi = zc(ji,jj,ik,3) * gdepw(ji,jj,jk+1,Kmm) ! gdepw/zze
! ! make sure zchl value is such that: 0.03 < zchl < 10.
zchl = MAX( 0.03_wp , MIN( zCze * ( zCb + zCmax * EXP( -( (zpsi - zpsimax) * zrdpsi )**2 ) ) , 10._wp ) )
! ! Convert chlorophyll value to attenuation coefficient
@@ -364,17 +369,18 @@ CONTAINS
END DO
!
DO jk = nk0+1, nkR !* down to Red extinction *! (< ~71 meters : RGB , IR removed from calculation)
- DO_2D( 0, 0, 0, 0 )
+ ik = MIN( jk , ipk )
+ DO_2D( 0, 0, 0, 0 )
! !- inverse of RGB attenuation lengths
- zlogc = zc(ji,jj,0)
+ zlogc = zc(ji,jj,ik,0)
zCb = 0.768 + zlogc * ( 0.087 - zlogc * ( 0.179 + zlogc * 0.025 ) )
zCmax = 0.299 - zlogc * ( 0.289 - zlogc * 0.579 )
zpsimax = 0.6 - zlogc * ( 0.640 - zlogc * ( 0.021 + zlogc * 0.115 ) )
! zdelpsi = 0.710 + zlogc * ( 0.159 + zlogc * 0.021 )
- zCze = zc(ji,jj,1)
- zrdpsi = zc(ji,jj,2) ! 1/zdelpsi
- zpsi = zc(ji,jj,3) * gdepw(ji,jj,jk+1,Kmm) ! gdepw/zze
-!!st05 zpsi = zc(ji,jj,3) * gdepw(ji,jj,jk,Kmm) ! gdepw/zze
+ zCze = zc(ji,jj,ik,1)
+ zrdpsi = zc(ji,jj,ik,2) ! 1/zdelpsi
+ zpsi = zc(ji,jj,ik,3) * gdepw(ji,jj,jk+1,Kmm) ! gdepw/zze
+!!st05 zpsi = zc(ji,jj,ik,3) * gdepw(ji,jj,jk,Kmm) ! gdepw/zze
! ! make sure zchl value is such that: 0.03 < zchl < 10.
zchl = MAX( 0.03_wp , MIN( zCze * ( zCb + zCmax * EXP( -( (zpsi - zpsimax) * zrdpsi )**2 ) ) , 10._wp ) )
! ! Convert chlorophyll value to attenuation coefficient
@@ -402,17 +408,18 @@ CONTAINS
END DO
!
DO jk = nkR+1, nkG !* down to Green extinction *! (< ~350 m : GB , IR+R removed from calculation)
- DO_2D( 0, 0, 0, 0 )
+ ik = MIN( jk , ipk )
+ DO_2D( 0, 0, 0, 0 )
! !- inverse of RGB attenuation lengths
- zlogc = zc(ji,jj,0)
+ zlogc = zc(ji,jj,ik,0)
zCb = 0.768 + zlogc * ( 0.087 - zlogc * ( 0.179 + zlogc * 0.025 ) )
zCmax = 0.299 - zlogc * ( 0.289 - zlogc * 0.579 )
zpsimax = 0.6 - zlogc * ( 0.640 - zlogc * ( 0.021 + zlogc * 0.115 ) )
! zdelpsi = 0.710 + zlogc * ( 0.159 + zlogc * 0.021 )
- zCze = zc(ji,jj,1)
- zrdpsi = zc(ji,jj,2) ! 1/zdelpsi
- zpsi = zc(ji,jj,3) * gdepw(ji,jj,jk+1,Kmm) ! gdepw/zze
-!!st05 zpsi = zc(ji,jj,3) * gdepw(ji,jj,jk,Kmm) ! gdepw/zze
+ zCze = zc(ji,jj,ik,1)
+ zrdpsi = zc(ji,jj,ik,2) ! 1/zdelpsi
+ zpsi = zc(ji,jj,ik,3) * gdepw(ji,jj,jk+1,Kmm) ! gdepw/zze
+!!st05 zpsi = zc(ji,jj,ik,3) * gdepw(ji,jj,jk,Kmm) ! gdepw/zze
! ! make sure zchl value is such that: 0.03 < zchl < 10.
zchl = MAX( 0.03_wp , MIN( zCze * ( zCb + zCmax * EXP( -( (zpsi - zpsimax) * zrdpsi )**2 ) ) , 10._wp ) )
! ! Convert chlorophyll value to attenuation coefficient
@@ -437,17 +444,18 @@ CONTAINS
END DO
!
DO jk = nkG+1, nkB !* down to Blue extinction *! (< ~1300 m : B , IR+RG removed from calculation)
- DO_2D( 0, 0, 0, 0 )
+ ik = MIN( jk , ipk )
+ DO_2D( 0, 0, 0, 0 )
! !- inverse of RGB attenuation lengths
- zlogc = zc(ji,jj,0)
+ zlogc = zc(ji,jj,ik,0)
zCb = 0.768 + zlogc * ( 0.087 - zlogc * ( 0.179 + zlogc * 0.025 ) )
zCmax = 0.299 - zlogc * ( 0.289 - zlogc * 0.579 )
zpsimax = 0.6 - zlogc * ( 0.640 - zlogc * ( 0.021 + zlogc * 0.115 ) )
! zdelpsi = 0.710 + zlogc * ( 0.159 + zlogc * 0.021 )
- zCze = zc(ji,jj,1)
- zrdpsi = zc(ji,jj,2) ! 1/zdelpsi
- zpsi = zc(ji,jj,3) * gdepw(ji,jj,jk+1,Kmm) ! gdepw/zze
-!!st05 zpsi = zc(ji,jj,3) * gdepw(ji,jj,jk,Kmm) ! gdepw/zze
+ zCze = zc(ji,jj,ik,1)
+ zrdpsi = zc(ji,jj,ik,2) ! 1/zdelpsi
+ zpsi = zc(ji,jj,ik,3) * gdepw(ji,jj,jk+1,Kmm) ! gdepw/zze
+!!st05 zpsi = zc(ji,jj,ik,3) * gdepw(ji,jj,jk,Kmm) ! gdepw/zze
! ! make sure zchl value is such that: 0.03 < zchl < 10.
zchl = MAX( 0.03_wp , MIN( zCze * ( zCb + zCmax * EXP( -( (zpsi - zpsimax) * zrdpsi )**2 ) ) , 10._wp ) )
! ! Convert chlorophyll value to attenuation coefficient
@@ -470,6 +478,8 @@ CONTAINS
END_2D
END DO
!
+ DEALLOCATE( zc )
+ !
END SUBROUTINE qsr_RGBc
@@ -499,7 +509,7 @@ CONTAINS
INTEGER :: ji, jj, jk ! dummy loop indices
REAL(wp) :: zze0, zzeR, zzeG, zzeB, zzeT ! - -
REAL(wp) :: zz0 , zz1 , ze3t ! - -
- REAL(wp), DIMENSION(A2D(0)) :: ze0, zeR, zeG, zeB, zeT
+ REAL(wp), DIMENSION(T2D(0)) :: ze0, zeR, zeG, zeB, zeT
!!----------------------------------------------------------------------
!
!
@@ -539,8 +549,8 @@ CONTAINS
zeT(ji,jj) = zzeT ! total - - -
END_2D
!!stbug IF( jk == 1 ) THEN !* sea-ice *! store the 1st level attenuation coeff.
-!!stbug WHERE( qsr(A2D(0)) /= 0._wp ) ; fraqsr_1lev(A2D(0)) = 1._wp - zeT(A2D(0)) / qsr(A2D(0))
-!!stbug ELSEWHERE ; fraqsr_1lev(A2D(0)) = 1._wp
+!!stbug WHERE( qsr(T2D(0)) /= 0._wp ) ; fraqsr_1lev(T2D(0)) = 1._wp - zeT(T2D(0)) / qsr(T2D(0))
+!!stbug ELSEWHERE ; fraqsr_1lev(T2D(0)) = 1._wp
!!stbug END WHERE
!!stbug ENDIF
END DO
@@ -633,7 +643,7 @@ CONTAINS
INTEGER :: ji, jj, jk ! dummy loop indices
REAL(wp) :: zzatt ! - -
REAL(wp) :: zz0 , zz1 , ze3t ! - -
- REAL(wp), DIMENSION(A2D(0)) :: zatt
+ REAL(wp), DIMENSION(T2D(0)) :: zatt
!!----------------------------------------------------------------------
!
! !======================!
@@ -643,7 +653,7 @@ CONTAINS
zz0 = rn_abs * r1_rho0_rcp ! surface equi-partition in 2-bands
zz1 = ( 1._wp - rn_abs ) * r1_rho0_rcp
!
- zatt(A2D(0)) = r1_rho0_rcp !* surface value *!
+ zatt(T2D(0)) = r1_rho0_rcp !* surface value *!
!
DO_2D( 0, 0, 0, 0 )
zatt(ji,jj) = ( zz0 * EXP( -gdepw(ji,jj,1,Kmm)*r1_si0 ) + zz1 * EXP( -gdepw(ji,jj,1,Kmm)*r1_si1 ) )
@@ -666,7 +676,7 @@ CONTAINS
zatt(ji,jj) = zzatt ! save for the next level computation
END_2D
!!stbug ! !* sea-ice *! store the 1st level attenuation coeff.
-!!stbug IF( jk == 1 ) fraqsr_1lev(A2D(0)) = 1._wp - zatt(A2D(0)) * rho0_rcp
+!!stbug IF( jk == 1 ) fraqsr_1lev(T2D(0)) = 1._wp - zatt(T2D(0)) * rho0_rcp
END DO
!!st IF(lwp) WRITE(numout,*) 'nk0+1= ', nk0+1, ' qsr max = ' , MAXVAL(zatt*qsr)*rho0_rcp, ' W/m2' , MAXVAL(zatt*qsr/e3t(:,:,nk0+1,Kmm)), ' K/s'
!
@@ -730,7 +740,8 @@ CONTAINS
!
zcoef = zprec * rho0_rcp / ( rDt * zQmax * pfr)
!
- IF( ln_zco .OR. ln_zps ) THEN ! z- or zps coordinate (use 1D ref vertcial coordinate)
+#if defined key_vco_1d || defined key_vco_1d3d
+ ! z- or zps coordinate (use 1D ref vertcial coordinate)
klev = jpkm1 ! Level of light extinction zco / zps
DO jk = jpkm1, 1, -1
zdw = gdepw_1d(jk+1) ! max w-depth at jk+1 level
@@ -738,7 +749,8 @@ CONTAINS
zhext = - pL * LOG( zcoef * ze3t ) ! extinction depth
IF( zdw >= zhext ) klev = jk ! last T-level reached by Qsr
END DO
- ELSE ! s- or s-z- coordinate (use 3D vertical coordinate)
+#else
+ ! s- or s-z- coordinate (use 3D vertical coordinate)
klev = jpkm1 ! Level of light extinction
DO jk = jpkm1, 1, -1 !
IF( SUM( tmask(:,:,jk) ) > 0 ) THEN ! ocean point at that level
@@ -752,7 +764,7 @@ CONTAINS
END DO
CALL mpp_max('tra_qsr', klev) ! needed for reproducibility !!st may be modified to avoid this comm.
! !!st use ssmask to remove the comm ?
- ENDIF
+#endif
!
!!st IF(lwp) WRITE(numout,*) ' level of e3t light extinction = ', klev, ' ref depth = ', gdepw_1d(klev+1), ' m'
END FUNCTION qsr_ext_lev
@@ -798,13 +810,13 @@ CONTAINS
WRITE(numout,*) 'tra_qsr_init : penetration of the surface solar radiation'
WRITE(numout,*) '~~~~~~~~~~~~'
WRITE(numout,*) ' Namelist namtra_qsr : set the parameter of penetration'
- WRITE(numout,*) ' RGB (Red-Green-Blue) light penetration ln_qsr_rgb = ', ln_qsr_rgb
- WRITE(numout,*) ' 2 band light penetration ln_qsr_2bd = ', ln_qsr_2bd
- WRITE(numout,*) ' bio-model light penetration ln_qsr_bio = ', ln_qsr_bio
- WRITE(numout,*) ' RGB : Chl data (=1) or cst value (=0) nn_chldta = ', nn_chldta
- WRITE(numout,*) ' RGB & 2 bands: fraction of light (rn_si1) rn_abs = ', rn_abs
- WRITE(numout,*) ' RGB & 2 bands: shortess attenuation depth rn_si0 = ', rn_si0
- WRITE(numout,*) ' 2 bands: longest attenuation depth rn_si1 = ', rn_si1
+ WRITE(numout,*) ' RGB (Red-Green-Blue) light penetration ln_qsr_rgb = ', ln_qsr_rgb
+ WRITE(numout,*) ' 2 band light penetration ln_qsr_2bd = ', ln_qsr_2bd
+ WRITE(numout,*) ' bio-model light penetration ln_qsr_bio = ', ln_qsr_bio
+ WRITE(numout,*) ' RGB : 3D/Surface Chl data or Cst value (2,1,0) nn_chldta = ', nn_chldta
+ WRITE(numout,*) ' RGB & 2 bands: fraction of light (rn_si1) rn_abs = ', rn_abs
+ WRITE(numout,*) ' RGB & 2 bands: shortess attenuation depth rn_si0 = ', rn_si0
+ WRITE(numout,*) ' 2 bands: longest attenuation depth rn_si1 = ', rn_si1
WRITE(numout,*)
ENDIF
!
@@ -816,10 +828,10 @@ CONTAINS
IF( ioptio /= 1 ) CALL ctl_stop( 'Choose ONE type of light penetration in namelist namtra_qsr', &
& ' 2 bands, 3 RGB bands or bio-model light penetration' )
!
- IF( ln_qsr_rgb .AND. nn_chldta == 0 ) nqsr = np_RGB
- IF( ln_qsr_rgb .AND. nn_chldta == 1 ) nqsr = np_RGBc
- IF( ln_qsr_2bd ) nqsr = np_2BD
- IF( ln_qsr_bio ) nqsr = np_BIO
+ IF( ln_qsr_rgb .AND. nn_chldta == 0 ) nqsr = np_RGB
+ IF( ln_qsr_rgb .AND. ( nn_chldta == 1 .OR. nn_chldta == 2 ) ) nqsr = np_RGBc
+ IF( ln_qsr_2bd ) nqsr = np_2BD
+ IF( ln_qsr_bio ) nqsr = np_BIO
!
! !** Initialisation **!
!
@@ -872,8 +884,13 @@ CONTAINS
IF( ierror > 0 ) THEN
CALL ctl_stop( 'tra_qsr_init: unable to allocate sf_chl structure' ) ; RETURN
ENDIF
- ALLOCATE( sf_chl(1)%fnow(jpi,jpj,1) )
- IF( sn_chl%ln_tint ) ALLOCATE( sf_chl(1)%fdta(jpi,jpj,1,2) )
+ IF ( nn_chldta == 1 ) THEN
+ ALLOCATE( sf_chl(1)%fnow(jpi,jpj,1) )
+ IF( sn_chl%ln_tint ) ALLOCATE( sf_chl(1)%fdta(jpi,jpj,1,2) )
+ ELSEIF( nn_chldta == 2 ) THEN
+ ALLOCATE( sf_chl(1)%fnow(jpi,jpj,jpk) )
+ IF( sn_chl%ln_tint ) ALLOCATE( sf_chl(1)%fdta(jpi,jpj,jpk,2) )
+ ENDIF
! ! fill sf_chl with sn_chl and control print
CALL fld_fill( sf_chl, (/ sn_chl /), cn_dir, 'tra_qsr_init', &
& 'Solar penetration function of read chlorophyll', 'namtra_qsr' , no_print )
diff --git a/src/OCE/TRA/trasbc.F90 b/src/OCE/TRA/trasbc.F90
index 0f8472a324a1753f8c1f128f1bd28e339a297643..d0a0b0429b3de42d9ff0d58cc1919c0515abb99d 100644
--- a/src/OCE/TRA/trasbc.F90
+++ b/src/OCE/TRA/trasbc.F90
@@ -100,7 +100,7 @@ CONTAINS
!
!!gm This should be moved into sbcmod.F90 module ? (especially now that ln_traqsr is read in namsbc namelist)
IF( .NOT.ln_traqsr ) THEN ! no solar radiation penetration
- DO_2D_OVR( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
qns(ji,jj) = qns(ji,jj) + qsr(ji,jj) ! total heat flux in qns
qsr(ji,jj) = 0._wp ! qsr set to zero
END_2D
@@ -121,24 +121,24 @@ CONTAINS
ENDIF
ELSE ! No restart or restart not found: Euler forward time stepping
zfact = 1._wp
- DO_2D_OVR( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
sbc_tsc(ji,jj,:) = 0._wp
sbc_tsc_b(ji,jj,:) = 0._wp
END_2D
ENDIF
ELSE !* other time-steps: swap of forcing fields
zfact = 0.5_wp
- DO_2D_OVR( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
sbc_tsc_b(ji,jj,:) = sbc_tsc(ji,jj,:)
END_2D
ENDIF
! !== Now sbc tracer content fields ==!
- DO_2D_OVR( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
sbc_tsc(ji,jj,jp_tem) = r1_rho0_rcp * qns(ji,jj) ! non solar heat flux
sbc_tsc(ji,jj,jp_sal) = r1_rho0 * sfx(ji,jj) ! salt flux due to freezing/melting
END_2D
IF( ln_linssh ) THEN !* linear free surface
- DO_2D_OVR( nn_hls, nn_hls, nn_hls, nn_hls ) !==>> add concentration/dilution effect due to constant volume cell
+ DO_2D( 0, 0, 0, 0 ) !==>> add concentration/dilution effect due to constant volume cell
sbc_tsc(ji,jj,jp_tem) = sbc_tsc(ji,jj,jp_tem) + r1_rho0 * emp(ji,jj) * pts(ji,jj,1,jp_tem,Kmm)
sbc_tsc(ji,jj,jp_sal) = sbc_tsc(ji,jj,jp_sal) + r1_rho0 * emp(ji,jj) * pts(ji,jj,1,jp_sal,Kmm)
END_2D !==>> output c./d. term
@@ -198,7 +198,7 @@ CONTAINS
END_2D
ELSE
DO_2D( 0, 0, 0, 0 )
- ztim = ssh_iau(ji,jj) / ( ht(ji,jj) + 1. - ssmask(ji, jj) )
+ ztim = ssh_iau(ji,jj) / ( ht(ji,jj,Kmm) + 1. - ssmask(ji, jj) )
pts(ji,jj,:,jp_tem,Krhs) = pts(ji,jj,:,jp_tem,Krhs) + pts(ji,jj,:,jp_tem,Kmm) * ztim
pts(ji,jj,:,jp_sal,Krhs) = pts(ji,jj,:,jp_sal,Krhs) + pts(ji,jj,:,jp_sal,Kmm) * ztim
END_2D
@@ -275,7 +275,7 @@ CONTAINS
!!gm This should be moved into sbcmod.F90 module ? (especially now that ln_traqsr is read in namsbc namelist)
IF( .NOT.ln_traqsr .AND. kstg == 1) THEN ! no solar radiation penetration
- DO_2D_OVR( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
qns(ji,jj) = qns(ji,jj) + qsr(ji,jj) ! total heat flux in qns
qsr(ji,jj) = 0._wp ! qsr set to zero
END_2D
@@ -358,7 +358,7 @@ CONTAINS
END_2D
ELSE
DO_2D( 0, 0, 0, 0 )
- ztim = ssh_iau(ji,jj) / ( ht(ji,jj) + 1. - ssmask(ji, jj) )
+ ztim = ssh_iau(ji,jj) / ( ht(ji,jj,Kmm) + 1. - ssmask(ji, jj) )
pts(ji,jj,:,jp_tem,Krhs) = pts(ji,jj,:,jp_tem,Krhs) + pts(ji,jj,:,jp_tem,Kmm) * ztim
pts(ji,jj,:,jp_sal,Krhs) = pts(ji,jj,:,jp_sal,Krhs) + pts(ji,jj,:,jp_sal,Kmm) * ztim
END_2D
diff --git a/src/OCE/TRA/trazdf.F90 b/src/OCE/TRA/trazdf.F90
index 8280d3181b6b2731e8616a0a24a938bd15b4d759..bdcf5235431deecd0b2dd1cbeadf5c89f70e87a9 100644
--- a/src/OCE/TRA/trazdf.F90
+++ b/src/OCE/TRA/trazdf.F90
@@ -6,6 +6,7 @@ MODULE trazdf
!! History : 1.0 ! 2005-11 (G. Madec) Original code
!! 3.0 ! 2008-01 (C. Ethe, G. Madec) merge TRC-TRA
!! 4.0 ! 2017-06 (G. Madec) remove explict time-stepping option
+ !! 4.5 ! 2022-06 (G. Madec) refactoring to reduce memory usage (j-k-i loops)
!!----------------------------------------------------------------------
!!----------------------------------------------------------------------
@@ -13,7 +14,6 @@ MODULE trazdf
!!----------------------------------------------------------------------
USE oce ! ocean dynamics and tracers variables
USE dom_oce ! ocean space and time domain variables
- USE domvvl ! variable volume
USE phycst ! physical constant
USE zdf_oce ! ocean vertical physics variables
USE zdfmfc ! Mass FLux Convection
@@ -22,7 +22,7 @@ MODULE trazdf
USE ldfslp ! lateral diffusion: iso-neutral slope
USE trd_oce ! trends: ocean variables
USE trdtra ! trends: tracer trend manager
- USE eosbn2, ONLY: ln_SEOS, rn_b0
+ USE eosbn2 , ONLY: ln_SEOS, rn_b0
!
USE in_out_manager ! I/O manager
USE prtctl ! Print control
@@ -77,7 +77,7 @@ CONTAINS
ENDIF
!
! !* compute lateral mixing trend and add it to the general trend
- CALL tra_zdf_imp( kt, nit000, 'TRA', rDt, Kbb, Kmm, Krhs, pts, Kaa, jpts )
+ CALL tra_zdf_imp( 'TRA', Kbb, Kmm, Krhs, pts, Kaa, jpts )
!!gm WHY here ! and I don't like that !
! DRAKKAR SSS control {
@@ -85,7 +85,7 @@ CONTAINS
! JMM : restore negative salinities to small salinities:
!!jc: discard this correction in case salinity is not used in eos
IF ( .NOT.(ln_SEOS.AND.(rn_b0==0._wp)) ) THEN
- WHERE( pts(A2D(0),:,jp_sal,Kaa) < 0._wp ) pts(A2D(0),:,jp_sal,Kaa) = 0.1_wp
+ WHERE( pts(T2D(0),:,jp_sal,Kaa) < 0._wp ) pts(T2D(0),:,jp_sal,Kaa) = 0.1_wp
ENDIF
!!gm
@@ -116,7 +116,7 @@ CONTAINS
END SUBROUTINE tra_zdf
- SUBROUTINE tra_zdf_imp( kt, kit000, cdtype, p2dt, Kbb, Kmm, Krhs, pt, Kaa, kjpt )
+ SUBROUTINE tra_zdf_imp( cdtype, Kbb, Kmm, Krhs, pt, Kaa, kjpt )
!!----------------------------------------------------------------------
!! *** ROUTINE tra_zdf_imp ***
!!
@@ -136,128 +136,177 @@ CONTAINS
!!
!! ** Action : - pt(:,:,:,:,Kaa) becomes the after tracer
!!---------------------------------------------------------------------
- INTEGER , INTENT(in ) :: kt ! ocean time-step index
INTEGER , INTENT(in ) :: Kbb, Kmm, Krhs, Kaa ! ocean time level indices
- INTEGER , INTENT(in ) :: kit000 ! first time step index
CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator)
INTEGER , INTENT(in ) :: kjpt ! number of tracers
- REAL(wp) , INTENT(in ) :: p2dt ! tracer time-step
REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) :: pt ! tracers and RHS of tracer equation
!
INTEGER :: ji, jj, jk, jn ! dummy loop indices
REAL(wp) :: zrhs, zzwi, zzws ! local scalars
- REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zwi, zwt, zwd, zws
+ REAL(wp), DIMENSION(T1Di(0),jpk) :: zwi, zwt, zwd, zws
!!---------------------------------------------------------------------
!
- ! ! ============= !
- DO jn = 1, kjpt ! tracer loop !
- ! ! ============= !
- ! Matrix construction
- ! --------------------
- ! Build matrix if temperature or salinity (only in double diffusion case) or first passive tracer
- !
- IF( ( cdtype == 'TRA' .AND. ( jn == jp_tem .OR. ( jn == jp_sal .AND. ln_zdfddm ) ) ) .OR. &
- & ( cdtype == 'TRC' .AND. jn == 1 ) ) THEN
+ ! ! ================= !
+ DO_1Dj( 0, 0 ) ! i-k slices loop !
+ ! ! ================= !
+ DO jn = 1, kjpt ! tracer loop !
+ ! ! ================= !
!
- ! vertical mixing coef.: avt for temperature, avs for salinity and passive tracers
- IF( cdtype == 'TRA' .AND. jn == jp_tem ) THEN
- DO_3D( 1, 1, 1, 1, 2, jpk )
- zwt(ji,jj,jk) = avt(ji,jj,jk)
- END_3D
- ELSE
- DO_3D( 1, 1, 1, 1, 2, jpk )
- zwt(ji,jj,jk) = avs(ji,jj,jk)
- END_3D
- ENDIF
- zwt(:,:,1) = 0._wp
+ ! Matrix construction
+ ! --------------------
+ ! Build matrix if temperature or salinity (only in double diffusion case) or first passive tracer
!
- IF( l_ldfslp ) THEN ! isoneutral diffusion: add the contribution
- IF( ln_traldf_msc ) THEN ! MSC iso-neutral operator
- DO_3D( 0, 0, 0, 0, 2, jpkm1 )
- zwt(ji,jj,jk) = zwt(ji,jj,jk) + akz(ji,jj,jk)
- END_3D
- ELSE ! standard or triad iso-neutral operator
- DO_3D( 0, 0, 0, 0, 2, jpkm1 )
- zwt(ji,jj,jk) = zwt(ji,jj,jk) + ah_wslp2(ji,jj,jk)
- END_3D
+ IF( ( cdtype == 'TRA' .AND. ( jn == jp_tem .OR. ( jn == jp_sal .AND. ln_zdfddm ) ) ) .OR. &
+ & ( cdtype == 'TRC' .AND. jn == 1 ) ) THEN
+ !
+ ! vertical mixing coef.: avt for temperature, avs for salinity and passive tracers
+ !
+ IF( cdtype == 'TRA' .AND. jn == jp_tem ) THEN ! use avt for temperature
+ !
+ IF( l_ldfslp ) THEN ! use avt + isoneutral diffusion contribution
+ IF( ln_traldf_msc ) THEN ! MSC iso-neutral operator
+ DO_2Dik( 0, 0, 2, jpk, 1 )
+ zwt(ji,jk) = avt(ji,jj,jk) + akz(ji,jj,jk)
+ END_2D
+ ELSE ! standard or triad iso-neutral operator
+ DO_2Dik( 0, 0, 2, jpk, 1 )
+ zwt(ji,jk) = avt(ji,jj,jk) + ah_wslp2(ji,jj,jk)
+ END_2D
+ ENDIF
+ ELSE ! use avt only
+ DO_2Dik( 0, 0, 2, jpk, 1 )
+ zwt(ji,jk) = avt(ji,jj,jk)
+ END_2D
+ ENDIF
+ !
+ ELSE ! use avs for salinty or passive tracers
+ !
+ IF( l_ldfslp ) THEN ! use avs + isoneutral diffusion contribution
+ IF( ln_traldf_msc ) THEN ! MSC iso-neutral operator
+ DO_2Dik( 0, 0, 2, jpk, 1 )
+ zwt(ji,jk) = avs(ji,jj,jk) + akz(ji,jj,jk)
+ END_2D
+ ELSE ! standard or triad iso-neutral operator
+ DO_2Dik( 0, 0, 2, jpk, 1 )
+ zwt(ji,jk) = avs(ji,jj,jk) + ah_wslp2(ji,jj,jk)
+ END_2D
+ ENDIF
+ ELSE !
+ DO_2Dik( 0, 0, 2, jpk, 1 )
+ zwt(ji,jk) = avs(ji,jj,jk)
+ END_2D
+ ENDIF
ENDIF
+ zwt(:,1) = 0._wp
+ !
+ ! Diagonal, lower (i), upper (s) (including the bottom boundary condition since avt is masked)
+ IF( ln_zad_Aimp ) THEN ! Adaptive implicit vertical advection
+ DO_2Dik( 0, 0, 1, jpkm1, 1 )
+ zzwi = - rDt * zwt(ji,jk ) / e3w(ji,jj,jk ,Kmm)
+ zzws = - rDt * zwt(ji,jk+1) / e3w(ji,jj,jk+1,Kmm)
+ zwd(ji,jk) = e3t(ji,jj,jk,Kaa) - ( zzwi + zzws ) &
+ & + rDt * ( MAX( wi(ji,jj,jk ) , 0._wp ) &
+ & - MIN( wi(ji,jj,jk+1) , 0._wp ) )
+ zwi(ji,jk) = zzwi + rDt * MIN( wi(ji,jj,jk ) , 0._wp )
+ zws(ji,jk) = zzws - rDt * MAX( wi(ji,jj,jk+1) , 0._wp )
+ END_2D
+ ELSE
+ DO_2Dik( 0, 0, 1, jpkm1, 1 )
+ zwi(ji,jk) = - rDt * zwt(ji,jk ) / e3w(ji,jj,jk,Kmm)
+ zws(ji,jk) = - rDt * zwt(ji,jk+1) / e3w(ji,jj,jk+1,Kmm)
+ zwd(ji,jk) = e3t(ji,jj,jk,Kaa) - ( zwi(ji,jk) + zws(ji,jk) )
+ END_2D
+ ENDIF
+ !
+!!gm BUG?? : if edmfm is equivalent to a w ==>>> just add +/- rDt * edmfm(ji,jj,jk+1/jk )
+!! but edmfm is at t-point !!!! crazy??? why not keep it at w-point????
+ !
+ IF( ln_zdfmfc ) THEN ! add upward Mass Flux in the matrix
+ DO_2Dik( 0, 0, 1, jpkm1, 1 )
+ zws(ji,jk) = zws(ji,jk) + e3t(ji,jj,jk,Kaa) * rDt * edmfm(ji,jj,jk+1) / e3w(ji,jj,jk+1,Kmm)
+ zwd(ji,jk) = zwd(ji,jk) - e3t(ji,jj,jk,Kaa) * rDt * edmfm(ji,jj,jk ) / e3w(ji,jj,jk+1,Kmm)
+ END_2D
+ ENDIF
+! DO_3D( 0, 0, 0, 0, 1, jpkm1 )
+! edmfa(ji,jj,jk) = 0._wp
+! edmfb(ji,jj,jk) = -edmfm(ji,jj,jk ) / e3w(ji,jj,jk+1,Kmm)
+! edmfc(ji,jj,jk) = edmfm(ji,jj,jk+1) / e3w(ji,jj,jk+1,Kmm)
+! END_3D
+!!gm BUG : level jpk never used in the inversion
+! DO_2D( 0, 0, 0, 0 )
+! edmfa(ji,jj,jpk) = -edmfm(ji,jj,jpk-1) / e3w(ji,jj,jpk,Kmm)
+! edmfb(ji,jj,jpk) = edmfm(ji,jj,jpk ) / e3w(ji,jj,jpk,Kmm)
+! edmfc(ji,jj,jpk) = 0._wp
+! END_2D
+!!
+!!gm BUG ??? below e3t_Kmm should be used ?
+!! or even no multiplication by e3t unless there is a bug in wi calculation
+!!
+! DO_3D( 0, 0, 0, 0, 1, jpkm1 )
+!!gm edmfa = 0._wp except at jpk which is not used ==>> zdiagi update is useless !
+! zdiagi(ji,jj,jk) = zdiagi(ji,jj,jk) + e3t(ji,jj,jk,Kaa) * p2dt *edmfa(ji,jj,jk)
+! zdiags(ji,jj,jk) = zdiags(ji,jj,jk) + e3t(ji,jj,jk,Kaa) * p2dt *edmfc(ji,jj,jk)
+! zdiagd(ji,jj,jk) = zdiagd(ji,jj,jk) + e3t(ji,jj,jk,Kaa) * p2dt *edmfb(ji,jj,jk)
+! END_3D
+!!gm CALL diag_mfc( zwi, zwd, zws, rDt, Kaa )
+!!gm SUBROUTINE diag_mfc( zdiagi, zdiagd, zdiags, p2dt, Kaa )
+ !
+ !! Matrix inversion from the first level
+ !!----------------------------------------------------------------------
+ ! solve m.x = y where m is a tri diagonal matrix ( jpk*jpk )
+ !
+ ! ( zwd1 zws1 0 0 0 )( zwx1 ) ( zwy1 )
+ ! ( zwi2 zwd2 zws2 0 0 )( zwx2 ) ( zwy2 )
+ ! ( 0 zwi3 zwd3 zws3 0 )( zwx3 )=( zwy3 )
+ ! ( ... )( ... ) ( ... )
+ ! ( 0 0 0 zwik zwdk )( zwxk ) ( zwyk )
+ !
+ ! m is decomposed in the product of an upper and lower triangular matrix.
+ ! The 3 diagonal terms are in 3d arrays: zwd, zws, zwi.
+ ! Suffices i,s and d indicate "inferior" (below diagonal), diagonal
+ ! and "superior" (above diagonal) components of the tridiagonal system.
+ ! The solution will be in the 4d array pta.
+ ! The 3d array zwt is used as a work space array.
+ ! En route to the solution pt(:,:,:,:,Kaa) is used a to evaluate the rhs and then
+ ! used as a work space array: its value is modified.
+ !
+ DO_1Di( 0, 0 ) !* 1st recurrence: Tk = Dk - Ik Sk-1 / Tk-1 (increasing k) ! done one for all passive tracers (so included in the IF instruction)
+ zwt(ji,1) = zwd(ji,1)
+ END_1D
+ DO_2Dik( 0, 0, 2, jpkm1, 1 )
+ zwt(ji,jk) = zwd(ji,jk) - zwi(ji,jk) * zws(ji,jk-1) / zwt(ji,jk-1)
+ END_2D
+ !
ENDIF
!
- ! Diagonal, lower (i), upper (s) (including the bottom boundary condition since avt is masked)
- IF( ln_zad_Aimp ) THEN ! Adaptive implicit vertical advection
- DO_3D( 0, 0, 0, 0, 1, jpkm1 )
- zzwi = - p2dt * zwt(ji,jj,jk ) / e3w(ji,jj,jk ,Kmm)
- zzws = - p2dt * zwt(ji,jj,jk+1) / e3w(ji,jj,jk+1,Kmm)
- zwd(ji,jj,jk) = e3t(ji,jj,jk,Kaa) - zzwi - zzws &
- & + p2dt * ( MAX( wi(ji,jj,jk ) , 0._wp ) - MIN( wi(ji,jj,jk+1) , 0._wp ) )
- zwi(ji,jj,jk) = zzwi + p2dt * MIN( wi(ji,jj,jk ) , 0._wp )
- zws(ji,jj,jk) = zzws - p2dt * MAX( wi(ji,jj,jk+1) , 0._wp )
- END_3D
- ELSE
- DO_3D( 0, 0, 0, 0, 1, jpkm1 )
- zwi(ji,jj,jk) = - p2dt * zwt(ji,jj,jk ) / e3w(ji,jj,jk,Kmm)
- zws(ji,jj,jk) = - p2dt * zwt(ji,jj,jk+1) / e3w(ji,jj,jk+1,Kmm)
- zwd(ji,jj,jk) = e3t(ji,jj,jk,Kaa) - zwi(ji,jj,jk) - zws(ji,jj,jk)
- END_3D
+ IF( ln_zdfmfc ) THEN ! add Mass Flux to the RHS
+ DO_2Dik( 0, 0, 1, jpkm1, 1 )
+ pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) + edmftra(ji,jj,jk,jn)
+ END_2D
+!!gm CALL rhs_mfc( pt(:,:,:,jn,Krhs), jn )
ENDIF
!
- ! Modification of diagonal to add MF scheme
- IF ( ln_zdfmfc ) THEN
- CALL diag_mfc( zwi, zwd, zws, p2dt, Kaa )
- END IF
- !
- !! Matrix inversion from the first level
- !!----------------------------------------------------------------------
- ! solve m.x = y where m is a tri diagonal matrix ( jpk*jpk )
- !
- ! ( zwd1 zws1 0 0 0 )( zwx1 ) ( zwy1 )
- ! ( zwi2 zwd2 zws2 0 0 )( zwx2 ) ( zwy2 )
- ! ( 0 zwi3 zwd3 zws3 0 )( zwx3 )=( zwy3 )
- ! ( ... )( ... ) ( ... )
- ! ( 0 0 0 zwik zwdk )( zwxk ) ( zwyk )
- !
- ! m is decomposed in the product of an upper and lower triangular matrix.
- ! The 3 diagonal terms are in 3d arrays: zwd, zws, zwi.
- ! Suffices i,s and d indicate "inferior" (below diagonal), diagonal
- ! and "superior" (above diagonal) components of the tridiagonal system.
- ! The solution will be in the 4d array pta.
- ! The 3d array zwt is used as a work space array.
- ! En route to the solution pt(:,:,:,:,Kaa) is used a to evaluate the rhs and then
- ! used as a work space array: its value is modified.
- !
- DO_2D( 0, 0, 0, 0 ) !* 1st recurrence: Tk = Dk - Ik Sk-1 / Tk-1 (increasing k) ! done one for all passive tracers (so included in the IF instruction)
- zwt(ji,jj,1) = zwd(ji,jj,1)
+ DO_1Di( 0, 0 ) !* 2nd recurrence: Zk = Yk - Ik / Tk-1 Zk-1
+ pt(ji,jj,1,jn,Kaa) = e3t(ji,jj,1,Kbb) * pt(ji,jj,1,jn,Kbb ) &
+ & + rDt * e3t(ji,jj,1,Kmm) * pt(ji,jj,1,jn,Krhs)
+ END_1D
+ DO_2Dik( 0, 0, 2, jpkm1, 1 )
+ zrhs = e3t(ji,jj,jk,Kbb) * pt(ji,jj,jk,jn,Kbb ) &
+ & + rDt * e3t(ji,jj,jk,Kmm) * pt(ji,jj,jk,jn,Krhs) ! zrhs=right hand side
+ pt(ji,jj,jk,jn,Kaa) = zrhs - zwi(ji,jk) / zwt(ji,jk-1) * pt(ji,jj,jk-1,jn,Kaa)
END_2D
- DO_3D( 0, 0, 0, 0, 2, jpkm1 )
- zwt(ji,jj,jk) = zwd(ji,jj,jk) - zwi(ji,jj,jk) * zws(ji,jj,jk-1) / zwt(ji,jj,jk-1)
- END_3D
!
- ENDIF
- !
- ! Modification of rhs to add MF scheme
- IF ( ln_zdfmfc ) THEN
- CALL rhs_mfc( pt(:,:,:,jn,Krhs), jn )
- END IF
- !
- DO_2D( 0, 0, 0, 0 ) !* 2nd recurrence: Zk = Yk - Ik / Tk-1 Zk-1
- pt(ji,jj,1,jn,Kaa) = e3t(ji,jj,1,Kbb) * pt(ji,jj,1,jn,Kbb) &
- & + p2dt * e3t(ji,jj,1,Kmm) * pt(ji,jj,1,jn,Krhs)
- END_2D
- DO_3D( 0, 0, 0, 0, 2, jpkm1 )
- zrhs = e3t(ji,jj,jk,Kbb) * pt(ji,jj,jk,jn,Kbb) &
- & + p2dt * e3t(ji,jj,jk,Kmm) * pt(ji,jj,jk,jn,Krhs) ! zrhs=right hand side
- pt(ji,jj,jk,jn,Kaa) = zrhs - zwi(ji,jj,jk) / zwt(ji,jj,jk-1) * pt(ji,jj,jk-1,jn,Kaa)
- END_3D
- !
- DO_2D( 0, 0, 0, 0 ) !* 3d recurrence: Xk = (Zk - Sk Xk+1 ) / Tk (result is the after tracer)
- pt(ji,jj,jpkm1,jn,Kaa) = pt(ji,jj,jpkm1,jn,Kaa) / zwt(ji,jj,jpkm1) * tmask(ji,jj,jpkm1)
- END_2D
- DO_3DS( 0, 0, 0, 0, jpk-2, 1, -1 )
- pt(ji,jj,jk,jn,Kaa) = ( pt(ji,jj,jk,jn,Kaa) - zws(ji,jj,jk) * pt(ji,jj,jk+1,jn,Kaa) ) &
- & / zwt(ji,jj,jk) * tmask(ji,jj,jk)
- END_3D
+ DO_1Di( 0, 0 ) !* 3d recurrence: Xk = (Zk - Sk Xk+1 ) / Tk (result is the after tracer)
+ pt(ji,jj,jpkm1,jn,Kaa) = pt(ji,jj,jpkm1,jn,Kaa) / zwt(ji,jpkm1) * tmask(ji,jj,jpkm1)
+ END_1D
+ DO_2Dik( 0, 0, jpk-2, 1, -1 )
+ pt(ji,jj,jk,jn,Kaa) = ( pt(ji,jj,jk,jn,Kaa) - zws(ji,jk) * pt(ji,jj,jk+1,jn,Kaa) ) &
+ & / zwt(ji,jk) * tmask(ji,jj,jk)
+ END_2D
+ ! ! ================= !
+ END DO ! tracer loop !
! ! ================= !
- END DO ! end tracer loop !
+ END_1D ! i-k slices loop !
! ! ================= !
END SUBROUTINE tra_zdf_imp
diff --git a/src/OCE/TRA/zpshde.F90 b/src/OCE/TRA/zpshde.F90
deleted file mode 100644
index 0591067f9e804265264b6aae3adb49d98dbfa6eb..0000000000000000000000000000000000000000
--- a/src/OCE/TRA/zpshde.F90
+++ /dev/null
@@ -1,487 +0,0 @@
-MODULE zpshde
- !!======================================================================
- !! *** MODULE zpshde ***
- !! z-coordinate + partial step : Horizontal Derivative at ocean bottom level
- !!======================================================================
- !! History : OPA ! 2002-04 (A. Bozec) Original code
- !! NEMO 1.0 ! 2002-08 (G. Madec E. Durand) Optimization and Free form
- !! - ! 2004-03 (C. Ethe) adapted for passive tracers
- !! 3.3 ! 2010-05 (C. Ethe, G. Madec) merge TRC-TRA
- !! 3.6 ! 2014-11 (P. Mathiot) Add zps_hde_isf (needed to open a cavity)
- !!======================================================================
-
- !!----------------------------------------------------------------------
- !! zps_hde : Horizontal DErivative of T, S and rd at the last
- !! ocean level (Z-coord. with Partial Steps)
- !!----------------------------------------------------------------------
- USE oce ! ocean: dynamics and tracers variables
- USE dom_oce ! domain: ocean variables
- USE domutl, ONLY : is_tile
- USE phycst ! physical constants
- USE eosbn2 ! ocean equation of state
- USE in_out_manager ! I/O manager
- USE lbclnk ! lateral boundary conditions (or mpp link)
- USE lib_mpp ! MPP library
- USE timing ! Timing
-
- IMPLICIT NONE
- PRIVATE
-
- PUBLIC zps_hde ! routine called by step.F90
- PUBLIC zps_hde_isf ! routine called by step.F90
-
- !! * Substitutions
-# include "do_loop_substitute.h90"
-# include "domzgr_substitute.h90"
- !!----------------------------------------------------------------------
- !! NEMO/OCE 4.0 , NEMO Consortium (2018)
- !! $Id: zpshde.F90 14834 2021-05-11 09:24:44Z hadcv $
- !! Software governed by the CeCILL license (see ./LICENSE)
- !!----------------------------------------------------------------------
-CONTAINS
-
- SUBROUTINE zps_hde( kt, kjpt, pta, pgtu, pgtv, prd, pgru, pgrv )
- !!
- INTEGER , INTENT(in ) :: kt ! ocean time-step index
- INTEGER , INTENT(in ) :: kjpt ! number of tracers
- REAL(wp), DIMENSION(:,:,:,:), INTENT(in ) :: pta ! 4D tracers fields
- REAL(wp), DIMENSION(:,:,:) , INTENT( out) :: pgtu, pgtv ! hor. grad. of ptra at u- & v-pts
- REAL(wp), DIMENSION(:,:,:) , INTENT(in ), OPTIONAL :: prd ! 3D density anomaly fields
- REAL(wp), DIMENSION(:,:) , INTENT( out), OPTIONAL :: pgru, pgrv ! hor. grad of prd at u- & v-pts (bottom)
- !
- INTEGER :: itrd, itgr
- !!
- IF( PRESENT(prd) ) THEN ; itrd = is_tile(prd) ; ELSE ; itrd = 0 ; ENDIF
- IF( PRESENT(pgru) ) THEN ; itgr = is_tile(pgru) ; ELSE ; itgr = 0 ; ENDIF
-
- CALL zps_hde_t( kt, kjpt, pta, is_tile(pta), pgtu, pgtv, is_tile(pgtu), &
- & prd, itrd, pgru, pgrv, itgr )
- END SUBROUTINE zps_hde
-
-
- SUBROUTINE zps_hde_t( kt, kjpt, pta, ktta, pgtu, pgtv, ktgt, &
- & prd, ktrd, pgru, pgrv, ktgr )
- !!----------------------------------------------------------------------
- !! *** ROUTINE zps_hde ***
- !!
- !! ** Purpose : Compute the horizontal derivative of T, S and rho
- !! at u- and v-points with a linear interpolation for z-coordinate
- !! with partial steps.
- !!
- !! ** Method : In z-coord with partial steps, scale factors on last
- !! levels are different for each grid point, so that T, S and rd
- !! points are not at the same depth as in z-coord. To have horizontal
- !! gradients again, we interpolate T and S at the good depth :
- !! Linear interpolation of T, S
- !! Computation of di(tb) and dj(tb) by vertical interpolation:
- !! di(t) = t~ - t(i,j,k) or t(i+1,j,k) - t~
- !! dj(t) = t~ - t(i,j,k) or t(i,j+1,k) - t~
- !! This formulation computes the two cases:
- !! CASE 1 CASE 2
- !! k-1 ___ ___________ k-1 ___ ___________
- !! Ti T~ T~ Ti+1
- !! _____ _____
- !! k | |Ti+1 k Ti | |
- !! | |____ ____| |
- !! ___ | | | ___ | | |
- !!
- !! case 1-> e3w_0(i+1,:,:) >= e3w_0(i,:,:) ( and e3w_0(:,j+1,:) >= e3w_0(:,j,:) ) then
- !! t~ = t(i+1,j ,k) + (e3w_0(i+1,j,k) - e3w_0(i,j,k)) * dk(Ti+1)/e3w_0(i+1,j,k)
- !! ( t~ = t(i ,j+1,k) + (e3w_0(i,j+1,k) - e3w_0(i,j,k)) * dk(Tj+1)/e3w_0(i,j+1,k) )
- !! or
- !! case 2-> e3w_0(i+1,:,:) <= e3w_0(i,:,:) ( and e3w_0(:,j+1,:) <= e3w_0(:,j,:) ) then
- !! t~ = t(i,j,k) + (e3w_0(i,j,k) - e3w_0(i+1,j,k)) * dk(Ti)/e3w_0(i,j,k)
- !! ( t~ = t(i,j,k) + (e3w_0(i,j,k) - e3w_0(i,j+1,k)) * dk(Tj)/e3w_0(i,j,k) )
- !! Idem for di(s) and dj(s)
- !!
- !! For rho, we call eos which will compute rd~(t~,s~) at the right
- !! depth zh from interpolated T and S for the different formulations
- !! of the equation of state (eos).
- !! Gradient formulation for rho :
- !! di(rho) = rd~ - rd(i,j,k) or rd(i+1,j,k) - rd~
- !!
- !! ** Action : compute for top interfaces
- !! - pgtu, pgtv: horizontal gradient of tracer at u- & v-points
- !! - pgru, pgrv: horizontal gradient of rho (if present) at u- & v-points
- !!----------------------------------------------------------------------
- INTEGER , INTENT(in ) :: kt ! ocean time-step index
- INTEGER , INTENT(in ) :: kjpt ! number of tracers
- INTEGER , INTENT(in ) :: ktta, ktgt, ktrd, ktgr
- REAL(wp), DIMENSION(A2D_T(ktta),JPK,KJPT), INTENT(in ) :: pta ! 4D tracers fields
- REAL(wp), DIMENSION(A2D_T(ktgt) ,KJPT), INTENT( out) :: pgtu, pgtv ! hor. grad. of ptra at u- & v-pts
- REAL(wp), DIMENSION(A2D_T(ktrd),JPK ), INTENT(in ), OPTIONAL :: prd ! 3D density anomaly fields
- REAL(wp), DIMENSION(A2D_T(ktgr) ), INTENT( out), OPTIONAL :: pgru, pgrv ! hor. grad of prd at u- & v-pts (bottom)
- !
- INTEGER :: ji, jj, jn ! Dummy loop indices
- INTEGER :: iku, ikv, ikum1, ikvm1 ! partial step level (ocean bottom level) at u- and v-points
- REAL(wp) :: ze3wu, ze3wv, zmaxu, zmaxv ! local scalars
- REAL(wp), DIMENSION(A2D(nn_hls)) :: zri, zrj, zhi, zhj ! NB: 3rd dim=1 to use eos
- REAL(wp), DIMENSION(A2D(nn_hls),kjpt) :: zti, ztj !
- !!----------------------------------------------------------------------
- !
- IF( ln_timing ) CALL timing_start( 'zps_hde')
- !
- pgtu(:,:,:) = 0._wp ; zti (:,:,:) = 0._wp ; zhi (:,:) = 0._wp
- pgtv(:,:,:) = 0._wp ; ztj (:,:,:) = 0._wp ; zhj (:,:) = 0._wp
- !
- DO jn = 1, kjpt !== Interpolation of tracers at the last ocean level ==!
- !
- DO_2D( nn_hls, nn_hls-1, nn_hls, nn_hls-1 ) ! Gradient of density at the last level
- iku = mbku(ji,jj) ; ikum1 = MAX( iku - 1 , 1 ) ! last and before last ocean level at u- & v-points
- ikv = mbkv(ji,jj) ; ikvm1 = MAX( ikv - 1 , 1 ) ! if level first is a p-step, ik.m1=1
- ze3wu = e3w_0(ji+1,jj ,iku) - e3w_0(ji,jj,iku)
- ze3wv = e3w_0(ji ,jj+1,ikv) - e3w_0(ji,jj,ikv)
- !
- ! i- direction
- IF( ze3wu >= 0._wp ) THEN ! case 1
- zmaxu = ze3wu / e3w_0(ji+1,jj,iku)
- ! interpolated values of tracers
- zti (ji,jj,jn) = pta(ji+1,jj,iku,jn) + zmaxu * ( pta(ji+1,jj,ikum1,jn) - pta(ji+1,jj,iku,jn) )
- ! gradient of tracers
- pgtu(ji,jj,jn) = umask(ji,jj,1) * ( zti(ji,jj,jn) - pta(ji,jj,iku,jn) )
- ELSE ! case 2
- zmaxu = -ze3wu / e3w_0(ji,jj,iku)
- ! interpolated values of tracers
- zti (ji,jj,jn) = pta(ji,jj,iku,jn) + zmaxu * ( pta(ji,jj,ikum1,jn) - pta(ji,jj,iku,jn) )
- ! gradient of tracers
- pgtu(ji,jj,jn) = umask(ji,jj,1) * ( pta(ji+1,jj,iku,jn) - zti(ji,jj,jn) )
- ENDIF
- !
- ! j- direction
- IF( ze3wv >= 0._wp ) THEN ! case 1
- zmaxv = ze3wv / e3w_0(ji,jj+1,ikv)
- ! interpolated values of tracers
- ztj (ji,jj,jn) = pta(ji,jj+1,ikv,jn) + zmaxv * ( pta(ji,jj+1,ikvm1,jn) - pta(ji,jj+1,ikv,jn) )
- ! gradient of tracers
- pgtv(ji,jj,jn) = vmask(ji,jj,1) * ( ztj(ji,jj,jn) - pta(ji,jj,ikv,jn) )
- ELSE ! case 2
- zmaxv = -ze3wv / e3w_0(ji,jj,ikv)
- ! interpolated values of tracers
- ztj (ji,jj,jn) = pta(ji,jj,ikv,jn) + zmaxv * ( pta(ji,jj,ikvm1,jn) - pta(ji,jj,ikv,jn) )
- ! gradient of tracers
- pgtv(ji,jj,jn) = vmask(ji,jj,1) * ( pta(ji,jj+1,ikv,jn) - ztj(ji,jj,jn) )
- ENDIF
- END_2D
- END DO
- !
- IF (nn_hls==1) CALL lbc_lnk( 'zpshde', pgtu, 'U', -1.0_wp , pgtv, 'V', -1.0_wp ) ! Lateral boundary cond.
- !
- IF( PRESENT( prd ) ) THEN !== horizontal derivative of density anomalies (rd) ==! (optional part)
- pgru(:,:) = 0._wp
- pgrv(:,:) = 0._wp ! depth of the partial step level
- DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 )
- iku = mbku(ji,jj)
- ikv = mbkv(ji,jj)
- ze3wu = e3w_0(ji+1,jj ,iku) - e3w_0(ji,jj,iku)
- ze3wv = e3w_0(ji ,jj+1,ikv) - e3w_0(ji,jj,ikv)
- IF( ze3wu >= 0._wp ) THEN ; zhi(ji,jj) = gdept_0(ji ,jj,iku) ! i-direction: case 1
- ELSE ; zhi(ji,jj) = gdept_0(ji+1,jj,iku) ! - - case 2
- ENDIF
- IF( ze3wv >= 0._wp ) THEN ; zhj(ji,jj) = gdept_0(ji,jj ,ikv) ! j-direction: case 1
- ELSE ; zhj(ji,jj) = gdept_0(ji,jj+1,ikv) ! - - case 2
- ENDIF
- END_2D
- !
- CALL eos( zti, zhi, zri ) ! interpolated density from zti, ztj
- CALL eos( ztj, zhj, zrj ) ! at the partial step depth output in zri, zrj
- !
- DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) ! Gradient of density at the last level
- iku = mbku(ji,jj)
- ikv = mbkv(ji,jj)
- ze3wu = e3w_0(ji+1,jj ,iku) - e3w_0(ji,jj,iku)
- ze3wv = e3w_0(ji ,jj+1,ikv) - e3w_0(ji,jj,ikv)
- IF( ze3wu >= 0._wp ) THEN ; pgru(ji,jj) = umask(ji,jj,1) * ( zri(ji ,jj ) - prd(ji,jj,iku) ) ! i: 1
- ELSE ; pgru(ji,jj) = umask(ji,jj,1) * ( prd(ji+1,jj,iku) - zri(ji,jj ) ) ! i: 2
- ENDIF
- IF( ze3wv >= 0._wp ) THEN ; pgrv(ji,jj) = vmask(ji,jj,1) * ( zrj(ji,jj ) - prd(ji,jj,ikv) ) ! j: 1
- ELSE ; pgrv(ji,jj) = vmask(ji,jj,1) * ( prd(ji,jj+1,ikv) - zrj(ji,jj ) ) ! j: 2
- ENDIF
- END_2D
- IF (nn_hls==1) CALL lbc_lnk( 'zpshde', pgru , 'U', -1.0_wp , pgrv , 'V', -1.0_wp ) ! Lateral boundary conditions
- !
- END IF
- !
- IF( ln_timing ) CALL timing_stop( 'zps_hde')
- !
- END SUBROUTINE zps_hde_t
-
-
- SUBROUTINE zps_hde_isf( kt, kjpt, pta, pgtu, pgtv, pgtui, pgtvi, &
- & prd, pgru, pgrv, pgrui, pgrvi )
- !!
- INTEGER , INTENT(in ) :: kt ! ocean time-step index
- INTEGER , INTENT(in ) :: kjpt ! number of tracers
- REAL(wp), DIMENSION(:,:,:,:), INTENT(in ) :: pta ! 4D tracers fields
- REAL(wp), DIMENSION(:,:,:) , INTENT( out) :: pgtu, pgtv ! hor. grad. of ptra at u- & v-pts
- REAL(wp), DIMENSION(:,:,:) , INTENT( out) :: pgtui, pgtvi ! hor. grad. of stra at u- & v-pts (ISF)
- REAL(wp), DIMENSION(:,:,:) , INTENT(in ), OPTIONAL :: prd ! 3D density anomaly fields
- REAL(wp), DIMENSION(:,:) , INTENT( out), OPTIONAL :: pgru, pgrv ! hor. grad of prd at u- & v-pts (bottom)
- REAL(wp), DIMENSION(:,:) , INTENT( out), OPTIONAL :: pgrui, pgrvi ! hor. grad of prd at u- & v-pts (top)
- !
- INTEGER :: itrd, itgr, itgri
- !!
- IF( PRESENT(prd) ) THEN ; itrd = is_tile(prd) ; ELSE ; itrd = 0 ; ENDIF
- IF( PRESENT(pgru) ) THEN ; itgr = is_tile(pgru) ; ELSE ; itgr = 0 ; ENDIF
- IF( PRESENT(pgrui) ) THEN ; itgri = is_tile(pgrui) ; ELSE ; itgri = 0 ; ENDIF
-
- CALL zps_hde_isf_t( kt, kjpt, pta, is_tile(pta), pgtu, pgtv, is_tile(pgtu), pgtui, pgtvi, is_tile(pgtui), &
- & prd, itrd, pgru, pgrv, itgr, pgrui, pgrvi, itgri )
- END SUBROUTINE zps_hde_isf
-
-
- SUBROUTINE zps_hde_isf_t( kt, kjpt, pta, ktta, pgtu, pgtv, ktgt, pgtui, pgtvi, ktgti, &
- & prd, ktrd, pgru, pgrv, ktgr, pgrui, pgrvi, ktgri )
- !!----------------------------------------------------------------------
- !! *** ROUTINE zps_hde_isf ***
- !!
- !! ** Purpose : Compute the horizontal derivative of T, S and rho
- !! at u- and v-points with a linear interpolation for z-coordinate
- !! with partial steps for top (ice shelf) and bottom.
- !!
- !! ** Method : In z-coord with partial steps, scale factors on last
- !! levels are different for each grid point, so that T, S and rd
- !! points are not at the same depth as in z-coord. To have horizontal
- !! gradients again, we interpolate T and S at the good depth :
- !! For the bottom case:
- !! Linear interpolation of T, S
- !! Computation of di(tb) and dj(tb) by vertical interpolation:
- !! di(t) = t~ - t(i,j,k) or t(i+1,j,k) - t~
- !! dj(t) = t~ - t(i,j,k) or t(i,j+1,k) - t~
- !! This formulation computes the two cases:
- !! CASE 1 CASE 2
- !! k-1 ___ ___________ k-1 ___ ___________
- !! Ti T~ T~ Ti+1
- !! _____ _____
- !! k | |Ti+1 k Ti | |
- !! | |____ ____| |
- !! ___ | | | ___ | | |
- !!
- !! case 1-> e3w_0(i+1,j,k) >= e3w_0(i,j,k) ( and e3w_0(i,j+1,k) >= e3w_0(i,j,k) ) then
- !! t~ = t(i+1,j ,k) + (e3w_0(i+1,j ,k) - e3w_0(i,j,k)) * dk(Ti+1)/e3w_0(i+1,j ,k)
- !! ( t~ = t(i ,j+1,k) + (e3w_0(i ,j+1,k) - e3w_0(i,j,k)) * dk(Tj+1)/e3w_0(i ,j+1,k) )
- !! or
- !! case 2-> e3w_0(i+1,j,k) <= e3w_0(i,j,k) ( and e3w_0(i,j+1,k) <= e3w_0(i,j,k) ) then
- !! t~ = t(i,j,k) + (e3w_0(i,j,k) - e3w_0(i+1,j ,k)) * dk(Ti)/e3w_0(i,j,k)
- !! ( t~ = t(i,j,k) + (e3w_0(i,j,k) - e3w_0(i ,j+1,k)) * dk(Tj)/e3w_0(i,j,k) )
- !! Idem for di(s) and dj(s)
- !!
- !! For rho, we call eos which will compute rd~(t~,s~) at the right
- !! depth zh from interpolated T and S for the different formulations
- !! of the equation of state (eos).
- !! Gradient formulation for rho :
- !! di(rho) = rd~ - rd(i,j,k) or rd(i+1,j,k) - rd~
- !!
- !! For the top case (ice shelf): As for the bottom case but upside down
- !!
- !! ** Action : compute for top and bottom interfaces
- !! - pgtu, pgtv, pgtui, pgtvi: horizontal gradient of tracer at u- & v-points
- !! - pgru, pgrv, pgrui, pgtvi: horizontal gradient of rho (if present) at u- & v-points
- !!----------------------------------------------------------------------
- INTEGER , INTENT(in ) :: kt ! ocean time-step index
- INTEGER , INTENT(in ) :: kjpt ! number of tracers
- INTEGER , INTENT(in ) :: ktta, ktgt, ktgti, ktrd, ktgr, ktgri
- REAL(wp), DIMENSION(A2D_T(ktta),JPK,KJPT), INTENT(in ) :: pta ! 4D tracers fields
- REAL(wp), DIMENSION(A2D_T(ktgt) ,KJPT), INTENT( out) :: pgtu, pgtv ! hor. grad. of ptra at u- & v-pts
- REAL(wp), DIMENSION(A2D_T(ktgti) ,KJPT), INTENT( out) :: pgtui, pgtvi ! hor. grad. of stra at u- & v-pts (ISF)
- REAL(wp), DIMENSION(A2D_T(ktrd),JPK ), INTENT(in ), OPTIONAL :: prd ! 3D density anomaly fields
- REAL(wp), DIMENSION(A2D_T(ktgr) ), INTENT( out), OPTIONAL :: pgru, pgrv ! hor. grad of prd at u- & v-pts (bottom)
- REAL(wp), DIMENSION(A2D_T(ktgri) ), INTENT( out), OPTIONAL :: pgrui, pgrvi ! hor. grad of prd at u- & v-pts (top)
- !
- INTEGER :: ji, jj, jn ! Dummy loop indices
- INTEGER :: iku, ikv, ikum1, ikvm1,ikup1, ikvp1 ! partial step level (ocean bottom level) at u- and v-points
- REAL(wp) :: ze3wu, ze3wv, zmaxu, zmaxv ! temporary scalars
- REAL(wp), DIMENSION(A2D(nn_hls)) :: zri, zrj, zhi, zhj ! NB: 3rd dim=1 to use eos
- REAL(wp), DIMENSION(A2D(nn_hls),kjpt) :: zti, ztj !
- !!----------------------------------------------------------------------
- !
- IF( ln_timing ) CALL timing_start( 'zps_hde_isf')
- !
- pgtu (:,:,:) = 0._wp ; pgtv (:,:,:) =0._wp
- pgtui(:,:,:) = 0._wp ; pgtvi(:,:,:) =0._wp
- zti (:,:,:) = 0._wp ; ztj (:,:,:) =0._wp
- zhi (:,: ) = 0._wp ; zhj (:,: ) =0._wp
- !
- DO jn = 1, kjpt !== Interpolation of tracers at the last ocean level ==!
- !
- DO_2D( nn_hls, nn_hls-1, nn_hls, nn_hls-1 )
-
- iku = mbku(ji,jj); ikum1 = MAX( iku - 1 , 1 ) ! last and before last ocean level at u- & v-points
- ikv = mbkv(ji,jj); ikvm1 = MAX( ikv - 1 , 1 ) ! if level first is a p-step, ik.m1=1
- ze3wu = gdept_0(ji+1,jj,iku) - gdept_0(ji,jj,iku)
- ze3wv = gdept_0(ji,jj+1,ikv) - gdept_0(ji,jj,ikv)
- !
- ! i- direction
- IF( ze3wu >= 0._wp ) THEN ! case 1
- zmaxu = ze3wu / e3w_0(ji+1,jj,iku)
- ! interpolated values of tracers
- zti (ji,jj,jn) = pta(ji+1,jj,iku,jn) + zmaxu * ( pta(ji+1,jj,ikum1,jn) - pta(ji+1,jj,iku,jn) )
- ! gradient of tracers
- pgtu(ji,jj,jn) = ssumask(ji,jj) * ( zti(ji,jj,jn) - pta(ji,jj,iku,jn) )
- ELSE ! case 2
- zmaxu = -ze3wu / e3w_0(ji,jj,iku)
- ! interpolated values of tracers
- zti (ji,jj,jn) = pta(ji,jj,iku,jn) + zmaxu * ( pta(ji,jj,ikum1,jn) - pta(ji,jj,iku,jn) )
- ! gradient of tracers
- pgtu(ji,jj,jn) = ssumask(ji,jj) * ( pta(ji+1,jj,iku,jn) - zti(ji,jj,jn) )
- ENDIF
- !
- ! j- direction
- IF( ze3wv >= 0._wp ) THEN ! case 1
- zmaxv = ze3wv / e3w_0(ji,jj+1,ikv)
- ! interpolated values of tracers
- ztj (ji,jj,jn) = pta(ji,jj+1,ikv,jn) + zmaxv * ( pta(ji,jj+1,ikvm1,jn) - pta(ji,jj+1,ikv,jn) )
- ! gradient of tracers
- pgtv(ji,jj,jn) = ssvmask(ji,jj) * ( ztj(ji,jj,jn) - pta(ji,jj,ikv,jn) )
- ELSE ! case 2
- zmaxv = -ze3wv / e3w_0(ji,jj,ikv)
- ! interpolated values of tracers
- ztj (ji,jj,jn) = pta(ji,jj,ikv,jn) + zmaxv * ( pta(ji,jj,ikvm1,jn) - pta(ji,jj,ikv,jn) )
- ! gradient of tracers
- pgtv(ji,jj,jn) = ssvmask(ji,jj) * ( pta(ji,jj+1,ikv,jn) - ztj(ji,jj,jn) )
- ENDIF
-
- END_2D
- END DO
- !
- IF (nn_hls==1) CALL lbc_lnk( 'zpshde', pgtu, 'U', -1.0_wp , pgtv, 'V', -1.0_wp ) ! Lateral boundary cond.
-
- ! horizontal derivative of density anomalies (rd)
- IF( PRESENT( prd ) ) THEN ! depth of the partial step level
- pgru(:,:)=0.0_wp ; pgrv(:,:)=0.0_wp ;
- !
- DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 )
-
- iku = mbku(ji,jj)
- ikv = mbkv(ji,jj)
- ze3wu = gdept_0(ji+1,jj,iku) - gdept_0(ji,jj,iku)
- ze3wv = gdept_0(ji,jj+1,ikv) - gdept_0(ji,jj,ikv)
- !
- IF( ze3wu >= 0._wp ) THEN ; zhi(ji,jj) = gdept_0(ji ,jj,iku) ! i-direction: case 1
- ELSE ; zhi(ji,jj) = gdept_0(ji+1,jj,iku) ! - - case 2
- ENDIF
- IF( ze3wv >= 0._wp ) THEN ; zhj(ji,jj) = gdept_0(ji,jj ,ikv) ! j-direction: case 1
- ELSE ; zhj(ji,jj) = gdept_0(ji,jj+1,ikv) ! - - case 2
- ENDIF
-
- END_2D
-
- ! Compute interpolated rd from zti, ztj for the 2 cases at the depth of the partial
- ! step and store it in zri, zrj for each case
- CALL eos( zti, zhi, zri )
- CALL eos( ztj, zhj, zrj )
-
- DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 )
- iku = mbku(ji,jj)
- ikv = mbkv(ji,jj)
- ze3wu = gdept_0(ji+1,jj,iku) - gdept_0(ji,jj,iku)
- ze3wv = gdept_0(ji,jj+1,ikv) - gdept_0(ji,jj,ikv)
-
- IF( ze3wu >= 0._wp ) THEN ; pgru(ji,jj) = ssumask(ji,jj) * ( zri(ji ,jj ) - prd(ji,jj,iku) ) ! i: 1
- ELSE ; pgru(ji,jj) = ssumask(ji,jj) * ( prd(ji+1,jj,iku) - zri(ji,jj ) ) ! i: 2
- ENDIF
- IF( ze3wv >= 0._wp ) THEN ; pgrv(ji,jj) = ssvmask(ji,jj) * ( zrj(ji,jj ) - prd(ji,jj,ikv) ) ! j: 1
- ELSE ; pgrv(ji,jj) = ssvmask(ji,jj) * ( prd(ji,jj+1,ikv) - zrj(ji,jj ) ) ! j: 2
- ENDIF
-
- END_2D
-
- IF (nn_hls==1) CALL lbc_lnk( 'zpshde', pgru , 'U', -1.0_wp , pgrv , 'V', -1.0_wp ) ! Lateral boundary conditions
- !
- END IF
- !
- ! !== (ISH) compute grui and gruvi ==!
- !
- DO jn = 1, kjpt !== Interpolation of tracers at the last ocean level ==! !
- DO_2D( nn_hls, nn_hls-1, nn_hls, nn_hls-1 )
- iku = miku(ji,jj); ikup1 = miku(ji,jj) + 1
- ikv = mikv(ji,jj); ikvp1 = mikv(ji,jj) + 1
- !
- ! (ISF) case partial step top and bottom in adjacent cell in vertical
- ! cannot used e3w because if 2 cell water column, we have ps at top and bottom
- ! in this case e3w_0(i,j,k) - e3w_0(i,j+1,k) is not the distance between Tj~ and Tj
- ! the only common depth between cells (i,j) and (i,j+1) is gdepw_0
- ze3wu = gdept_0(ji,jj,iku) - gdept_0(ji+1,jj,iku)
- ze3wv = gdept_0(ji,jj,ikv) - gdept_0(ji,jj+1,ikv)
-
- ! i- direction
- IF( ze3wu >= 0._wp ) THEN ! case 1
- zmaxu = ze3wu / e3w_0(ji+1,jj,ikup1)
- ! interpolated values of tracers
- zti(ji,jj,jn) = pta(ji+1,jj,iku,jn) + zmaxu * ( pta(ji+1,jj,ikup1,jn) - pta(ji+1,jj,iku,jn) )
- ! gradient of tracers
- pgtui(ji,jj,jn) = ssumask(ji,jj) * ( zti(ji,jj,jn) - pta(ji,jj,iku,jn) )
- ELSE ! case 2
- zmaxu = - ze3wu / e3w_0(ji,jj,ikup1)
- ! interpolated values of tracers
- zti(ji,jj,jn) = pta(ji,jj,iku,jn) + zmaxu * ( pta(ji,jj,ikup1,jn) - pta(ji,jj,iku,jn) )
- ! gradient of tracers
- pgtui(ji,jj,jn) = ssumask(ji,jj) * ( pta(ji+1,jj,iku,jn) - zti(ji,jj,jn) )
- ENDIF
- !
- ! j- direction
- IF( ze3wv >= 0._wp ) THEN ! case 1
- zmaxv = ze3wv / e3w_0(ji,jj+1,ikvp1)
- ! interpolated values of tracers
- ztj(ji,jj,jn) = pta(ji,jj+1,ikv,jn) + zmaxv * ( pta(ji,jj+1,ikvp1,jn) - pta(ji,jj+1,ikv,jn) )
- ! gradient of tracers
- pgtvi(ji,jj,jn) = ssvmask(ji,jj) * ( ztj(ji,jj,jn) - pta(ji,jj,ikv,jn) )
- ELSE ! case 2
- zmaxv = - ze3wv / e3w_0(ji,jj,ikvp1)
- ! interpolated values of tracers
- ztj(ji,jj,jn) = pta(ji,jj,ikv,jn) + zmaxv * ( pta(ji,jj,ikvp1,jn) - pta(ji,jj,ikv,jn) )
- ! gradient of tracers
- pgtvi(ji,jj,jn) = ssvmask(ji,jj) * ( pta(ji,jj+1,ikv,jn) - ztj(ji,jj,jn) )
- ENDIF
-
- END_2D
- !
- END DO
- IF (nn_hls==1) CALL lbc_lnk( 'zpshde', pgtui, 'U', -1.0_wp , pgtvi, 'V', -1.0_wp ) ! Lateral boundary cond.
-
- IF( PRESENT( prd ) ) THEN !== horizontal derivative of density anomalies (rd) ==! (optional part)
- !
- pgrui(:,:) =0.0_wp; pgrvi(:,:) =0.0_wp;
- DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 )
-
- iku = miku(ji,jj)
- ikv = mikv(ji,jj)
- ze3wu = gdept_0(ji,jj,iku) - gdept_0(ji+1,jj,iku)
- ze3wv = gdept_0(ji,jj,ikv) - gdept_0(ji,jj+1,ikv)
- !
- IF( ze3wu >= 0._wp ) THEN ; zhi(ji,jj) = gdept_0(ji ,jj,iku) ! i-direction: case 1
- ELSE ; zhi(ji,jj) = gdept_0(ji+1,jj,iku) ! - - case 2
- ENDIF
-
- IF( ze3wv >= 0._wp ) THEN ; zhj(ji,jj) = gdept_0(ji,jj ,ikv) ! j-direction: case 1
- ELSE ; zhj(ji,jj) = gdept_0(ji,jj+1,ikv) ! - - case 2
- ENDIF
-
- END_2D
- !
- CALL eos( zti, zhi, zri ) ! interpolated density from zti, ztj
- CALL eos( ztj, zhj, zrj ) ! at the partial step depth output in zri, zrj
- !
- DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 )
- iku = miku(ji,jj)
- ikv = mikv(ji,jj)
- ze3wu = gdept_0(ji,jj,iku) - gdept_0(ji+1,jj,iku)
- ze3wv = gdept_0(ji,jj,ikv) - gdept_0(ji,jj+1,ikv)
-
- IF( ze3wu >= 0._wp ) THEN ; pgrui(ji,jj) = ssumask(ji,jj) * ( zri(ji ,jj ) - prd(ji,jj,iku) ) ! i: 1
- ELSE ; pgrui(ji,jj) = ssumask(ji,jj) * ( prd(ji+1,jj ,iku) - zri(ji,jj ) ) ! i: 2
- ENDIF
- IF( ze3wv >= 0._wp ) THEN ; pgrvi(ji,jj) = ssvmask(ji,jj) * ( zrj(ji ,jj ) - prd(ji,jj,ikv) ) ! j: 1
- ELSE ; pgrvi(ji,jj) = ssvmask(ji,jj) * ( prd(ji ,jj+1,ikv) - zrj(ji,jj ) ) ! j: 2
- ENDIF
-
- END_2D
- IF (nn_hls==1) CALL lbc_lnk( 'zpshde', pgrui, 'U', -1.0_wp , pgrvi, 'V', -1.0_wp ) ! Lateral boundary conditions
- !
- END IF
- !
- IF( ln_timing ) CALL timing_stop( 'zps_hde_isf')
- !
- END SUBROUTINE zps_hde_isf_t
-
- !!======================================================================
-END MODULE zpshde
diff --git a/src/OCE/TRD/trddyn.F90 b/src/OCE/TRD/trddyn.F90
index 8816056e52b877dbd4118eaba52ceb326bc1c8b4..464ebbbf8cff2284a9630a876db342919dc96168 100644
--- a/src/OCE/TRD/trddyn.F90
+++ b/src/OCE/TRD/trddyn.F90
@@ -56,10 +56,13 @@ CONTAINS
INTEGER , INTENT(in ) :: ktrd ! trend index
INTEGER , INTENT(in ) :: kt ! time step
INTEGER , INTENT(in ) :: Kmm ! time level index
+ INTEGER :: ji, jj, jk ! lopp indices
!!----------------------------------------------------------------------
!
- putrd(:,:,:) = putrd(:,:,:) * umask(:,:,:) ! mask the trends
- pvtrd(:,:,:) = pvtrd(:,:,:) * vmask(:,:,:)
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
+ putrd(ji,jj,jk) = putrd(ji,jj,jk) * umask(ji,jj,jk) ! mask the trends
+ pvtrd(ji,jj,jk) = pvtrd(ji,jj,jk) * vmask(ji,jj,jk)
+ END_3D
!
!!gm NB : here a lbc_lnk should probably be added
@@ -120,10 +123,10 @@ CONTAINS
CALL iom_put( "vtrd_rvo", pvtrd )
CASE( jpdyn_keg ) ; CALL iom_put( "utrd_keg", putrd ) ! Kinetic Energy gradient (or had)
CALL iom_put( "vtrd_keg", pvtrd )
- ALLOCATE( z3dx(jpi,jpj,jpk) , z3dy(jpi,jpj,jpk) )
- z3dx(:,:,:) = 0._wp ! U.dxU & V.dyV (approximation)
- z3dy(:,:,:) = 0._wp
- DO_3D( 0, 0, 0, 0, 1, jpkm1 ) ! no mask as un,vn are masked
+ ALLOCATE( z3dx(T2D(0),jpk) , z3dy(T2D(0),jpk) ) ! U.dxU & V.dyV (approximation)
+ z3dx(T2D(0),jpk) = 0._wp
+ z3dy(T2D(0),jpk) = 0._wp
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 ) ! no mask as un,vn are masked
z3dx(ji,jj,jk) = uu(ji,jj,jk,Kmm) * ( uu(ji+1,jj,jk,Kmm) - uu(ji-1,jj,jk,Kmm) ) / ( 2._wp * e1u(ji,jj) )
z3dy(ji,jj,jk) = vv(ji,jj,jk,Kmm) * ( vv(ji,jj+1,jk,Kmm) - vv(ji,jj-1,jk,Kmm) ) / ( 2._wp * e2v(ji,jj) )
END_3D
@@ -139,9 +142,11 @@ CONTAINS
CALL iom_put( "vtrd_zdf", pvtrd )
!
! ! wind stress trends
- ALLOCATE( z2dx(jpi,jpj) , z2dy(jpi,jpj) )
- z2dx(:,:) = ( utau_b(:,:) + utau(:,:) ) / ( e3u(:,:,1,Kmm) * rho0 )
- z2dy(:,:) = ( vtau_b(:,:) + vtau(:,:) ) / ( e3v(:,:,1,Kmm) * rho0 )
+ ALLOCATE( z2dx(T2D(0)) , z2dy(T2D(0)) )
+ DO_2D( 0, 0, 0, 0 )
+ z2dx(ji,jj) = ( utau_b(ji,jj) + utauU(ji,jj) ) / ( e3u(ji,jj,1,Kmm) * rho0 )
+ z2dy(ji,jj) = ( vtau_b(ji,jj) + vtauV(ji,jj) ) / ( e3v(ji,jj,1,Kmm) * rho0 )
+ END_2D
CALL iom_put( "utrd_tau", z2dx )
CALL iom_put( "vtrd_tau", z2dy )
DEALLOCATE( z2dx , z2dy )
diff --git a/src/OCE/TRD/trdglo.F90 b/src/OCE/TRD/trdglo.F90
index 0e4a2aea0f1d16b4f7299c6d414d292d8b45b027..29dd173fc58088cc549ed32169f8880a1a1b639b 100644
--- a/src/OCE/TRD/trdglo.F90
+++ b/src/OCE/TRD/trdglo.F90
@@ -42,6 +42,7 @@ MODULE trdglo
REAL(wp) :: tvolv ! volume of the whole ocean computed at v-points
REAL(wp) :: rpktrd ! potential to kinetic energy conversion
REAL(wp) :: peke ! conversion potential energy - kinetic energy trend
+ REAL(wp) :: xcof
! !!! domain averaged trends
REAL(wp), DIMENSION(jptot_tra) :: tmo, smo ! temperature and salinity trends
@@ -77,44 +78,47 @@ CONTAINS
INTEGER :: ji, jj, jk ! dummy loop indices
INTEGER :: ikbu, ikbv ! local integers
REAL(wp):: zvm, zvt, zvs, z1_2rho0 ! local scalars
- REAL(wp), DIMENSION(jpi,jpj) :: ztswu, ztswv, z2dx, z2dy ! 2D workspace
+ REAL(wp), DIMENSION(T2D(0)) :: ztswu, ztswv, z2dx, z2dy ! 2D workspace
!!----------------------------------------------------------------------
!
IF( MOD(kt,nn_trd) == 0 .OR. kt == nit000 .OR. kt == nitend ) THEN
!
- SELECT CASE( ctype )
- !
- CASE( 'TRA' ) !== Tracers (T & S) ==!
- DO_3D( 1, 1, 1, 1, 1, jpkm1 ) ! global sum of mask volume trend and trend*T (including interior mask)
- zvm = e1e2t(ji,jj) * e3t(ji,jj,jk,Kmm) * tmask(ji,jj,jk) * tmask_i(ji,jj)
- zvt = ptrdx(ji,jj,jk) * zvm
- zvs = ptrdy(ji,jj,jk) * zvm
- tmo(ktrd) = tmo(ktrd) + zvt
- smo(ktrd) = smo(ktrd) + zvs
- t2 (ktrd) = t2(ktrd) + zvt * ts(ji,jj,jk,jp_tem,Kmm)
- s2 (ktrd) = s2(ktrd) + zvs * ts(ji,jj,jk,jp_sal,Kmm)
- END_3D
+ SELECT CASE( ctype )
+ !
+ CASE( 'TRA' ) !== Tracers (T & S) ==!
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 ) ! global sum of mask volume trend and trend*T (including interior mask)
+ zvm = e1e2t(ji,jj) * e3t(ji,jj,jk,Kmm) * tmask(ji,jj,jk) * tmask_i(ji,jj)
+ zvt = ptrdx(ji,jj,jk) * zvm
+ zvs = ptrdy(ji,jj,jk) * zvm
+ tmo(ktrd) = tmo(ktrd) + zvt
+ smo(ktrd) = smo(ktrd) + zvs
+ t2 (ktrd) = t2(ktrd) + zvt * ts(ji,jj,jk,jp_tem,Kmm)
+ s2 (ktrd) = s2(ktrd) + zvs * ts(ji,jj,jk,jp_sal,Kmm)
+ END_3D
! ! linear free surface: diagnose advective flux trough the fixed k=1 w-surface
- IF( ln_linssh .AND. ktrd == jptra_zad ) THEN
- tmo(jptra_sad) = SUM( ww(:,:,1) * ts(:,:,1,jp_tem,Kmm) * e1e2t(:,:) * tmask_i(:,:) )
- smo(jptra_sad) = SUM( ww(:,:,1) * ts(:,:,1,jp_sal,Kmm) * e1e2t(:,:) * tmask_i(:,:) )
- t2 (jptra_sad) = SUM( ww(:,:,1) * ts(:,:,1,jp_tem,Kmm) * ts(:,:,1,jp_tem,Kmm) * e1e2t(:,:) * tmask_i(:,:) )
- s2 (jptra_sad) = SUM( ww(:,:,1) * ts(:,:,1,jp_sal,Kmm) * ts(:,:,1,jp_sal,Kmm) * e1e2t(:,:) * tmask_i(:,:) )
- ENDIF
+ IF( ln_linssh .AND. ktrd == jptra_zad ) THEN
+ DO_2D( 0, 0, 0, 0 ) ! global sum of mask volume trend and trend*T (including interior mask)
+ zvm = ww(ji,jj,1) * e1e2t(ji,jj) * tmask_i(ji,jj)
+ tmo(jptra_sad) = tmo(jptra_sad) + ts(ji,jj,1,jp_tem,Kmm) * zvm
+ smo(jptra_sad) = smo(jptra_sad) + ts(ji,jj,1,jp_sal,Kmm) * zvm
+ t2 (jptra_sad) = t2 (jptra_sad) + ts(ji,jj,1,jp_tem,Kmm) * ts(ji,jj,1,jp_tem,Kmm) * zvm
+ s2 (jptra_sad) = s2 (jptra_sad) + ts(ji,jj,1,jp_sal,Kmm) * ts(ji,jj,1,jp_sal,Kmm) * zvm
+ END_2D
+ ENDIF
!
- IF( ktrd == jptra_atf ) THEN ! last trend (asselin time filter)
- !
- CALL glo_tra_wri( kt ) ! print the results in ocean.output
- !
- tmo(:) = 0._wp ! prepare the next time step (domain averaged array reset to zero)
- smo(:) = 0._wp
- t2 (:) = 0._wp
- s2 (:) = 0._wp
- !
- ENDIF
+ IF( ktrd == jptra_atf ) THEN ! last trend (asselin time filter)
+ !
+ CALL glo_tra_wri( kt ) ! print the results in ocean.output
+ !
+ tmo(:) = 0._wp ! prepare the next time step (domain averaged array reset to zero)
+ smo(:) = 0._wp
+ t2 (:) = 0._wp
+ s2 (:) = 0._wp
+ !
+ ENDIF
!
CASE( 'DYN' ) !== Momentum and KE ==!
- DO_3D( 1, 0, 1, 0, 1, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
zvt = ptrdx(ji,jj,jk) * tmask_i(ji+1,jj) * tmask_i(ji,jj) * umask(ji,jj,jk) &
& * e1e2u (ji,jj) * e3u(ji,jj,jk,Kmm)
zvs = ptrdy(ji,jj,jk) * tmask_i(ji,jj+1) * tmask_i(ji,jj) * vmask(ji,jj,jk) &
@@ -126,11 +130,11 @@ CONTAINS
!
IF( ktrd == jpdyn_zdf ) THEN ! zdf trend: compute separately the surface forcing trend
z1_2rho0 = 0.5_wp / rho0
- DO_2D( 1, 0, 1, 0 )
- zvt = ( utau_b(ji,jj) + utau(ji,jj) ) * tmask_i(ji+1,jj) * tmask_i(ji,jj) * umask(ji,jj,jk) &
- & * z1_2rho0 * e1e2u(ji,jj)
- zvs = ( vtau_b(ji,jj) + vtau(ji,jj) ) * tmask_i(ji,jj+1) * tmask_i(ji,jj) * vmask(ji,jj,jk) &
- & * z1_2rho0 * e1e2v(ji,jj)
+ DO_2D( 0, 0, 0, 0 )
+ zvt = ( utau_b(ji,jj) + utauU(ji,jj) ) * tmask_i(ji+1,jj) * tmask_i(ji,jj) * umask(ji,jj,jk) &
+ & * z1_2rho0 * e1e2u(ji,jj)
+ zvs = ( vtau_b(ji,jj) + vtauV(ji,jj) ) * tmask_i(ji,jj+1) * tmask_i(ji,jj) * vmask(ji,jj,jk) &
+ & * z1_2rho0 * e1e2v(ji,jj)
umo(jpdyn_tau) = umo(jpdyn_tau) + zvt
vmo(jpdyn_tau) = vmo(jpdyn_tau) + zvs
hke(jpdyn_tau) = hke(jpdyn_tau) + uu(ji,jj,1,Kmm) * zvt + vv(ji,jj,1,Kmm) * zvs
@@ -184,8 +188,7 @@ CONTAINS
INTEGER, INTENT(in) :: Kmm ! time level index
!
INTEGER :: ji, jj, jk ! dummy loop indices
- REAL(wp) :: zcof ! local scalar
- REAL(wp), DIMENSION(jpi,jpj,jpk) :: zkx, zky, zkz, zkepe
+ REAL(wp), DIMENSION(T2D(0),jpk) :: zkx, zky, zkz, zkepe
!!----------------------------------------------------------------------
! I. Momentum trends
@@ -196,24 +199,24 @@ CONTAINS
! I.1 Conversion potential energy - kinetic energy
! --------------------------------------------------
! c a u t i o n here, trends are computed at kt+1 (now , but after the swap)
- zkx (:,:,:) = 0._wp
- zky (:,:,:) = 0._wp
- zkz (:,:,:) = 0._wp
- zkepe(:,:,:) = 0._wp
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 ) ! loop from top to bottom
+ zkx (ji,jj,jk) = 0._wp
+ zky (ji,jj,jk) = 0._wp
+ zkz (ji,jj,jk) = 0._wp
+ zkepe(ji,jj,jk) = 0._wp
+ END_3D
CALL eos( ts(:,:,:,:,Kmm), rhd, rhop ) ! now potential density
- zcof = 0.5_wp / rho0 ! Density flux at w-point
- zkz(:,:,1) = 0._wp
- DO jk = 2, jpk
- zkz(:,:,jk) = zcof * e1e2t(:,:) * ww(:,:,jk) * ( rhop(:,:,jk) + rhop(:,:,jk-1) ) * tmask_i(:,:)
- END DO
+ zkz(T2D(0),1) = 0._wp
+ DO_3D( 0, 0, 0, 0, 1, jpk ) ! loop from top to bottom
+ zkz(ji,jj,jk) = xcof * e1e2t(ji,jj) * ww(ji,jj,jk) * ( rhop(ji,jj,jk) + rhop(ji,jj,jk-1) ) * tmask_i(ji,jj)
+ END_3D
- zcof = 0.5_wp / rho0 ! Density flux at u and v-points
- DO_3D( 1, 0, 1, 0, 1, jpkm1 )
- zkx(ji,jj,jk) = zcof * e2u(ji,jj) * e3u(ji,jj,jk,Kmm) &
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
+ zkx(ji,jj,jk) = xcof * e2u(ji,jj) * e3u(ji,jj,jk,Kmm) &
& * uu(ji,jj,jk,Kmm) * ( rhop(ji,jj,jk) + rhop(ji+1,jj,jk) )
- zky(ji,jj,jk) = zcof * e1v(ji,jj) * e3v(ji,jj,jk,Kmm) &
+ zky(ji,jj,jk) = xcof * e1v(ji,jj) * e3v(ji,jj,jk,Kmm) &
& * vv(ji,jj,jk,Kmm) * ( rhop(ji,jj,jk) + rhop(ji,jj+1,jk) )
END_3D
@@ -227,10 +230,9 @@ CONTAINS
! I.2 Basin averaged kinetic energy trend
! ----------------------------------------
peke = 0._wp
- DO jk = 1, jpkm1
- peke = peke + SUM( zkepe(:,:,jk) * gdept(:,:,jk,Kmm) * e1e2t(:,:) &
- & * e3t(:,:,jk,Kmm) )
- END DO
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 ) ! loop from top to bottom
+ peke = peke + zkepe(ji,jj,jk) * gdept(ji,jj,jk,Kmm) * e1e2t(ji,jj) * e3t(ji,jj,jk,Kmm)
+ END_3D
peke = grav * peke
! I.3 Sums over the global domain
@@ -509,11 +511,14 @@ CONTAINS
WRITE(numout,*) '~~~~~~~~~~~~~'
ENDIF
+ xcof = 0.5_wp / rho0
+
! Total volume at t-points:
tvolt = 0._wp
- DO jk = 1, jpkm1
- tvolt = tvolt + SUM( e1e2t(:,:) * e3t(:,:,jk,Kmm) * tmask(:,:,jk) * tmask_i(:,:) )
- END DO
+
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 ) ! Density flux divergence at t-point
+ tvolt = tvolt + e1e2t(ji,jj) * e3t(ji,jj,jk,Kmm) * tmask(ji,jj,jk) * tmask_i(ji,jj)
+ END_3D
CALL mpp_sum( 'trdglo', tvolt ) ! sum over the global domain
IF(lwp) WRITE(numout,*) ' total ocean volume at T-point tvolt = ',tvolt
diff --git a/src/OCE/TRD/trdken.F90 b/src/OCE/TRD/trdken.F90
index d97b3eb80a37e9db31884014b55435e2ba3547cc..6b0595fcf83553d1a47f9a74af93d0eb3199beb9 100644
--- a/src/OCE/TRD/trdken.F90
+++ b/src/OCE/TRD/trdken.F90
@@ -30,6 +30,10 @@ MODULE trdken
IMPLICIT NONE
PRIVATE
+ !! * Substitutions
+# include "do_loop_substitute.h90"
+# include "domzgr_substitute.h90"
+
PUBLIC trd_ken ! called by trddyn module
PUBLIC trd_ken_init ! called by trdini module
@@ -38,9 +42,6 @@ MODULE trdken
REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: bu, bv ! volume of u- and v-boxes
REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: r1_bt ! inverse of t-box volume
- !! * Substitutions
-# include "do_loop_substitute.h90"
-# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
!! $Id: trdken.F90 15104 2021-07-07 14:36:00Z clem $
@@ -52,7 +53,7 @@ CONTAINS
!!---------------------------------------------------------------------
!! *** FUNCTION trd_ken_alloc ***
!!---------------------------------------------------------------------
- ALLOCATE( bu(jpi,jpj,jpk) , bv(jpi,jpj,jpk) , r1_bt(jpi,jpj,jpk) , STAT= trd_ken_alloc )
+ ALLOCATE( bu(T2D(0),jpk) , bv(T2D(0),jpk) , r1_bt(T2D(0),jpk) , STAT= trd_ken_alloc )
!
CALL mpp_sum ( 'trdken', trd_ken_alloc )
IF( trd_ken_alloc /= 0 ) CALL ctl_stop( 'STOP', 'trd_ken_alloc: failed to allocate arrays' )
@@ -77,31 +78,32 @@ CONTAINS
!
!
!!----------------------------------------------------------------------
- REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: putrd, pvtrd ! U and V masked trends
- INTEGER , INTENT(in ) :: ktrd ! trend index
- INTEGER , INTENT(in ) :: kt ! time step
- INTEGER , INTENT(in ) :: Kmm ! time level index
+ REAL(wp), DIMENSION(:,:,:) , INTENT(inout) :: putrd, pvtrd ! U and V masked trends
+ INTEGER , INTENT(in ) :: ktrd ! trend index
+ INTEGER , INTENT(in ) :: kt ! time step
+ INTEGER , INTENT(in ) :: Kmm ! time level index
!
INTEGER :: ji, jj, jk ! dummy loop indices
INTEGER :: ikbu , ikbv ! local integers
INTEGER :: ikbum1, ikbvm1 ! - -
- REAL(wp), DIMENSION(:,:), ALLOCATABLE :: z2dx, z2dy, zke2d ! 2D workspace
- REAL(wp), DIMENSION(jpi,jpj,jpk) :: zke ! 3D workspace
+ REAL(wp), DIMENSION(:,:), ALLOCATABLE :: zke2d ! 2D workspace
+ REAL(wp) :: z2dx, z2dy, z2dxm1, z2dym1 ! 2D workspace
+ REAL(wp), DIMENSION(T2D(0),jpk) :: zke ! 3D workspace
!!----------------------------------------------------------------------
!
CALL lbc_lnk( 'trdken', putrd, 'U', -1.0_wp , pvtrd, 'V', -1.0_wp ) ! lateral boundary conditions
!
nkstp = kt
DO jk = 1, jpkm1
- bu (:,:,jk) = e1e2u(:,:) * e3u(:,:,jk,Kmm)
- bv (:,:,jk) = e1e2v(:,:) * e3v(:,:,jk,Kmm)
- r1_bt(:,:,jk) = r1_e1e2t(:,:) / e3t(:,:,jk,Kmm) * tmask(:,:,jk)
+ DO_2D( 0, 0, 0, 0 )
+ bu (ji,jj,jk) = e1e2u(ji,jj) * e3u(ji,jj,jk,Kmm)
+ bv (ji,jj,jk) = e1e2v(ji,jj) * e3v(ji,jj,jk,Kmm)
+ r1_bt(ji,jj,jk) = r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) * tmask(ji,jj,jk)
+ END_2D
END DO
!
- zke(:,:,jpk) = 0._wp
- zke(1:nn_hls,:, : ) = 0._wp
- zke(:,1:nn_hls, : ) = 0._wp
- DO_3D( 0, nn_hls, 0, nn_hls, 1, jpkm1 )
+ zke(T2D(0),:) = 0._wp
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
zke(ji,jj,jk) = 0.5_wp * rho0 *( uu(ji ,jj,jk,Kmm) * putrd(ji ,jj,jk) * bu(ji ,jj,jk) &
& + uu(ji-1,jj,jk,Kmm) * putrd(ji-1,jj,jk) * bu(ji-1,jj,jk) &
& + vv(ji,jj ,jk,Kmm) * pvtrd(ji,jj ,jk) * bv(ji,jj ,jk) &
@@ -118,35 +120,31 @@ CONTAINS
CASE( jpdyn_ldf ) ; CALL iom_put( "ketrd_ldf" , zke ) ! lateral diffusion
CASE( jpdyn_zdf ) ; CALL iom_put( "ketrd_zdf" , zke ) ! vertical diffusion
! ! ! wind stress trends
- ALLOCATE( z2dx(jpi,jpj) , z2dy(jpi,jpj) , zke2d(jpi,jpj) )
- z2dx(:,:) = uu(:,:,1,Kmm) * ( utau_b(:,:) + utau(:,:) ) * e1e2u(:,:) * umask(:,:,1)
- z2dy(:,:) = vv(:,:,1,Kmm) * ( vtau_b(:,:) + vtau(:,:) ) * e1e2v(:,:) * vmask(:,:,1)
- zke2d(1:nn_hls,:) = 0._wp ; zke2d(:,1:nn_hls) = 0._wp
- DO_2D( 0, nn_hls, 0, nn_hls )
- zke2d(ji,jj) = r1_rho0 * 0.5_wp * ( z2dx(ji,jj) + z2dx(ji-1,jj) &
- & + z2dy(ji,jj) + z2dy(ji,jj-1) ) * r1_bt(ji,jj,1)
- END_2D
+ ALLOCATE( zke2d(T2D(0)) ) ; zke2d(T2D(0)) = 0._wp
+ DO_2D( 0, 0, 0, 0 )
+ z2dx = uu(ji,jj,1,Kmm) * ( utau_b(ji,jj) + utauU(ji,jj) ) * e1e2u(ji,jj) * umask(ji,jj,1)
+ z2dy = vv(ji,jj,1,Kmm) * ( vtau_b(ji,jj) + vtauV(ji,jj) ) * e1e2v(ji,jj) * vmask(ji,jj,1)
+ z2dxm1 = uu(ji-1,jj,1,Kmm) * ( utau_b(ji-1,jj) + utauU(ji-1,jj) ) * e1e2u(ji-1,jj) * umask(ji-1,jj,1)
+ z2dym1 = vv(ji,jj-1,1,Kmm) * ( vtau_b(ji,jj-1) + vtauV(ji,jj-1) ) * e1e2v(ji,jj-1) * vmask(ji,jj-1,1)
+ zke2d(ji,jj) = r1_rho0 * 0.5_wp * ( z2dx + z2dxm1 + z2dy + z2dym1 ) * r1_bt(ji,jj,1)
+ END_2D
CALL iom_put( "ketrd_tau" , zke2d ) !
- DEALLOCATE( z2dx , z2dy , zke2d )
+ DEALLOCATE( zke2d )
CASE( jpdyn_bfr ) ; CALL iom_put( "ketrd_bfr" , zke ) ! bottom friction (explicit case)
!!gm TO BE DONE properly
!!gm only valid if ln_drgimp=F otherwise the bottom stress as to be recomputed at the end of the computation....
! IF(.NOT. ln_drgimp) THEN
-! DO jj = 1, jpj !
-! DO ji = 1, jpi
-! ikbu = mbku(ji,jj) ! deepest ocean u- & v-levels
-! ikbv = mbkv(ji,jj)
-! z2dx(ji,jj) = uu(ji,jj,ikbu,Kmm) * bfrua(ji,jj) * uu(ji,jj,ikbu,Kmm)
-! z2dy(ji,jj) = vv(ji,jj,ikbu,Kmm) * bfrva(ji,jj) * vv(ji,jj,ikbv,Kmm)
-! END DO
-! END DO
+! zke2d(T2D(0)) = 0._wp
+! DO_2D( 0, 0, 0, 0 )
+! ikbu = mbku(ji,jj) ! deepest ocean u- & v-levels
+! ikbv = mbkv(ji,jj)
+! z2dx = uu(ji,jj,ikbu,Kmm) * bfrua(ji,jj) * uu(ji,jj,ikbu,Kmm)
+! z2dy = vv(ji,jj,ikbu,Kmm) * bfrva(ji,jj) * vv(ji,jj,ikbv,Kmm)
+! z2dxm1 = uu(ji-1,jj,ikbu,Kmm) * bfrua(ji-1,jj) * uu(ji-1,jj,ikbu,Kmm)
+! z2dym1 = vv(ji,jj-1,ikbu,Kmm) * bfrva(ji,jj-1) * vv(ji,jj-1,ikbv,Kmm)
+! zke2d(ji,jj) = 0.5_wp * ( z2dx + z2dxm1 + z2dy + z2dym1 ) * r1_bt(ji,jj,1)
+! END_2D
! zke2d(1,:) = 0._wp ; zke2d(:,1) = 0._wp
-! DO jj = 2, jpj
-! DO ji = 2, jpi
-! zke2d(ji,jj) = 0.5_wp * ( z2dx(ji,jj) + z2dx(ji-1,jj) &
-! & + z2dy(ji,jj) + z2dy(ji,jj-1) ) * r1_bt(ji,jj, BEURK!!!
-! END DO
-! END DO
! CALL iom_put( "ketrd_bfr" , zke2d ) ! bottom friction (explicit case)
! ENDIF
!!gm end
@@ -175,11 +173,11 @@ CONTAINS
CASE( jpdyn_ken ) ; ! kinetic energy
! called in dynnxt.F90 before asselin time filter
! with putrd=uu(Krhs) and pvtrd=vv(Krhs)
- zke(:,:,:) = 0.5_wp * zke(:,:,:)
+ zke(T2D(0),:) = 0.5_wp * zke(T2D(0),:)
CALL iom_put( "KE", zke )
!
CALL ken_p2k( kt , zke, Kmm )
- CALL iom_put( "ketrd_convP2K", zke ) ! conversion -rau*g*w
+ CALL iom_put( "ketrd_convP2K", zke ) ! conversion -rau*g*w
!
END SELECT
!
@@ -203,22 +201,23 @@ CONTAINS
INTEGER :: ji, jj, jk ! dummy loop indices
INTEGER :: iku, ikv ! local integers
REAL(wp) :: zcoef ! local scalars
- REAL(wp), DIMENSION(jpi,jpj,jpk) :: zconv ! 3D workspace
+ REAL(wp), DIMENSION(T2D(0),jpk) :: zconv ! 3D workspace
!!----------------------------------------------------------------------
!
! Local constant initialization
zcoef = - rho0 * grav * 0.5_wp
! Surface value (also valid in partial step case)
- zconv(:,:,1) = zcoef * ( 2._wp * rhd(:,:,1) ) * ww(:,:,1) * e3w(:,:,1,Kmm)
-
+ DO_2D( 0, 0, 0, 0 )
+ zconv(ji,jj,1) = zcoef * ( 2._wp * rhd(ji,jj,1) ) * ww(ji,jj,1) * e3w(ji,jj,1,Kmm)
+ END_2D
! interior value (2=<jk=<jpkm1)
- DO jk = 2, jpk
- zconv(:,:,jk) = zcoef * ( rhd(:,:,jk) + rhd(:,:,jk-1) ) * ww(:,:,jk) * e3w(:,:,jk,Kmm)
- END DO
+ DO_3D( 0, 0, 0, 0 , 2, jpk )
+ zconv(ji,jj,jk) = zcoef * ( rhd(ji,jj,jk) + rhd(ji,jj,jk-1) ) * ww(ji,jj,jk) * e3w(ji,jj,jk,Kmm)
+ END_3D
! conv value on T-point
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
zcoef = 0.5_wp / e3t(ji,jj,jk,Kmm)
pconv(ji,jj,jk) = zcoef * ( zconv(ji,jj,jk) + zconv(ji,jj,jk+1) ) * tmask(ji,jj,jk)
END_3D
diff --git a/src/OCE/TRD/trdmxl.F90 b/src/OCE/TRD/trdmxl.F90
index bce0dd5367ca329c9588297506059ddc4f662177..f9fab190d9726bbccfc135cadfe4ffd49bfe6542 100644
--- a/src/OCE/TRD/trdmxl.F90
+++ b/src/OCE/TRD/trdmxl.F90
@@ -45,20 +45,7 @@ MODULE trdmxl
PUBLIC trd_mxl_init ! routine called by opa.F90
PUBLIC trd_mxl_zint ! routine called by tracers routines
- INTEGER :: nkstp ! current time step
-
-!!gm to be moved from trdmxl_oce
-! REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: hml ! ML depth (sum of e3t over nmln-1 levels) [m]
-! REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: tml , sml ! now ML averaged T & S
-! REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: tmlb_nf, smlb_nf ! not filtered before ML averaged T & S
-!
-!
-! REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: hmlb, hmln ! before, now, and after Mixed Layer depths [m]
-!
-! REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: tb_mlb, tb_mln ! before (not filtered) tracer averaged over before and now ML
-!
-! REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: tn_mln ! now tracer averaged over now ML
-!!gm end
+ INTEGER :: nkstp ! current time step
CHARACTER (LEN=40) :: clhstnam ! name of the trends NetCDF file
INTEGER :: nh_t, nmoymltrd
@@ -111,44 +98,41 @@ CONTAINS
IF ( kt /= nkstp ) THEN != 1st call at kt time step =!
! !==============================!
nkstp = kt
-
-
! !== reset trend arrays to zero ==!
- tmltrd(:,:,:) = 0._wp ; smltrd(:,:,:) = 0._wp
-
-
+ DO_3D( 0, 0, 0, 0, 1, jpktrd )
+ tmltrd(ji,jj,jk) = 0._wp
+ smltrd(ji,jj,jk) = 0._wp
+ END_3D
!
- wkx(:,:,:) = 0._wp !== now ML weights for vertical averaging ==!
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpktrd ) ! initialize wkx with vertical scale factor in mixed-layer
+ ! !== now ML weights for vertical averaging ==!
+ DO_3D( 0, 0, 0, 0, 1, jpktrd ) ! initialize wkx with vertical scale factor in mixed-layer
IF( jk - kmxln(ji,jj) < 0 ) THEN
wkx(ji,jj,jk) = e3t(ji,jj,jk,Kmm) * tmask(ji,jj,jk)
+ ELSE
+ wkx(ji,jj,jk) = 0._wp
ENDIF
END_3D
+ !
hmxl(:,:) = 0._wp ! NOW mixed-layer depth
- DO jk = 1, jpktrd
- hmxl(:,:) = hmxl(:,:) + wkx(:,:,jk)
- END DO
- DO jk = 1, jpktrd ! integration weights
- wkx(:,:,jk) = wkx(:,:,jk) / MAX( 1.e-20_wp, hmxl(:,:) ) * tmask(:,:,1)
- END DO
-
-
+ DO_3D( 0, 0, 0, 0, 1, jpktrd )
+ hmxl(ji,jj) = hmxl(ji,jj) + wkx(ji,jj,jk)
+ wkx (ji,jj,jk) = wkx (ji,jj,jk) / MAX( 1.e-20_wp, hmxl(ji,jj) ) * tmask(ji,jj,1)
+ END_3D
!
! !== Vertically averaged T and S ==!
tml(:,:) = 0._wp ; sml(:,:) = 0._wp
- DO jk = 1, jpktrd
- tml(:,:) = tml(:,:) + wkx(:,:,jk) * ts(:,:,jk,jp_tem,Kmm)
- sml(:,:) = sml(:,:) + wkx(:,:,jk) * ts(:,:,jk,jp_sal,Kmm)
- END DO
+ DO_3D( 0, 0, 0, 0, 1, jpktrd )
+ tml(ji,jj) = tml(ji,jj) + wkx(ji,jj,jk) * ts(ji,jj,jk,jp_tem,Kmm)
+ sml(ji,jj) = sml(ji,jj) + wkx(ji,jj,jk) * ts(ji,jj,jk,jp_sal,Kmm)
+ END_3D
!
ENDIF
-
-
! mean now trends over the now ML
- tmltrd(:,:,ktrd) = tmltrd(:,:,ktrd) + ptrdx(:,:,jk) * wkx(:,:,jk) ! temperature
- smltrd(:,:,ktrd) = smltrd(:,:,ktrd) + ptrdy(:,:,jk) * wkx(:,:,jk) ! salinity
-
+ DO_2D( 0, 0, 0, 0 )
+ tmltrd(ji,jj,ktrd) = tmltrd(ji,jj,ktrd) + ptrdx(ji,jj,jk) * wkx(ji,jj,jk) ! temperature
+ smltrd(ji,jj,ktrd) = smltrd(ji,jj,ktrd) + ptrdy(ji,jj,jk) * wkx(ji,jj,jk) ! salinity
+ END_2D
!!gm to be put juste before the output !
@@ -249,11 +233,11 @@ CONTAINS
!!----------------------------------------------------------------------
INTEGER , INTENT( in ) :: ktrd ! ocean trend index
CHARACTER(len=2) , INTENT( in ) :: ctype ! 2D surface/bottom or 3D interior physics
- REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT( in ) :: pttrdmxl ! temperature trend
- REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT( in ) :: pstrdmxl ! salinity trend
+ REAL(wp), DIMENSION(T2D(0),jpk), INTENT( in ) :: pttrdmxl ! temperature trend
+ REAL(wp), DIMENSION(T2D(0),jpk), INTENT( in ) :: pstrdmxl ! salinity trend
!
INTEGER :: ji, jj, jk, isum
- REAL(wp), DIMENSION(jpi,jpj) :: zvlmsk
+ REAL(wp), DIMENSION(T2D(0)) :: zvlmsk
!!----------------------------------------------------------------------
! I. Definition of control surface and associated fields
@@ -268,11 +252,13 @@ CONTAINS
! ... Set nmxl(ji,jj) = index of first T point below control surf. or outside mixed-layer
- IF( nn_ctls == 0 ) THEN ! * control surface = mixed-layer with density criterion
- nmxl(:,:) = nmln(:,:) ! array nmln computed in zdfmxl.F90
- ELSEIF( nn_ctls == 1 ) THEN ! * control surface = read index from file
+ IF( nn_ctls == 0 ) THEN ! * control surface = mixed-layer with density criterion
+ DO_2D( 0, 0, 0, 0 )
+ nmxl(ji,jj) = nmln(ji,jj) ! array nmln computed in zdfmxl.F90
+ END_2D
+ ELSEIF( nn_ctls == 1 ) THEN ! * control surface = read index from file
nmxl(:,:) = nbol(:,:)
- ELSEIF( nn_ctls >= 2 ) THEN ! * control surface = model level
+ ELSEIF( nn_ctls >= 2 ) THEN ! * control surface = model level
nn_ctls = MIN( nn_ctls, jpktrd - 1 )
nmxl(:,:) = nn_ctls + 1
ENDIF
@@ -335,9 +321,9 @@ CONTAINS
REAL(wp) :: zavt, zfn, zfn2
! ! z(ts)mltot : dT/dt over the anlysis window (including Asselin)
! ! z(ts)mlres : residual = dh/dt entrainment term
- REAL(wp), DIMENSION(jpi,jpj ) :: ztmltot , zsmltot , ztmlres , zsmlres , ztmlatf , zsmlatf
- REAL(wp), DIMENSION(jpi,jpj ) :: ztmltot2, zsmltot2, ztmlres2, zsmlres2, ztmlatf2, zsmlatf2, ztmltrdm2, zsmltrdm2
- REAL(wp), DIMENSION(jpi,jpj,jpk) :: ztmltrd2, zsmltrd2 ! only needed for mean diagnostics
+ REAL(wp), DIMENSION(T2D(0) ) :: ztmltot , zsmltot , ztmlres , zsmlres , ztmlatf , zsmlatf
+ REAL(wp), DIMENSION(T2D(0) ) :: ztmltot2, zsmltot2, ztmlres2, zsmlres2, ztmlatf2, zsmlatf2, ztmltrdm2, zsmltrdm2
+ REAL(wp), DIMENSION(T2D(0),jpk) :: ztmltrd2, zsmltrd2 ! only needed for mean diagnostics
!!----------------------------------------------------------------------
! ======================================================================
@@ -446,12 +432,7 @@ CONTAINS
itmod = kt - nit000 + 1
MODULO_NTRD : IF( MOD( itmod, nn_trd ) == 0 ) THEN ! nitend MUST be multiple of nn_trd
- !
- ztmltot (:,:) = 0.e0 ; zsmltot (:,:) = 0.e0 ! reset arrays to zero
- ztmlres (:,:) = 0.e0 ; zsmlres (:,:) = 0.e0
- ztmltot2(:,:) = 0.e0 ; zsmltot2(:,:) = 0.e0
- ztmlres2(:,:) = 0.e0 ; zsmlres2(:,:) = 0.e0
-
+ !
zfn = REAL( nmoymltrd, wp ) ; zfn2 = zfn * zfn
! III.1 Prepare fields for output ("instantaneous" diagnostics)
@@ -469,25 +450,18 @@ CONTAINS
ztmlatf(:,:) = tmlatfm(:,:) - tmlatfn(:,:) + tmlatfb(:,:)
zsmlatf(:,:) = smlatfm(:,:) - smlatfn(:,:) + smlatfb(:,:)
- !-- Lateral boundary conditions
- ! ... temperature ... ... salinity ...
- CALL lbc_lnk( 'trdmxl', ztmltot , 'T', 1.0_wp, zsmltot , 'T', 1.0_wp, &
- & ztmlres , 'T', 1.0_wp, zsmlres , 'T', 1.0_wp, &
- & ztmlatf , 'T', 1.0_wp, zsmlatf , 'T', 1.0_wp )
-
-
! III.2 Prepare fields for output ("mean" diagnostics)
! ----------------------------------------------------
!-- Update the ML depth time sum (to build the Leap-Frog time mean)
- hmxl_sum(:,:) = hmxlbn(:,:) + 2 * ( hmxl_sum(:,:) - hmxl(:,:) ) + hmxl(:,:)
+ hmxl_sum(:,:) = hmxlbn(:,:) + 2._wp * ( hmxl_sum(:,:) - hmxl(:,:) ) + hmxl(:,:)
!-- Compute temperature total trends
- tml_sum (:,:) = tmlbn(:,:) + 2 * ( tml_sum(:,:) - tml(:,:) ) + tml(:,:)
+ tml_sum (:,:) = tmlbn(:,:) + 2._wp * ( tml_sum(:,:) - tml(:,:) ) + tml(:,:)
ztmltot2(:,:) = ( tml_sum(:,:) - tml_sumb(:,:) ) / p2dt ! now in degC/s
!-- Compute salinity total trends
- sml_sum (:,:) = smlbn(:,:) + 2 * ( sml_sum(:,:) - sml(:,:) ) + sml(:,:)
+ sml_sum (:,:) = smlbn(:,:) + 2._wp * ( sml_sum(:,:) - sml(:,:) ) + sml(:,:)
zsmltot2(:,:) = ( sml_sum(:,:) - sml_sumb(:,:) ) / p2dt ! now in psu/s
!-- Compute temperature residuals
@@ -495,7 +469,7 @@ CONTAINS
ztmltrd2(:,:,jl) = tmltrd_csum_ub(:,:,jl) + tmltrd_csum_ln(:,:,jl)
END DO
- ztmltrdm2(:,:) = 0.e0
+ ztmltrdm2(:,:) = 0._wp
DO jl = 1, jpltrd
ztmltrdm2(:,:) = ztmltrdm2(:,:) + ztmltrd2(:,:,jl)
END DO
@@ -508,7 +482,7 @@ CONTAINS
zsmltrd2(:,:,jl) = smltrd_csum_ub(:,:,jl) + smltrd_csum_ln(:,:,jl)
END DO
- zsmltrdm2(:,:) = 0.
+ zsmltrdm2(:,:) = 0._wp
DO jl = 1, jpltrd
zsmltrdm2(:,:) = zsmltrdm2(:,:) + zsmltrd2(:,:,jl)
END DO
@@ -519,13 +493,6 @@ CONTAINS
!-- Diagnose Asselin trend over the analysis window
ztmlatf2(:,:) = ztmltrd2(:,:,jpmxl_atf) - tmltrd_sum(:,:,jpmxl_atf) + tmltrd_atf_sumb(:,:)
zsmlatf2(:,:) = zsmltrd2(:,:,jpmxl_atf) - smltrd_sum(:,:,jpmxl_atf) + smltrd_atf_sumb(:,:)
-
- !-- Lateral boundary conditions
- ! ... temperature ... ... salinity ...
- CALL lbc_lnk( 'trdmxl', ztmltot2, 'T', 1.0_wp, zsmltot2, 'T', 1.0_wp, &
- & ztmlres2, 'T', 1.0_wp, zsmlres2, 'T', 1.0_wp )
- !
- CALL lbc_lnk( 'trdmxl', ztmltrd2(:,:,:), 'T', 1.0_wp, zsmltrd2(:,:,:), 'T', 1.0_wp ) ! / in the NetCDF trends file
! III.3 Time evolution array swap
! -------------------------------
@@ -622,6 +589,8 @@ CONTAINS
! ======================================================================
!-- Write the trends for T/S instantaneous diagnostics
+
+ ! clem => these fields do not exist in field_def
IF( ln_trdmxl_instant ) THEN
diff --git a/src/OCE/TRD/trdmxl_oce.F90 b/src/OCE/TRD/trdmxl_oce.F90
index c2d4d4be9da076a4dbb7d7eb4cc08370bfd5e485..728ec10d1985b78bf8e9d16a763eca4266955d1e 100644
--- a/src/OCE/TRD/trdmxl_oce.F90
+++ b/src/OCE/TRD/trdmxl_oce.F90
@@ -80,6 +80,8 @@ MODULE trdmxl_oce
smltrd_csum_ln, & !: ( idem for salinity )
smltrd_csum_ub !:
+ !! * Substitutions
+# include "do_loop_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
!! $Id: trdmxl_oce.F90 10425 2018-12-19 21:54:16Z smasson $
@@ -101,29 +103,29 @@ CONTAINS
ierr(:) = 0
- ALLOCATE( nmxl (jpi,jpj) , nbol (jpi,jpj), &
- & wkx (jpi,jpj,jpk), hmxl (jpi,jpj), &
- & tml (jpi,jpj) , sml (jpi,jpj), &
- & tmlb (jpi,jpj) , smlb (jpi,jpj), &
- & tmlbb(jpi,jpj) , smlbb(jpi,jpj), STAT = ierr(1) )
-
- ALLOCATE( tmlbn(jpi,jpj) , smlbn(jpi,jpj), &
- & tmltrdm(jpi,jpj), smltrdm(jpi,jpj), &
- & tml_sum(jpi,jpj), tml_sumb(jpi,jpj),&
- & tmltrd_atf_sumb(jpi,jpj) , STAT=ierr(2) )
-
- ALLOCATE( sml_sum(jpi,jpj), sml_sumb(jpi,jpj), &
- & smltrd_atf_sumb(jpi,jpj), &
- & hmxl_sum(jpi,jpj), hmxlbn(jpi,jpj), &
- & tmlatfb(jpi,jpj), tmlatfn(jpi,jpj), STAT = ierr(3) )
-
- ALLOCATE( smlatfb(jpi,jpj), smlatfn(jpi,jpj), &
- & tmlatfm(jpi,jpj), smlatfm(jpi,jpj), &
- & tmltrd(jpi,jpj,jpltrd), smltrd(jpi,jpj,jpltrd), STAT=ierr(4))
-
- ALLOCATE( tmltrd_sum(jpi,jpj,jpltrd),tmltrd_csum_ln(jpi,jpj,jpltrd), &
- & tmltrd_csum_ub(jpi,jpj,jpltrd), smltrd_sum(jpi,jpj,jpltrd), &
- & smltrd_csum_ln(jpi,jpj,jpltrd), smltrd_csum_ub(jpi,jpj,jpltrd), STAT=ierr(5) )
+ ALLOCATE( nmxl (T2D(0)) , nbol (T2D(0)), &
+ & wkx (T2D(0),jpk), hmxl (T2D(0)), &
+ & tml (T2D(0)) , sml (T2D(0)), &
+ & tmlb (T2D(0)) , smlb (T2D(0)), &
+ & tmlbb(T2D(0)) , smlbb(T2D(0)), STAT = ierr(1) )
+
+ ALLOCATE( tmlbn(T2D(0)) , smlbn(T2D(0)), &
+ & tmltrdm(T2D(0)), smltrdm(T2D(0)), &
+ & tml_sum(T2D(0)), tml_sumb(T2D(0)),&
+ & tmltrd_atf_sumb(T2D(0)) , STAT=ierr(2) )
+
+ ALLOCATE( sml_sum(T2D(0)), sml_sumb(T2D(0)), &
+ & smltrd_atf_sumb(T2D(0)), &
+ & hmxl_sum(T2D(0)), hmxlbn(T2D(0)), &
+ & tmlatfb(T2D(0)), tmlatfn(T2D(0)), STAT = ierr(3) )
+
+ ALLOCATE( smlatfb(T2D(0)), smlatfn(T2D(0)), &
+ & tmlatfm(T2D(0)), smlatfm(T2D(0)), &
+ & tmltrd(T2D(0),jpltrd), smltrd(T2D(0),jpltrd), STAT=ierr(4))
+
+ ALLOCATE( tmltrd_sum(T2D(0),jpltrd),tmltrd_csum_ln(T2D(0),jpltrd), &
+ & tmltrd_csum_ub(T2D(0),jpltrd), smltrd_sum(T2D(0),jpltrd), &
+ & smltrd_csum_ln(T2D(0),jpltrd), smltrd_csum_ub(T2D(0),jpltrd), STAT=ierr(5) )
!
trdmxl_oce_alloc = MAXVAL( ierr )
CALL mpp_sum ( 'trdmxl_oce', trdmxl_oce_alloc )
diff --git a/src/OCE/TRD/trdpen.F90 b/src/OCE/TRD/trdpen.F90
index 0c356f841b8ef2122ddc847db98675675c1d8eaf..c21ba9b18b883be207e14808a4b5aca50aa4af9f 100644
--- a/src/OCE/TRD/trdpen.F90
+++ b/src/OCE/TRD/trdpen.F90
@@ -35,6 +35,7 @@ MODULE trdpen
REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: rab_pe ! partial derivatives of PE anomaly with respect to T and S
!! * Substitutions
+# include "do_loop_substitute.h90"
# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
@@ -48,7 +49,7 @@ CONTAINS
!!---------------------------------------------------------------------
!! *** FUNCTION trd_tra_alloc ***
!!---------------------------------------------------------------------
- ALLOCATE( rab_pe(jpi,jpj,jpk,jpts) , STAT= trd_pen_alloc )
+ ALLOCATE( rab_pe(T2D(0),jpk,jpts) , STAT= trd_pen_alloc )
!
CALL mpp_sum ( 'trdpen', trd_pen_alloc )
IF( trd_pen_alloc /= 0 ) CALL ctl_stop( 'STOP', 'trd_pen_alloc: failed to allocate arrays' )
@@ -69,37 +70,40 @@ CONTAINS
INTEGER , INTENT(in) :: Kmm ! time level index
REAL(wp) , INTENT(in) :: pdt ! time step [s]
!
- INTEGER :: jk ! dummy loop indices
- REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: z2d ! 2D workspace
- REAL(wp), DIMENSION(jpi,jpj,jpk) :: zpe ! 3D workspace
+ INTEGER :: ji, jj, jk ! dummy loop indices
+ REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: z2d ! 2D workspace
+ REAL(wp), DIMENSION(T2D(0),jpk) :: zpe ! 3D workspace
!!----------------------------------------------------------------------
!
- zpe(:,:,:) = 0._wp
+ zpe(T2D(0),:) = 0._wp
!
IF( kt /= nkstp ) THEN ! full eos: set partial derivatives at the 1st call of kt time step
nkstp = kt
- CALL eos_pen( ts(:,:,:,:,Kmm), rab_PE, zpe, Kmm )
+ CALL eos_pen( ts(:,:,:,:,Kmm), rab_pe, zpe, Kmm )
CALL iom_put( "alphaPE", rab_pe(:,:,:,jp_tem) )
CALL iom_put( "betaPE" , rab_pe(:,:,:,jp_sal) )
CALL iom_put( "PEanom" , zpe )
ENDIF
!
- zpe(:,:,jpk) = 0._wp
- DO jk = 1, jpkm1
- zpe(:,:,jk) = ( - ( rab_n(:,:,jk,jp_tem) + rab_pe(:,:,jk,jp_tem) ) * ptrdx(:,:,jk) &
- & + ( rab_n(:,:,jk,jp_sal) + rab_pe(:,:,jk,jp_sal) ) * ptrdy(:,:,jk) )
- END DO
+ zpe(T2D(0),jpk) = 0._wp
+ !
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
+ zpe(ji,jj,jk) = ( - ( rab_n(ji,jj,jk,jp_tem) + rab_pe(ji,jj,jk,jp_tem) ) * ptrdx(ji,jj,jk) &
+ & + ( rab_n(ji,jj,jk,jp_sal) + rab_pe(ji,jj,jk,jp_sal) ) * ptrdy(ji,jj,jk) )
+ END_3D
SELECT CASE ( ktrd )
CASE ( jptra_xad ) ; CALL iom_put( "petrd_xad", zpe ) ! zonal advection
CASE ( jptra_yad ) ; CALL iom_put( "petrd_yad", zpe ) ! merid. advection
CASE ( jptra_zad ) ; CALL iom_put( "petrd_zad", zpe ) ! vertical advection
IF( ln_linssh ) THEN ! cst volume : adv flux through z=0 surface
- ALLOCATE( z2d(jpi,jpj) )
- z2d(:,:) = ww(:,:,1) * ( &
- & - ( rab_n(:,:,1,jp_tem) + rab_pe(:,:,1,jp_tem) ) * ts(:,:,1,jp_tem,Kmm) &
- & + ( rab_n(:,:,1,jp_sal) + rab_pe(:,:,1,jp_sal) ) * ts(:,:,1,jp_sal,Kmm) &
- & ) / e3t(:,:,1,Kmm)
+ ALLOCATE( z2d(T2D(0)) )
+ DO_2D( 0, 0, 0, 0 )
+ z2d(ji,jj) = ww(ji,jj,1) * ( &
+ & - ( rab_n(ji,jj,1,jp_tem) + rab_pe(ji,jj,1,jp_tem) ) * ts(ji,jj,1,jp_tem,Kmm) &
+ & + ( rab_n(ji,jj,1,jp_sal) + rab_pe(ji,jj,1,jp_sal) ) * ts(ji,jj,1,jp_sal,Kmm) &
+ & ) / e3t(ji,jj,1,Kmm)
+ END_2D
CALL iom_put( "petrd_sad" , z2d )
DEALLOCATE( z2d )
ENDIF
diff --git a/src/OCE/TRD/trdtra.F90 b/src/OCE/TRD/trdtra.F90
index a3377863268e3c79e108bfaebad9e761281bfac5..b073b1b79ae86eff0403ac016e94d6df84f4d64b 100644
--- a/src/OCE/TRD/trdtra.F90
+++ b/src/OCE/TRD/trdtra.F90
@@ -53,7 +53,7 @@ CONTAINS
!!---------------------------------------------------------------------
!! *** FUNCTION trd_tra_alloc ***
!!---------------------------------------------------------------------
- ALLOCATE( trdtx(jpi,jpj,jpk) , trdty(jpi,jpj,jpk) , trdt(jpi,jpj,jpk) , avt_evd(jpi,jpj,jpk), STAT= trd_tra_alloc )
+ ALLOCATE( trdtx(T2D(0),jpk), trdty(T2D(0),jpk), trdt(T2D(0),jpk), avt_evd(T2D(0),jpk), STAT= trd_tra_alloc )
!
CALL mpp_sum ( 'trdtra', trd_tra_alloc )
IF( trd_tra_alloc /= 0 ) CALL ctl_stop( 'STOP', 'trd_tra_alloc: failed to allocate arrays' )
@@ -73,24 +73,25 @@ CONTAINS
!! - 'TRA' case : regroup T & S trends
!! - send the trends to trd_tra_mng (trdtrc) for further processing
!!----------------------------------------------------------------------
- INTEGER , INTENT(in) :: kt ! time step
- CHARACTER(len=3) , INTENT(in) :: ctype ! tracers trends type 'TRA'/'TRC'
- INTEGER , INTENT(in) :: ktra ! tracer index
- INTEGER , INTENT(in) :: ktrd ! tracer trend index
- INTEGER , INTENT(in) :: Kmm, Krhs ! time level indices
- REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in) :: ptrd ! tracer trend or flux
- REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in), OPTIONAL :: pu ! now velocity
- REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in), OPTIONAL :: ptra ! now tracer variable
+ INTEGER , INTENT(in) :: kt ! time step
+ CHARACTER(len=3) , INTENT(in) :: ctype ! tracers trends type 'TRA'/'TRC'
+ INTEGER , INTENT(in) :: ktra ! tracer index
+ INTEGER , INTENT(in) :: ktrd ! tracer trend index
+ INTEGER , INTENT(in) :: Kmm, Krhs ! time level indices
+ REAL(wp), DIMENSION(:,:,:), INTENT(in) :: ptrd ! tracer trend or flux
+ REAL(wp), DIMENSION(:,:,:), INTENT(in), OPTIONAL :: pu ! now velocity
+ REAL(wp), DIMENSION(:,:,:), INTENT(in), OPTIONAL :: ptra ! now tracer variable
!
- INTEGER :: jk ! loop indices
- INTEGER :: i01 ! 0 or 1
- REAL(wp), DIMENSION(jpi,jpj,jpk) :: ztrds ! 3D workspace
+ INTEGER :: ji,jj,jk ! loop indices
+ INTEGER :: i01 ! 0 or 1
+ REAL(wp) :: z1e3w
+ REAL(wp), DIMENSION(T2D(0),jpk) :: ztrds ! 3D workspace
REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zwt, zws, ztrdt ! 3D workspace
!!----------------------------------------------------------------------
!
IF( .NOT. ALLOCATED( trdtx ) ) THEN ! allocate trdtra arrays
IF( trd_tra_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'trd_tra : unable to allocate arrays' )
- avt_evd(:,:,:) = 0._wp
+ avt_evd(T2D(0),:) = 0._wp
ENDIF
!
i01 = COUNT( (/ PRESENT(pu) .OR. ( ktrd /= jptra_xad .AND. ktrd /= jptra_yad .AND. ktrd /= jptra_zad ) /) )
@@ -103,13 +104,13 @@ CONTAINS
CASE( jptra_yad ) ; CALL trd_tra_adv( ptrd, pu, ptra, 'Y', trdty, Kmm )
CASE( jptra_zad ) ; CALL trd_tra_adv( ptrd, pu, ptra, 'Z', trdt, Kmm )
CASE( jptra_bbc, & ! qsr, bbc: on temperature only, send to trd_tra_mng
- & jptra_qsr ) ; trdt(:,:,:) = ptrd(:,:,:) * tmask(:,:,:)
- ztrds(:,:,:) = 0._wp
+ & jptra_qsr ) ; trdt(T2D(0),:) = ptrd(T2D(0),:) * tmask(T2D(0),:)
+ ztrds(T2D(0),:) = 0._wp
CALL trd_tra_mng( trdt, ztrds, ktrd, kt, Kmm )
!!gm Gurvan, verify the jptra_evd trend please !
- CASE( jptra_evd ) ; avt_evd(:,:,:) = ptrd(:,:,:) * tmask(:,:,:)
+ CASE( jptra_evd ) ; avt_evd(T2D(0),:) = ptrd(T2D(0),:) * tmask(T2D(0),:)
CASE DEFAULT ! other trends: masked trends
- trdt(:,:,:) = ptrd(:,:,:) * tmask(:,:,:) ! mask & store
+ trdt(T2D(0),:) = ptrd(T2D(0),:) * tmask(T2D(0),:) ! mask & store
END SELECT
!
ENDIF
@@ -127,44 +128,44 @@ CONTAINS
CALL trd_tra_mng( trdt , ztrds, ktrd, kt, Kmm )
CASE( jptra_zdfp ) ! diagnose the "PURE" Kz trend (here: just before the swap)
! ! iso-neutral diffusion case otherwise jptra_zdf is "PURE"
- ALLOCATE( zwt(jpi,jpj,jpk), zws(jpi,jpj,jpk), ztrdt(jpi,jpj,jpk) )
+ ALLOCATE( zwt(T2D(0),jpk), zws(T2D(0),jpk), ztrdt(T2D(0),jpk) )
!
- zwt(:,:, 1 ) = 0._wp ; zws(:,:, 1 ) = 0._wp ! vertical diffusive fluxes
- zwt(:,:,jpk) = 0._wp ; zws(:,:,jpk) = 0._wp
- DO jk = 2, jpk
- zwt(:,:,jk) = avt(:,:,jk) * ( ts(:,:,jk-1,jp_tem,Krhs) - ts(:,:,jk,jp_tem,Krhs) ) &
- & / e3w(:,:,jk,Kmm) * tmask(:,:,jk)
- zws(:,:,jk) = avs(:,:,jk) * ( ts(:,:,jk-1,jp_sal,Krhs) - ts(:,:,jk,jp_sal,Krhs) ) &
- & / e3w(:,:,jk,Kmm) * tmask(:,:,jk)
- END DO
+ zwt(T2D(0), 1 ) = 0._wp ; zws(T2D(0), 1 ) = 0._wp ! vertical diffusive fluxes
+ zwt(T2D(0),jpk) = 0._wp ; zws(T2D(0),jpk) = 0._wp
+ DO_3D( 0, 0, 0, 0, 2, jpk )
+ z1e3w = 1._wp / ( e3w(ji,jj,jk,Kmm) * tmask(ji,jj,jk) )
+ zwt(ji,jj,jk) = avt(ji,jj,jk) * ( ts(ji,jj,jk-1,jp_tem,Krhs) - ts(ji,jj,jk,jp_tem,Krhs) ) * z1e3w
+ zws(ji,jj,jk) = avs(ji,jj,jk) * ( ts(ji,jj,jk-1,jp_sal,Krhs) - ts(ji,jj,jk,jp_sal,Krhs) ) * z1e3w
+ END_3D
!
- ztrdt(:,:,jpk) = 0._wp ; ztrds(:,:,jpk) = 0._wp
- DO jk = 1, jpkm1
- ztrdt(:,:,jk) = ( zwt(:,:,jk) - zwt(:,:,jk+1) ) / e3t(:,:,jk,Kmm)
- ztrds(:,:,jk) = ( zws(:,:,jk) - zws(:,:,jk+1) ) / e3t(:,:,jk,Kmm)
- END DO
+ ztrdt(T2D(0),jpk) = 0._wp ; ztrds(T2D(0),jpk) = 0._wp
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
+ z1e3w = 1._wp / e3w(ji,jj,jk,Kmm)
+ ztrdt(ji,jj,jk) = ( zwt(ji,jj,jk) - zwt(ji,jj,jk+1) ) * z1e3w
+ ztrds(ji,jj,jk) = ( zws(ji,jj,jk) - zws(ji,jj,jk+1) ) * z1e3w
+ END_3D
CALL trd_tra_mng( ztrdt, ztrds, jptra_zdfp, kt, Kmm )
!
! ! Also calculate EVD trend at this point.
- zwt(:,:,:) = 0._wp ; zws(:,:,:) = 0._wp ! vertical diffusive fluxes
- DO jk = 2, jpk
- zwt(:,:,jk) = avt_evd(:,:,jk) * ( ts(:,:,jk-1,jp_tem,Krhs) - ts(:,:,jk,jp_tem,Krhs) ) &
- & / e3w(:,:,jk,Kmm) * tmask(:,:,jk)
- zws(:,:,jk) = avt_evd(:,:,jk) * ( ts(:,:,jk-1,jp_sal,Krhs) - ts(:,:,jk,jp_sal,Krhs) ) &
- & / e3w(:,:,jk,Kmm) * tmask(:,:,jk)
- END DO
+ zwt(T2D(0), :) = 0._wp ; zws(T2D(0), :) = 0._wp ! vertical diffusive fluxes
+ DO_3D( 0, 0, 0, 0, 2, jpk )
+ z1e3w = 1._wp / ( e3w(ji,jj,jk,Kmm) * tmask(ji,jj,jk) )
+ zwt(ji,jj,jk) = avt_evd(ji,jj,jk) * ( ts(ji,jj,jk-1,jp_tem,Krhs) - ts(ji,jj,jk,jp_tem,Krhs) ) * z1e3w
+ zws(ji,jj,jk) = avt_evd(ji,jj,jk) * ( ts(ji,jj,jk-1,jp_sal,Krhs) - ts(ji,jj,jk,jp_sal,Krhs) ) * z1e3w
+ END_3D
!
- ztrdt(:,:,jpk) = 0._wp ; ztrds(:,:,jpk) = 0._wp
- DO jk = 1, jpkm1
- ztrdt(:,:,jk) = ( zwt(:,:,jk) - zwt(:,:,jk+1) ) / e3t(:,:,jk,Kmm)
- ztrds(:,:,jk) = ( zws(:,:,jk) - zws(:,:,jk+1) ) / e3t(:,:,jk,Kmm)
- END DO
+ ztrdt(T2D(0),jpk) = 0._wp ; ztrds(T2D(0),jpk) = 0._wp
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
+ z1e3w = 1._wp / e3w(ji,jj,jk,Kmm)
+ ztrdt(ji,jj,jk) = ( zwt(ji,jj,jk) - zwt(ji,jj,jk+1) ) * z1e3w
+ ztrds(ji,jj,jk) = ( zws(ji,jj,jk) - zws(ji,jj,jk+1) ) * z1e3w
+ END_3D
CALL trd_tra_mng( ztrdt, ztrds, jptra_evd, kt, Kmm )
!
DEALLOCATE( zwt, zws, ztrdt )
!
CASE DEFAULT ! other trends: mask and send T & S trends to trd_tra_mng
- ztrds(:,:,:) = ptrd(:,:,:) * tmask(:,:,:)
+ ztrds(T2D(0),:) = ptrd(T2D(0),:) * tmask(T2D(0),:)
CALL trd_tra_mng( trdt, ztrds, ktrd, kt, Kmm )
END SELECT
ENDIF
@@ -177,7 +178,7 @@ CONTAINS
CASE( jptra_yad ) ; CALL trd_tra_adv( ptrd , pu , ptra, 'Y', ztrds, Kmm )
CASE( jptra_zad ) ; CALL trd_tra_adv( ptrd , pu , ptra, 'Z', ztrds, Kmm )
CASE DEFAULT ! other trends: just masked
- ztrds(:,:,:) = ptrd(:,:,:) * tmask(:,:,:)
+ ztrds(T2D(0),:) = ptrd(T2D(0),:) * tmask(T2D(0),:)
END SELECT
! ! send trend to trd_trc
CALL trd_trc( ztrds, ktra, ktrd, kt, Kmm )
@@ -199,12 +200,12 @@ CONTAINS
!! k-advective trends = -un. di+1[T] = -( dk+1[fi] - tn dk+1[un] )
!! where fi is the incoming advective flux.
!!----------------------------------------------------------------------
- REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in ) :: pf ! advective flux in one direction
- REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in ) :: pu ! now velocity in one direction
- REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in ) :: pt ! now or before tracer
- CHARACTER(len=1) , INTENT(in ) :: cdir ! X/Y/Z direction
- REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT( out) :: ptrd ! advective trend in one direction
- INTEGER, INTENT(in) :: Kmm ! time level index
+ REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: pf ! advective flux in one direction
+ REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: pu ! now velocity in one direction
+ REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: pt ! now or before tracer
+ CHARACTER(len=1) , INTENT(in ) :: cdir ! X/Y/Z direction
+ REAL(wp), DIMENSION(:,:,:), INTENT( out) :: ptrd ! advective trend in one direction
+ INTEGER, INTENT(in) :: Kmm ! time level index
!
INTEGER :: ji, jj, jk ! dummy loop indices
INTEGER :: ii, ij, ik ! index shift as function of the direction
@@ -217,9 +218,7 @@ CONTAINS
END SELECT
!
! ! set to zero uncomputed values
- ptrd(jpi,:,:) = 0._wp ; ptrd(1,:,:) = 0._wp
- ptrd(:,jpj,:) = 0._wp ; ptrd(:,1,:) = 0._wp
- ptrd(:,:,jpk) = 0._wp
+ ptrd(:,:,:) = 0._wp
!
DO_3D( 0, 0, 0, 0, 1, jpkm1 ) ! advective trend
ptrd(ji,jj,jk) = - ( pf (ji,jj,jk) - pf (ji-ii,jj-ij,jk-ik) &
@@ -248,7 +247,7 @@ CONTAINS
! ! 3D output of tracers trends using IOM interface
IF( ln_tra_trd ) CALL trd_tra_iom ( ptrdx, ptrdy, ktrd, kt, Kmm )
- ! ! Integral Constraints Properties for tracers trends !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+ ! ! Integral Constraints Properties for tracers trends
IF( ln_glo_trd ) CALL trd_glo( ptrdx, ptrdy, ktrd, 'TRA', kt, Kmm )
! ! Potential ENergy trends
@@ -305,8 +304,8 @@ CONTAINS
INTEGER , INTENT(in ) :: kt ! time step
INTEGER , INTENT(in ) :: Kmm ! time level index
!!
- INTEGER :: ji, jj, jk ! dummy loop indices
- INTEGER :: ikbu, ikbv ! local integers
+ INTEGER :: ji, jj
+ REAL(wp) :: z1e3
REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: z2dx, z2dy ! 2D workspace
!!----------------------------------------------------------------------
!
@@ -329,9 +328,12 @@ CONTAINS
CASE( jptra_zad ) ; CALL iom_put( "ttrd_zad" , ptrdx ) ! z- vertical advection
CALL iom_put( "strd_zad" , ptrdy )
IF( ln_linssh ) THEN ! cst volume : adv flux through z=0 surface
- ALLOCATE( z2dx(jpi,jpj), z2dy(jpi,jpj) )
- z2dx(:,:) = ww(:,:,1) * ts(:,:,1,jp_tem,Kmm) / e3t(:,:,1,Kmm)
- z2dy(:,:) = ww(:,:,1) * ts(:,:,1,jp_sal,Kmm) / e3t(:,:,1,Kmm)
+ ALLOCATE( z2dx(T2D(0)), z2dy(T2D(0)) )
+ DO_2D( 0, 0, 0, 0 )
+ z1e3 = ww(ji,jj,1) / e3t(ji,jj,1,Kmm)
+ z2dx(ji,jj) = ts(ji,jj,1,jp_tem,Kmm) * z1e3
+ z2dy(ji,jj) = ts(ji,jj,1,jp_sal,Kmm) * z1e3
+ END_2D
CALL iom_put( "ttrd_sad", z2dx )
CALL iom_put( "strd_sad", z2dy )
DEALLOCATE( z2dx, z2dy )
diff --git a/src/OCE/TRD/trdvor.F90 b/src/OCE/TRD/trdvor.F90
index 974f5b1a9b06f1a16fcdbee8d7457b71f9a5ea6c..72763255e5edf11b24800be434b6334e3996f5b9 100644
--- a/src/OCE/TRD/trdvor.F90
+++ b/src/OCE/TRD/trdvor.F90
@@ -68,9 +68,9 @@ CONTAINS
!!----------------------------------------------------------------------------
!! *** ROUTINE trd_vor_alloc ***
!!----------------------------------------------------------------------------
- ALLOCATE( vor_avr (jpi,jpj) , vor_avrb(jpi,jpj) , vor_avrbb (jpi,jpj) , &
- & vor_avrbn (jpi,jpj) , rotot (jpi,jpj) , vor_avrtot(jpi,jpj) , &
- & vor_avrres(jpi,jpj) , vortrd (jpi,jpj,jpltot_vor) , &
+ ALLOCATE( vor_avr (T2D(0)) , vor_avrb(T2D(0)) , vor_avrbb (T2D(0)) , &
+ & vor_avrbn (T2D(0)) , rotot (T2D(0)) , vor_avrtot(T2D(0)) , &
+ & vor_avrres(T2D(0)) , vortrd (T2D(0),jpltot_vor) , &
& ndexvor1 (jpi*jpj) , STAT= trd_vor_alloc )
!
CALL mpp_sum ( 'trdvor', trd_vor_alloc )
@@ -105,9 +105,9 @@ CONTAINS
CASE( jpdyn_zad ) ; CALL trd_vor_zint( putrd, pvtrd, jpvor_zad, Kmm ) ! Vertical Advection
CASE( jpdyn_spg ) ; CALL trd_vor_zint( putrd, pvtrd, jpvor_spg, Kmm ) ! Surface Pressure Grad.
CASE( jpdyn_zdf ) ! Vertical Diffusion
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) ! wind stress trends
- ztswu(ji,jj) = 0.5 * ( utau_b(ji,jj) + utau(ji,jj) ) / ( e3u(ji,jj,1,Kmm) * rho0 )
- ztswv(ji,jj) = 0.5 * ( vtau_b(ji,jj) + vtau(ji,jj) ) / ( e3v(ji,jj,1,Kmm) * rho0 )
+ DO_2D( 0, 1, 0, 1 ) ! wind stress trends
+ ztswu(ji,jj) = 0.5 * ( utau_b(ji,jj) + utauU(ji,jj) ) / ( e3u(ji,jj,1,Kmm) * rho0 )
+ ztswv(ji,jj) = 0.5 * ( vtau_b(ji,jj) + vtauV(ji,jj) ) / ( e3v(ji,jj,1,Kmm) * rho0 )
END_2D
CALL trd_vor_zint( putrd, pvtrd, jpvor_zdf, Kmm ) ! zdf trend including surf./bot. stresses
CALL trd_vor_zint( ztswu, ztswv, jpvor_swf, Kmm ) ! surface wind stress
@@ -165,7 +165,7 @@ CONTAINS
SELECT CASE( ktrd )
!
CASE( jpvor_bfr ) ! bottom friction
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 1, 0, 1 )
ikbu = mbkv(ji,jj)
ikbv = mbkv(ji,jj)
zudpvor(ji,jj) = putrdvor(ji,jj) * e3u(ji,jj,ikbu,Kmm) * e1u(ji,jj) * umask(ji,jj,ikbu)
@@ -173,14 +173,18 @@ CONTAINS
END_2D
!
CASE( jpvor_swf ) ! wind stress
- zudpvor(:,:) = putrdvor(:,:) * e3u(:,:,1,Kmm) * e1u(:,:) * umask(:,:,1)
- zvdpvor(:,:) = pvtrdvor(:,:) * e3v(:,:,1,Kmm) * e2v(:,:) * vmask(:,:,1)
+ DO_2D( 0, 1, 0, 1 )
+ zudpvor(ji,jj) = putrdvor(ji,jj) * e3u(ji,jj,1,Kmm) * e1u(ji,jj) * umask(ji,jj,1)
+ zvdpvor(ji,jj) = pvtrdvor(ji,jj) * e3v(ji,jj,1,Kmm) * e2v(ji,jj) * vmask(ji,jj,1)
+ END_2D
!
END SELECT
! Average except for Beta.V
- zudpvor(:,:) = zudpvor(:,:) * r1_hu(:,:,Kmm)
- zvdpvor(:,:) = zvdpvor(:,:) * r1_hv(:,:,Kmm)
+ DO_2D( 0, 1, 0, 1 )
+ zudpvor(ji,jj) = zudpvor(ji,jj) * r1_hu(ji,jj,Kmm)
+ zvdpvor(ji,jj) = zvdpvor(ji,jj) * r1_hv(ji,jj,Kmm)
+ END_2D
! Curl
DO_2D( 0, 0, 0, 0 )
@@ -238,10 +242,11 @@ CONTAINS
! I vertical integration of 3D trends
! =====================================
! putrdvor and pvtrdvor terms
- DO jk = 1,jpk
- zudpvor(:,:) = zudpvor(:,:) + putrdvor(:,:,jk) * e3u(:,:,jk,Kmm) * e1u(:,:) * umask(:,:,jk)
- zvdpvor(:,:) = zvdpvor(:,:) + pvtrdvor(:,:,jk) * e3v(:,:,jk,Kmm) * e2v(:,:) * vmask(:,:,jk)
- END DO
+ zudpvor(:,:) = 0._wp ; zvdpvor(:,:) = 0._wp
+ DO_3D( 0, 1, 0, 1, 1, jpk )
+ zudpvor(ji,jj) = zudpvor(ji,jj) + putrdvor(ji,jj,jk) * e3u(ji,jj,jk,Kmm) * e1u(ji,jj) * umask(ji,jj,jk)
+ zvdpvor(ji,jj) = zvdpvor(ji,jj) + pvtrdvor(ji,jj,jk) * e3v(ji,jj,jk,Kmm) * e2v(ji,jj) * vmask(ji,jj,jk)
+ END_3D
! Planetary vorticity: 2nd computation (Beta.V term) store the vertical sum
! as Beta.V term need intergration, not average
@@ -254,8 +259,10 @@ CONTAINS
ENDIF
!
! Average
- zudpvor(:,:) = zudpvor(:,:) * r1_hu(:,:,Kmm)
- zvdpvor(:,:) = zvdpvor(:,:) * r1_hv(:,:,Kmm)
+ DO_2D( 0, 1, 0, 1 )
+ zudpvor(ji,jj) = zudpvor(ji,jj) * r1_hu(ji,jj,Kmm)
+ zvdpvor(ji,jj) = zvdpvor(ji,jj) * r1_hv(ji,jj,Kmm)
+ END_2D
!
! Curl
DO_2D( 0, 0, 0, 0 )
@@ -368,10 +375,6 @@ CONTAINS
zmean = 1._wp / REAL( nmoydpvor, wp )
vor_avrres(:,:) = vor_avrtot(:,:) - rotot(:,:) / zmean
- ! Boundary conditions
- CALL lbc_lnk( 'trdvor', vor_avrtot, 'F', 1.0_wp , vor_avrres, 'F', 1.0_wp )
-
-
! III.3 time evolution array swap
! ------------------------------
vor_avrbb(:,:) = vor_avrb(:,:)
diff --git a/src/OCE/USR/usrdef_fmask.F90 b/src/OCE/USR/usrdef_fmask.F90
index bc97a2edf925254ca4604227ffe31eae3f3d723e..d1e0d482524aeafae8f7c958562297327f9b81fe 100644
--- a/src/OCE/USR/usrdef_fmask.F90
+++ b/src/OCE/USR/usrdef_fmask.F90
@@ -69,25 +69,25 @@ CONTAINS
IF(lwp) WRITE(numout,*) ' Gibraltar '
ij0 = 101 + nn_hls ; ij1 = 101 + nn_hls ! Gibraltar strait : partial slip (pfmsk=0.5)
ii0 = 139 + nn_hls - 1 ; ii1 = 140 + nn_hls - 1
- pfmsk( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , 1:jpk ) = 0.5_wp
+ pfmsk( mi0(ii0,nn_hls):mi1(ii1,nn_hls) , mj0(ij0,nn_hls):mj1(ij1,nn_hls) , 1:jpk ) = 0.5_wp
ij0 = 102 + nn_hls ; ij1 = 102 + nn_hls
ii0 = 139 + nn_hls - 1 ; ii1 = 140 + nn_hls - 1
- pfmsk( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , 1:jpk ) = 0.5_wp
+ pfmsk( mi0(ii0,nn_hls):mi1(ii1,nn_hls) , mj0(ij0,nn_hls):mj1(ij1,nn_hls) , 1:jpk ) = 0.5_wp
!
IF(lwp) WRITE(numout,*) ' Bab el Mandeb '
ij0 = 87 + nn_hls ; ij1 = 88 + nn_hls ! Bab el Mandeb : partial slip (pfmsk=1)
ii0 = 160 + nn_hls - 1 ; ii1 = 160 + nn_hls - 1
- pfmsk( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , 1:jpk ) = 1._wp
+ pfmsk( mi0(ii0,nn_hls):mi1(ii1,nn_hls) , mj0(ij0,nn_hls):mj1(ij1,nn_hls) , 1:jpk ) = 1._wp
ij0 = 88 + nn_hls ; ij1 = 88 + nn_hls
ii0 = 159 + nn_hls - 1 ; ii1 = 159 + nn_hls - 1
- pfmsk( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , 1:jpk ) = 1._wp
+ pfmsk( mi0(ii0,nn_hls):mi1(ii1,nn_hls) , mj0(ij0,nn_hls):mj1(ij1,nn_hls) , 1:jpk ) = 1._wp
!
! We keep this as an example but it is instable in this case
!IF(lwp) WRITE(numout,*) ' Danish straits '
! ij0 = 115 ; ij1 = 115 ! Danish straits : strong slip (pfmsk > 2)
- ! ii0 = 145 ; ii1 = 146 ; pfmsk( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , 1:jpk ) = 4._wp
+ ! ii0 = 145 ; ii1 = 146 ; pfmsk( mi0(ii0,nn_hls):mi1(ii1,nn_hls) , mj0(ij0,nn_hls):mj1(ij1,nn_hls) , 1:jpk ) = 4._wp
! ij0 = 116 ; ij1 = 116
- ! ii0 = 145 ; ii1 = 146 ; pfmsk( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , 1:jpk ) = 4._wp
+ ! ii0 = 145 ; ii1 = 146 ; pfmsk( mi0(ii0,nn_hls):mi1(ii1,nn_hls) , mj0(ij0,nn_hls):mj1(ij1,nn_hls) , 1:jpk ) = 4._wp
!
CASE( 1 ) ! R1 case
IF(lwp) WRITE(numout,*)
@@ -104,42 +104,42 @@ CONTAINS
IF(lwp) WRITE(numout,*) ' Gibraltar '
ii0 = 282 + nn_hls - 1 ; ii1 = 283 + nn_hls - 1 ! Gibraltar Strait
ij0 = 241 + nn_hls - isrow ; ij1 = 241 + nn_hls - isrow
- pfmsk( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp
+ pfmsk( mi0(ii0,nn_hls):mi1(ii1,nn_hls),mj0(ij0,nn_hls):mj1(ij1,nn_hls),1:jpk ) = 2._wp
!
IF(lwp) WRITE(numout,*) ' Bhosporus '
ii0 = 314 + nn_hls - 1 ; ii1 = 315 + nn_hls - 1 ! Bhosporus Strait
ij0 = 248 + nn_hls - isrow ; ij1 = 248 + nn_hls - isrow
- pfmsk( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp
+ pfmsk( mi0(ii0,nn_hls):mi1(ii1,nn_hls),mj0(ij0,nn_hls):mj1(ij1,nn_hls),1:jpk ) = 2._wp
!
IF(lwp) WRITE(numout,*) ' Makassar (Top) '
ii0 = 48 + nn_hls - 1 ; ii1 = 48 + nn_hls - 1 ! Makassar Strait (Top)
ij0 = 189 + nn_hls - isrow ; ij1 = 190 + nn_hls - isrow
- pfmsk( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 3._wp
+ pfmsk( mi0(ii0,nn_hls):mi1(ii1,nn_hls),mj0(ij0,nn_hls):mj1(ij1,nn_hls),1:jpk ) = 3._wp
!
IF(lwp) WRITE(numout,*) ' Lombok '
ii0 = 44 + nn_hls - 1 ; ii1 = 44 + nn_hls - 1 ! Lombok Strait
ij0 = 164 + nn_hls - isrow ; ij1 = 165 + nn_hls - isrow
- pfmsk( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp
+ pfmsk( mi0(ii0,nn_hls):mi1(ii1,nn_hls),mj0(ij0,nn_hls):mj1(ij1,nn_hls),1:jpk ) = 2._wp
!
IF(lwp) WRITE(numout,*) ' Ombai '
ii0 = 53 + nn_hls - 1 ; ii1 = 53 + nn_hls - 1 ! Ombai Strait
ij0 = 164 + nn_hls - isrow ; ij1 = 165 + nn_hls - isrow
- pfmsk( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp
+ pfmsk( mi0(ii0,nn_hls):mi1(ii1,nn_hls),mj0(ij0,nn_hls):mj1(ij1,nn_hls),1:jpk ) = 2._wp
!
IF(lwp) WRITE(numout,*) ' Timor Passage '
ii0 = 56 + nn_hls - 1 ; ii1 = 56 + nn_hls - 1 ! Timor Passage
ij0 = 164 + nn_hls - isrow ; ij1 = 165 + nn_hls - isrow
- pfmsk( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp
+ pfmsk( mi0(ii0,nn_hls):mi1(ii1,nn_hls),mj0(ij0,nn_hls):mj1(ij1,nn_hls),1:jpk ) = 2._wp
!
IF(lwp) WRITE(numout,*) ' West Halmahera '
ii0 = 58 + nn_hls - 1 ; ii1 = 58 + nn_hls - 1 ! West Halmahera Strait
ij0 = 181 + nn_hls - isrow ; ij1 = 182 + nn_hls - isrow
- pfmsk( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 3._wp
+ pfmsk( mi0(ii0,nn_hls):mi1(ii1,nn_hls),mj0(ij0,nn_hls):mj1(ij1,nn_hls),1:jpk ) = 3._wp
!
IF(lwp) WRITE(numout,*) ' East Halmahera '
ii0 = 55 + nn_hls - 1 ; ii1 = 55 + nn_hls - 1 ! East Halmahera Strait
ij0 = 181 + nn_hls - isrow ; ij1 = 182 + nn_hls - isrow
- pfmsk( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 3._wp
+ pfmsk( mi0(ii0,nn_hls):mi1(ii1,nn_hls),mj0(ij0,nn_hls):mj1(ij1,nn_hls),1:jpk ) = 3._wp
!
CASE DEFAULT
IF(lwp) WRITE(numout,*)
diff --git a/src/OCE/USR/usrdef_hgr.F90 b/src/OCE/USR/usrdef_hgr.F90
index 2f617b552235a7b19c9cad93e777a785bcca0884..cbcb3ff8e94f3db7cb6d7d78b44aad78e1f683c6 100644
--- a/src/OCE/USR/usrdef_hgr.F90
+++ b/src/OCE/USR/usrdef_hgr.F90
@@ -115,8 +115,8 @@ CONTAINS
ENDIF
!
DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
- zim1 = REAL( mig0(ji), wp ) - 1. ; zim05 = REAL( mig0(ji), wp ) - 1.5
- zjm1 = REAL( mjg0(jj), wp ) - 1. ; zjm05 = REAL( mjg0(jj), wp ) - 1.5
+ zim1 = REAL( mig(ji,0), wp ) - 1. ; zim05 = REAL( mig(ji,0), wp ) - 1.5
+ zjm1 = REAL( mjg(jj,0), wp ) - 1. ; zjm05 = REAL( mjg(jj,0), wp ) - 1.5
!
!glamt(i,j) longitude at T-point
!gphit(i,j) latitude at T-point
diff --git a/src/OCE/USR/usrdef_sbc.F90 b/src/OCE/USR/usrdef_sbc.F90
index ce5b785a973082a9dd81b952667d965cd21a2bfc..0be3bd7e98fc014cf9ae38301933a870dcb89998 100644
--- a/src/OCE/USR/usrdef_sbc.F90
+++ b/src/OCE/USR/usrdef_sbc.F90
@@ -109,7 +109,7 @@ CONTAINS
ztrp= - 40.e0 ! retroaction term on heat fluxes (W/m2/K)
zconv = 3.16e-5 ! convertion factor: 1 m/yr => 3.16e-5 mm/s
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) ! emp and rnf used in sshwzv over the whole domain
+ DO_2D( 0, 0, 0, 0 )
! domain from 15 deg to 50 deg between 27 and 28 degC at 15N, -3
! and 13 degC at 50N 53.5 + or - 11 = 1/4 period :
! 64.5 in summer, 42.5 in winter
@@ -119,6 +119,8 @@ CONTAINS
! 23.5 deg : tropics
qsr (ji,jj) = 230 * COS( 3.1415 * ( gphit(ji,jj) - 23.5 * zcos_sais1 ) / ( 0.9 * 180 ) )
qns (ji,jj) = ztrp * ( ts(ji,jj,1,jp_tem,Kbb) - t_star ) - qsr(ji,jj)
+ END_2D
+ DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) ! emp and rnf used in sshwzv over the whole domain
IF( gphit(ji,jj) >= 14.845 .AND. 37.2 >= gphit(ji,jj) ) THEN ! zero at 37.8 deg, max at 24.6 deg
emp (ji,jj) = zemp_S * zconv &
& * SIN( rpi / 2 * (gphit(ji,jj) - 37.2) / (24.6 - 37.2) ) &
@@ -137,6 +139,8 @@ CONTAINS
! freshwater (mass flux) and update of qns with heat content of emp
DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) ! emp used in sshwzv over the whole domain
emp (ji,jj) = emp(ji,jj) - zsumemp * tmask(ji,jj,1) ! freshwater flux (=0 in domain average)
+ END_2D
+ DO_2D( 0, 0, 0, 0 )
sfx (ji,jj) = 0.0_wp ! no salt flux
qns (ji,jj) = qns(ji,jj) - emp(ji,jj) * sst_m(ji,jj) * rcp ! evap and precip are at SST
END_2D
@@ -166,19 +170,17 @@ CONTAINS
! seasonal oscillation intensity
ztau_sais = 0.015
ztaun = ztau - ztau_sais * COS( (ztime - ztimemax) / (ztimemin - ztimemax) * rpi )
- DO_2D( 1, 1, 1, 1 )
+ DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
! domain from 15deg to 50deg and 1/2 period along 14deg
! so 5/4 of half period with seasonal cycle
- utau(ji,jj) = - ztaun * SIN( rpi * (gphiu(ji,jj) - 15.) / (29.-15.) )
- vtau(ji,jj) = ztaun * SIN( rpi * (gphiv(ji,jj) - 15.) / (29.-15.) )
+ utau(ji,jj) = - ztaun * SIN( rpi * (gphit(ji,jj) - 15.) / (29.-15.) )
+ vtau(ji,jj) = ztaun * SIN( rpi * (gphit(ji,jj) - 15.) / (29.-15.) )
END_2D
! module of wind stress and wind speed at T-point
zcoef = 1. / ( zrhoa * zcdrag )
DO_2D( 0, 0, 0, 0 )
- ztx = utau(ji-1,jj ) + utau(ji,jj)
- zty = vtau(ji ,jj-1) + vtau(ji,jj)
- zmod = 0.5 * SQRT( ztx * ztx + zty * zty )
+ zmod = SQRT( utau(ji,jj) * utau(ji,jj) + vtau(ji,jj) * vtau(ji,jj) )
taum(ji,jj) = zmod
wndm(ji,jj) = SQRT( zmod * zcoef )
END_2D
diff --git a/src/OCE/USR/usrdef_zgr.F90 b/src/OCE/USR/usrdef_zgr.F90
index 99916151b849bf1bf43cda85df0c902111b48ed8..4523a2fff3d193b690b04211c7c76ff3ae602f76 100644
--- a/src/OCE/USR/usrdef_zgr.F90
+++ b/src/OCE/USR/usrdef_zgr.F90
@@ -36,11 +36,11 @@ MODULE usrdef_zgr
CONTAINS
SUBROUTINE usr_def_zgr( ld_zco , ld_zps , ld_sco , ld_isfcav, & ! type of vertical coordinate
+ & k_top , k_bot , & ! top & bottom ocean level
& pdept_1d, pdepw_1d, pe3t_1d , pe3w_1d , & ! 1D reference vertical coordinate
& pdept , pdepw , & ! 3D t & w-points depth
& pe3t , pe3u , pe3v , pe3f , & ! vertical scale factors
- & pe3w , pe3uw , pe3vw , & ! - - -
- & k_top , k_bot ) ! top & bottom ocean level
+ & pe3w , pe3uw , pe3vw ) ! - - -
!!---------------------------------------------------------------------
!! *** ROUTINE usr_def_zgr ***
!!
@@ -49,16 +49,12 @@ CONTAINS
!!----------------------------------------------------------------------
LOGICAL , INTENT(out) :: ld_zco, ld_zps, ld_sco ! vertical coordinate flags
LOGICAL , INTENT(out) :: ld_isfcav ! under iceshelf cavity flag
+ INTEGER , DIMENSION(:,:) , INTENT(out) :: k_top, k_bot ! first & last ocean level
REAL(wp), DIMENSION(:) , INTENT(out) :: pdept_1d, pdepw_1d ! 1D grid-point depth [m]
REAL(wp), DIMENSION(:) , INTENT(out) :: pe3t_1d , pe3w_1d ! 1D grid-point depth [m]
- REAL(wp), DIMENSION(:,:,:), INTENT(out) :: pdept, pdepw ! grid-point depth [m]
- REAL(wp), DIMENSION(:,:,:), INTENT(out) :: pe3t , pe3u , pe3v , pe3f ! vertical scale factors [m]
- REAL(wp), DIMENSION(:,:,:), INTENT(out) :: pe3w , pe3uw, pe3vw ! i-scale factors
- INTEGER , DIMENSION(:,:) , INTENT(out) :: k_top, k_bot ! first & last ocean level
- !
- INTEGER :: inum ! local logical unit
- REAL(WP) :: z_zco, z_zps, z_sco, z_cav
- REAL(wp), DIMENSION(jpi,jpj) :: z2d ! 2D workspace
+ REAL(wp), DIMENSION(:,:,:), OPTIONAL, INTENT(out) :: pdept, pdepw ! grid-point depth [m]
+ REAL(wp), DIMENSION(:,:,:), OPTIONAL, INTENT(out) :: pe3t , pe3u , pe3v , pe3f ! vertical scale factors [m]
+ REAL(wp), DIMENSION(:,:,:), OPTIONAL, INTENT(out) :: pe3w , pe3uw, pe3vw ! i-scale factors
!!----------------------------------------------------------------------
!
IF(lwp) WRITE(numout,*)
@@ -80,11 +76,12 @@ CONTAINS
!
CALL zgr_msk_top_bot( k_top , k_bot ) ! masked top and bottom ocean t-level indices
!
- ! ! z-coordinate (3D arrays) from the 1D z-coord.
- CALL zgr_zco( pdept_1d, pdepw_1d, pe3t_1d, pe3w_1d, & ! in : 1D reference vertical coordinate
- & pdept , pdepw , & ! out : 3D t & w-points depth
- & pe3t , pe3u , pe3v , pe3f , & ! vertical scale factors
- & pe3w , pe3uw , pe3vw ) ! - - -
+ IF( PRESENT( pe3t ) ) THEN ! z-coordinate (3D arrays) from the 1D z-coord.
+ CALL zgr_zco( pdept_1d, pdepw_1d, pe3t_1d, pe3w_1d, & ! in : 1D reference vertical coordinate
+ & pdept , pdepw , & ! out : 3D t & w-points depth
+ & pe3t , pe3u , pe3v , pe3f , & ! vertical scale factors
+ & pe3w , pe3uw , pe3vw ) ! - - -
+ ENDIF
!
END SUBROUTINE usr_def_zgr
diff --git a/src/OCE/ZDF/zdf_oce.F90 b/src/OCE/ZDF/zdf_oce.F90
index 40bcb56ce9b07a1c3ac51ffd51d45f310e0c64fa..ca4a688a3d8601f1a28fe1a57549608481ea493b 100644
--- a/src/OCE/ZDF/zdf_oce.F90
+++ b/src/OCE/ZDF/zdf_oce.F90
@@ -53,6 +53,8 @@ MODULE zdf_oce
REAL(wp), PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:) :: avmb , avtb !: background profile of avm and avt [m2/s]
REAL(wp), PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:,:) :: avtb_2d !: horizontal shape of background Kz profile [-]
+ !! * Substitutions
+# include "do_loop_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
!! $Id: zdf_oce.F90 14072 2020-12-04 07:48:38Z laurent $
@@ -65,9 +67,9 @@ CONTAINS
!! *** FUNCTION zdf_oce_alloc ***
!!----------------------------------------------------------------------
!
- ALLOCATE( avm (jpi,jpj,jpk) , avm_k(jpi,jpj,jpk) , avs(jpi,jpj,jpk) , &
- & avt (jpi,jpj,jpk) , avt_k(jpi,jpj,jpk) , en (jpi,jpj,jpk) , &
- & avmb(jpk) , avtb(jpk) , avtb_2d(jpi,jpj) , STAT = zdf_oce_alloc )
+ ALLOCATE( avm (jpi,jpj,jpk), avm_k(jpi,jpj,jpk), avs(A2D(0),jpk) , &
+ & avt (A2D(0),jpk) , avt_k(A2D(0),jpk) , en (A2D(0),jpk) , &
+ & avmb(jpk) , avtb(jpk) , avtb_2d(A2D(0)) , STAT = zdf_oce_alloc )
!
IF( zdf_oce_alloc /= 0 ) CALL ctl_stop( 'STOP', 'zdf_oce_alloc: failed to allocate arrays' )
!
diff --git a/src/OCE/ZDF/zdfddm.F90 b/src/OCE/ZDF/zdfddm.F90
index a08cf3439b254cff6f6864f7eee3f7052aed3ae6..5fa6c719accb7b97fe379cb548384b3245525110 100644
--- a/src/OCE/ZDF/zdfddm.F90
+++ b/src/OCE/ZDF/zdfddm.F90
@@ -70,9 +70,9 @@ CONTAINS
!!----------------------------------------------------------------------
INTEGER, INTENT(in ) :: kt ! ocean time-step index
INTEGER, INTENT(in ) :: Kmm ! ocean time level index
- REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: p_avm ! Kz on momentum (w-points)
- REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: p_avt ! Kz on temperature (w-points)
- REAL(wp), DIMENSION(:,:,:), INTENT( out) :: p_avs ! Kz on salinity (w-points)
+ REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: p_avm ! Kz on momentum (w-points)
+ REAL(wp), DIMENSION(A2D(0) ,jpk), INTENT(inout) :: p_avt ! Kz on temperature (w-points)
+ REAL(wp), DIMENSION(A2D(0) ,jpk), INTENT( out) :: p_avs ! Kz on salinity (w-points)
!
INTEGER :: ji, jj , jk ! dummy loop indices
REAL(wp) :: zaw, zbw, zrw ! local scalars
@@ -82,7 +82,7 @@ CONTAINS
REAL(wp) :: zavft ! - -
REAL(dp) :: zavfs ! - -
REAL(wp) :: zavdt, zavds ! - -
- REAL(wp), DIMENSION(A2D(nn_hls)) :: zrau, zmsks, zmskf, zmskd1, zmskd2, zmskd3
+ REAL(wp), DIMENSION(T2D(0)) :: zrau, zmsks, zmskf, zmskd1, zmskd2, zmskd3
!!----------------------------------------------------------------------
!
! ! ===============
@@ -94,7 +94,7 @@ CONTAINS
!!gm ==>>> test in the loop instead of use of mask arrays
!!gm and many acces in memory
- DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) !== R=zrau = (alpha / beta) (dk[t] / dk[s]) ==!
+ DO_2D( 0, 0, 0, 0 ) !== R=zrau = (alpha / beta) (dk[t] / dk[s]) ==!
zrw = ( gdepw(ji,jj,jk ,Kmm) - gdept(ji,jj,jk,Kmm) ) &
!!gm please, use e3w at Kmm below
& / ( gdept(ji,jj,jk-1,Kmm) - gdept(ji,jj,jk,Kmm) )
@@ -110,7 +110,7 @@ CONTAINS
zrau(ji,jj) = MAX( 1.e-20, zdt / zds ) ! only retains positive value of zrau
END_2D
- DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) !== indicators ==!
+ DO_2D( 0, 0, 0, 0 ) !== indicators ==!
! stability indicator: msks=1 if rn2>0; 0 elsewhere
IF( rn2(ji,jj,jk) + 1.e-12 <= 0. ) THEN ; zmsks(ji,jj) = 0._wp
ELSE ; zmsks(ji,jj) = 1._wp * wmask(ji,jj,jk) ! mask so avt and avs masked
@@ -137,7 +137,7 @@ CONTAINS
! Update avt and avs
! ------------------
! Constant eddy coefficient: reset to the background value
- DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 )
+ DO_2D( 0, 0, 0, 0 )
zinr = 1._wp / zrau(ji,jj)
! salt fingering
zrr = zrau(ji,jj) / rn_hsbfr
diff --git a/src/OCE/ZDF/zdfdrg.F90 b/src/OCE/ZDF/zdfdrg.F90
index 7c866594d4d6e9a06a3be206caa898d2eb2f7686..a20067bfbb6fae0a45fcc472fecde504942de5b0 100644
--- a/src/OCE/ZDF/zdfdrg.F90
+++ b/src/OCE/ZDF/zdfdrg.F90
@@ -116,7 +116,7 @@ CONTAINS
!!----------------------------------------------------------------------
!
IF( l_log_not_linssh ) THEN !== "log layer" ==! compute Cd and -Cd*|U|
- DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 )
+ DO_2D( 0, 0, 0, 0 )
imk = k_mk(ji,jj) ! ocean bottom level at t-points
zut = uu(ji,jj,imk,Kmm) + uu(ji-1,jj,imk,Kmm) ! 2 x velocity at t-point
zvt = vv(ji,jj,imk,Kmm) + vv(ji,jj-1,imk,Kmm)
@@ -128,7 +128,7 @@ CONTAINS
pCdU(ji,jj) = - zcd * SQRT( 0.25 * ( zut*zut + zvt*zvt ) + pke0 )
END_2D
ELSE !== standard Cd ==!
- DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 )
+ DO_2D( 0, 0, 0, 0 )
imk = k_mk(ji,jj) ! ocean bottom level at t-points
zut = uu(ji,jj,imk,Kmm) + uu(ji-1,jj,imk,Kmm) ! 2 x velocity at t-point
zvt = vv(ji,jj,imk,Kmm) + vv(ji,jj-1,imk,Kmm)
diff --git a/src/OCE/ZDF/zdfevd.F90 b/src/OCE/ZDF/zdfevd.F90
index df8bfeaa5b701b30b19d265031f0b0732d803bac..373fd1f6a33ad37caeb3d77a9f0f85af7fb9ad39 100644
--- a/src/OCE/ZDF/zdfevd.F90
+++ b/src/OCE/ZDF/zdfevd.F90
@@ -56,13 +56,14 @@ CONTAINS
!!
!! ** Action : avt, avm enhanced where static instability occurs
!!----------------------------------------------------------------------
- INTEGER , INTENT(in ) :: kt ! ocean time-step indexocean time step
- INTEGER , INTENT(in ) :: Kmm, Krhs ! time level indices
- REAL(wp), DIMENSION(:,:,:) , INTENT(inout) :: p_avm, p_avt ! momentum and tracer Kz (w-points)
+ INTEGER , INTENT(in ) :: kt ! ocean time-step indexocean time step
+ INTEGER , INTENT(in ) :: Kmm, Krhs ! time level indices
+ REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: p_avm ! vertical eddy viscosity (w-points)
+ REAL(wp), DIMENSION(A2D(0) ,jpk), INTENT(inout) :: p_avt ! vertical eddy diffusivity (w-points)
!
INTEGER :: ji, jj, jk ! dummy loop indices
- ! NOTE: [tiling] use a SAVE array to store diagnostics, then send after all tiles are finished. This is necessary because p_avt/p_avm are modified on adjacent tiles when using nn_hls > 1. zavt_evd/zavm_evd are then zero on some points when subsequently calculated for these tiles.
- REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:,:) :: zavt_evd, zavm_evd
+ REAL(wp), DIMENSION(T2D(0),jpk) :: zavt_evd
+ REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zavm_evd
!!----------------------------------------------------------------------
!
IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile
@@ -72,13 +73,10 @@ CONTAINS
IF(lwp) WRITE(numout,*) '~~~~~~~ '
IF(lwp) WRITE(numout,*)
ENDIF
-
- ALLOCATE( zavt_evd(jpi,jpj,jpk) )
- IF( nn_evdm == 1 ) ALLOCATE( zavm_evd(jpi,jpj,jpk) )
ENDIF
!
!
- DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpk )
+ DO_3D( 0, 0, 0, 0, 1, jpk )
zavt_evd(ji,jj,jk) = p_avt(ji,jj,jk) ! set avt prior to evd application
END_3D
!
@@ -86,7 +84,8 @@ CONTAINS
!
CASE ( 1 ) !== enhance tracer & momentum Kz ==! (if rn2<-1.e-12)
!
- DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpk )
+ ALLOCATE( zavm_evd(T2D(0),jpk) )
+ DO_3D( 0, 0, 0, 0, 1, jpk )
zavm_evd(ji,jj,jk) = p_avm(ji,jj,jk) ! set avm prior to evd application
END_3D
!
@@ -96,20 +95,18 @@ CONTAINS
! p_avm(2:jpi,2:jpj,2:jpkm1) = rn_evd * wmask(2:jpi,2:jpj,2:jpkm1)
! END WHERE
!
- DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
IF( MIN( rn2(ji,jj,jk), rn2b(ji,jj,jk) ) <= -1.e-12 ) THEN
p_avt(ji,jj,jk) = rn_evd * wmask(ji,jj,jk)
p_avm(ji,jj,jk) = rn_evd * wmask(ji,jj,jk)
ENDIF
END_3D
!
- DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpk )
+ DO_3D( 0, 0, 0, 0, 1, jpk )
zavm_evd(ji,jj,jk) = p_avm(ji,jj,jk) - zavm_evd(ji,jj,jk) ! change in avm due to evd
END_3D
- IF( .NOT. l_istiled .OR. ntile == nijtile ) THEN ! Do only on the last tile
- CALL iom_put( "avm_evd", zavm_evd ) ! output this change
- DEALLOCATE( zavm_evd )
- ENDIF
+ CALL iom_put( "avm_evd", zavm_evd ) ! output this change
+ DEALLOCATE( zavm_evd )
!
CASE DEFAULT !== enhance tracer Kz ==! (if rn2<-1.e-12)
!! change last digits results
@@ -117,24 +114,19 @@ CONTAINS
! p_avt(2:jpi,2:jpj,2:jpkm1) = rn_evd * wmask(2:jpi,2:jpj,2:jpkm1)
! END WHERE
- DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
IF( MIN( rn2(ji,jj,jk), rn2b(ji,jj,jk) ) <= -1.e-12 ) &
p_avt(ji,jj,jk) = rn_evd * wmask(ji,jj,jk)
END_3D
!
END SELECT
!
- DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpk )
+ DO_3D( 0, 0, 0, 0, 1, jpk )
zavt_evd(ji,jj,jk) = p_avt(ji,jj,jk) - zavt_evd(ji,jj,jk) ! change in avt due to evd
END_3D
- !
+ CALL iom_put( "avt_evd", zavt_evd ) ! output this change
IF( l_trdtra ) CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_tem, jptra_evd, zavt_evd )
!
- IF( .NOT. l_istiled .OR. ntile == nijtile ) THEN ! Do only on the last tile
- CALL iom_put( "avt_evd", zavt_evd ) ! output this change
- DEALLOCATE( zavt_evd )
- ENDIF
- !
END SUBROUTINE zdf_evd
!!======================================================================
diff --git a/src/OCE/ZDF/zdfgls.F90 b/src/OCE/ZDF/zdfgls.F90
index b25670799dae097c9853dfdda687a3743aeea10a..d5fd971fd3de13965fc979df8c85414d70857576 100644
--- a/src/OCE/ZDF/zdfgls.F90
+++ b/src/OCE/ZDF/zdfgls.F90
@@ -17,7 +17,6 @@ MODULE zdfgls
!!----------------------------------------------------------------------
USE oce ! ocean dynamics and active tracers
USE dom_oce ! ocean space and time domain
- USE domvvl ! ocean space and time domain : variable volume layer
USE zdfdrg , ONLY : ln_drg_OFF ! top/bottom free-slip flag
USE zdfdrg , ONLY : r_z0_top , r_z0_bot ! top/bottom roughness
USE zdfdrg , ONLY : rCdU_top , rCdU_bot ! top/bottom friction
@@ -126,8 +125,8 @@ CONTAINS
!!----------------------------------------------------------------------
!! *** FUNCTION zdf_gls_alloc ***
!!----------------------------------------------------------------------
- ALLOCATE( hmxl_n(jpi,jpj,jpk) , ustar2_surf(jpi,jpj) , &
- & zwall (jpi,jpj,jpk) , ustar2_top (jpi,jpj) , ustar2_bot(jpi,jpj) , STAT= zdf_gls_alloc )
+ ALLOCATE( hmxl_n(A2D(0),jpk) , ustar2_surf(A2D(0)) , &
+ & zwall (A2D(0),jpk) , ustar2_top (A2D(0)) , ustar2_bot(A2D(0)) , STAT= zdf_gls_alloc )
!
CALL mpp_sum ( 'zdfgls', zdf_gls_alloc )
IF( zdf_gls_alloc /= 0 ) CALL ctl_stop( 'STOP', 'zdf_gls_alloc: failed to allocate arrays' )
@@ -143,10 +142,11 @@ CONTAINS
!!----------------------------------------------------------------------
USE zdf_oce , ONLY : en, avtb, avmb ! ocean vertical physics
!!
- INTEGER , INTENT(in ) :: kt ! ocean time step
- INTEGER , INTENT(in ) :: Kbb, Kmm ! ocean time level indices
- REAL(wp), DIMENSION(A2D(nn_hls),jpk), INTENT(in ) :: p_sh2 ! shear production term
- REAL(wp), DIMENSION(:,:,:) , INTENT(inout) :: p_avm, p_avt ! momentum and tracer Kz (w-points)
+ INTEGER , INTENT(in ) :: kt ! ocean time step
+ INTEGER , INTENT(in ) :: Kbb, Kmm ! ocean time level indices
+ REAL(wp), DIMENSION(A2D(0) ,jpk), INTENT(in ) :: p_sh2 ! shear production term
+ REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: p_avm ! vertical eddy viscosity (w-points)
+ REAL(wp), DIMENSION(A2D(0) ,jpk), INTENT(inout) :: p_avt ! vertical eddy diffusivity (w-points)
!
INTEGER :: ji, jj, jk ! dummy loop arguments
INTEGER :: ibot, ibotm1 ! local integers
@@ -157,51 +157,51 @@ CONTAINS
REAL(wp) :: prod, buoy, diss, zdiss, sm ! - -
REAL(wp) :: gh, gm, shr, dif, zsqen, zavt, zavm ! - -
REAL(wp) :: zmsku, zmskv ! - -
- REAL(wp), DIMENSION(A2D(nn_hls)) :: zdep
- REAL(wp), DIMENSION(A2D(nn_hls)) :: zkar
- REAL(wp), DIMENSION(A2D(nn_hls)) :: zflxs ! Turbulence fluxed induced by internal waves
- REAL(wp), DIMENSION(A2D(nn_hls)) :: zhsro ! Surface roughness (surface waves)
- REAL(wp), DIMENSION(A2D(nn_hls)) :: zice_fra ! Tapering of wave breaking under sea ice
- REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: eb ! tke at time before
- REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: hmxl_b ! mixing length at time before
- REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: eps ! dissipation rate
- REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zwall_psi ! Wall function use in the wb case (ln_sigpsi)
- REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: psi ! psi at time now
- REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zd_lw, zd_up, zdiag ! lower, upper and diagonal of the matrix
- REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zstt, zstm ! stability function on tracer and momentum
+ REAL(wp), DIMENSION(T2D(0)) :: zdep
+ REAL(wp), DIMENSION(T2D(0)) :: zkar
+ REAL(wp), DIMENSION(T2D(0)) :: zflxs ! Turbulence fluxed induced by internal waves
+ REAL(wp), DIMENSION(T2D(0)) :: zhsro ! Surface roughness (surface waves)
+ REAL(wp), DIMENSION(T2D(0)) :: zice_fra ! Tapering of wave breaking under sea ice
+ REAL(wp), DIMENSION(T2D(0),jpk) :: eb ! tke at time before
+ REAL(wp), DIMENSION(T2D(0),jpk) :: hmxl_b ! mixing length at time before
+ REAL(wp), DIMENSION(T2D(0),jpk) :: eps ! dissipation rate
+ REAL(wp), DIMENSION(T2D(0),jpk) :: zwall_psi ! Wall function use in the wb case (ln_sigpsi)
+ REAL(wp), DIMENSION(T2D(0),jpk) :: psi ! psi at time now
+ REAL(wp), DIMENSION(T2D(0),jpk) :: zd_lw, zd_up, zdiag ! lower, upper and diagonal of the matrix
+ REAL(wp), DIMENSION(T2D(0),jpk) :: zstt, zstm ! stability function on tracer and momentum
!!--------------------------------------------------------------------
!
! Preliminary computing
- DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 )
+ DO_2D( 0, 0, 0, 0 )
ustar2_surf(ji,jj) = 0._wp ; ustar2_top(ji,jj) = 0._wp ; ustar2_bot(ji,jj) = 0._wp
END_2D
- DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpk )
+ DO_3D( 0, 0, 0, 0, 1, jpk )
psi(ji,jj,jk) = 0._wp ; zwall_psi(ji,jj,jk) = 0._wp
END_3D
SELECT CASE ( nn_z0_ice )
CASE( 0 ) ; zice_fra(:,:) = 0._wp
- CASE( 1 ) ; zice_fra(:,:) = TANH( fr_i(A2D(nn_hls)) * 10._wp )
- CASE( 2 ) ; zice_fra(:,:) = fr_i(A2D(nn_hls))
- CASE( 3 ) ; zice_fra(:,:) = MIN( 4._wp * fr_i(A2D(nn_hls)) , 1._wp )
+ CASE( 1 ) ; zice_fra(:,:) = TANH( fr_i(T2D(0)) * 10._wp )
+ CASE( 2 ) ; zice_fra(:,:) = fr_i(T2D(0))
+ CASE( 3 ) ; zice_fra(:,:) = MIN( 4._wp * fr_i(T2D(0)) , 1._wp )
END SELECT
! Compute surface, top and bottom friction at T-points
- DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) !== surface ocean friction
+ DO_2D( 0, 0, 0, 0 ) !== surface ocean friction
ustar2_surf(ji,jj) = r1_rho0 * taum(ji,jj) * tmask(ji,jj,1) ! surface friction
END_2D
!
!!gm Rq we may add here r_ke0(_top/_bot) ? ==>> think about that...
!
IF( .NOT.ln_drg_OFF ) THEN !== top/bottom friction (explicit before friction)
- DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) ! bottom friction (explicit before friction)
+ DO_2D( 0, 0, 0, 0 ) ! bottom friction (explicit before friction)
zmsku = 0.5_wp * ( 2._wp - umask(ji-1,jj,mbkt(ji,jj)) * umask(ji,jj,mbkt(ji,jj)) )
zmskv = 0.5_wp * ( 2._wp - vmask(ji,jj-1,mbkt(ji,jj)) * vmask(ji,jj,mbkt(ji,jj)) ) ! (CAUTION: CdU<0)
ustar2_bot(ji,jj) = - rCdU_bot(ji,jj) * SQRT( ( zmsku*( uu(ji,jj,mbkt(ji,jj),Kbb)+uu(ji-1,jj,mbkt(ji,jj),Kbb) ) )**2 &
& + ( zmskv*( vv(ji,jj,mbkt(ji,jj),Kbb)+vv(ji,jj-1,mbkt(ji,jj),Kbb) ) )**2 )
END_2D
IF( ln_isfcav ) THEN
- DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) ! top friction
+ DO_2D( 0, 0, 0, 0 ) ! top friction
zmsku = 0.5_wp * ( 2. - umask(ji-1,jj,mikt(ji,jj)) * umask(ji,jj,mikt(ji,jj)) )
zmskv = 0.5_wp * ( 2. - vmask(ji,jj-1,mikt(ji,jj)) * vmask(ji,jj,mikt(ji,jj)) ) ! (CAUTION: CdU<0)
ustar2_top(ji,jj) = - rCdU_top(ji,jj) * SQRT( ( zmsku*( uu(ji,jj,mikt(ji,jj),Kbb)+uu(ji-1,jj,mikt(ji,jj),Kbb) ) )**2 &
@@ -214,57 +214,59 @@ CONTAINS
CASE ( 0 ) ! Constant roughness
zhsro(:,:) = rn_hsro
CASE ( 1 ) ! Standard Charnock formula
- DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 )
+ DO_2D( 0, 0, 0, 0 )
zhsro(ji,jj) = MAX( rsbc_zs1 * ustar2_surf(ji,jj) , rn_hsro )
END_2D
CASE ( 2 ) ! Roughness formulae according to Rascle et al., Ocean Modelling (2008)
!!gm faster coding : the 2 comment lines should be used
!!gm zcof = 2._wp * 0.6_wp / 28._wp
!!gm zdep(:,:) = 30._wp * TANH( zcof/ SQRT( MAX(ustar2_surf(:,:),rsmall) ) ) ! Wave age (eq. 10)
- DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 )
+ DO_2D( 0, 0, 0, 0 )
zcof = 30.*TANH( 2.*0.3/(28.*SQRT(MAX(ustar2_surf(ji,jj),rsmall))) ) ! Wave age (eq. 10)
zhsro(ji,jj) = MAX(rsbc_zs2 * ustar2_surf(ji,jj) * zcof**1.5, rn_hsro) ! zhsro = rn_frac_hs * Hsw (eq. 11)
END_2D
CASE ( 3 ) ! Roughness given by the wave model (coupled or read in file)
- zhsro(:,:) = MAX(rn_frac_hs * hsw(A2D(nn_hls)), rn_hsro) ! (rn_frac_hs=1.6 see Eq. (5) of Rascle et al. 2008 )
+ DO_2D( 0, 0, 0, 0 )
+ zhsro(ji,jj) = MAX(rn_frac_hs * hsw(ji,jj), rn_hsro) ! (rn_frac_hs=1.6 see Eq. (5) of Rascle et al. 2008 )
+ END_2D
END SELECT
!
! adapt roughness where there is sea ice
SELECT CASE( nn_mxlice ) ! Type of scaling under sea-ice
!
CASE( 1 ) ! scaling with constant sea-ice roughness
- DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 )
+ DO_2D( 0, 0, 0, 0 )
zhsro(ji,jj) = ( (1._wp-zice_fra(ji,jj)) * zhsro(ji,jj) + zice_fra(ji,jj) * rn_hsri )*tmask(ji,jj,1) + (1._wp - tmask(ji,jj,1))*rn_hsro
END_2D
!
CASE( 2 ) ! scaling with mean sea-ice thickness
#if defined key_si3
- DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 )
+ DO_2D( 0, 0, 0, 0 )
zhsro(ji,jj) = ( (1._wp-zice_fra(ji,jj)) * zhsro(ji,jj) + zice_fra(ji,jj) * hm_i(ji,jj) )*tmask(ji,jj,1) + (1._wp - tmask(ji,jj,1))*rn_hsro
END_2D
#endif
!
CASE( 3 ) ! scaling with max sea-ice thickness
#if defined key_si3 || defined key_cice
- DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 )
+ DO_2D( 0, 0, 0, 0 )
zhsro(ji,jj) = ( (1._wp-zice_fra(ji,jj)) * zhsro(ji,jj) + zice_fra(ji,jj) * MAXVAL(h_i(ji,jj,:)) )*tmask(ji,jj,1) + (1._wp - tmask(ji,jj,1))*rn_hsro
END_2D
#endif
!
END SELECT
!
- DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) !== Compute dissipation rate ==!
+ DO_3D( 0, 0, 0, 0, 2, jpkm1 ) !== Compute dissipation rate ==!
eps(ji,jj,jk) = rc03 * en(ji,jj,jk) * SQRT( en(ji,jj,jk) ) / hmxl_n(ji,jj,jk)
END_3D
! Save tke at before time step
- DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpk )
+ DO_3D( 0, 0, 0, 0, 1, jpk )
eb (ji,jj,jk) = en (ji,jj,jk)
hmxl_b(ji,jj,jk) = hmxl_n(ji,jj,jk)
END_3D
IF( nn_clos == 0 ) THEN ! Mellor-Yamada
- DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 2, jpkm1 )
zup = hmxl_n(ji,jj,jk) * gdepw(ji,jj,mbkt(ji,jj)+1,Kmm)
zdown = vkarmn * gdepw(ji,jj,jk,Kmm) * ( -gdepw(ji,jj,jk,Kmm) + gdepw(ji,jj,mbkt(ji,jj)+1,Kmm) )
zcoef = ( zup / MAX( zdown, rsmall ) )
@@ -285,7 +287,7 @@ CONTAINS
! zdiag : diagonal zd_up : upper diagonal zd_lw : lower diagonal
! Warning : after this step, en : right hand side of the matrix
- DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 2, jpkm1 )
!
buoy = - p_avt(ji,jj,jk) * rn2(ji,jj,jk) ! stratif. destruction
!
@@ -326,7 +328,7 @@ CONTAINS
en(ji,jj,jk) = en(ji,jj,jk) + rn_Dt * zesh2 * wmask(ji,jj,jk)
END_3D
!
- DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 )
+ DO_2D( 0, 0, 0, 0 )
zdiag(ji,jj,jpk) = 1._wp
!
! Set surface condition on zwall_psi (1 at the bottom)
@@ -340,7 +342,7 @@ CONTAINS
SELECT CASE ( nn_bc_surf )
!
CASE ( 0 ) ! Dirichlet boundary condition (set e at k=1 & 2)
- DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 )
+ DO_2D( 0, 0, 0, 0 )
! First level
en (ji,jj,1) = MAX( rn_emin , rc02r * ustar2_surf(ji,jj) * (1._wp + (1._wp-zice_fra(ji,jj))*rsbc_tke1)**r2_3 )
zd_lw(ji,jj,1) = en(ji,jj,1)
@@ -356,7 +358,7 @@ CONTAINS
END_2D
!
IF( ln_isfcav) THEN ! top boundary (ocean cavity)
- DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 )
+ DO_2D( 0, 0, 0, 0 )
IF( mikt(ji,jj) > 1 )THEN
itop = mikt(ji,jj) ! k top w-point
itopp1 = mikt(ji,jj) + 1 ! k+1 1st w-point below the top one
@@ -377,7 +379,7 @@ CONTAINS
!
CASE ( 1 ) ! Neumann boundary condition (set d(e)/dz)
!
- DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 )
+ DO_2D( 0, 0, 0, 0 )
! Dirichlet conditions at k=1
en (ji,jj,1) = MAX( rn_emin , rc02r * ustar2_surf(ji,jj) * (1._wp + (1._wp-zice_fra(ji,jj))*rsbc_tke1)**r2_3 )
zd_lw(ji,jj,1) = en(ji,jj,1)
@@ -398,7 +400,7 @@ CONTAINS
END_2D
!
IF( ln_isfcav) THEN ! top boundary (ocean cavity)
- DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 )
+ DO_2D( 0, 0, 0, 0 )
IF( mikt(ji,jj) > 1 )THEN
itop = mikt(ji,jj) ! k top w-point
itopp1 = mikt(ji,jj) + 1 ! k+1 1st w-point below the top one
@@ -428,7 +430,7 @@ CONTAINS
CASE ( 0 ) ! Dirichlet
! ! en(ibot) = u*^2 / Co2 and hmxl_n(ibot) = rn_lmin
! ! Balance between the production and the dissipation terms
- DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 )
+ DO_2D( 0, 0, 0, 0 )
!!gm This means that bottom and ocean w-level above have a specified "en" value. Sure ????
!! With thick deep ocean level thickness, this may be quite large, no ???
!! in particular in ocean cavities where top stratification can be large...
@@ -447,7 +449,7 @@ CONTAINS
!
! NOTE: ctl_stop with ln_isfcav when using GLS
IF( ln_isfcav) THEN ! top boundary (ocean cavity)
- DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 )
+ DO_2D( 0, 0, 0, 0 )
itop = mikt(ji,jj) ! k top w-point
itopp1 = mikt(ji,jj) + 1 ! k+1 1st w-point below the top one
! ! mask at the ocean surface points
@@ -465,7 +467,7 @@ CONTAINS
!
CASE ( 1 ) ! Neumman boundary condition
!
- DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 )
+ DO_2D( 0, 0, 0, 0 )
ibot = mbkt(ji,jj) + 1 ! k bottom level of w-point
ibotm1 = mbkt(ji,jj) ! k-1 bottom level of w-point but >=1
!
@@ -481,7 +483,7 @@ CONTAINS
END_2D
! NOTE: ctl_stop with ln_isfcav when using GLS
IF( ln_isfcav) THEN ! top boundary (ocean cavity)
- DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 )
+ DO_2D( 0, 0, 0, 0 )
itop = mikt(ji,jj) ! k top w-point
itopp1 = mikt(ji,jj) + 1 ! k+1 1st w-point below the top one
! ! mask at the ocean surface points
@@ -502,17 +504,17 @@ CONTAINS
! Matrix inversion (en prescribed at surface and the bottom)
! ----------------------------------------------------------
!
- DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) ! First recurrence : Dk = Dk - Lk * Uk-1 / Dk-1
+ DO_3D( 0, 0, 0, 0, 2, jpkm1 ) ! First recurrence : Dk = Dk - Lk * Uk-1 / Dk-1
zdiag(ji,jj,jk) = zdiag(ji,jj,jk) - zd_lw(ji,jj,jk) * zd_up(ji,jj,jk-1) / zdiag(ji,jj,jk-1)
END_3D
- DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) ! Second recurrence : Lk = RHSk - Lk / Dk-1 * Lk-1
+ DO_3D( 0, 0, 0, 0, 2, jpkm1 ) ! Second recurrence : Lk = RHSk - Lk / Dk-1 * Lk-1
zd_lw(ji,jj,jk) = en(ji,jj,jk) - zd_lw(ji,jj,jk) / zdiag(ji,jj,jk-1) * zd_lw(ji,jj,jk-1)
END_3D
- DO_3DS_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, jpkm1, 2, -1 ) ! Third recurrence : Ek = ( Lk - Uk * Ek+1 ) / Dk
+ DO_3DS( 0, 0, 0, 0, jpkm1, 2, -1 ) ! Third recurrence : Ek = ( Lk - Uk * Ek+1 ) / Dk
en(ji,jj,jk) = ( zd_lw(ji,jj,jk) - zd_up(ji,jj,jk) * en(ji,jj,jk+1) ) / zdiag(ji,jj,jk)
END_3D
! ! set the minimum value of tke
- DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpk )
+ DO_3D( 0, 0, 0, 0, 1, jpk )
en(ji,jj,jk) = MAX( en(ji,jj,jk), rn_emin )
END_3D
@@ -525,22 +527,22 @@ CONTAINS
SELECT CASE ( nn_clos )
!
CASE( 0 ) ! k-kl (Mellor-Yamada)
- DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 2, jpkm1 )
psi(ji,jj,jk) = eb(ji,jj,jk) * hmxl_b(ji,jj,jk)
END_3D
!
CASE( 1 ) ! k-eps
- DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 2, jpkm1 )
psi(ji,jj,jk) = eps(ji,jj,jk)
END_3D
!
CASE( 2 ) ! k-w
- DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 2, jpkm1 )
psi(ji,jj,jk) = SQRT( eb(ji,jj,jk) ) / ( rc0 * hmxl_b(ji,jj,jk) )
END_3D
!
CASE( 3 ) ! generic
- DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 2, jpkm1 )
psi(ji,jj,jk) = rc02 * eb(ji,jj,jk) * hmxl_b(ji,jj,jk)**rnn
END_3D
!
@@ -553,7 +555,7 @@ CONTAINS
! zdiag : diagonal zd_up : upper diagonal zd_lw : lower diagonal
! Warning : after this step, en : right hand side of the matrix
- DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 2, jpkm1 )
!
! psi / k
zratio = psi(ji,jj,jk) / eb(ji,jj,jk)
@@ -591,7 +593,7 @@ CONTAINS
psi(ji,jj,jk) = psi(ji,jj,jk) + rn_Dt * zesh2 * wmask(ji,jj,jk)
END_3D
!
- DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 )
+ DO_2D( 0, 0, 0, 0 )
zdiag(ji,jj,jpk) = 1._wp
END_2D
@@ -602,7 +604,7 @@ CONTAINS
!
CASE ( 0 ) ! Dirichlet boundary conditions
!
- DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 )
+ DO_2D( 0, 0, 0, 0 )
! Surface value
zdep (ji,jj) = zhsro(ji,jj) * rl_sf ! Cosmetic
psi (ji,jj,1) = rc0**rpp * en(ji,jj,1)**rmm * zdep(ji,jj)**rnn * tmask(ji,jj,1)
@@ -621,7 +623,7 @@ CONTAINS
!
CASE ( 1 ) ! Neumann boundary condition on d(psi)/dz
!
- DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 )
+ DO_2D( 0, 0, 0, 0 )
! Surface value: Dirichlet
zdep (ji,jj) = zhsro(ji,jj) * rl_sf
psi (ji,jj,1) = rc0**rpp * en(ji,jj,1)**rmm * zdep(ji,jj)**rnn * tmask(ji,jj,1)
@@ -657,7 +659,7 @@ CONTAINS
CASE ( 0 ) ! Dirichlet
! ! en(ibot) = u*^2 / Co2 and hmxl_n(ibot) = vkarmn * r_z0_bot
! ! Balance between the production and the dissipation terms
- DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 )
+ DO_2D( 0, 0, 0, 0 )
ibot = mbkt(ji,jj) + 1 ! k bottom level of w-point
ibotm1 = mbkt(ji,jj) ! k-1 bottom level of w-point but >=1
zdep(ji,jj) = vkarmn * r_z0_bot
@@ -675,7 +677,7 @@ CONTAINS
END_2D
!
IF( ln_isfcav) THEN ! top boundary (ocean cavity)
- DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 )
+ DO_2D( 0, 0, 0, 0 )
IF ( mikt(ji,jj) > 1 ) THEN
itop = mikt(ji,jj) ! k top w-point
itopp1 = mikt(ji,jj) + 1 ! k+1 1st w-point below the top one
@@ -698,7 +700,7 @@ CONTAINS
!
CASE ( 1 ) ! Neumman boundary condition
!
- DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 )
+ DO_2D( 0, 0, 0, 0 )
ibot = mbkt(ji,jj) + 1 ! k bottom level of w-point
ibotm1 = mbkt(ji,jj) ! k-1 bottom level of w-point but >=1
!
@@ -722,7 +724,7 @@ CONTAINS
END_2D
!
IF( ln_isfcav) THEN ! top boundary (ocean cavity)
- DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 )
+ DO_2D( 0, 0, 0, 0 )
IF ( mikt(ji,jj) > 1 ) THEN
itop = mikt(ji,jj) ! k top w-point
itopp1 = mikt(ji,jj) + 1 ! k+1 1st w-point below the top one
@@ -755,13 +757,13 @@ CONTAINS
! Matrix inversion
! ----------------
!
- DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) ! First recurrence : Dk = Dk - Lk * Uk-1 / Dk-1
+ DO_3D( 0, 0, 0, 0, 2, jpkm1 ) ! First recurrence : Dk = Dk - Lk * Uk-1 / Dk-1
zdiag(ji,jj,jk) = zdiag(ji,jj,jk) - zd_lw(ji,jj,jk) * zd_up(ji,jj,jk-1) / zdiag(ji,jj,jk-1)
END_3D
- DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) ! Second recurrence : Lk = RHSk - Lk / Dk-1 * Lk-1
+ DO_3D( 0, 0, 0, 0, 2, jpkm1 ) ! Second recurrence : Lk = RHSk - Lk / Dk-1 * Lk-1
zd_lw(ji,jj,jk) = psi(ji,jj,jk) - zd_lw(ji,jj,jk) / zdiag(ji,jj,jk-1) * zd_lw(ji,jj,jk-1)
END_3D
- DO_3DS( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, jpkm1, 2, -1 ) ! Third recurrence : Ek = ( Lk - Uk * Ek+1 ) / Dk
+ DO_3DS( 0, 0, 0, 0, jpkm1, 2, -1 ) ! Third recurrence : Ek = ( Lk - Uk * Ek+1 ) / Dk
psi(ji,jj,jk) = ( zd_lw(ji,jj,jk) - zd_up(ji,jj,jk) * psi(ji,jj,jk+1) ) / zdiag(ji,jj,jk)
END_3D
@@ -771,17 +773,17 @@ CONTAINS
SELECT CASE ( nn_clos )
!
CASE( 0 ) ! k-kl (Mellor-Yamada)
- DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
eps(ji,jj,jk) = rc03 * en(ji,jj,jk) * en(ji,jj,jk) * SQRT( en(ji,jj,jk) ) / MAX( psi(ji,jj,jk), rn_epsmin)
END_3D
!
CASE( 1 ) ! k-eps
- DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
eps(ji,jj,jk) = psi(ji,jj,jk)
END_3D
!
CASE( 2 ) ! k-w
- DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
eps(ji,jj,jk) = rc04 * en(ji,jj,jk) * psi(ji,jj,jk)
END_3D
!
@@ -789,7 +791,7 @@ CONTAINS
zcoef = rc0**( 3._wp + rpp/rnn )
zex1 = ( 1.5_wp + rmm/rnn )
zex2 = -1._wp / rnn
- DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
eps(ji,jj,jk) = zcoef * en(ji,jj,jk)**zex1 * psi(ji,jj,jk)**zex2
END_3D
!
@@ -797,13 +799,13 @@ CONTAINS
! Limit dissipation rate under stable stratification
! --------------------------------------------------
- DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpkm1 ) ! Note that this set boundary conditions on hmxl_n at the same time
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 ) ! Note that this set boundary conditions on hmxl_n at the same time
! limitation
eps (ji,jj,jk) = MAX( eps(ji,jj,jk), rn_epsmin )
hmxl_n(ji,jj,jk) = rc03 * en(ji,jj,jk) * SQRT( en(ji,jj,jk) ) / eps(ji,jj,jk)
END_3D
IF( ln_length_lim ) THEN ! Galperin criterium (NOTE : Not required if the proper value of C3 in stable cases is calculated)
- DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
zrn2 = MAX( rn2(ji,jj,jk), rsmall )
hmxl_n(ji,jj,jk) = MIN( rn_clim_galp * SQRT( 2._wp * en(ji,jj,jk) / zrn2 ), hmxl_n(ji,jj,jk) )
END_3D
@@ -816,7 +818,7 @@ CONTAINS
SELECT CASE ( nn_stab_func )
!
CASE ( 0 , 1 ) ! Galperin or Kantha-Clayson stability functions
- DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 2, jpkm1 )
! zcof = l²/q²
zcof = hmxl_b(ji,jj,jk) * hmxl_b(ji,jj,jk) / ( 2._wp*eb(ji,jj,jk) )
! Gh = -N²l²/q²
@@ -833,7 +835,7 @@ CONTAINS
END_3D
!
CASE ( 2, 3 ) ! Canuto stability functions
- DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 2, jpkm1 )
! zcof = l²/q²
zcof = hmxl_b(ji,jj,jk)*hmxl_b(ji,jj,jk) / ( 2._wp * eb(ji,jj,jk) )
! Gh = -N²l²/q²
@@ -861,17 +863,16 @@ CONTAINS
! Boundary conditions on stability functions for momentum (Neumann):
! Lines below are useless if GOTM style Dirichlet conditions are used
- DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 )
+ DO_2D( 0, 0, 0, 0 )
zstm(ji,jj,1) = zstm(ji,jj,2)
zstm(ji,jj,jpk) = 0. ! default value, in case jpk > mbkt(ji,jj)+1
! ! Not needed but avoid a bug when looking for undefined values (-fpe0)
END_2D
- DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) ! update bottom with good values
+ DO_2D( 0, 0, 0, 0 ) ! update bottom with good values
zstm(ji,jj,mbkt(ji,jj)+1) = zstm(ji,jj,mbkt(ji,jj))
END_2D
-
- zstt(:,:, 1) = wmask(A2D(nn_hls), 1) ! default value not needed but avoid a bug when looking for undefined values (-fpe0)
- zstt(:,:,jpk) = wmask(A2D(nn_hls),jpk) ! default value not needed but avoid a bug when looking for undefined values (-fpe0)
+ zstt(:,:, 1) = wmask(A2D(0), 1) ! default value not needed but avoid a bug when looking for undefined values (-fpe0)
+ zstt(:,:,jpk) = wmask(A2D(0),jpk) ! default value not needed but avoid a bug when looking for undefined values (-fpe0)
!!gm should be done for ISF (top boundary cond.)
!!gm so, totally new staff needed!!gm
@@ -881,14 +882,14 @@ CONTAINS
! -> yes BUT p_avm(:,:1) and p_avm(:,:jpk) are used when we compute zd_lw(:,:2) and zd_up(:,:jpkm1). These values are
! later overwritten by surface/bottom boundaries conditions, so we don't really care of p_avm(:,:1) and p_avm(:,:jpk)
! for zd_lw and zd_up but they have to be defined to avoid a bug when looking for undefined values (-fpe0)
- DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpk )
+ DO_3D( 0, 0, 0, 0, 1, jpk )
zsqen = SQRT( 2._wp * en(ji,jj,jk) ) * hmxl_n(ji,jj,jk)
zavt = zsqen * zstt(ji,jj,jk)
zavm = zsqen * zstm(ji,jj,jk)
p_avt(ji,jj,jk) = MAX( zavt, avtb(jk) ) * wmask(ji,jj,jk) ! apply mask for zdfmxl routine
p_avm(ji,jj,jk) = MAX( zavm, avmb(jk) ) ! Note that avm is not masked at the surface and the bottom
END_3D
- p_avt(A2D(nn_hls),1) = 0._wp
+ p_avt(:,:,1) = 0._wp
!
IF(sn_cfctl%l_prtctl) THEN
CALL prt_ctl( tab3d_1=en , clinfo1=' gls - e: ', tab3d_2=p_avt, clinfo2=' t: ' )
@@ -970,7 +971,8 @@ CONTAINS
CALL ctl_stop( 'zdf_gls_init: wrong value for nn_mxlice, should be 0,1,2,3 ')
END SELECT
IF ( (nn_mxlice>0).AND.(nn_ice==0) ) THEN
- CALL ctl_stop( 'zdf_gls_init: with no ice at all, nn_mxlice must be 0 ')
+ CALL ctl_warn( 'zdf_gls_init: with no ice at all, nn_mxlice is set to 0 ')
+ nn_mxlice = 0
ELSEIF ( (nn_mxlice>1).AND.(nn_ice==1) ) THEN
CALL ctl_stop( 'zdf_gls_init: with no ice model, nn_mxlice must be 0 or 1')
ENDIF
@@ -1212,7 +1214,7 @@ CONTAINS
!
! !* Wall proximity function
!!gm tmask or wmask ????
- zwall(:,:,:) = 1._wp * tmask(:,:,:)
+ zwall(:,:,:) = 1._wp * tmask(A2D(0),:)
! !* read or initialize all required files
CALL gls_rst( nit000, 'READ' ) ! (en, avt_k, avm_k, hmxl_n)
diff --git a/src/OCE/ZDF/zdfiwm.F90 b/src/OCE/ZDF/zdfiwm.F90
index d0a9540eaa619d70c6eff3ba70b4c417f26f84d1..240adb952733bad3ac3ef20eba14ceb2745ac2c1 100644
--- a/src/OCE/ZDF/zdfiwm.F90
+++ b/src/OCE/ZDF/zdfiwm.F90
@@ -65,8 +65,8 @@ CONTAINS
!!----------------------------------------------------------------------
!! *** FUNCTION zdf_iwm_alloc ***
!!----------------------------------------------------------------------
- ALLOCATE( ebot_iwm(jpi,jpj), ecri_iwm(jpi,jpj), ensq_iwm(jpi,jpj) , &
- & esho_iwm(jpi,jpj), hbot_iwm(jpi,jpj), hcri_iwm(jpi,jpj) , STAT=zdf_iwm_alloc )
+ ALLOCATE( ebot_iwm(A2D(0)), ecri_iwm(A2D(0)), ensq_iwm(A2D(0)) , &
+ & esho_iwm(A2D(0)), hbot_iwm(A2D(0)), hcri_iwm(A2D(0)) , STAT=zdf_iwm_alloc )
!
CALL mpp_sum ( 'zdfiwm', zdf_iwm_alloc )
IF( zdf_iwm_alloc /= 0 ) CALL ctl_stop( 'STOP', 'zdf_iwm_alloc: failed to allocate arrays' )
@@ -100,7 +100,7 @@ CONTAINS
!! 2. Bottom-intensified dissipation above abyssal hills, expressed
!! as an algebraic decay above bottom.
!! zemx_iwm(z) = ( ebot_iwm / rho0 ) * ( 1 + hbot_iwm/H )
- !! / ( 1 + (H-z)/hbot_iwm )^2
+ !! / ( 1 + (H-z)/hbot_iwm )^2
!! where hbot_iwm is the characteristic length scale of the bottom
!! intensification and ebot_iwm is a static 2D map of available power.
!! 3. Dissipation scaling in the vertical with the squared buoyancy
@@ -127,29 +127,32 @@ CONTAINS
!! References : de Lavergne et al. JAMES 2020, https://doi.org/10.1029/2020MS002065
!! de Lavergne et al. JPO 2016, https://doi.org/10.1175/JPO-D-14-0259.1
!!----------------------------------------------------------------------
- INTEGER , INTENT(in ) :: kt ! ocean time step
- INTEGER , INTENT(in ) :: Kmm ! time level index
- REAL(wp), DIMENSION(:,:,:) , INTENT(inout) :: p_avm ! momentum Kz (w-points)
- REAL(wp), DIMENSION(:,:,:) , INTENT(inout) :: p_avt, p_avs ! tracer Kz (w-points)
+ INTEGER , INTENT(in ) :: kt ! ocean time step
+ INTEGER , INTENT(in ) :: Kmm ! time level index
+ REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: p_avm ! vertical eddy viscosity (w-points)
+ REAL(wp), DIMENSION(A2D(0) ,jpk), INTENT(inout) :: p_avt, p_avs ! vertical eddy diffusivity (w-points)
!
INTEGER :: ji, jj, jk ! dummy loop indices
REAL(wp), SAVE :: zztmp
!
- REAL(wp), DIMENSION(A2D(nn_hls)) :: zfact ! Used for vertical structure
- REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zReb ! Turbulence intensity parameter
- REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zemx_iwm ! local energy density available for mixing (W/kg)
- REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zav_ratio ! S/T diffusivity ratio (only for ln_tsdiff=T)
- REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zav_wave ! Internal wave-induced diffusivity
+ REAL(wp), DIMENSION(T2D(0)) :: zfact ! Used for vertical structure
+ REAL(wp), DIMENSION(T2D(0),jpk) :: zReb ! Turbulence intensity parameter
+ REAL(wp), DIMENSION(T2D(0),jpk) :: zemx_iwm ! local energy density available for mixing (W/kg)
+ REAL(wp), DIMENSION(T2D(0),jpk) :: zav_ratio ! S/T diffusivity ratio (only for ln_tsdiff=T)
+ REAL(wp), DIMENSION(T2D(0),jpk) :: zav_wave ! Internal wave-induced diffusivity
REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: z3d ! 3D workspace used for iom_put
REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: z2d ! 2D - - - -
!!----------------------------------------------------------------------
!
- ! !* Initialize appropriately certain variables
- DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpk )
- zav_ratio(ji,jj,jk) = 1._wp * wmask(ji,jj,jk) ! important to set it to 1 here
- END_3D
- IF( iom_use("emix_iwm") ) zemx_iwm (:,:,:) = 0._wp
- IF( iom_use("av_wave") .OR. sn_cfctl%l_prtctl ) zav_wave (:,:,:) = 0._wp
+ ! !* Initialize variables at 1 & jpk for diagnostics
+ zav_ratio(:,:,1 ) = 1._wp * wmask(T2D(0),1 ) ! important to set it to 1 here
+ zav_ratio(:,:,jpk) = 1._wp * wmask(T2D(0),jpk)
+ IF( iom_use("emix_iwm") ) THEN
+ zemx_iwm(:,:,1) = 0._wp ; zemx_iwm(:,:,jpk) = 0._wp
+ ENDIF
+ IF( iom_use("av_wave") .OR. sn_cfctl%l_prtctl ) THEN
+ zav_wave(:,:,1) = 0._wp ; zav_wave(:,:,jpk) = 0._wp
+ ENDIF
!
! ! ----------------------------- !
! ! Internal wave-driven mixing ! (compute zav_wave)
@@ -157,79 +160,78 @@ CONTAINS
!
! !* 'cri' component: distribute energy over the time-varying
! !* ocean depth using an exponential decay from the seafloor.
- DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) ! part independent of the level
- IF( ht(ji,jj) /= 0._wp ) THEN ; zfact(ji,jj) = ecri_iwm(ji,jj) * r1_rho0 / ( 1._wp - EXP( -ht(ji,jj) * hcri_iwm(ji,jj) ) )
- ELSE ; zfact(ji,jj) = 0._wp
+ DO_2D( 0, 0, 0, 0 ) ! part independent of the level
+ IF( ht(ji,jj,Kmm) /= 0._wp ) THEN ; zfact(ji,jj) = ecri_iwm(ji,jj) * r1_rho0 / ( 1._wp - EXP( -ht(ji,jj,Kmm) * hcri_iwm(ji,jj) ) )
+ ELSE ; zfact(ji,jj) = 0._wp
ENDIF
END_2D
-
- DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) ! complete with the level-dependent part
- zemx_iwm(ji,jj,jk) = zfact(ji,jj) * ( EXP( ( gdept(ji,jj,jk ,Kmm) - ht(ji,jj) ) * hcri_iwm(ji,jj) ) &
- & - EXP( ( gdept(ji,jj,jk-1,Kmm) - ht(ji,jj) ) * hcri_iwm(ji,jj) ) &
+ DO_3D( 0, 0, 0, 0, 2, jpkm1 ) ! complete with the level-dependent part
+ zemx_iwm(ji,jj,jk) = zfact(ji,jj) * ( EXP( ( gdept(ji,jj,jk ,Kmm) - ht(ji,jj,Kmm) ) * hcri_iwm(ji,jj) ) &
+ & - EXP( ( gdept(ji,jj,jk-1,Kmm) - ht(ji,jj,Kmm) ) * hcri_iwm(ji,jj) ) &
& ) * wmask(ji,jj,jk) / e3w(ji,jj,jk,Kmm)
END_3D
-
!* 'bot' component: distribute energy over the time-varying
!* ocean depth using an algebraic decay above the seafloor.
- DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) ! part independent of the level
- IF( ht(ji,jj) /= 0._wp ) THEN ; zfact(ji,jj) = ebot_iwm(ji,jj) * ( 1._wp + hbot_iwm(ji,jj) / ht(ji,jj) ) * r1_rho0
- ELSE ; zfact(ji,jj) = 0._wp
+
+ DO_2D( 0, 0, 0, 0 ) ! part independent of the level
+ IF( ht(ji,jj,Kmm) /= 0._wp ) THEN ; zfact(ji,jj) = ebot_iwm(ji,jj) * ( 1._wp + hbot_iwm(ji,jj) / ht(ji,jj,Kmm) ) * r1_rho0
+ ELSE ; zfact(ji,jj) = 0._wp
ENDIF
END_2D
- DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) ! complete with the level-dependent part
+ DO_3D( 0, 0, 0, 0, 2, jpkm1 ) ! complete with the level-dependent part
zemx_iwm(ji,jj,jk) = zemx_iwm(ji,jj,jk) + &
- & zfact(ji,jj) * ( 1._wp / ( 1._wp + ( ht(ji,jj) - gdept(ji,jj,jk ,Kmm) ) / hbot_iwm(ji,jj) ) &
- & - 1._wp / ( 1._wp + ( ht(ji,jj) - gdept(ji,jj,jk-1,Kmm) ) / hbot_iwm(ji,jj) ) &
+ & zfact(ji,jj) * ( 1._wp / ( 1._wp + ( ht(ji,jj,Kmm) - gdept(ji,jj,jk ,Kmm) ) / hbot_iwm(ji,jj) ) &
+ & - 1._wp / ( 1._wp + ( ht(ji,jj,Kmm) - gdept(ji,jj,jk-1,Kmm) ) / hbot_iwm(ji,jj) ) &
& ) * wmask(ji,jj,jk) / e3w(ji,jj,jk,Kmm)
END_3D
!* 'nsq' component: distribute energy over the time-varying
!* ocean depth as proportional to rn2
- DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 )
+ DO_2D( 0, 0, 0, 0 )
zfact(ji,jj) = 0._wp
END_2D
- DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) ! part independent of the level
+ DO_3D( 0, 0, 0, 0, 2, jpkm1 ) ! part independent of the level
zfact(ji,jj) = zfact(ji,jj) + e3w(ji,jj,jk,Kmm) * MAX( 0._wp, rn2(ji,jj,jk) )
END_3D
!
- DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 )
+ DO_2D( 0, 0, 0, 0 )
IF( zfact(ji,jj) /= 0._wp ) zfact(ji,jj) = ensq_iwm(ji,jj) * r1_rho0 / zfact(ji,jj)
END_2D
!
- DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) ! complete with the level-dependent part
+ DO_3D( 0, 0, 0, 0, 2, jpkm1 ) ! complete with the level-dependent part
zemx_iwm(ji,jj,jk) = zemx_iwm(ji,jj,jk) + zfact(ji,jj) * MAX( 0._wp, rn2(ji,jj,jk) )
END_3D
!* 'sho' component: distribute energy over the time-varying
!* ocean depth as proportional to sqrt(rn2)
- DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 )
+ DO_2D( 0, 0, 0, 0 )
zfact(ji,jj) = 0._wp
END_2D
- DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) ! part independent of the level
+ DO_3D( 0, 0, 0, 0, 2, jpkm1 ) ! part independent of the level
zfact(ji,jj) = zfact(ji,jj) + e3w(ji,jj,jk,Kmm) * SQRT( MAX( 0._wp, rn2(ji,jj,jk) ) )
END_3D
!
- DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 )
+ DO_2D( 0, 0, 0, 0 )
IF( zfact(ji,jj) /= 0._wp ) zfact(ji,jj) = esho_iwm(ji,jj) * r1_rho0 / zfact(ji,jj)
END_2D
!
- DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) ! complete with the level-dependent part
+ DO_3D( 0, 0, 0, 0, 2, jpkm1 ) ! complete with the level-dependent part
zemx_iwm(ji,jj,jk) = zemx_iwm(ji,jj,jk) + zfact(ji,jj) * SQRT( MAX( 0._wp, rn2(ji,jj,jk) ) )
END_3D
! Calculate turbulence intensity parameter Reb
- DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 2, jpkm1 )
zReb(ji,jj,jk) = zemx_iwm(ji,jj,jk) / MAX( 1.e-20_wp, rnu * rn2(ji,jj,jk) )
END_3D
!
! Define internal wave-induced diffusivity
- DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 2, jpkm1 )
zav_wave(ji,jj,jk) = zReb(ji,jj,jk) * r1_6 * rnu ! This corresponds to a constant mixing efficiency of 1/6
END_3D
!
IF( ln_mevar ) THEN ! Variable mixing efficiency case : modify zav_wave in the
- DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) ! energetic (Reb > 480) and buoyancy-controlled (Reb <10.224) regimes
+ DO_3D( 0, 0, 0, 0, 2, jpkm1 ) ! energetic (Reb > 480) and buoyancy-controlled (Reb <10.224) regimes
IF( zReb(ji,jj,jk) > 480.00_wp ) THEN
zav_wave(ji,jj,jk) = 3.6515_wp * rnu * SQRT( zReb(ji,jj,jk) )
ELSEIF( zReb(ji,jj,jk) < 10.224_wp ) THEN
@@ -238,7 +240,7 @@ CONTAINS
END_3D
ENDIF
!
- DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) ! Bound diffusivity by molecular value and 100 cm2/s
+ DO_3D( 0, 0, 0, 0, 2, jpkm1 ) ! Bound diffusivity by molecular value and 100 cm2/s
zav_wave(ji,jj,jk) = MIN( MAX( 1.4e-7_wp, zav_wave(ji,jj,jk) ), 1.e-2_wp ) * wmask(ji,jj,jk)
END_3D
!
@@ -247,15 +249,19 @@ CONTAINS
! ! ----------------------- !
!
IF( ln_tsdiff ) THEN !* Option for differential mixing of salinity and temperature
- DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) ! Calculate S/T diffusivity ratio as a function of Reb (else it is set to 1)
+ DO_3D( 0, 0, 0, 0, 2, jpkm1 ) ! Calculate S/T diffusivity ratio as a function of Reb (else it is set to 1)
zav_ratio(ji,jj,jk) = ( 0.505_wp + &
& 0.495_wp * TANH( 0.92_wp * ( LOG10( MAX( 1.e-20, zReb(ji,jj,jk) * 5._wp * r1_6 ) ) - 0.60_wp ) ) &
& ) * wmask(ji,jj,jk)
END_3D
+ ELSE
+ DO_3D( 0, 0, 0, 0, 2, jpkm1 )
+ zav_ratio(ji,jj,jk) = 1._wp * wmask(ji,jj,jk)
+ END_3D
ENDIF
CALL iom_put( "av_ratio", zav_ratio )
!
- DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) !* update momentum & tracer diffusivity with wave-driven mixing
+ DO_3D( 0, 0, 0, 0, 2, jpkm1 ) !* update momentum & tracer diffusivity with wave-driven mixing
p_avs(ji,jj,jk) = p_avs(ji,jj,jk) + zav_wave(ji,jj,jk) * zav_ratio(ji,jj,jk)
p_avt(ji,jj,jk) = p_avt(ji,jj,jk) + zav_wave(ji,jj,jk)
p_avm(ji,jj,jk) = p_avm(ji,jj,jk) + zav_wave(ji,jj,jk)
@@ -265,8 +271,10 @@ CONTAINS
!* output useful diagnostics: Kz*N^2 ,
! vertical integral of rho0 * Kz * N^2 , energy density (zemx_iwm)
IF( iom_use("bflx_iwm") .OR. iom_use("pcmap_iwm") ) THEN
- ALLOCATE( z2d(A2D(nn_hls)) , z3d(A2D(nn_hls),jpk) )
- z2d(:,:) = 0._wp ; z3d(:,:,:) = 0._wp ! Initialisation for iom_put
+ ALLOCATE( z2d(T2D(0)), z3d(T2D(0),jpk) )
+ ! Initialise 1 & jpk for diagnostics
+ z2d(:,:) = 0._wp ; z3d(:,:,1) = 0._wp ; z3d(:,:,jpk) = 0._wp
+
DO_3D( 0, 0, 0, 0, 2, jpkm1 )
z3d(ji,jj,jk) = MAX( 0._wp, rn2(ji,jj,jk) ) * zav_wave(ji,jj,jk)
z2d(ji,jj) = z2d(ji,jj) + rho0 * e3w(ji,jj,jk,Kmm) * z3d(ji,jj,jk) * wmask(ji,jj,jk)
@@ -282,7 +290,7 @@ CONTAINS
IF( .NOT. l_istiled .OR. ntile == 1 ) zztmp = 0._wp ! Do only on the first tile
DO_3D( 0, 0, 0, 0, 2, jpkm1 )
zztmp = zztmp + e3w(ji,jj,jk,Kmm) * e1e2t(ji,jj) &
- & * MAX( 0._wp, rn2(ji,jj,jk) ) * zav_wave(ji,jj,jk) * wmask(ji,jj,jk) * tmask_i(ji,jj)
+ & * MAX( 0._wp, rn2(ji,jj,jk) ) * zav_wave(ji,jj,jk) * wmask(ji,jj,jk) * smask0_i(ji,jj)
END_3D
IF( .NOT. l_istiled .OR. ntile == nijtile ) THEN ! Do only on the last tile
@@ -299,7 +307,7 @@ CONTAINS
ENDIF
ENDIF
- IF(sn_cfctl%l_prtctl) CALL prt_ctl(tab3d_1=zav_wave , clinfo1=' iwm - av_wave: ', tab3d_2=avt, clinfo2=' avt: ')
+ IF(sn_cfctl%l_prtctl) CALL prt_ctl(tab3d_1=zav_wave , clinfo1=' iwm - av_wave: ', tab3d_2=p_avt, clinfo2=' avt: ')
!
END SUBROUTINE zdf_iwm
@@ -341,14 +349,16 @@ CONTAINS
INTEGER, PARAMETER :: jp_mps = 4
INTEGER, PARAMETER :: jp_dsb = 5
INTEGER, PARAMETER :: jp_dsc = 6
+ INTEGER :: ji, jj
!
TYPE(FLD_N), DIMENSION(jpiwm) :: slf_iwm ! array of namelist informations
TYPE(FLD_N) :: sn_mpb, sn_mpc, sn_mpn, sn_mps ! information about Mixing Power field to be read
TYPE(FLD_N) :: sn_dsb, sn_dsc ! information about Decay Scale field to be read
TYPE(FLD ), DIMENSION(jpiwm) :: sf_iwm ! structure of input fields (file informations, fields read)
!
- REAL(wp), DIMENSION(jpi,jpj,4) :: ztmp
- REAL(wp), DIMENSION(4) :: zdia
+ REAL(wp), DIMENSION(A2D(0),4) :: ztmp
+ REAL(wp), DIMENSION(4) :: zdia
+ REAL(wp) :: zcte
!
NAMELIST/namzdf_iwm/ ln_mevar, ln_tsdiff, &
& cn_dir, sn_mpb, sn_mpc, sn_mpn, sn_mps, sn_dsb, sn_dsc
@@ -373,10 +383,10 @@ CONTAINS
! This internal-wave-driven mixing parameterization elevates avt and avm in the interior, and
! ensures that avt remains larger than its molecular value (=1.4e-7). Therefore, avtb should
! be set here to a very small value, and avmb to its (uniform) molecular value (=1.4e-6).
- avmb(:) = rnu ! molecular value
- avtb(:) = 1.e-10_wp ! very small diffusive minimum (background avt is specified in zdf_iwm)
- avtb_2d(:,:) = 1._wp ! uniform
- IF(lwp) THEN ! Control print
+ avmb(:) = rnu ! molecular value
+ avtb(:) = 1.e-10_wp ! very small diffusive minimum (background avt is specified in zdf_iwm)
+ avtb_2d(:,:) = 1._wp ! uniform
+ IF(lwp) THEN ! Control print
WRITE(numout,*)
WRITE(numout,*) ' Force the background value applied to avm & avt in TKE to be everywhere ', &
& 'the viscous molecular value & a very small diffusive value, resp.'
@@ -390,40 +400,46 @@ CONTAINS
slf_iwm(jp_dsb) = sn_dsb ; slf_iwm(jp_dsc) = sn_dsc
!
DO ifpr= 1, jpiwm
- ALLOCATE( sf_iwm(ifpr)%fnow(jpi,jpj,1) )
- IF( slf_iwm(ifpr)%ln_tint ) ALLOCATE( sf_iwm(ifpr)%fdta(jpi,jpj,1,2) )
+ ALLOCATE( sf_iwm(ifpr)%fnow(A2D(0),1) )
+ IF( slf_iwm(ifpr)%ln_tint ) ALLOCATE( sf_iwm(ifpr)%fdta(A2D(0),1,2) )
END DO
! fill sf_iwm with sf_iwm and control print
CALL fld_fill( sf_iwm, slf_iwm , cn_dir, 'zdfiwm_init', 'iwm input file', 'namiwm' )
! ! hard-coded default values
- sf_iwm(jp_mpb)%fnow(:,:,1) = 1.e-10_wp
- sf_iwm(jp_mpc)%fnow(:,:,1) = 1.e-10_wp
- sf_iwm(jp_mpn)%fnow(:,:,1) = 1.e-5_wp
- sf_iwm(jp_mps)%fnow(:,:,1) = 1.e-10_wp
- sf_iwm(jp_dsb)%fnow(:,:,1) = 100._wp
- sf_iwm(jp_dsc)%fnow(:,:,1) = 100._wp
+ DO_2D( 0, 0, 0, 0 )
+ sf_iwm(jp_mpb)%fnow(ji,jj,1) = 1.e-10_wp
+ sf_iwm(jp_mpc)%fnow(ji,jj,1) = 1.e-10_wp
+ sf_iwm(jp_mpn)%fnow(ji,jj,1) = 1.e-5_wp
+ sf_iwm(jp_mps)%fnow(ji,jj,1) = 1.e-10_wp
+ sf_iwm(jp_dsb)%fnow(ji,jj,1) = 100._wp
+ sf_iwm(jp_dsc)%fnow(ji,jj,1) = 100._wp
+ END_2D
! ! read necessary fields
CALL fld_read( nit000, 1, sf_iwm )
- ebot_iwm(:,:) = sf_iwm(1)%fnow(:,:,1) * ssmask(:,:) ! energy flux for dissipation above abyssal hills [W/m2]
- ecri_iwm(:,:) = sf_iwm(2)%fnow(:,:,1) * ssmask(:,:) ! energy flux for dissipation at topographic slopes [W/m2]
- ensq_iwm(:,:) = sf_iwm(3)%fnow(:,:,1) * ssmask(:,:) ! energy flux for dissipation scaling with N^2 [W/m2]
- esho_iwm(:,:) = sf_iwm(4)%fnow(:,:,1) * ssmask(:,:) ! energy flux for dissipation due to shoaling [W/m2]
- hbot_iwm(:,:) = sf_iwm(5)%fnow(:,:,1) ! spatially variable decay scale for abyssal hill dissipation [m]
- hcri_iwm(:,:) = sf_iwm(6)%fnow(:,:,1) ! spatially variable decay scale for topographic-slope [m]
-
- hcri_iwm(:,:) = 1._wp / hcri_iwm(:,:) ! only the inverse height is used, hence calculated here once for all
+ DO_2D( 0, 0, 0, 0 )
+ zcte = smask0(ji,jj)
+ ebot_iwm(ji,jj) = sf_iwm(1)%fnow(ji,jj,1) * zcte ! energy flux for dissipation above abyssal hills [W/m2]
+ ecri_iwm(ji,jj) = sf_iwm(2)%fnow(ji,jj,1) * zcte ! energy flux for dissipation at topographic slopes [W/m2]
+ ensq_iwm(ji,jj) = sf_iwm(3)%fnow(ji,jj,1) * zcte ! energy flux for dissipation scaling with N^2 [W/m2]
+ esho_iwm(ji,jj) = sf_iwm(4)%fnow(ji,jj,1) * zcte ! energy flux for dissipation due to shoaling [W/m2]
+ hbot_iwm(ji,jj) = sf_iwm(5)%fnow(ji,jj,1) ! spatially variable decay scale for abyssal hill dissipation [m]
+ hcri_iwm(ji,jj) = 1._wp / sf_iwm(6)%fnow(ji,jj,1) ! inverse decay scale for topographic slope dissipation [m-1]
+ END_2D
! diags
- ztmp(:,:,1) = e1e2t(:,:) * ebot_iwm(:,:)
- ztmp(:,:,2) = e1e2t(:,:) * ecri_iwm(:,:)
- ztmp(:,:,3) = e1e2t(:,:) * ensq_iwm(:,:)
- ztmp(:,:,4) = e1e2t(:,:) * esho_iwm(:,:)
+ DO_2D( 0, 0, 0, 0 )
+ zcte = e1e2t(ji,jj)
+ ztmp(ji,jj,1) = zcte * ebot_iwm(ji,jj)
+ ztmp(ji,jj,2) = zcte * ecri_iwm(ji,jj)
+ ztmp(ji,jj,3) = zcte * ensq_iwm(ji,jj)
+ ztmp(ji,jj,4) = zcte * esho_iwm(ji,jj)
+ END_2D
- zdia(1:4) = glob_sum_vec( 'zdfiwm', ztmp(:,:,1:4) )
+ zdia(1:4) = glob_sum_vec( 'zdfiwm', ztmp )
IF(lwp) THEN
WRITE(numout,*) ' Dissipation above abyssal hills: ', zdia(1) * 1.e-12_wp, 'TW'
diff --git a/src/OCE/ZDF/zdfmfc.F90 b/src/OCE/ZDF/zdfmfc.F90
index f984b2bfa425f1ceb62b6c249dff7a5a3fca0a98..76999f8c0ae32d74178247849fb1d268ad14e2ae 100644
--- a/src/OCE/ZDF/zdfmfc.F90
+++ b/src/OCE/ZDF/zdfmfc.F90
@@ -19,7 +19,6 @@
!
USE oce ! ocean dynamics and active tracers
USE dom_oce ! ocean space and time domain
- USE domvvl ! ocean space and time domain : variable volume layer
USE domzgr
USE zdf_oce ! ocean vertical physics
USE sbc_oce ! surface boundary condition: ocean
@@ -69,8 +68,8 @@ CONTAINS
!!----------------------------------------------------------------------
!! *** FUNCTION zdf_edmf_alloc ***
!!----------------------------------------------------------------------
- ALLOCATE( edmfa(jpi,jpj,jpk) , edmfb(jpi,jpj,jpk) , edmfc(jpi,jpj,jpk) &
- & , edmftra(jpi,jpj,jpk,2), edmfm(jpi,jpj,jpk) , STAT= zdf_mfc_alloc )
+ ALLOCATE( edmfa(A2D(0),jpk) , edmfb(A2D(0),jpk) , edmfc(A2D(0),jpk), &
+ & edmftra(A2D(0),jpk,2), edmfm(A2D(0),jpk) , STAT= zdf_mfc_alloc )
!
IF( lk_mpp ) CALL mpp_sum ( 'zdfmfc', zdf_mfc_alloc )
IF( zdf_mfc_alloc /= 0 ) CALL ctl_warn('zdf_mfc_alloc: failed to allocate arrays')
@@ -95,26 +94,26 @@ CONTAINS
!!----------------------------------------------------------------------
INTEGER , INTENT(in) :: Kmm, Krhs ! time level indices
REAL(wp), DIMENSION(jpi,jpj,jpk,jpts,jpt), INTENT(inout) :: pts ! active tracers and RHS of tracer equation
- REAL(wp), DIMENSION(A2D(nn_hls),jpk,2) :: ztsp ! T/S of the plume
- REAL(wp), DIMENSION(A2D(nn_hls),jpk,2) :: ztse ! T/S at W point
- REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zrwp !
- REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zrwp2 !
- REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zapp !
- REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zedmf !
- REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zepsT, zepsW !
+ REAL(wp), DIMENSION(T2D(0),jpk,2) :: ztsp ! T/S of the plume
+ REAL(wp), DIMENSION(T2D(0),jpk,2) :: ztse ! T/S at W point
+ REAL(wp), DIMENSION(T2D(0),jpk) :: zrwp !
+ REAL(wp), DIMENSION(T2D(0),jpk) :: zrwp2 !
+ REAL(wp), DIMENSION(T2D(0),jpk) :: zapp !
+ REAL(wp), DIMENSION(T2D(0),jpk) :: zedmf !
+ REAL(wp), DIMENSION(T2D(0),jpk) :: zepsT, zepsW !
!
- REAL(wp), DIMENSION(A2D(nn_hls)) :: zustar, zustar2 !
- REAL(wp), DIMENSION(A2D(nn_hls)) :: zuws, zvws, zsws, zfnet !
- REAL(wp), DIMENSION(A2D(nn_hls)) :: zfbuo, zrautbm1, zrautb, zraupl
- REAL(wp), DIMENSION(A2D(nn_hls)) :: zwpsurf !
- REAL(wp), DIMENSION(A2D(nn_hls)) :: zop0 , zsp0 !
- REAL(wp), DIMENSION(A2D(nn_hls)) :: zrwp_0, zrwp2_0 !
- REAL(wp), DIMENSION(A2D(nn_hls)) :: zapp0 !
- REAL(wp), DIMENSION(A2D(nn_hls)) :: zphp, zph, zphpm1, zphm1, zNHydro
- REAL(wp), DIMENSION(A2D(nn_hls)) :: zhcmo !
+ REAL(wp), DIMENSION(T2D(0)) :: zustar, zustar2 !
+ REAL(wp), DIMENSION(T2D(0)) :: zuws, zvws, zsws, zfnet !
+ REAL(wp), DIMENSION(T2D(0)) :: zfbuo, zrautbm1, zrautb, zraupl
+ REAL(wp), DIMENSION(T2D(0)) :: zwpsurf !
+ REAL(wp), DIMENSION(T2D(0)) :: zop0 , zsp0 !
+ REAL(wp), DIMENSION(T2D(0)) :: zrwp_0, zrwp2_0 !
+ REAL(wp), DIMENSION(T2D(0)) :: zapp0 !
+ REAL(wp), DIMENSION(T2D(0)) :: zphp, zph, zphpm1, zphm1, zNHydro
+ REAL(wp), DIMENSION(T2D(0)) :: zhcmo !
!
- REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zn2 ! N^2
- REAL(wp), DIMENSION(A2D(nn_hls),2 ) :: zab, zabm1, zabp ! alpha and beta
+ REAL(wp), DIMENSION(T2D(0),jpk) :: zn2 ! N^2
+ REAL(wp), DIMENSION(T2D(0),2 ) :: zab, zabm1, zabp ! alpha and beta
REAL(wp), PARAMETER :: zepsilon = 1.e-30 ! local small value
@@ -135,7 +134,7 @@ CONTAINS
zcb = 1._wp
zcd = 1._wp
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
!------------------------------------------------------------------
! Surface boundary condition
!------------------------------------------------------------------
@@ -160,8 +159,10 @@ CONTAINS
!-------------------------------------------
zrwp (ji,jj,:) = 0._wp ; zrwp2(ji,jj,:) = 0._wp ; zedmf(ji,jj,:) = 0._wp
zph (ji,jj) = 0._wp ; zphm1(ji,jj) = 0._wp ; zphpm1(ji,jj) = 0._wp
- ztsp(ji,jj,:,:)= 0._wp
+ END_2D
+ DO_2D( 0, 0, 0, 0 )
+ ztsp(ji,jj,:,:) = 0._wp ; ztse(ji,jj,:,:) = 0._wp
! Tracers inside plume (ztsp) and environment (ztse)
ztsp(ji,jj,1,jp_tem) = pts(ji,jj,1,jp_tem,Kmm) * tmask(ji,jj,1)
ztsp(ji,jj,1,jp_sal) = pts(ji,jj,1,jp_sal,Kmm) * tmask(ji,jj,1)
@@ -169,17 +170,19 @@ CONTAINS
ztse(ji,jj,1,jp_sal) = pts(ji,jj,1,jp_sal,Kmm) * tmask(ji,jj,1)
END_2D
- CALL eos( ztse(:,:,1,:) , zrautb(:,:) )
- CALL eos( ztsp(:,:,1,:) , zraupl(:,:) )
+ CALL eos( ztse(:,:,1,:) , zrautb(:,:), kbnd=0 )
+ CALL eos( ztsp(:,:,1,:) , zraupl(:,:), kbnd=0 )
!-------------------------------------------
! Boundary Condition of Mass Flux (plume velo.; convective area, entrain/detrain)
!-------------------------------------------
- zhcmo(:,:) = e3t(A1Di(nn_hls),A1Dj(nn_hls),1,Kmm)
- zfbuo(:,:) = 0._wp
+ DO_2D( 0, 0, 0, 0 )
+ zhcmo(ji,jj) = e3t(ji,jj,1,Kmm)
+ zfbuo(ji,jj) = 0._wp
+ END_2D
WHERE ( ABS(zrautb(:,:)) > 1.e-20 ) zfbuo(:,:) = &
& grav * ( 2.e-4_wp *zfnet(:,:) &
- & - 7.6E-4_wp*pts(A2D(nn_hls),1,jp_sal,Kmm) &
+ & - 7.6E-4_wp*pts(T2D(0),1,jp_sal,Kmm) &
& * zsws(:,:)/zrautb(:,:)) * zhcmo(:,:)
zedmf(:,:,1) = -0.065_wp*(ABS(zfbuo(:,:)))**(1._wp/3._wp)*SIGN(1.,zfbuo(:,:))
@@ -211,8 +214,8 @@ CONTAINS
! Compute the buoyancy acceleration on T-points at jk-1
zrautbm1(:,:) = zrautb(:,:)
- CALL eos( pts (:,:,jk ,:,Kmm) , zrautb(:,:) )
- CALL eos( ztsp(:,:,jk-1,: ) , zraupl(:,:) )
+ CALL eos( pts (:,:,jk ,:,Kmm) , zrautb(:,:), kbnd=0 )
+ CALL eos( ztsp(:,:,jk-1,: ) , zraupl(:,:), kbnd=0 )
DO_2D( 0, 0, 0, 0 )
zphm1(ji,jj) = zphm1(ji,jj) + grav * zrautbm1(ji,jj) * e3t(ji,jj,jk-1, Kmm)
@@ -395,9 +398,9 @@ CONTAINS
SUBROUTINE diag_mfc( zdiagi, zdiagd, zdiags, p2dt, Kaa )
- REAL(wp), DIMENSION(A2D(nn_hls),jpk), INTENT(inout) :: zdiagi, zdiagd, zdiags ! inout: tridaig. terms
- REAL(wp) , INTENT(in ) :: p2dt ! tracer time-step
- INTEGER , INTENT(in ) :: Kaa ! ocean time level indices
+ REAL(wp), DIMENSION(T2D(0),jpk), INTENT(inout) :: zdiagi, zdiagd, zdiags ! inout: tridaig. terms
+ REAL(wp) , INTENT(in ) :: p2dt ! tracer time-step
+ INTEGER , INTENT(in ) :: Kaa ! ocean time level indices
INTEGER :: ji, jj, jk ! dummy loop arguments
diff --git a/src/OCE/ZDF/zdfmxl.F90 b/src/OCE/ZDF/zdfmxl.F90
index c387bdb14eb18cced95ea452b9f8f7c4906ce06a..66dd2e23e881b39b2106f6c39490f0a1365811ba 100644
--- a/src/OCE/ZDF/zdfmxl.F90
+++ b/src/OCE/ZDF/zdfmxl.F90
@@ -30,7 +30,6 @@ MODULE zdfmxl
INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: nmln !: number of level in the mixed layer (used by LDF, ZDF, TRD, TOP)
REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hmld !: mixing layer depth (turbocline) [m] (used by TOP)
REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hmlp !: mixed layer depth (rho=rho0+zdcrit) [m] (used by LDF)
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hmlpt !: depth of the last T-point inside the mixed layer [m] (used by LDF)
REAL(wp), PUBLIC :: rho_c = 0.01_wp !: density criterion for mixed layer depth
REAL(wp), PUBLIC :: avt_c = 5.e-4_wp ! Kz criterion for the turbocline depth
@@ -51,7 +50,7 @@ CONTAINS
!!----------------------------------------------------------------------
zdf_mxl_alloc = 0 ! set to zero if no array to be allocated
IF( .NOT. ALLOCATED( nmln ) ) THEN
- ALLOCATE( nmln(jpi,jpj), hmld(jpi,jpj), hmlp(jpi,jpj), hmlpt(jpi,jpj), STAT= zdf_mxl_alloc )
+ ALLOCATE( hmld(A2D(0)), nmln(jpi,jpj), hmlp(A2D(1)), STAT= zdf_mxl_alloc )
!
CALL mpp_sum ( 'zdfmxl', zdf_mxl_alloc )
IF( zdf_mxl_alloc /= 0 ) CALL ctl_stop( 'STOP', 'zdf_mxl_alloc: failed to allocate arrays.' )
@@ -70,7 +69,7 @@ CONTAINS
!! the density of the corresponding T point (just bellow) bellow a
!! given value defined locally as rho(10m) + rho_c
!!
- !! ** Action : nmln, hmlp, hmlpt
+ !! ** Action : nmln, hmlp
!!----------------------------------------------------------------------
INTEGER, INTENT(in) :: kt ! ocean time-step index
INTEGER, INTENT(in) :: Kmm ! ocean time level index
@@ -78,6 +77,7 @@ CONTAINS
INTEGER :: ji, jj, jk ! dummy loop indices
INTEGER :: iik, ikt ! local integer
REAL(wp) :: zN2_c ! local scalar
+ REAL(wp), DIMENSION(:,:), ALLOCATABLE :: zhmlp
!!----------------------------------------------------------------------
!
IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile
@@ -89,30 +89,32 @@ CONTAINS
ENDIF
!
! w-level of the mixing and mixed layers
- DO_2D_OVR( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
nmln(ji,jj) = nlb10 ! Initialization to the number of w ocean point
hmlp(ji,jj) = 0._wp ! here hmlp used as a dummy variable, integrating vertically N^2
END_2D
zN2_c = grav * rho_c * r1_rho0 ! convert density criteria into N^2 criteria
- DO_3D_OVR( nn_hls, nn_hls, nn_hls, nn_hls, nlb10, jpkm1 ) ! Mixed layer level: w-level
+ DO_3D( 0, 0, 0, 0, nlb10, jpkm1 ) ! Mixed layer level: w-level
ikt = mbkt(ji,jj)
hmlp(ji,jj) = &
& hmlp(ji,jj) + MAX( rn2b(ji,jj,jk) , 0._wp ) * e3w(ji,jj,jk,Kmm)
IF( hmlp(ji,jj) < zN2_c ) nmln(ji,jj) = MIN( jk , ikt ) + 1 ! Mixed layer level
END_3D
! depth of the mixed layer
- DO_2D_OVR( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
iik = nmln(ji,jj)
- hmlp (ji,jj) = gdepw(ji,jj,iik ,Kmm) * ssmask(ji,jj) ! Mixed layer depth
- hmlpt(ji,jj) = gdept(ji,jj,iik-1,Kmm) * ssmask(ji,jj) ! depth of the last T-point inside the mixed layer
+ hmlp(ji,jj) = gdepw(ji,jj,iik ,Kmm) * ssmask(ji,jj) ! Mixed layer depth
END_2D
!
IF( .NOT.l_offline .AND. iom_use("mldr10_1") ) THEN
- IF( .NOT. l_istiled .OR. ntile == nijtile ) THEN ! Do only on the last tile
- IF( ln_isfcav ) THEN ; CALL iom_put( "mldr10_1", hmlp - risfdep) ! mixed layer thickness
- ELSE ; CALL iom_put( "mldr10_1", hmlp ) ! mixed layer depth
- END IF
+ ALLOCATE( zhmlp(T2D(0)) )
+ IF( ln_isfcav ) THEN
+ zhmlp(:,:) = hmlp(T2D(0)) - risfdep(T2D(0)) ! mixed layer thickness
+ ELSE
+ zhmlp(:,:) = hmlp(T2D(0)) ! mixed layer depth
ENDIF
+ CALL iom_put( "mldr10_1", zhmlp(:,:) )
+ DEALLOCATE( zhmlp )
ENDIF
!
IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab2d_1=REAL(nmln,wp), clinfo1=' nmln : ', tab2d_2=hmlp, clinfo2=' hmlp : ' )
@@ -138,24 +140,24 @@ CONTAINS
!
INTEGER :: ji, jj, jk ! dummy loop indices
INTEGER :: iik ! local integer
- INTEGER, DIMENSION(A2D(nn_hls)) :: imld ! 2D workspace
+ INTEGER, DIMENSION(T2D(0)) :: imld ! 2D workspace
!!----------------------------------------------------------------------
!
! w-level of the turbocline and mixing layer (iom_use)
- imld(:,:) = mbkt(A2D(nn_hls)) + 1 ! Initialization to the number of w ocean point
- DO_3DS( 1, 1, 1, 1, jpkm1, nlb10, -1 ) ! from the bottom to nlb10
+ imld(:,:) = mbkt(T2D(0)) + 1 ! Initialization to the number of w ocean point
+ DO_3DS( 0, 0, 0, 0, jpkm1, nlb10, -1 ) ! from the bottom to nlb10
IF( avt (ji,jj,jk) < avt_c * wmask(ji,jj,jk) ) imld(ji,jj) = jk ! Turbocline
END_3D
! depth of the mixing layer
- DO_2D_OVR( 1, 1, 1, 1 )
+ DO_2D( 0, 0, 0, 0 )
iik = imld(ji,jj)
hmld (ji,jj) = gdepw(ji,jj,iik ,Kmm) * ssmask(ji,jj) ! Turbocline depth
END_2D
!
IF( .NOT.l_offline .AND. iom_use("mldkz5") ) THEN
IF( .NOT. l_istiled .OR. ntile == nijtile ) THEN ! Do only on the last tile
- IF( ln_isfcav ) THEN ; CALL iom_put( "mldkz5" , hmld - risfdep ) ! turbocline thickness
- ELSE ; CALL iom_put( "mldkz5" , hmld ) ! turbocline depth
+ IF( ln_isfcav ) THEN ; CALL iom_put( "mldkz5" , hmld - risfdep(A2D(0)) ) ! turbocline thickness
+ ELSE ; CALL iom_put( "mldkz5" , hmld ) ! turbocline depth
END IF
ENDIF
ENDIF
diff --git a/src/OCE/ZDF/zdfosm.F90 b/src/OCE/ZDF/zdfosm.F90
index 1a4bfabbce4a561a1f9e95b51ba55e24dc339a86..cc76f85fbe4395d587ab5209c1ad00e8eb815a2a 100644
--- a/src/OCE/ZDF/zdfosm.F90
+++ b/src/OCE/ZDF/zdfosm.F90
@@ -68,6 +68,7 @@ MODULE zdfosm
USE oce ! Ocean dynamics and active tracers
! ! Uses ww from previous time step (which is now wb) to calculate hbl
USE dom_oce ! Ocean space and time domain
+ USE domtile, ONLY : dom_tile_init
USE zdf_oce ! Ocean vertical physics
USE sbc_oce ! Surface boundary condition: ocean
USE sbcwave ! Surface wave parameters
@@ -349,57 +350,58 @@ CONTAINS
!! Comments in the code refer to this paper, particularly
!! the equation number. (LMD94, here after)
!!----------------------------------------------------------------------
- INTEGER , INTENT(in ) :: kt ! Ocean time step
- INTEGER , INTENT(in ) :: Kbb, Kmm, Krhs ! Ocean time level indices
- REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: p_avm, p_avt ! Momentum and tracer Kz (w-points)
+ INTEGER , INTENT(in ) :: kt ! Ocean time step
+ INTEGER , INTENT(in ) :: Kbb, Kmm, Krhs ! Ocean time level indices
+ REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: p_avm ! vertical eddy viscosity (w-points)
+ REAL(wp), DIMENSION(A2D(0) ,jpk), INTENT(inout) :: p_avt ! vertical eddy diffusivity (w-points)
!!
INTEGER :: ji, jj, jk, jl, jm, jkflt ! Dummy loop indices
!!
REAL(wp) :: zthermal, zbeta
REAL(wp) :: zesh2, zri, zfri ! Interior Richardson mixing
!! Scales
- REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zrad0 ! Surface solar temperature flux (deg m/s)
- REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zradh ! Radiative flux at bl base (Buoyancy units)
+ REAL(wp), DIMENSION(T2D(nn_hls-1)) :: zrad0 ! Surface solar temperature flux (deg m/s)
+ REAL(wp), DIMENSION(T2D(nn_hls-1)) :: zradh ! Radiative flux at bl base (Buoyancy units)
REAL(wp) :: zradav ! Radiative flux, bl average (Buoyancy Units)
REAL(wp) :: zvw0 ! Surface v-momentum flux
- REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zwb0tot ! Total surface buoyancy flux including insolation
- REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zwb_ent ! Buoyancy entrainment flux
- REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zwb_min
- REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zwb_fk_b ! MLE buoyancy flux averaged over OSBL
- REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zwb_fk ! Max MLE buoyancy flux
- REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zdiff_mle ! Extra MLE vertical diff
- REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zvel_mle ! Velocity scale for dhdt with stable ML and FK
+ REAL(wp), DIMENSION(T2D(nn_hls-1)) :: zwb0tot ! Total surface buoyancy flux including insolation
+ REAL(wp), DIMENSION(T2D(nn_hls-1)) :: zwb_ent ! Buoyancy entrainment flux
+ REAL(wp), DIMENSION(T2D(nn_hls-1)) :: zwb_min
+ REAL(wp), DIMENSION(T2D(nn_hls-1)) :: zwb_fk_b ! MLE buoyancy flux averaged over OSBL
+ REAL(wp), DIMENSION(T2D(nn_hls-1)) :: zwb_fk ! Max MLE buoyancy flux
+ REAL(wp), DIMENSION(T2D(nn_hls-1)) :: zdiff_mle ! Extra MLE vertical diff
+ REAL(wp), DIMENSION(T2D(nn_hls-1)) :: zvel_mle ! Velocity scale for dhdt with stable ML and FK
!! Mixed-layer variables
- INTEGER, DIMENSION(A2D(nn_hls-1)) :: jk_nlev ! Number of levels
- INTEGER, DIMENSION(A2D(nn_hls-1)) :: jk_ext ! Offset for external level
+ INTEGER, DIMENSION(T2D(nn_hls-1)) :: jk_nlev ! Number of levels
+ INTEGER, DIMENSION(T2D(nn_hls-1)) :: jk_ext ! Offset for external level
!!
- REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zhbl ! BL depth - grid
- REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zhml ! ML depth - grid
+ REAL(wp), DIMENSION(T2D(nn_hls-1)) :: zhbl ! BL depth - grid
+ REAL(wp), DIMENSION(T2D(nn_hls-1)) :: zhml ! ML depth - grid
!!
- REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zhmle ! MLE depth - grid
- REAL(wp), DIMENSION(A2D(nn_hls)) :: zmld ! ML depth on grid
+ REAL(wp), DIMENSION(T2D(nn_hls-1)) :: zhmle ! MLE depth - grid
+ REAL(wp), DIMENSION(T2D(nn_hls)) :: zmld ! ML depth on grid
!!
- REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zdh ! Pycnocline depth - grid
- REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zdhdt ! BL depth tendency
- REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zdtdz_bl_ext, zdsdz_bl_ext ! External temperature/salinity gradients
- REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zdbdz_bl_ext ! External buoyancy gradients
- REAL(wp), DIMENSION(A2D(nn_hls)) :: zdtdx, zdtdy, zdsdx, zdsdy ! Horizontal gradients for Fox-Kemper parametrization
+ REAL(wp), DIMENSION(T2D(nn_hls-1)) :: zdh ! Pycnocline depth - grid
+ REAL(wp), DIMENSION(T2D(nn_hls-1)) :: zdhdt ! BL depth tendency
+ REAL(wp), DIMENSION(T2D(nn_hls-1)) :: zdtdz_bl_ext, zdsdz_bl_ext ! External temperature/salinity gradients
+ REAL(wp), DIMENSION(T2D(nn_hls-1)) :: zdbdz_bl_ext ! External buoyancy gradients
+ REAL(wp), DIMENSION(T2D(nn_hls)) :: zdtdx, zdtdy, zdsdx, zdsdy ! Horizontal gradients for Fox-Kemper parametrization
!!
- REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zdbds_mle ! Magnitude of horizontal buoyancy gradient
+ REAL(wp), DIMENSION(T2D(nn_hls-1)) :: zdbds_mle ! Magnitude of horizontal buoyancy gradient
!! Flux-gradient relationship variables
- REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zshear ! Shear production
+ REAL(wp), DIMENSION(T2D(nn_hls-1)) :: zshear ! Shear production
!!
- REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zhbl_t ! Holds boundary layer depth updated by full timestep
+ REAL(wp), DIMENSION(T2D(nn_hls-1)) :: zhbl_t ! Holds boundary layer depth updated by full timestep
!! For calculating Ri#-dependent mixing
- REAL(wp), DIMENSION(A2D(nn_hls)) :: z2du ! u-shear^2
- REAL(wp), DIMENSION(A2D(nn_hls)) :: z2dv ! v-shear^2
+ REAL(wp), DIMENSION(T2D(nn_hls)) :: z2du ! u-shear^2
+ REAL(wp), DIMENSION(T2D(nn_hls)) :: z2dv ! v-shear^2
REAL(wp) :: zrimix ! Spatial form of ri#-induced diffusion
!! Temporary variables
REAL(wp) :: znd ! Temporary non-dimensional depth
REAL(wp) :: zz0, zz1, zfac
REAL(wp) :: zus_x, zus_y ! Temporary Stokes drift
- REAL(wp), DIMENSION(A2D(nn_hls-1),jpk) :: zviscos ! Viscosity
- REAL(wp), DIMENSION(A2D(nn_hls-1),jpk) :: zdiffut ! t-diffusivity
+ REAL(wp), DIMENSION(T2D(nn_hls-1),jpk) :: zviscos ! Viscosity
+ REAL(wp), DIMENSION(T2D(nn_hls-1),jpk) :: zdiffut ! t-diffusivity
REAL(wp) :: zabsstke
REAL(wp) :: zsqrtpi, z_two_thirds, zthickness
REAL(wp) :: z2k_times_thickness, zsqrt_depth, zexp_depth, zf, zexperfc
@@ -486,8 +488,8 @@ CONTAINS
& grav * zbeta * swsav(ji,jj) ! OBSBL
END_2D
DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 )
- suw0(ji,jj) = -0.5_wp * (utau(ji-1,jj) + utau(ji,jj)) * r1_rho0 * tmask(ji,jj,1) ! Surface upward velocity fluxes
- zvw0 = -0.5_wp * (vtau(ji,jj-1) + vtau(ji,jj)) * r1_rho0 * tmask(ji,jj,1)
+ suw0(ji,jj) = - utau(ji,jj) * r1_rho0 * tmask(ji,jj,1) ! Surface upward velocity fluxes
+ zvw0 = - vtau(ji,jj) * r1_rho0 * tmask(ji,jj,1)
sustar(ji,jj) = MAX( SQRT( SQRT( suw0(ji,jj) * suw0(ji,jj) + zvw0 * zvw0 ) ), & ! Friction velocity (sustar), at
& 1e-8_wp ) ! T-point : LMD94 eq. 2
scos_wind(ji,jj) = -1.0_wp * suw0(ji,jj) / ( sustar(ji,jj) * sustar(ji,jj) )
@@ -643,13 +645,13 @@ CONTAINS
END_2D
!
! Averages over well-mixed and boundary layer, note BL averages use jk_ext=2 everywhere
- jk_nlev(:,:) = nbld(A2D(nn_hls-1))
+ jk_nlev(:,:) = nbld(T2D(nn_hls-1))
jk_ext(:,:) = 1 ! ag 19/03
CALL zdf_osm_vertical_average( Kbb, Kmm, jk_nlev, av_t_bl, av_s_bl, &
& av_b_bl, av_u_bl, av_v_bl, jk_ext, av_dt_bl, &
& av_ds_bl, av_db_bl, av_du_bl, av_dv_bl )
- jk_nlev(:,:) = nmld(A2D(nn_hls-1)) - 1
- jk_ext(:,:) = nbld(A2D(nn_hls-1)) - nmld(A2D(nn_hls-1)) + jk_ext(:,:) + 1 ! ag 19/03
+ jk_nlev(:,:) = nmld(T2D(nn_hls-1)) - 1
+ jk_ext(:,:) = nbld(T2D(nn_hls-1)) - nmld(T2D(nn_hls-1)) + jk_ext(:,:) + 1 ! ag 19/03
CALL zdf_osm_vertical_average( Kbb, Kmm, jk_nlev, av_t_ml, av_s_ml, &
& av_b_ml, av_u_ml, av_v_ml, jk_ext, av_dt_ml, &
& av_ds_ml, av_db_ml, av_du_ml, av_dv_ml )
@@ -671,7 +673,7 @@ CONTAINS
DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 5, jpkm1 )
IF ( hmle(ji,jj) >= gdepw(ji,jj,jk,Kmm) ) mld_prof(ji,jj) = MIN( mbkt(ji,jj), jk)
END_3D
- jk_nlev(:,:) = mld_prof(A2D(nn_hls-1))
+ jk_nlev(:,:) = mld_prof(T2D(nn_hls-1))
CALL zdf_osm_vertical_average( Kbb, Kmm, jk_nlev, av_t_mle, av_s_mle, &
& av_b_mle, av_u_mle, av_v_mle )
!
@@ -699,7 +701,7 @@ CONTAINS
ENDIF ! ln_osm_mle
!
!! External gradient below BL needed both with and w/o FK
- jk_ext(:,:) = nbld(A2D(nn_hls-1)) + 1
+ jk_ext(:,:) = nbld(T2D(nn_hls-1)) + 1
CALL zdf_osm_external_gradients( Kmm, jk_ext, zdtdz_bl_ext, zdsdz_bl_ext, zdbdz_bl_ext ) ! ag 19/03
!
! Test if pycnocline well resolved
@@ -720,13 +722,13 @@ CONTAINS
! END_2D
!
! Recalculate bl averages using jk_ext & ml averages .... note no rotation of u & v here..
- jk_nlev(:,:) = nbld(A2D(nn_hls-1))
+ jk_nlev(:,:) = nbld(T2D(nn_hls-1))
jk_ext(:,:) = 1 ! ag 19/03
CALL zdf_osm_vertical_average( Kbb, Kmm, jk_nlev, av_t_bl, av_s_bl, &
& av_b_bl, av_u_bl, av_v_bl, jk_ext, av_dt_bl, &
& av_ds_bl, av_db_bl, av_du_bl, av_dv_bl )
- jk_nlev(:,:) = nmld(A2D(nn_hls-1)) - 1
- jk_ext(:,:) = nbld(A2D(nn_hls-1)) - nmld(A2D(nn_hls-1)) + jk_ext(:,:) + 1 ! ag 19/03
+ jk_nlev(:,:) = nmld(T2D(nn_hls-1)) - 1
+ jk_ext(:,:) = nbld(T2D(nn_hls-1)) - nmld(T2D(nn_hls-1)) + jk_ext(:,:) + 1 ! ag 19/03
CALL zdf_osm_vertical_average( Kbb, Kmm, jk_nlev, av_t_ml, av_s_ml, &
& av_b_ml, av_u_ml, av_v_ml, jk_ext, av_dt_ml, &
& av_ds_ml, av_db_ml, av_du_ml, av_dv_ml ) ! ag 19/03
@@ -741,7 +743,7 @@ CONTAINS
! Adjustment to represent limiting by ocean bottom
IF ( mbkt(ji,jj) > 2 ) THEN ! To ensure mbkt(ji,jj) - 2 > 0 so no incorrect array access
IF ( zhbl_t(ji,jj) > gdepw(ji, jj,mbkt(ji,jj)-2,Kmm) ) THEN
- zhbl_t(ji,jj) = MIN( zhbl_t(ji,jj), gdepw(ji,jj,mbkt(ji,jj)-2,Kmm) ) ! ht(:,:))
+ zhbl_t(ji,jj) = MIN( zhbl_t(ji,jj), gdepw(ji,jj,mbkt(ji,jj)-2,Kmm) ) ! ht(:,:,Kmm))
l_pyc(ji,jj) = .FALSE.
l_coup(ji,jj) = .TRUE. ! ag 19/03
END IF
@@ -767,7 +769,7 @@ CONTAINS
! Is external level in bounds?
!
! Recalculate BL averages and differences using new BL depth
- jk_nlev(:,:) = nbld(A2D(nn_hls-1))
+ jk_nlev(:,:) = nbld(T2D(nn_hls-1))
jk_ext(:,:) = 1 ! ag 19/03
CALL zdf_osm_vertical_average( Kbb, Kmm, jk_nlev, av_t_bl, av_s_bl, &
& av_b_bl, av_u_bl, av_v_bl, jk_ext, av_dt_bl, &
@@ -799,13 +801,13 @@ CONTAINS
! Average over the depth of the mixed layer in the convective boundary layer
! jk_ext = nbld - nmld + 1
! Recalculate ML averages and differences using new ML depth
- jk_nlev(:,:) = nmld(A2D(nn_hls-1)) - 1
- jk_ext(:,:) = nbld(A2D(nn_hls-1)) - nmld(A2D(nn_hls-1)) + jk_ext(:,:) + 1 ! ag 19/03
+ jk_nlev(:,:) = nmld(T2D(nn_hls-1)) - 1
+ jk_ext(:,:) = nbld(T2D(nn_hls-1)) - nmld(T2D(nn_hls-1)) + jk_ext(:,:) + 1 ! ag 19/03
CALL zdf_osm_vertical_average( Kbb, Kmm, jk_nlev, av_t_ml, av_s_ml, &
& av_b_ml, av_u_ml, av_v_ml, jk_ext, av_dt_ml, &
& av_ds_ml, av_db_ml, av_du_ml, av_dv_ml )
!
- jk_ext(:,:) = nbld(A2D(nn_hls-1)) + 1
+ jk_ext(:,:) = nbld(T2D(nn_hls-1)) + 1
CALL zdf_osm_external_gradients( Kmm, jk_ext, zdtdz_bl_ext, zdsdz_bl_ext, zdbdz_bl_ext )
! Rotate mean currents and changes onto wind aligned co-ordinates
CALL zdf_osm_velocity_rotation( av_u_ml, av_v_ml )
@@ -833,7 +835,7 @@ CONTAINS
!<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
!
! Rotate non-gradient velocity terms back to model reference frame
- jk_nlev(:,:) = nbld(A2D(nn_hls-1))
+ jk_nlev(:,:) = nbld(T2D(nn_hls-1))
CALL zdf_osm_velocity_rotation( ghamu, ghamv, .FALSE., 2, jk_nlev )
!
! KPP-style Ri# mixing
@@ -910,7 +912,7 @@ CONTAINS
! Lateral boundary conditions on zvicos (sign unchanged), needed to caclulate viscosities on u and v grids
! CALL lbc_lnk( 'zdfosm', zviscos(:,:,:), 'W', 1.0_wp )
! GN 25/8: need to change tmask --> wmask
- DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 2, jpkm1 )
p_avt(ji,jj,jk) = MAX( zdiffut(ji,jj,jk), avtb(jk) ) * tmask(ji,jj,jk)
p_avm(ji,jj,jk) = MAX( zviscos(ji,jj,jk), avmb(jk) ) * tmask(ji,jj,jk)
END_3D
@@ -919,76 +921,76 @@ CONTAINS
SELECT CASE (nn_osm_wave)
! Stokes drift set by assumimg onstant La#=0.3 (=0) or Pierson-Moskovitz spectrum (=1)
CASE(0:1)
- CALL zdf_osm_iomput( "us_x", tmask(A2D(0),1) * sustke(A2D(0)) * scos_wind(A2D(0)) ) ! x surface Stokes drift
- CALL zdf_osm_iomput( "us_y", tmask(A2D(0),1) * sustke(A2D(0)) * ssin_wind(A2D(0)) ) ! y surface Stokes drift
- CALL zdf_osm_iomput( "wind_wave_abs_power", 1000.0_wp * rho0 * tmask(A2D(0),1) * sustar(A2D(0))**2 * sustke(A2D(0)) )
+ CALL zdf_osm_iomput( "us_x", tmask(T2D(0),1) * sustke(T2D(0)) * scos_wind(T2D(0)) ) ! x surface Stokes drift
+ CALL zdf_osm_iomput( "us_y", tmask(T2D(0),1) * sustke(T2D(0)) * ssin_wind(T2D(0)) ) ! y surface Stokes drift
+ CALL zdf_osm_iomput( "wind_wave_abs_power", 1000.0_wp * rho0 * tmask(T2D(0),1) * sustar(T2D(0))**2 * sustke(T2D(0)) )
! Stokes drift read in from sbcwave (=2).
CASE(2:3)
- CALL zdf_osm_iomput( "us_x", ut0sd(A2D(0)) * umask(A2D(0),1) ) ! x surface Stokes drift
- CALL zdf_osm_iomput( "us_y", vt0sd(A2D(0)) * vmask(A2D(0),1) ) ! y surface Stokes drift
- CALL zdf_osm_iomput( "wmp", wmp(A2D(0)) * tmask(A2D(0),1) ) ! Wave mean period
- CALL zdf_osm_iomput( "hsw", hsw(A2D(0)) * tmask(A2D(0),1) ) ! Significant wave height
+ CALL zdf_osm_iomput( "us_x", ut0sd(T2D(0)) * umask(T2D(0),1) ) ! x surface Stokes drift
+ CALL zdf_osm_iomput( "us_y", vt0sd(T2D(0)) * vmask(T2D(0),1) ) ! y surface Stokes drift
+ CALL zdf_osm_iomput( "wmp", wmp(T2D(0)) * tmask(T2D(0),1) ) ! Wave mean period
+ CALL zdf_osm_iomput( "hsw", hsw(T2D(0)) * tmask(T2D(0),1) ) ! Significant wave height
CALL zdf_osm_iomput( "wmp_NP", ( 2.0_wp * rpi * 1.026_wp / ( 0.877_wp * grav ) ) * & ! Wave mean period from NP
- & wndm(A2D(0)) * tmask(A2D(0),1) ) ! spectrum
- CALL zdf_osm_iomput( "hsw_NP", ( 0.22_wp / grav ) * wndm(A2D(0))**2 * tmask(A2D(0),1) ) ! Significant wave height from
+ & wndm(T2D(0)) * tmask(T2D(0),1) ) ! spectrum
+ CALL zdf_osm_iomput( "hsw_NP", ( 0.22_wp / grav ) * wndm(T2D(0))**2 * tmask(T2D(0),1) ) ! Significant wave height from
! ! NP spectrum
- CALL zdf_osm_iomput( "wndm", wndm(A2D(0)) * tmask(A2D(0),1) ) ! U_10
- CALL zdf_osm_iomput( "wind_wave_abs_power", 1000.0_wp * rho0 * tmask(A2D(0),1) * sustar(A2D(0))**2 * &
- & SQRT( ut0sd(A2D(0))**2 + vt0sd(A2D(0))**2 ) )
+ CALL zdf_osm_iomput( "wndm", wndm(T2D(0)) * tmask(T2D(0),1) ) ! U_10
+ CALL zdf_osm_iomput( "wind_wave_abs_power", 1000.0_wp * rho0 * tmask(T2D(0),1) * sustar(T2D(0))**2 * &
+ & SQRT( ut0sd(T2D(0))**2 + vt0sd(T2D(0))**2 ) )
END SELECT
- CALL zdf_osm_iomput( "zwth0", tmask(A2D(0),1) * swth0(A2D(0)) ) ! <Tw_0>
- CALL zdf_osm_iomput( "zws0", tmask(A2D(0),1) * sws0(A2D(0)) ) ! <Sw_0>
- CALL zdf_osm_iomput( "zwb0", tmask(A2D(0),1) * swb0(A2D(0)) ) ! <bw_0>
- CALL zdf_osm_iomput( "zwbav", tmask(A2D(0),1) * swbav(A2D(0)) ) ! Upward BL-avged turb buoyancy flux
- CALL zdf_osm_iomput( "ibld", tmask(A2D(0),1) * nbld(A2D(0)) ) ! Boundary-layer max k
- CALL zdf_osm_iomput( "zdt_bl", tmask(A2D(0),1) * av_dt_bl(A2D(0)) ) ! dt at ml base
- CALL zdf_osm_iomput( "zds_bl", tmask(A2D(0),1) * av_ds_bl(A2D(0)) ) ! ds at ml base
- CALL zdf_osm_iomput( "zdb_bl", tmask(A2D(0),1) * av_db_bl(A2D(0)) ) ! db at ml base
- CALL zdf_osm_iomput( "zdu_bl", tmask(A2D(0),1) * av_du_bl(A2D(0)) ) ! du at ml base
- CALL zdf_osm_iomput( "zdv_bl", tmask(A2D(0),1) * av_dv_bl(A2D(0)) ) ! dv at ml base
- CALL zdf_osm_iomput( "dh", tmask(A2D(0),1) * dh(A2D(0)) ) ! Initial boundary-layer depth
- CALL zdf_osm_iomput( "hml", tmask(A2D(0),1) * hml(A2D(0)) ) ! Initial boundary-layer depth
- CALL zdf_osm_iomput( "zdt_ml", tmask(A2D(0),1) * av_dt_ml(A2D(0)) ) ! dt at ml base
- CALL zdf_osm_iomput( "zds_ml", tmask(A2D(0),1) * av_ds_ml(A2D(0)) ) ! ds at ml base
- CALL zdf_osm_iomput( "zdb_ml", tmask(A2D(0),1) * av_db_ml(A2D(0)) ) ! db at ml base
- CALL zdf_osm_iomput( "dstokes", tmask(A2D(0),1) * dstokes(A2D(0)) ) ! Stokes drift penetration depth
- CALL zdf_osm_iomput( "zustke", tmask(A2D(0),1) * sustke(A2D(0)) ) ! Stokes drift magnitude at T-points
- CALL zdf_osm_iomput( "zwstrc", tmask(A2D(0),1) * swstrc(A2D(0)) ) ! Convective velocity scale
- CALL zdf_osm_iomput( "zwstrl", tmask(A2D(0),1) * swstrl(A2D(0)) ) ! Langmuir velocity scale
- CALL zdf_osm_iomput( "zustar", tmask(A2D(0),1) * sustar(A2D(0)) ) ! Friction velocity scale
- CALL zdf_osm_iomput( "zvstr", tmask(A2D(0),1) * svstr(A2D(0)) ) ! Mixed velocity scale
- CALL zdf_osm_iomput( "zla", tmask(A2D(0),1) * sla(A2D(0)) ) ! Langmuir #
- CALL zdf_osm_iomput( "wind_power", 1000.0_wp * rho0 * tmask(A2D(0),1) * & ! BL depth internal to zdf_osm routine
- & sustar(A2D(0))**3 )
- CALL zdf_osm_iomput( "wind_wave_power", 1000.0_wp * rho0 * tmask(A2D(0),1) * &
- & sustar(A2D(0))**2 * sustke(A2D(0)) )
- CALL zdf_osm_iomput( "zhbl", tmask(A2D(0),1) * zhbl(A2D(0)) ) ! BL depth internal to zdf_osm routine
- CALL zdf_osm_iomput( "zhml", tmask(A2D(0),1) * zhml(A2D(0)) ) ! ML depth internal to zdf_osm routine
- CALL zdf_osm_iomput( "imld", tmask(A2D(0),1) * nmld(A2D(0)) ) ! Index for ML depth internal to zdf_osm
+ CALL zdf_osm_iomput( "zwth0", tmask(T2D(0),1) * swth0(T2D(0)) ) ! <Tw_0>
+ CALL zdf_osm_iomput( "zws0", tmask(T2D(0),1) * sws0(T2D(0)) ) ! <Sw_0>
+ CALL zdf_osm_iomput( "zwb0", tmask(T2D(0),1) * swb0(T2D(0)) ) ! <Sw_0>
+ CALL zdf_osm_iomput( "zwbav", tmask(T2D(0),1) * swth0(T2D(0)) ) ! Upward BL-avged turb buoyancy flux
+ CALL zdf_osm_iomput( "ibld", tmask(T2D(0),1) * nbld(T2D(0)) ) ! Boundary-layer max k
+ CALL zdf_osm_iomput( "zdt_bl", tmask(T2D(0),1) * av_dt_bl(T2D(0)) ) ! dt at ml base
+ CALL zdf_osm_iomput( "zds_bl", tmask(T2D(0),1) * av_ds_bl(T2D(0)) ) ! ds at ml base
+ CALL zdf_osm_iomput( "zdb_bl", tmask(T2D(0),1) * av_db_bl(T2D(0)) ) ! db at ml base
+ CALL zdf_osm_iomput( "zdu_bl", tmask(T2D(0),1) * av_du_bl(T2D(0)) ) ! du at ml base
+ CALL zdf_osm_iomput( "zdv_bl", tmask(T2D(0),1) * av_dv_bl(T2D(0)) ) ! dv at ml base
+ CALL zdf_osm_iomput( "dh", tmask(T2D(0),1) * dh(T2D(0)) ) ! Initial boundary-layer depth
+ CALL zdf_osm_iomput( "hml", tmask(T2D(0),1) * hml(T2D(0)) ) ! Initial boundary-layer depth
+ CALL zdf_osm_iomput( "zdt_ml", tmask(T2D(0),1) * av_dt_ml(T2D(0)) ) ! dt at ml base
+ CALL zdf_osm_iomput( "zds_ml", tmask(T2D(0),1) * av_ds_ml(T2D(0)) ) ! ds at ml base
+ CALL zdf_osm_iomput( "zdb_ml", tmask(T2D(0),1) * av_db_ml(T2D(0)) ) ! db at ml base
+ CALL zdf_osm_iomput( "dstokes", tmask(T2D(0),1) * dstokes(T2D(0)) ) ! Stokes drift penetration depth
+ CALL zdf_osm_iomput( "zustke", tmask(T2D(0),1) * sustke(T2D(0)) ) ! Stokes drift magnitude at T-points
+ CALL zdf_osm_iomput( "zwstrc", tmask(T2D(0),1) * swstrc(T2D(0)) ) ! Convective velocity scale
+ CALL zdf_osm_iomput( "zwstrl", tmask(T2D(0),1) * swstrl(T2D(0)) ) ! Langmuir velocity scale
+ CALL zdf_osm_iomput( "zustar", tmask(T2D(0),1) * sustar(T2D(0)) ) ! Friction velocity scale
+ CALL zdf_osm_iomput( "zvstr", tmask(T2D(0),1) * svstr(T2D(0)) ) ! Mixed velocity scale
+ CALL zdf_osm_iomput( "zla", tmask(T2D(0),1) * sla(T2D(0)) ) ! Langmuir #
+ CALL zdf_osm_iomput( "wind_power", 1000.0_wp * rho0 * tmask(T2D(0),1) * & ! BL depth internal to zdf_osm routine
+ & sustar(T2D(0))**3 )
+ CALL zdf_osm_iomput( "wind_wave_power", 1000.0_wp * rho0 * tmask(T2D(0),1) * &
+ & sustar(T2D(0))**2 * sustke(T2D(0)) )
+ CALL zdf_osm_iomput( "zhbl", tmask(T2D(0),1) * zhbl(T2D(0)) ) ! BL depth internal to zdf_osm routine
+ CALL zdf_osm_iomput( "zhml", tmask(T2D(0),1) * zhml(T2D(0)) ) ! ML depth internal to zdf_osm routine
+ CALL zdf_osm_iomput( "imld", tmask(T2D(0),1) * nmld(T2D(0)) ) ! Index for ML depth internal to zdf_osm
! ! routine
- CALL zdf_osm_iomput( "jp_ext", tmask(A2D(0),1) * jk_ext(A2D(0)) ) ! =1 if pycnocline resolved internal to
+ CALL zdf_osm_iomput( "jp_ext", tmask(T2D(0),1) * jk_ext(T2D(0)) ) ! =1 if pycnocline resolved internal to
! ! zdf_osm routine
- CALL zdf_osm_iomput( "j_ddh", tmask(A2D(0),1) * n_ddh(A2D(0)) ) ! Index forpyc thicknessh internal to
+ CALL zdf_osm_iomput( "j_ddh", tmask(T2D(0),1) * n_ddh(T2D(0)) ) ! Index forpyc thicknessh internal to
! ! zdf_osm routine
- CALL zdf_osm_iomput( "zshear", tmask(A2D(0),1) * zshear(A2D(0)) ) ! Shear production of TKE internal to
+ CALL zdf_osm_iomput( "zshear", tmask(T2D(0),1) * zshear(T2D(0)) ) ! Shear production of TKE internal to
! ! zdf_osm routine
- CALL zdf_osm_iomput( "zdh", tmask(A2D(0),1) * zdh(A2D(0)) ) ! Pyc thicknessh internal to zdf_osm
+ CALL zdf_osm_iomput( "zdh", tmask(T2D(0),1) * zdh(T2D(0)) ) ! Pyc thicknessh internal to zdf_osm
! ! routine
- CALL zdf_osm_iomput( "zhol", tmask(A2D(0),1) * shol(A2D(0)) ) ! ML depth internal to zdf_osm routine
- CALL zdf_osm_iomput( "zwb_ent", tmask(A2D(0),1) * zwb_ent(A2D(0)) ) ! Upward turb buoyancy entrainment flux
- CALL zdf_osm_iomput( "zt_ml", tmask(A2D(0),1) * av_t_ml(A2D(0)) ) ! Average T in ML
- CALL zdf_osm_iomput( "zmld", tmask(A2D(0),1) * zmld(A2D(0)) ) ! FK target layer depth
- CALL zdf_osm_iomput( "zwb_fk", tmask(A2D(0),1) * zwb_fk(A2D(0)) ) ! FK b flux
- CALL zdf_osm_iomput( "zwb_fk_b", tmask(A2D(0),1) * zwb_fk_b(A2D(0)) ) ! FK b flux averaged over ML
- CALL zdf_osm_iomput( "mld_prof", tmask(A2D(0),1) * mld_prof(A2D(0)) ) ! FK layer max k
- CALL zdf_osm_iomput( "zdtdx", umask(A2D(0),1) * zdtdx(A2D(0)) ) ! FK dtdx at u-pt
- CALL zdf_osm_iomput( "zdtdy", vmask(A2D(0),1) * zdtdy(A2D(0)) ) ! FK dtdy at v-pt
- CALL zdf_osm_iomput( "zdsdx", umask(A2D(0),1) * zdsdx(A2D(0)) ) ! FK dtdx at u-pt
- CALL zdf_osm_iomput( "zdsdy", vmask(A2D(0),1) * zdsdy(A2D(0)) ) ! FK dsdy at v-pt
- CALL zdf_osm_iomput( "dbdx_mle", umask(A2D(0),1) * dbdx_mle(A2D(0)) ) ! FK dbdx at u-pt
- CALL zdf_osm_iomput( "dbdy_mle", vmask(A2D(0),1) * dbdy_mle(A2D(0)) ) ! FK dbdy at v-pt
- CALL zdf_osm_iomput( "zdiff_mle", tmask(A2D(0),1) * zdiff_mle(A2D(0)) ) ! FK diff in MLE at t-pt
- CALL zdf_osm_iomput( "zvel_mle", tmask(A2D(0),1) * zvel_mle(A2D(0)) ) ! FK velocity in MLE at t-pt
+ CALL zdf_osm_iomput( "zhol", tmask(T2D(0),1) * shol(T2D(0)) ) ! ML depth internal to zdf_osm routine
+ CALL zdf_osm_iomput( "zwb_ent", tmask(T2D(0),1) * zwb_ent(T2D(0)) ) ! Upward turb buoyancy entrainment flux
+ CALL zdf_osm_iomput( "zt_ml", tmask(T2D(0),1) * av_t_ml(T2D(0)) ) ! Average T in ML
+ CALL zdf_osm_iomput( "zmld", tmask(T2D(0),1) * zmld(T2D(0)) ) ! FK target layer depth
+ CALL zdf_osm_iomput( "zwb_fk", tmask(T2D(0),1) * zwb_fk(T2D(0)) ) ! FK b flux
+ CALL zdf_osm_iomput( "zwb_fk_b", tmask(T2D(0),1) * zwb_fk_b(T2D(0)) ) ! FK b flux averaged over ML
+ CALL zdf_osm_iomput( "mld_prof", tmask(T2D(0),1) * mld_prof(T2D(0)) ) ! FK layer max k
+ CALL zdf_osm_iomput( "zdtdx", umask(T2D(0),1) * zdtdx(T2D(0)) ) ! FK dtdx at u-pt
+ CALL zdf_osm_iomput( "zdtdy", vmask(T2D(0),1) * zdtdy(T2D(0)) ) ! FK dtdy at v-pt
+ CALL zdf_osm_iomput( "zdsdx", umask(T2D(0),1) * zdsdx(T2D(0)) ) ! FK dtdx at u-pt
+ CALL zdf_osm_iomput( "zdsdy", vmask(T2D(0),1) * zdsdy(T2D(0)) ) ! FK dsdy at v-pt
+ CALL zdf_osm_iomput( "dbdx_mle", umask(T2D(0),1) * dbdx_mle(T2D(0)) ) ! FK dbdx at u-pt
+ CALL zdf_osm_iomput( "dbdy_mle", vmask(T2D(0),1) * dbdy_mle(T2D(0)) ) ! FK dbdy at v-pt
+ CALL zdf_osm_iomput( "zdiff_mle", tmask(T2D(0),1) * zdiff_mle(T2D(0)) ) ! FK diff in MLE at t-pt
+ CALL zdf_osm_iomput( "zvel_mle", tmask(T2D(0),1) * zvel_mle(T2D(0)) ) ! FK velocity in MLE at t-pt
END IF
!
! Lateral boundary conditions on ghamu and ghamv, currently on W-grid (sign unchanged), needed to caclulate gham[uv] on u and
@@ -1038,11 +1040,11 @@ CONTAINS
!! knlev+kp_ext
!!----------------------------------------------------------------------
INTEGER, INTENT(in ) :: Kbb, Kmm ! Ocean time-level indices
- INTEGER, DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: knlev ! Number of levels to average over.
+ INTEGER, DIMENSION(T2D(nn_hls-1)), INTENT(in ) :: knlev ! Number of levels to average over.
REAL(wp), DIMENSION(jpi,jpj), INTENT( out) :: pt, ps ! Average temperature and salinity
REAL(wp), DIMENSION(jpi,jpj), INTENT( out) :: pb ! Average buoyancy
REAL(wp), DIMENSION(jpi,jpj), INTENT( out) :: pu, pv ! Average current components
- INTEGER, DIMENSION(A2D(nn_hls-1)), INTENT(in ), OPTIONAL :: kp_ext ! External-level offsets
+ INTEGER, DIMENSION(T2D(nn_hls-1)), INTENT(in ), OPTIONAL :: kp_ext ! External-level offsets
REAL(wp), DIMENSION(jpi,jpj), INTENT( out), OPTIONAL :: pdt ! Difference between average temperature,
REAL(wp), DIMENSION(jpi,jpj), INTENT( out), OPTIONAL :: pds ! salinity,
REAL(wp), DIMENSION(jpi,jpj), INTENT( out), OPTIONAL :: pdb ! buoyancy, and
@@ -1050,7 +1052,7 @@ CONTAINS
!!
INTEGER :: jk, jkflt, jkmax, ji, jj ! Loop indices
INTEGER :: ibld_ext ! External-layer index
- REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zthick ! Layer thickness
+ REAL(wp), DIMENSION(T2D(nn_hls-1)) :: zthick ! Layer thickness
REAL(wp) :: zthermal ! Thermal expansion coefficient
REAL(wp) :: zbeta ! Haline contraction coefficient
!!----------------------------------------------------------------------
@@ -1176,7 +1178,7 @@ CONTAINS
REAL(wp), INTENT(inout), DIMENSION(jpi,jpj,jpk) :: pu, pv ! Components of current
LOGICAL, OPTIONAL, INTENT(in ) :: fwd ! Forward (default) or reverse rotation
INTEGER, OPTIONAL, INTENT(in ) :: ktop ! Minimum depth index
- INTEGER, OPTIONAL, INTENT(in ), DIMENSION(A2D(nn_hls-1)) :: knlev ! Array of maximum depth indices
+ INTEGER, OPTIONAL, INTENT(in ), DIMENSION(T2D(nn_hls-1)) :: knlev ! Array of maximum depth indices
!!
INTEGER :: ji, jj, jk, jktop, jkmax ! Loop indices
REAL(wp) :: ztmp, zfwd ! Auxiliary variables
@@ -1221,17 +1223,17 @@ CONTAINS
!!
!!----------------------------------------------------------------------
INTEGER, INTENT(in ) :: Kmm ! Ocean time-level index
- REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT( out) :: pwb_ent ! Buoyancy fluxes at base
- REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT( out) :: pwb_min ! of well-mixed layer
- REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT( out) :: pshear ! Production of TKE due to shear across the pycnocline
- REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: phbl ! BL depth
- REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: phml ! ML depth
- REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pdh ! Pycnocline depth
+ REAL(wp), DIMENSION(T2D(nn_hls-1)), INTENT( out) :: pwb_ent ! Buoyancy fluxes at base
+ REAL(wp), DIMENSION(T2D(nn_hls-1)), INTENT( out) :: pwb_min ! of well-mixed layer
+ REAL(wp), DIMENSION(T2D(nn_hls-1)), INTENT( out) :: pshear ! Production of TKE due to shear across the pycnocline
+ REAL(wp), DIMENSION(T2D(nn_hls-1)), INTENT(in ) :: phbl ! BL depth
+ REAL(wp), DIMENSION(T2D(nn_hls-1)), INTENT(in ) :: phml ! ML depth
+ REAL(wp), DIMENSION(T2D(nn_hls-1)), INTENT(in ) :: pdh ! Pycnocline depth
!!
INTEGER :: jj, ji ! Loop indices
!!
- REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zekman
- REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zri_p, zri_b ! Richardson numbers
+ REAL(wp), DIMENSION(T2D(nn_hls-1)) :: zekman
+ REAL(wp), DIMENSION(T2D(nn_hls-1)) :: zri_p, zri_b ! Richardson numbers
REAL(wp) :: zshear_u, zshear_v, zwb_shr
REAL(wp) :: zwcor, zrf_conv, zrf_shear, zrf_langmuir, zr_stokes
!!
@@ -1268,8 +1270,8 @@ CONTAINS
DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 )
pshear(ji,jj) = 0.0_wp
END_2D
- zekman(:,:) = EXP( -1.0_wp * pp_ek * ABS( ff_t(A2D(nn_hls-1)) ) * phbl(A2D(nn_hls-1)) / &
- & MAX( sustar(A2D(nn_hls-1)), 1.e-8 ) )
+ zekman(:,:) = EXP( -1.0_wp * pp_ek * ABS( ff_t(T2D(nn_hls-1)) ) * phbl(T2D(nn_hls-1)) / &
+ & MAX( sustar(T2D(nn_hls-1)), 1.e-8 ) )
!
DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 )
IF ( l_conv(ji,jj) ) THEN
@@ -1384,9 +1386,9 @@ CONTAINS
!!
!!----------------------------------------------------------------------
INTEGER, INTENT(in ) :: Kmm ! Ocean time-level index
- INTEGER, DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: kbase ! OSBL base layer index
- REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT( out) :: pdtdz, pdsdz ! External gradients of temperature, salinity
- REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT( out) :: pdbdz ! and buoyancy
+ INTEGER, DIMENSION(T2D(nn_hls-1)), INTENT(in ) :: kbase ! OSBL base layer index
+ REAL(wp), DIMENSION(T2D(nn_hls-1)), INTENT( out) :: pdtdz, pdsdz ! External gradients of temperature, salinity
+ REAL(wp), DIMENSION(T2D(nn_hls-1)), INTENT( out) :: pdbdz ! and buoyancy
!!
INTEGER :: ji, jj, jkb, jkb1
REAL(wp) :: zthermal, zbeta
@@ -1428,15 +1430,15 @@ CONTAINS
!! ** Method :
!!
!!----------------------------------------------------------------------
- REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT( out) :: pdhdt ! Rate of change of hbl
- REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: phbl ! BL depth
- REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pdh ! Pycnocline depth
- REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pwb_ent ! Buoyancy entrainment flux
- REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pwb_min
- REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pdbdz_bl_ext ! External buoyancy gradients
- REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT( out) :: pwb_fk_b ! MLE buoyancy flux averaged over OSBL
- REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pwb_fk ! Max MLE buoyancy flux
- REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pvel_mle ! Vvelocity scale for dhdt with stable ML and FK
+ REAL(wp), DIMENSION(T2D(nn_hls-1)), INTENT( out) :: pdhdt ! Rate of change of hbl
+ REAL(wp), DIMENSION(T2D(nn_hls-1)), INTENT(in ) :: phbl ! BL depth
+ REAL(wp), DIMENSION(T2D(nn_hls-1)), INTENT(in ) :: pdh ! Pycnocline depth
+ REAL(wp), DIMENSION(T2D(nn_hls-1)), INTENT(in ) :: pwb_ent ! Buoyancy entrainment flux
+ REAL(wp), DIMENSION(T2D(nn_hls-1)), INTENT(in ) :: pwb_min
+ REAL(wp), DIMENSION(T2D(nn_hls-1)), INTENT(in ) :: pdbdz_bl_ext ! External buoyancy gradients
+ REAL(wp), DIMENSION(T2D(nn_hls-1)), INTENT( out) :: pwb_fk_b ! MLE buoyancy flux averaged over OSBL
+ REAL(wp), DIMENSION(T2D(nn_hls-1)), INTENT(in ) :: pwb_fk ! Max MLE buoyancy flux
+ REAL(wp), DIMENSION(T2D(nn_hls-1)), INTENT(in ) :: pvel_mle ! Vvelocity scale for dhdt with stable ML and FK
!!
INTEGER :: jj, ji
REAL(wp) :: zgamma_b_nd, zgamma_dh_nd, zpert, zpsi, zari
@@ -1598,11 +1600,11 @@ CONTAINS
!!
!!----------------------------------------------------------------------
INTEGER, INTENT(in ) :: Kmm ! Ocean time-level index
- REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(inout) :: pdhdt ! Rates of change of hbl
- REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(inout) :: phbl ! BL depth
- REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: phbl_t ! BL depth
- REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pwb_ent ! Buoyancy entrainment flux
- REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pwb_fk_b ! MLE buoyancy flux averaged over OSBL
+ REAL(wp), DIMENSION(T2D(nn_hls-1)), INTENT(inout) :: pdhdt ! Rates of change of hbl
+ REAL(wp), DIMENSION(T2D(nn_hls-1)), INTENT(inout) :: phbl ! BL depth
+ REAL(wp), DIMENSION(T2D(nn_hls-1)), INTENT(in ) :: phbl_t ! BL depth
+ REAL(wp), DIMENSION(T2D(nn_hls-1)), INTENT(in ) :: pwb_ent ! Buoyancy entrainment flux
+ REAL(wp), DIMENSION(T2D(nn_hls-1)), INTENT(in ) :: pwb_fk_b ! MLE buoyancy flux averaged over OSBL
!!
INTEGER :: jk, jj, ji, jm
REAL(wp) :: zhbl_s, zvel_max, zdb
@@ -1698,13 +1700,13 @@ CONTAINS
!!
!!----------------------------------------------------------------------
INTEGER, INTENT(in ) :: Kmm ! Ocean time-level index
- REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(inout) :: pdh ! Pycnocline thickness
- REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(inout) :: phml ! ML depth
- REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pdhdt ! BL depth tendency
- REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: phbl ! BL depth
- REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pwb_ent ! Buoyancy entrainment flux
- REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pdbdz_bl_ext ! External buoyancy gradients
- REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pwb_fk_b ! MLE buoyancy flux averaged over OSBL
+ REAL(wp), DIMENSION(T2D(nn_hls-1)), INTENT(inout) :: pdh ! Pycnocline thickness
+ REAL(wp), DIMENSION(T2D(nn_hls-1)), INTENT(inout) :: phml ! ML depth
+ REAL(wp), DIMENSION(T2D(nn_hls-1)), INTENT(in ) :: pdhdt ! BL depth tendency
+ REAL(wp), DIMENSION(T2D(nn_hls-1)), INTENT(in ) :: phbl ! BL depth
+ REAL(wp), DIMENSION(T2D(nn_hls-1)), INTENT(in ) :: pwb_ent ! Buoyancy entrainment flux
+ REAL(wp), DIMENSION(T2D(nn_hls-1)), INTENT(in ) :: pdbdz_bl_ext ! External buoyancy gradients
+ REAL(wp), DIMENSION(T2D(nn_hls-1)), INTENT(in ) :: pwb_fk_b ! MLE buoyancy flux averaged over OSBL
!!
INTEGER :: jj, ji
INTEGER :: inhml
@@ -1858,14 +1860,14 @@ CONTAINS
!!
!!----------------------------------------------------------------------
INTEGER, INTENT(in ) :: Kmm ! Ocean time-level index
- INTEGER, DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: kp_ext ! External-level offsets
- REAL(wp), DIMENSION(A2D(nn_hls-1),jpk), INTENT( out) :: pdbdz ! Gradients in the pycnocline
- REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT( out) :: palpha
- REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pdh ! Pycnocline thickness
- REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: phbl ! BL depth
- REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pdbdz_bl_ext ! External buoyancy gradients
- REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: phml ! ML depth
- REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pdhdt ! Rates of change of hbl
+ INTEGER, DIMENSION(T2D(nn_hls-1)), INTENT(in ) :: kp_ext ! External-level offsets
+ REAL(wp), DIMENSION(T2D(nn_hls-1),jpk), INTENT( out) :: pdbdz ! Gradients in the pycnocline
+ REAL(wp), DIMENSION(T2D(nn_hls-1)), INTENT( out) :: palpha
+ REAL(wp), DIMENSION(T2D(nn_hls-1)), INTENT(in ) :: pdh ! Pycnocline thickness
+ REAL(wp), DIMENSION(T2D(nn_hls-1)), INTENT(in ) :: phbl ! BL depth
+ REAL(wp), DIMENSION(T2D(nn_hls-1)), INTENT(in ) :: pdbdz_bl_ext ! External buoyancy gradients
+ REAL(wp), DIMENSION(T2D(nn_hls-1)), INTENT(in ) :: phml ! ML depth
+ REAL(wp), DIMENSION(T2D(nn_hls-1)), INTENT(in ) :: pdhdt ! Rates of change of hbl
!!
INTEGER :: jk, jj, ji
REAL(wp) :: zbgrad
@@ -1951,7 +1953,7 @@ CONTAINS
END_2D
!
IF ( ln_dia_pyc_scl ) THEN ! Output of pycnocline gradient profiles
- CALL zdf_osm_iomput( "zdbdz_pyc", wmask(A2D(0),:) * pdbdz(A2D(0),:) )
+ CALL zdf_osm_iomput( "zdbdz_pyc", wmask(T2D(0),:) * pdbdz(T2D(0),:) )
END IF
!
END SUBROUTINE zdf_osm_pycnocline_buoyancy_profiles
@@ -1969,23 +1971,23 @@ CONTAINS
!!
!!----------------------------------------------------------------------
INTEGER, INTENT(in ) :: Kbb, Kmm ! Ocean time-level indices
- REAL(wp), DIMENSION(A2D(nn_hls-1),jpk), INTENT(inout) :: pdiffut ! t-diffusivity
- REAL(wp), DIMENSION(A2D(nn_hls-1),jpk), INTENT(inout) :: pviscos ! Viscosity
- REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: phbl ! BL depth
- REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: phml ! ML depth
- REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pdh ! Pycnocline depth
- REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pdhdt ! BL depth tendency
- REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pshear ! Shear production
- REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pwb_ent ! Buoyancy entrainment flux
- REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pwb_min
+ REAL(wp), DIMENSION(T2D(nn_hls-1),jpk), INTENT(inout) :: pdiffut ! t-diffusivity
+ REAL(wp), DIMENSION(T2D(nn_hls-1),jpk), INTENT(inout) :: pviscos ! Viscosity
+ REAL(wp), DIMENSION(T2D(nn_hls-1)), INTENT(in ) :: phbl ! BL depth
+ REAL(wp), DIMENSION(T2D(nn_hls-1)), INTENT(in ) :: phml ! ML depth
+ REAL(wp), DIMENSION(T2D(nn_hls-1)), INTENT(in ) :: pdh ! Pycnocline depth
+ REAL(wp), DIMENSION(T2D(nn_hls-1)), INTENT(in ) :: pdhdt ! BL depth tendency
+ REAL(wp), DIMENSION(T2D(nn_hls-1)), INTENT(in ) :: pshear ! Shear production
+ REAL(wp), DIMENSION(T2D(nn_hls-1)), INTENT(in ) :: pwb_ent ! Buoyancy entrainment flux
+ REAL(wp), DIMENSION(T2D(nn_hls-1)), INTENT(in ) :: pwb_min
!!
INTEGER :: ji, jj, jk ! Loop indices
!! Scales used to calculate eddy diffusivity and viscosity profiles
- REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zdifml_sc, zvisml_sc
- REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zdifpyc_n_sc, zdifpyc_s_sc
- REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zvispyc_n_sc, zvispyc_s_sc
- REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zbeta_d_sc, zbeta_v_sc
- REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zb_coup, zc_coup_vis, zc_coup_dif
+ REAL(wp), DIMENSION(T2D(nn_hls-1)) :: zdifml_sc, zvisml_sc
+ REAL(wp), DIMENSION(T2D(nn_hls-1)) :: zdifpyc_n_sc, zdifpyc_s_sc
+ REAL(wp), DIMENSION(T2D(nn_hls-1)) :: zvispyc_n_sc, zvispyc_s_sc
+ REAL(wp), DIMENSION(T2D(nn_hls-1)) :: zbeta_d_sc, zbeta_v_sc
+ REAL(wp), DIMENSION(T2D(nn_hls-1)) :: zb_coup, zc_coup_vis, zc_coup_dif
!!
REAL(wp) :: zvel_sc_pyc, zvel_sc_ml, zstab_fac, zz_b
REAL(wp) :: za_cubic, zb_d_cubic, zc_d_cubic, zd_d_cubic, & ! Coefficients in cubic polynomial specifying diffusivity
@@ -2148,7 +2150,7 @@ CONTAINS
ENDIF ! End if ( l_conv )
!
END_2D
- CALL zdf_osm_iomput( "pb_coup", tmask(A2D(0),1) * zb_coup(A2D(0)) ) ! BBL-coupling velocity scale
+ CALL zdf_osm_iomput( "pb_coup", tmask(T2D(0),1) * zb_coup(T2D(0)) ) ! BBL-coupling velocity scale
!
END SUBROUTINE zdf_osm_diffusivity_viscosity
@@ -2164,39 +2166,39 @@ CONTAINS
!!
!!----------------------------------------------------------------------
INTEGER, INTENT(in ) :: Kmm ! Time-level index
- INTEGER, DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: kp_ext ! Offset for external level
- REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: phbl ! BL depth
- REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: phml ! ML depth
- REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pdh ! Pycnocline depth
- REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pdhdt ! BL depth tendency
- REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pshear ! Shear production
- REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pdtdz_bl_ext ! External temperature gradients
- REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pdsdz_bl_ext ! External salinity gradients
- REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pdbdz_bl_ext ! External buoyancy gradients
- REAL(wp), DIMENSION(A2D(nn_hls-1),jpk), INTENT(in ) :: pdiffut ! t-diffusivity
- REAL(wp), DIMENSION(A2D(nn_hls-1),jpk), INTENT(in ) :: pviscos ! Viscosity
- !!
- REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zalpha_pyc !
- REAL(wp), DIMENSION(A2D(nn_hls-1),jpk) :: zdbdz_pyc ! Parametrised gradient of buoyancy in the pycnocline
+ INTEGER, DIMENSION(T2D(nn_hls-1)), INTENT(in ) :: kp_ext ! Offset for external level
+ REAL(wp), DIMENSION(T2D(nn_hls-1)), INTENT(in ) :: phbl ! BL depth
+ REAL(wp), DIMENSION(T2D(nn_hls-1)), INTENT(in ) :: phml ! ML depth
+ REAL(wp), DIMENSION(T2D(nn_hls-1)), INTENT(in ) :: pdh ! Pycnocline depth
+ REAL(wp), DIMENSION(T2D(nn_hls-1)), INTENT(in ) :: pdhdt ! BL depth tendency
+ REAL(wp), DIMENSION(T2D(nn_hls-1)), INTENT(in ) :: pshear ! Shear production
+ REAL(wp), DIMENSION(T2D(nn_hls-1)), INTENT(in ) :: pdtdz_bl_ext ! External temperature gradients
+ REAL(wp), DIMENSION(T2D(nn_hls-1)), INTENT(in ) :: pdsdz_bl_ext ! External salinity gradients
+ REAL(wp), DIMENSION(T2D(nn_hls-1)), INTENT(in ) :: pdbdz_bl_ext ! External buoyancy gradients
+ REAL(wp), DIMENSION(T2D(nn_hls-1),jpk), INTENT(in ) :: pdiffut ! t-diffusivity
+ REAL(wp), DIMENSION(T2D(nn_hls-1),jpk), INTENT(in ) :: pviscos ! Viscosity
+ !!
+ REAL(wp), DIMENSION(T2D(nn_hls-1)) :: zalpha_pyc !
+ REAL(wp), DIMENSION(T2D(nn_hls-1),jpk) :: zdbdz_pyc ! Parametrised gradient of buoyancy in the pycnocline
REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: z3ddz_pyc_1, z3ddz_pyc_2 ! Pycnocline gradient/shear profiles
!!
INTEGER :: ji, jj, jk, jkm_bld, jkf_mld, jkm_mld ! Loop indices
INTEGER :: istat ! Memory allocation status
REAL(wp) :: zznd_d, zznd_ml, zznd_pyc, znd ! Temporary non-dimensional depths
- REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zsc_wth_1,zsc_ws_1 ! Temporary scales
- REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zsc_uw_1, zsc_uw_2 ! Temporary scales
- REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zsc_vw_1, zsc_vw_2 ! Temporary scales
- REAL(wp), DIMENSION(A2D(nn_hls-1)) :: ztau_sc_u ! Dissipation timescale at base of WML
+ REAL(wp), DIMENSION(T2D(nn_hls-1)) :: zsc_wth_1,zsc_ws_1 ! Temporary scales
+ REAL(wp), DIMENSION(T2D(nn_hls-1)) :: zsc_uw_1, zsc_uw_2 ! Temporary scales
+ REAL(wp), DIMENSION(T2D(nn_hls-1)) :: zsc_vw_1, zsc_vw_2 ! Temporary scales
+ REAL(wp), DIMENSION(T2D(nn_hls-1)) :: ztau_sc_u ! Dissipation timescale at base of WML
REAL(wp) :: zbuoy_pyc_sc, zdelta_pyc !
REAL(wp) :: zl_c,zl_l,zl_eps ! Used to calculate turbulence length scale
- REAL(wp), DIMENSION(A2D(nn_hls-1)) :: za_cubic, zb_cubic ! Coefficients in cubic polynomial specifying
- REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zc_cubic, zd_cubic ! diffusivity in pycnocline
- REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zwt_pyc_sc_1, zws_pyc_sc_1 !
- REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zzeta_pyc !
+ REAL(wp), DIMENSION(T2D(nn_hls-1)) :: za_cubic, zb_cubic ! Coefficients in cubic polynomial specifying
+ REAL(wp), DIMENSION(T2D(nn_hls-1)) :: zc_cubic, zd_cubic ! diffusivity in pycnocline
+ REAL(wp), DIMENSION(T2D(nn_hls-1)) :: zwt_pyc_sc_1, zws_pyc_sc_1 !
+ REAL(wp), DIMENSION(T2D(nn_hls-1)) :: zzeta_pyc !
REAL(wp) :: zomega, zvw_max !
- REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zuw_bse,zvw_bse ! Momentum, heat, and salinity fluxes
- REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zwth_ent,zws_ent ! at the top of the pycnocline
- REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zsc_wth_pyc, zsc_ws_pyc ! Scales for pycnocline transport term
+ REAL(wp), DIMENSION(T2D(nn_hls-1)) :: zuw_bse,zvw_bse ! Momentum, heat, and salinity fluxes
+ REAL(wp), DIMENSION(T2D(nn_hls-1)) :: zwth_ent,zws_ent ! at the top of the pycnocline
+ REAL(wp), DIMENSION(T2D(nn_hls-1)) :: zsc_wth_pyc, zsc_ws_pyc ! Scales for pycnocline transport term
REAL(wp) :: ztmp !
REAL(wp) :: ztgrad, zsgrad, zbgrad ! Variables used to calculate pycnocline
!! ! gradients
@@ -2228,14 +2230,14 @@ CONTAINS
!
! Stokes term in scalar flux, flux-gradient relationship
! ------------------------------------------------------
- WHERE ( l_conv(A2D(nn_hls-1)) )
- zsc_wth_1(:,:) = swstrl(A2D(nn_hls-1))**3 * swth0(A2D(nn_hls-1)) / &
- & ( svstr(A2D(nn_hls-1))**3 + 0.5_wp * swstrc(A2D(nn_hls-1))**3 + epsln )
- zsc_ws_1(:,:) = swstrl(A2D(nn_hls-1))**3 * sws0(A2D(nn_hls-1)) / &
- & ( svstr(A2D(nn_hls-1))**3 + 0.5_wp * swstrc(A2D(nn_hls-1))**3 + epsln )
+ WHERE ( l_conv(T2D(nn_hls-1)) )
+ zsc_wth_1(:,:) = swstrl(T2D(nn_hls-1))**3 * swth0(T2D(nn_hls-1)) / &
+ & ( svstr(T2D(nn_hls-1))**3 + 0.5_wp * swstrc(T2D(nn_hls-1))**3 + epsln )
+ zsc_ws_1(:,:) = swstrl(T2D(nn_hls-1))**3 * sws0(T2D(nn_hls-1)) / &
+ & ( svstr(T2D(nn_hls-1))**3 + 0.5_wp * swstrc(T2D(nn_hls-1))**3 + epsln )
ELSEWHERE
- zsc_wth_1(:,:) = 2.0_wp * swthav(A2D(nn_hls-1))
- zsc_ws_1(:,:) = 2.0_wp * swsav(A2D(nn_hls-1))
+ zsc_wth_1(:,:) = 2.0_wp * swthav(T2D(nn_hls-1))
+ zsc_ws_1(:,:) = 2.0_wp * swsav(T2D(nn_hls-1))
ENDWHERE
DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, MAX( jkm_mld, jkm_bld ) )
IF ( l_conv(ji,jj) ) THEN
@@ -2258,27 +2260,27 @@ CONTAINS
END_3D
!
IF ( ln_dia_osm ) THEN
- CALL zdf_osm_iomput( "ghamu_00", wmask(A2D(0),:) * ghamu(A2D(0),:) )
- CALL zdf_osm_iomput( "ghamv_00", wmask(A2D(0),:) * ghamv(A2D(0),:) )
+ CALL zdf_osm_iomput( "ghamu_00", wmask(T2D(0),:) * ghamu(T2D(0),:) )
+ CALL zdf_osm_iomput( "ghamv_00", wmask(T2D(0),:) * ghamv(T2D(0),:) )
END IF
!
! Stokes term in flux-gradient relationship (note in zsc_uw_n don't use
! svstr since term needs to go to zero as swstrl goes to zero)
! ---------------------------------------------------------------------
- WHERE ( l_conv(A2D(nn_hls-1)) )
- zsc_uw_1(:,:) = ( swstrl(A2D(nn_hls-1))**3 + &
- & 0.5_wp * swstrc(A2D(nn_hls-1))**3 )**pthird * sustke(A2D(nn_hls-1)) / &
- & MAX( ( 1.0_wp - 1.0_wp * 6.5_wp * sla(A2D(nn_hls-1))**( 8.0_wp / 3.0_wp ) ), 0.2_wp )
- zsc_uw_2(:,:) = ( swstrl(A2D(nn_hls-1))**3 + &
- & 0.5_wp * swstrc(A2D(nn_hls-1))**3 )**pthird * sustke(A2D(nn_hls-1)) / &
- & MIN( sla(A2D(nn_hls-1))**( 8.0_wp / 3.0_wp ) + epsln, 0.12_wp )
- zsc_vw_1(:,:) = ff_t(A2D(nn_hls-1)) * phml(A2D(nn_hls-1)) * sustke(A2D(nn_hls-1))**3 * &
- & MIN( sla(A2D(nn_hls-1))**( 8.0_wp / 3.0_wp ), 0.12_wp ) / &
- & ( ( svstr(A2D(nn_hls-1))**3 + 0.5_wp * swstrc(A2D(nn_hls-1))**3 )**( 2.0_wp / 3.0_wp ) + epsln )
+ WHERE ( l_conv(T2D(nn_hls-1)) )
+ zsc_uw_1(:,:) = ( swstrl(T2D(nn_hls-1))**3 + &
+ & 0.5_wp * swstrc(T2D(nn_hls-1))**3 )**pthird * sustke(T2D(nn_hls-1)) / &
+ & MAX( ( 1.0_wp - 1.0_wp * 6.5_wp * sla(T2D(nn_hls-1))**( 8.0_wp / 3.0_wp ) ), 0.2_wp )
+ zsc_uw_2(:,:) = ( swstrl(T2D(nn_hls-1))**3 + &
+ & 0.5_wp * swstrc(T2D(nn_hls-1))**3 )**pthird * sustke(T2D(nn_hls-1)) / &
+ & MIN( sla(T2D(nn_hls-1))**( 8.0_wp / 3.0_wp ) + epsln, 0.12_wp )
+ zsc_vw_1(:,:) = ff_t(T2D(nn_hls-1)) * phml(T2D(nn_hls-1)) * sustke(T2D(nn_hls-1))**3 * &
+ & MIN( sla(T2D(nn_hls-1))**( 8.0_wp / 3.0_wp ), 0.12_wp ) / &
+ & ( ( svstr(T2D(nn_hls-1))**3 + 0.5_wp * swstrc(T2D(nn_hls-1))**3 )**( 2.0_wp / 3.0_wp ) + epsln )
ELSEWHERE
- zsc_uw_1(:,:) = sustar(A2D(nn_hls-1))**2
- zsc_vw_1(:,:) = ff_t(A2D(nn_hls-1)) * phbl(A2D(nn_hls-1)) * sustke(A2D(nn_hls-1))**3 * &
- & MIN( sla(A2D(nn_hls-1))**( 8.0_wp / 3.0_wp ), 0.12_wp ) / ( svstr(A2D(nn_hls-1))**2 + epsln )
+ zsc_uw_1(:,:) = sustar(T2D(nn_hls-1))**2
+ zsc_vw_1(:,:) = ff_t(T2D(nn_hls-1)) * phbl(T2D(nn_hls-1)) * sustke(T2D(nn_hls-1))**3 * &
+ & MIN( sla(T2D(nn_hls-1))**( 8.0_wp / 3.0_wp ), 0.12_wp ) / ( svstr(T2D(nn_hls-1))**2 + epsln )
ENDWHERE
DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, MAX( jkm_mld, jkm_bld ) )
IF ( l_conv(ji,jj) ) THEN
@@ -2302,11 +2304,11 @@ CONTAINS
! Buoyancy term in flux-gradient relationship [note : includes ROI ratio
! (X0.3) and pressure (X0.5)]
! ----------------------------------------------------------------------
- WHERE ( l_conv(A2D(nn_hls-1)) )
- zsc_wth_1(:,:) = swbav(A2D(nn_hls-1)) * swth0(A2D(nn_hls-1)) * ( 1.0_wp + EXP( 0.2_wp * shol(A2D(nn_hls-1)) ) ) * &
- & phml(A2D(nn_hls-1)) / ( svstr(A2D(nn_hls-1))**3 + 0.5_wp * swstrc(A2D(nn_hls-1))**3 + epsln )
- zsc_ws_1(:,:) = swbav(A2D(nn_hls-1)) * sws0(A2D(nn_hls-1)) * ( 1.0_wp + EXP( 0.2_wp * shol(A2D(nn_hls-1)) ) ) * &
- & phml(A2D(nn_hls-1)) / ( svstr(A2D(nn_hls-1))**3 + 0.5_wp * swstrc(A2D(nn_hls-1))**3 + epsln )
+ WHERE ( l_conv(T2D(nn_hls-1)) )
+ zsc_wth_1(:,:) = swbav(T2D(nn_hls-1)) * swth0(T2D(nn_hls-1)) * ( 1.0_wp + EXP( 0.2_wp * shol(T2D(nn_hls-1)) ) ) * &
+ & phml(T2D(nn_hls-1)) / ( svstr(T2D(nn_hls-1))**3 + 0.5_wp * swstrc(T2D(nn_hls-1))**3 + epsln )
+ zsc_ws_1(:,:) = swbav(T2D(nn_hls-1)) * sws0(T2D(nn_hls-1)) * ( 1.0_wp + EXP( 0.2_wp * shol(T2D(nn_hls-1)) ) ) * &
+ & phml(T2D(nn_hls-1)) / ( svstr(T2D(nn_hls-1))**3 + 0.5_wp * swstrc(T2D(nn_hls-1))**3 + epsln )
ELSEWHERE
zsc_wth_1(:,:) = 0.0_wp
zsc_ws_1(:,:) = 0.0_wp
@@ -2373,16 +2375,16 @@ CONTAINS
END_3D
!
IF ( ln_dia_osm ) THEN
- CALL zdf_osm_iomput( "zwth_ent", tmask(A2D(0),1) * zwth_ent(A2D(0)) ) ! Upward turb. temperature entrainment flux
- CALL zdf_osm_iomput( "zws_ent", tmask(A2D(0),1) * zws_ent(A2D(0)) ) ! Upward turb. salinity entrainment flux
+ CALL zdf_osm_iomput( "zwth_ent", tmask(T2D(0),1) * zwth_ent(T2D(0)) ) ! Upward turb. temperature entrainment flux
+ CALL zdf_osm_iomput( "zws_ent", tmask(T2D(0),1) * zws_ent(T2D(0)) ) ! Upward turb. salinity entrainment flux
END IF
!
zsc_vw_1(:,:) = 0.0_wp
- WHERE ( l_conv(A2D(nn_hls-1)) )
- zsc_uw_1(:,:) = -1.0_wp * swb0(A2D(nn_hls-1)) * sustar(A2D(nn_hls-1))**2 * phml(A2D(nn_hls-1)) / &
- & ( svstr(A2D(nn_hls-1))**3 + 0.5_wp * swstrc(A2D(nn_hls-1))**3 + epsln )
- zsc_uw_2(:,:) = swb0(A2D(nn_hls-1)) * sustke(A2D(nn_hls-1)) * phml(A2D(nn_hls-1)) / &
- & ( svstr(A2D(nn_hls-1))**3 + 0.5_wp * swstrc(A2D(nn_hls-1))**3 + epsln )**( 2.0_wp / 3.0_wp )
+ WHERE ( l_conv(T2D(nn_hls-1)) )
+ zsc_uw_1(:,:) = -1.0_wp * swb0(T2D(nn_hls-1)) * sustar(T2D(nn_hls-1))**2 * phml(T2D(nn_hls-1)) / &
+ & ( svstr(T2D(nn_hls-1))**3 + 0.5_wp * swstrc(T2D(nn_hls-1))**3 + epsln )
+ zsc_uw_2(:,:) = swb0(T2D(nn_hls-1)) * sustke(T2D(nn_hls-1)) * phml(T2D(nn_hls-1)) / &
+ & ( svstr(T2D(nn_hls-1))**3 + 0.5_wp * swstrc(T2D(nn_hls-1))**3 + epsln )**( 2.0_wp / 3.0_wp )
ELSEWHERE
zsc_uw_1(:,:) = 0.0_wp
ENDWHERE
@@ -2435,25 +2437,25 @@ CONTAINS
END_3D
!
IF ( ln_dia_osm ) THEN
- CALL zdf_osm_iomput( "ghamu_0", wmask(A2D(0),:) * ghamu(A2D(0),:) )
- CALL zdf_osm_iomput( "zsc_uw_1_0", tmask(A2D(0),1) * zsc_uw_1(A2D(0)) )
+ CALL zdf_osm_iomput( "ghamu_0", wmask(T2D(0),:) * ghamu(T2D(0),:) )
+ CALL zdf_osm_iomput( "zsc_uw_1_0", tmask(T2D(0),1) * zsc_uw_1(T2D(0)) )
END IF
!
! Transport term in flux-gradient relationship [note : includes ROI ratio
! (X0.3) ]
! -----------------------------------------------------------------------
- WHERE ( l_conv(A2D(nn_hls-1)) )
- zsc_wth_1(:,:) = swth0(A2D(nn_hls-1)) / ( 1.0_wp - 0.56_wp * EXP( shol(A2D(nn_hls-1)) ) )
- zsc_ws_1(:,:) = sws0(A2D(nn_hls-1)) / ( 1.0_wp - 0.56_wp * EXP( shol(A2D(nn_hls-1)) ) )
- WHERE ( l_pyc(A2D(nn_hls-1)) ) ! Pycnocline scales
- zsc_wth_pyc(:,:) = -0.003_wp * swstrc(A2D(nn_hls-1)) * ( 1.0_wp - pdh(A2D(nn_hls-1)) / phbl(A2D(nn_hls-1)) ) * &
- & av_dt_ml(A2D(nn_hls-1))
- zsc_ws_pyc(:,:) = -0.003_wp * swstrc(A2D(nn_hls-1)) * ( 1.0_wp - pdh(A2D(nn_hls-1)) / phbl(A2D(nn_hls-1)) ) * &
- & av_ds_ml(A2D(nn_hls-1))
+ WHERE ( l_conv(T2D(nn_hls-1)) )
+ zsc_wth_1(:,:) = swth0(T2D(nn_hls-1)) / ( 1.0_wp - 0.56_wp * EXP( shol(T2D(nn_hls-1)) ) )
+ zsc_ws_1(:,:) = sws0(T2D(nn_hls-1)) / ( 1.0_wp - 0.56_wp * EXP( shol(T2D(nn_hls-1)) ) )
+ WHERE ( l_pyc(T2D(nn_hls-1)) ) ! Pycnocline scales
+ zsc_wth_pyc(:,:) = -0.003_wp * swstrc(T2D(nn_hls-1)) * ( 1.0_wp - pdh(T2D(nn_hls-1)) / phbl(T2D(nn_hls-1)) ) * &
+ & av_dt_ml(T2D(nn_hls-1))
+ zsc_ws_pyc(:,:) = -0.003_wp * swstrc(T2D(nn_hls-1)) * ( 1.0_wp - pdh(T2D(nn_hls-1)) / phbl(T2D(nn_hls-1)) ) * &
+ & av_ds_ml(T2D(nn_hls-1))
END WHERE
ELSEWHERE
- zsc_wth_1(:,:) = 2.0_wp * swthav(A2D(nn_hls-1))
- zsc_ws_1(:,:) = sws0(A2D(nn_hls-1))
+ zsc_wth_1(:,:) = 2.0_wp * swthav(T2D(nn_hls-1))
+ zsc_ws_1(:,:) = sws0(T2D(nn_hls-1))
END WHERE
DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, MAX( jkm_mld, jkm_bld ) )
IF ( l_conv(ji,jj) ) THEN
@@ -2490,14 +2492,14 @@ CONTAINS
ENDIF
END_3D
!
- WHERE ( l_conv(A2D(nn_hls-1)) )
- zsc_uw_1(:,:) = sustar(A2D(nn_hls-1))**2
- zsc_vw_1(:,:) = ff_t(A2D(nn_hls-1)) * sustke(A2D(nn_hls-1)) * phml(A2D(nn_hls-1))
+ WHERE ( l_conv(T2D(nn_hls-1)) )
+ zsc_uw_1(:,:) = sustar(T2D(nn_hls-1))**2
+ zsc_vw_1(:,:) = ff_t(T2D(nn_hls-1)) * sustke(T2D(nn_hls-1)) * phml(T2D(nn_hls-1))
ELSEWHERE
- zsc_uw_1(:,:) = sustar(A2D(nn_hls-1))**2
+ zsc_uw_1(:,:) = sustar(T2D(nn_hls-1))**2
zsc_uw_2(:,:) = ( 2.25_wp - 3.0_wp * ( 1.0_wp - EXP( -1.25_wp * 2.0_wp ) ) ) * ( 1.0_wp - EXP( -4.0_wp * 2.0_wp ) ) * &
& zsc_uw_1(:,:)
- zsc_vw_1(:,:) = ff_t(A2D(nn_hls-1)) * sustke(A2D(nn_hls-1)) * phbl(A2D(nn_hls-1))
+ zsc_vw_1(:,:) = ff_t(T2D(nn_hls-1)) * sustke(T2D(nn_hls-1)) * phbl(T2D(nn_hls-1))
zsc_vw_2(:,:) = -0.11_wp * SIN( 3.14159_wp * ( 2.0_wp + 0.4_wp ) ) * EXP( -1.0_wp * ( 1.5_wp + 2.0_wp )**2 ) * &
& zsc_vw_1(:,:)
ENDWHERE
@@ -2534,12 +2536,12 @@ CONTAINS
END_3D
!
IF ( ln_dia_osm ) THEN
- CALL zdf_osm_iomput( "ghamu_f", wmask(A2D(0),:) * ghamu(A2D(0),:) )
- CALL zdf_osm_iomput( "ghamv_f", wmask(A2D(0),:) * ghamv(A2D(0),:) )
- CALL zdf_osm_iomput( "zsc_uw_1_f", tmask(A2D(0),1) * zsc_uw_1(A2D(0)) )
- CALL zdf_osm_iomput( "zsc_vw_1_f", tmask(A2D(0),1) * zsc_vw_1(A2D(0)) )
- CALL zdf_osm_iomput( "zsc_uw_2_f", tmask(A2D(0),1) * zsc_uw_2(A2D(0)) )
- CALL zdf_osm_iomput( "zsc_vw_2_f", tmask(A2D(0),1) * zsc_vw_2(A2D(0)) )
+ CALL zdf_osm_iomput( "ghamu_f", wmask(T2D(0),:) * ghamu(T2D(0),:) )
+ CALL zdf_osm_iomput( "ghamv_f", wmask(T2D(0),:) * ghamv(T2D(0),:) )
+ CALL zdf_osm_iomput( "zsc_uw_1_f", tmask(T2D(0),1) * zsc_uw_1(T2D(0)) )
+ CALL zdf_osm_iomput( "zsc_vw_1_f", tmask(T2D(0),1) * zsc_vw_1(T2D(0)) )
+ CALL zdf_osm_iomput( "zsc_uw_2_f", tmask(T2D(0),1) * zsc_uw_2(T2D(0)) )
+ CALL zdf_osm_iomput( "zsc_vw_2_f", tmask(T2D(0),1) * zsc_vw_2(T2D(0)) )
END IF
!
! Make surface forced velocity non-gradient terms go to zero at the base
@@ -2563,7 +2565,7 @@ CONTAINS
! Pynocline contributions
!
IF ( ln_dia_pyc_scl .OR. ln_dia_pyc_shr ) THEN ! Allocate arrays for output of pycnocline gradient/shear profiles
- ALLOCATE( z3ddz_pyc_1(A2D(nn_hls),jpk), z3ddz_pyc_2(A2D(nn_hls),jpk), STAT=istat )
+ ALLOCATE( z3ddz_pyc_1(T2D(nn_hls),jpk), z3ddz_pyc_2(T2D(nn_hls),jpk), STAT=istat )
IF ( istat /= 0 ) CALL ctl_stop( 'zdf_osm: failed to allocate temporary arrays' )
z3ddz_pyc_1(:,:,:) = 0.0_wp
z3ddz_pyc_2(:,:,:) = 0.0_wp
@@ -2634,8 +2636,8 @@ CONTAINS
END IF
END_3D
IF ( ln_dia_pyc_scl ) THEN ! Output of pycnocline gradient profiles
- CALL zdf_osm_iomput( "zdtdz_pyc", wmask(A2D(0),:) * z3ddz_pyc_1(A2D(0),:) )
- CALL zdf_osm_iomput( "zdsdz_pyc", wmask(A2D(0),:) * z3ddz_pyc_2(A2D(0),:) )
+ CALL zdf_osm_iomput( "zdtdz_pyc", wmask(T2D(0),:) * z3ddz_pyc_1(T2D(0),:) )
+ CALL zdf_osm_iomput( "zdsdz_pyc", wmask(T2D(0),:) * z3ddz_pyc_2(T2D(0),:) )
END IF
DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jkm_bld )
IF ( .NOT. l_conv (ji,jj) ) THEN
@@ -2661,12 +2663,12 @@ CONTAINS
END IF
END_3D
IF ( ln_dia_pyc_shr ) THEN ! Output of pycnocline shear profiles
- CALL zdf_osm_iomput( "zdudz_pyc", wmask(A2D(0),:) * z3ddz_pyc_1(A2D(0),:) )
- CALL zdf_osm_iomput( "zdvdz_pyc", wmask(A2D(0),:) * z3ddz_pyc_2(A2D(0),:) )
+ CALL zdf_osm_iomput( "zdudz_pyc", wmask(T2D(0),:) * z3ddz_pyc_1(T2D(0),:) )
+ CALL zdf_osm_iomput( "zdvdz_pyc", wmask(T2D(0),:) * z3ddz_pyc_2(T2D(0),:) )
END IF
IF ( ln_dia_osm ) THEN
- CALL zdf_osm_iomput( "ghamu_b", wmask(A2D(0),:) * ghamu(A2D(0),:) )
- CALL zdf_osm_iomput( "ghamv_b", wmask(A2D(0),:) * ghamv(A2D(0),:) )
+ CALL zdf_osm_iomput( "ghamu_b", wmask(T2D(0),:) * ghamu(T2D(0),:) )
+ CALL zdf_osm_iomput( "ghamv_b", wmask(T2D(0),:) * ghamv(T2D(0),:) )
END IF
IF ( ln_dia_pyc_scl .OR. ln_dia_pyc_shr ) THEN ! Deallocate arrays used for output of pycnocline gradient/shear profiles
DEALLOCATE( z3ddz_pyc_1, z3ddz_pyc_2 )
@@ -2680,9 +2682,9 @@ CONTAINS
END_2D
!
IF ( ln_dia_osm ) THEN
- CALL zdf_osm_iomput( "ghamu_1", wmask(A2D(0),:) * ghamu(A2D(0),:) )
- CALL zdf_osm_iomput( "ghamv_1", wmask(A2D(0),:) * ghamv(A2D(0),:) )
- CALL zdf_osm_iomput( "zviscos", wmask(A2D(0),:) * pviscos(A2D(0),:) )
+ CALL zdf_osm_iomput( "ghamu_1", wmask(T2D(0),:) * ghamu(T2D(0),:) )
+ CALL zdf_osm_iomput( "ghamv_1", wmask(T2D(0),:) * ghamv(T2D(0),:) )
+ CALL zdf_osm_iomput( "zviscos", wmask(T2D(0),:) * pviscos(T2D(0),:) )
END IF
!
END SUBROUTINE zdf_osm_fgr_terms
@@ -2702,26 +2704,26 @@ CONTAINS
!!
!!----------------------------------------------------------------------
INTEGER, INTENT(in ) :: Kmm ! Time-level index
- REAL(wp), DIMENSION(A2D(nn_hls)), INTENT( out) :: pmld ! == Estimated FK BLD used for MLE horizontal gradients == !
- REAL(wp), DIMENSION(A2D(nn_hls)), INTENT(inout) :: pdtdx ! Horizontal gradient for Fox-Kemper parametrization
- REAL(wp), DIMENSION(A2D(nn_hls)), INTENT(inout) :: pdtdy ! Horizontal gradient for Fox-Kemper parametrization
- REAL(wp), DIMENSION(A2D(nn_hls)), INTENT(inout) :: pdsdx ! Horizontal gradient for Fox-Kemper parametrization
- REAL(wp), DIMENSION(A2D(nn_hls)), INTENT(inout) :: pdsdy ! Horizontal gradient for Fox-Kemper parametrization
- REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(inout) :: pdbds_mle ! Magnitude of horizontal buoyancy gradient
+ REAL(wp), DIMENSION(T2D(nn_hls)), INTENT( out) :: pmld ! == Estimated FK BLD used for MLE horizontal gradients == !
+ REAL(wp), DIMENSION(T2D(nn_hls)), INTENT(inout) :: pdtdx ! Horizontal gradient for Fox-Kemper parametrization
+ REAL(wp), DIMENSION(T2D(nn_hls)), INTENT(inout) :: pdtdy ! Horizontal gradient for Fox-Kemper parametrization
+ REAL(wp), DIMENSION(T2D(nn_hls)), INTENT(inout) :: pdsdx ! Horizontal gradient for Fox-Kemper parametrization
+ REAL(wp), DIMENSION(T2D(nn_hls)), INTENT(inout) :: pdsdy ! Horizontal gradient for Fox-Kemper parametrization
+ REAL(wp), DIMENSION(T2D(nn_hls-1)), INTENT(inout) :: pdbds_mle ! Magnitude of horizontal buoyancy gradient
!!
INTEGER :: ji, jj, jk ! Dummy loop indices
- INTEGER, DIMENSION(A2D(nn_hls)) :: jk_mld_prof ! Base level of MLE layer
+ INTEGER, DIMENSION(T2D(nn_hls)) :: jk_mld_prof ! Base level of MLE layer
INTEGER :: ikt, ikmax ! Local integers
REAL(wp) :: zc
REAL(wp) :: zN2_c ! Local buoyancy difference from 10m value
- REAL(wp), DIMENSION(A2D(nn_hls)) :: ztm
- REAL(wp), DIMENSION(A2D(nn_hls)) :: zsm
- REAL(wp), DIMENSION(A2D(nn_hls),jpts) :: ztsm_midu
- REAL(wp), DIMENSION(A2D(nn_hls),jpts) :: ztsm_midv
- REAL(wp), DIMENSION(A2D(nn_hls),jpts) :: zabu
- REAL(wp), DIMENSION(A2D(nn_hls),jpts) :: zabv
- REAL(wp), DIMENSION(A2D(nn_hls)) :: zmld_midu
- REAL(wp), DIMENSION(A2D(nn_hls)) :: zmld_midv
+ REAL(wp), DIMENSION(T2D(nn_hls)) :: ztm
+ REAL(wp), DIMENSION(T2D(nn_hls)) :: zsm
+ REAL(wp), DIMENSION(T2D(nn_hls),jpts) :: ztsm_midu
+ REAL(wp), DIMENSION(T2D(nn_hls),jpts) :: ztsm_midv
+ REAL(wp), DIMENSION(T2D(nn_hls),jpts) :: zabu
+ REAL(wp), DIMENSION(T2D(nn_hls),jpts) :: zabv
+ REAL(wp), DIMENSION(T2D(nn_hls)) :: zmld_midu
+ REAL(wp), DIMENSION(T2D(nn_hls)) :: zmld_midv
!!----------------------------------------------------------------------
!
! == MLD used for MLE ==!
@@ -2743,7 +2745,7 @@ CONTAINS
mld_prof(ji,jj) = jk_mld_prof(ji,jj)
END_2D
!
- ikmax = MIN( MAXVAL( jk_mld_prof(A2D(nn_hls)) ), jpkm1 ) ! Max level of the computation
+ ikmax = MIN( MAXVAL( jk_mld_prof(T2D(nn_hls)) ), jpkm1 ) ! Max level of the computation
ztm(:,:) = 0.0_wp
zsm(:,:) = 0.0_wp
DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, ikmax )
@@ -2811,14 +2813,14 @@ CONTAINS
!!
!!----------------------------------------------------------------------
INTEGER, INTENT(in ) :: Kmm ! Time-level index
- REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(inout) :: pwb_fk
- REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: phbl ! BL depth
- REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: phmle ! MLE depth
- REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pwb_ent ! Buoyancy entrainment flux
- REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pdbds_mle ! Magnitude of horizontal buoyancy gradient
+ REAL(wp), DIMENSION(T2D(nn_hls-1)), INTENT(inout) :: pwb_fk
+ REAL(wp), DIMENSION(T2D(nn_hls-1)), INTENT(in ) :: phbl ! BL depth
+ REAL(wp), DIMENSION(T2D(nn_hls-1)), INTENT(in ) :: phmle ! MLE depth
+ REAL(wp), DIMENSION(T2D(nn_hls-1)), INTENT(in ) :: pwb_ent ! Buoyancy entrainment flux
+ REAL(wp), DIMENSION(T2D(nn_hls-1)), INTENT(in ) :: pdbds_mle ! Magnitude of horizontal buoyancy gradient
!!
INTEGER :: ji, jj, jk ! Dummy loop indices
- REAL(wp), DIMENSION(A2D(nn_hls-1)) :: znd_param
+ REAL(wp), DIMENSION(T2D(nn_hls-1)) :: znd_param
REAL(wp) :: zthermal, zbeta
REAL(wp) :: zbuoy
REAL(wp) :: ztmp
@@ -2923,13 +2925,13 @@ CONTAINS
!!
!!----------------------------------------------------------------------
INTEGER, INTENT(in ) :: Kmm ! Time-level index
- REAL(wp), DIMENSION(A2D(nn_hls)), INTENT(in ) :: pmld ! == Estimated FK BLD used for MLE horiz gradients == !
- REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(inout) :: phmle ! MLE depth
- REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(inout) :: pvel_mle ! Velocity scale for dhdt with stable ML and FK
- REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(inout) :: pdiff_mle ! Extra MLE vertical diff
- REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pdbds_mle ! Magnitude of horizontal buoyancy gradient
- REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: phbl ! BL depth
- REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pwb0tot ! Total surface buoyancy flux including insolation
+ REAL(wp), DIMENSION(T2D(nn_hls)), INTENT(in ) :: pmld ! == Estimated FK BLD used for MLE horiz gradients == !
+ REAL(wp), DIMENSION(T2D(nn_hls-1)), INTENT(inout) :: phmle ! MLE depth
+ REAL(wp), DIMENSION(T2D(nn_hls-1)), INTENT(inout) :: pvel_mle ! Velocity scale for dhdt with stable ML and FK
+ REAL(wp), DIMENSION(T2D(nn_hls-1)), INTENT(inout) :: pdiff_mle ! Extra MLE vertical diff
+ REAL(wp), DIMENSION(T2D(nn_hls-1)), INTENT(in ) :: pdbds_mle ! Magnitude of horizontal buoyancy gradient
+ REAL(wp), DIMENSION(T2D(nn_hls-1)), INTENT(in ) :: phbl ! BL depth
+ REAL(wp), DIMENSION(T2D(nn_hls-1)), INTENT(in ) :: pwb0tot ! Total surface buoyancy flux including insolation
!!
INTEGER :: ji, jj, jk ! Dummy loop indices
REAL(wp) :: ztmp
@@ -2943,6 +2945,7 @@ CONTAINS
!!----------------------------------------------------------------------
!
! Calculate vertical buoyancy, heat and salinity fluxes due to MLE
+ ! BUG: [zdfosm_avt_diag] lbc_lnk changes the value of avt on the northfold (see zdfphy.F90 comment). It seems to stem from here- if ztmp is converted to an array, calling lbc_lnk on this array has the same effect as calling lbc_lnk on avt. I think it could be related to l_conv.
DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 )
IF ( l_conv(ji,jj) ) THEN
ztmp = r1_ft(ji,jj) * MIN( 111e3_wp, e1u(ji,jj) ) / rn_osm_mle_lf
@@ -2969,7 +2972,7 @@ CONTAINS
hmle(ji,jj) = hmle(ji,jj) - 10.0_wp * ( hmle(ji,jj) - hbl(ji,jj) ) * rn_Dt / rn_osm_mle_tau
END IF
END IF
- hmle(ji,jj) = MAX( MIN( hmle(ji,jj), ht(ji,jj) ), gdepw(ji,jj,4,Kmm) )
+ hmle(ji,jj) = MAX( MIN( hmle(ji,jj), ht(ji,jj,Kmm) ), gdepw(ji,jj,4,Kmm) )
IF ( ln_osm_hmle_limit ) hmle(ji,jj) = MIN( hmle(ji,jj), rn_osm_hmle_limit*hbl(ji,jj) )
hmle(ji,jj) = pmld(ji,jj) ! For now try just set hmle to pmld
END_2D
@@ -3070,6 +3073,13 @@ CONTAINS
& CALL ctl_stop( 'zdf_osm_init : ln_zdfosm and nn_osm_wave=2, ln_wave and ln_sdw must be true' )
END IF
!
+ ! TEMP: Specifically, the issue is that rCdU_bot is accessed on halo points but is no longer defined there. We must remove halo calculations from zdfosm where possible.
+ IF( ln_tile ) THEN
+ CALL ctl_warn( 'zdf_osm_init: tiling is not currently working with OSMOSIS- it is disabled' )
+ ln_tile = .FALSE.
+ CALL dom_tile_init
+ ENDIF
+ !
! Flags associated with diagnostic output
IF ( ln_dia_osm .AND. ( iom_use("zdudz_pyc") .OR. iom_use("zdvdz_pyc") ) ) ln_dia_pyc_shr = .TRUE.
IF ( ln_dia_osm .AND. ( iom_use("zdtdz_pyc") .OR. iom_use("zdsdz_pyc") .OR. iom_use("zdbdz_pyc" ) ) ) ln_dia_pyc_scl = .TRUE.
@@ -3196,9 +3206,9 @@ CONTAINS
!
! Initialization of vertical eddy coef. to the background value
! -------------------------------------------------------------
- DO jk = 1, jpk
- avt(:,:,jk) = avtb(jk) * tmask(:,:,jk)
- END DO
+ DO_3D( 0, 0, 0, 0, 1, jpk )
+ avt(ji,jj,jk) = avtb(jk) * tmask(ji,jj,jk)
+ END_3D
!
! Zero the surface flux for non local term and osm mixed layer depth
! ------------------------------------------------------------------
@@ -3447,8 +3457,8 @@ CONTAINS
!
IF ( ln_dia_osm .AND. iom_use( cdname ) ) THEN
IF ( SIZE( posmdia2d, 1 ) == ntei-ntsi+1 .AND. SIZE( posmdia2d, 2 ) == ntej-ntsj+1 ) THEN ! Halo absent
- osmdia2d(A2D(0)) = posmdia2d(:,:)
- CALL iom_put( cdname, osmdia2d(A2D(nn_hls)) )
+ osmdia2d(T2D(0)) = posmdia2d(:,:)
+ CALL iom_put( cdname, osmdia2d(T2D(nn_hls)) )
ELSE ! Halo present
CALL iom_put( cdname, posmdia2d )
END IF
@@ -3470,8 +3480,8 @@ CONTAINS
!
IF ( ln_dia_osm .AND. iom_use( cdname ) ) THEN
IF ( SIZE( posmdia3d, 1 ) == ntei-ntsi+1 .AND. SIZE( posmdia3d, 2 ) == ntej-ntsj+1 ) THEN ! Halo absent
- osmdia3d(A2D(0),:) = posmdia3d(:,:,:)
- CALL iom_put( cdname, osmdia3d(A2D(nn_hls),:) )
+ osmdia3d(T2D(0),:) = posmdia3d(:,:,:)
+ CALL iom_put( cdname, osmdia3d(T2D(nn_hls),:) )
ELSE ! Halo present
CALL iom_put( cdname, posmdia3d )
END IF
diff --git a/src/OCE/ZDF/zdfphy.F90 b/src/OCE/ZDF/zdfphy.F90
index 5fbf2322015ec8b3097169ea4ac576cab62a9986..aa83add78a0fb35fdbab61e28e1992386fd86fcb 100644
--- a/src/OCE/ZDF/zdfphy.F90
+++ b/src/OCE/ZDF/zdfphy.F90
@@ -11,8 +11,6 @@ MODULE zdfphy
!! zdf_phy : upadate at each time-step the vertical mixing coeff.
!!----------------------------------------------------------------------
USE oce ! ocean dynamics and tracers variables
- ! TEMP: [tiling] This change not necessary after finalisation of zdf_osm (not yet tiled)
- USE domtile
USE zdf_oce ! vertical physics: shared variables
USE zdfdrg ! vertical physics: top/bottom drag coef.
USE zdfsh2 ! vertical physics: shear production term of TKE
@@ -31,6 +29,7 @@ MODULE zdfphy
USE sbc_oce ! surface module (only for nn_isf in the option compatibility test)
USE sbcrnf ! surface boundary condition: runoff variables
USE sbc_ice ! sea ice drag
+ USE domtile
#if defined key_agrif
USE agrif_oce_interp ! interpavm
#endif
@@ -57,7 +56,7 @@ MODULE zdfphy
LOGICAL, PUBLIC :: l_zdfsh2 ! shear production term flag (=F for CST, =T otherwise (i.e. TKE, GLS, RIC))
- REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:,:) :: avm_k_n !: "Now" avm_k used for calculation of zsh2 with tiling
+ REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: sh2 !: Shear term
!! * Substitutions
# include "do_loop_substitute.h90"
@@ -145,8 +144,10 @@ CONTAINS
Cu_adv(:,:,:) = 0._wp
wi (:,:,:) = 0._wp
ENDIF
- ! ! Initialise zdf_mxl arrays (only hmld as not set everywhere when nn_hls > 1)
+ ! ! Initialise zdf_mxl arrays
IF( zdf_mxl_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'zdf_mxl : unable to allocate arrays' )
+ ! Initialize halo for diagnostics (only updated on internal points)
+ hmlp(:,:) = 0._wp
hmld(:,:) = 0._wp
! !== Background eddy viscosity and diffusivity ==!
IF( nn_avb == 0 ) THEN ! Define avmb, avtb from namelist parameter
@@ -155,7 +156,7 @@ CONTAINS
ELSE ! Background profile of avt (fit a theoretical/observational profile (Krauss 1990)
avmb(:) = rn_avm0
avtb(:) = rn_avt0 + ( 3.e-4_wp - 2._wp * rn_avt0 ) * 1.e-4_wp * gdepw_1d(:) ! m2/s
- IF(ln_sco .AND. lwp) CALL ctl_warn( 'avtb profile not valid in sco' )
+ IF(l_sco .AND. lwp) CALL ctl_warn( 'avtb profile not valid in sco' )
ENDIF
! ! 2D shape of the avtb
avtb_2d(:,:) = 1._wp ! uniform
@@ -164,14 +165,14 @@ CONTAINS
! ! -15S -5S : linear decrease from avt0 to avt0/10.
! ! -5S +5N : cst value avt0/10.
! ! 5N 15N : linear increase from avt0/10, to avt0
- WHERE(-15. <= gphit .AND. gphit < -5 ) avtb_2d = (1. - 0.09 * (gphit + 15.))
- WHERE( -5. <= gphit .AND. gphit < 5 ) avtb_2d = 0.1
- WHERE( 5. <= gphit .AND. gphit < 15 ) avtb_2d = (0.1 + 0.09 * (gphit - 5.))
+ WHERE(-15. <= gphit(A2D(0)) .AND. gphit(A2D(0)) < -5 ) avtb_2d(:,:) = (1. - 0.09 * (gphit(A2D(0)) + 15.))
+ WHERE( -5. <= gphit(A2D(0)) .AND. gphit(A2D(0)) < 5 ) avtb_2d(:,:) = 0.1
+ WHERE( 5. <= gphit(A2D(0)) .AND. gphit(A2D(0)) < 15 ) avtb_2d(:,:) = (0.1 + 0.09 * (gphit(A2D(0)) - 5.))
ENDIF
!
DO jk = 1, jpk ! set turbulent closure Kz to the background value (avt_k, avm_k)
- avt_k(:,:,jk) = avtb_2d(:,:) * avtb(jk) * wmask (:,:,jk)
- avm_k(:,:,jk) = avmb(jk) * wmask (:,:,jk)
+ avt_k(:,:,jk) = avtb_2d(:,:) * avtb(jk) * wmask(A2D(0),jk)
+ avm_k(A2D(1),jk) = avmb(jk) * wmask(A2D(1),jk)
END DO
!!gm to be tested only the 1st & last levels
! avt (:,:, 1 ) = 0._wp ; avs(:,:, 1 ) = 0._wp ; avm (:,:, 1 ) = 0._wp
@@ -221,7 +222,6 @@ CONTAINS
IF( ln_zdfcst .OR. ln_zdfosm ) THEN ; l_zdfsh2 = .FALSE.
ELSE ; l_zdfsh2 = .TRUE.
ENDIF
- IF( ln_tile .AND. l_zdfsh2 ) ALLOCATE( avm_k_n(jpi,jpj,jpk) )
! !== Mass Flux Convectiive algorithm ==!
IF( ln_zdfmfc ) CALL zdf_mfc_init ! Convection computed with eddy diffusivity mass flux
!
@@ -255,11 +255,20 @@ CONTAINS
INTEGER, INTENT(in) :: Kbb, Kmm, Krhs ! ocean time level indices
!
INTEGER :: ji, jj, jk ! dummy loop indice
- REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zsh2 ! shear production
!! ---------------------------------------------------------------------
!
IF( ln_timing ) CALL timing_start('zdf_phy')
!
+ IF( l_zdfsh2 ) THEN !* shear production at w-points (energy conserving form)
+ IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only for the full domain
+ IF( ln_tile ) CALL dom_tile_stop( ldhold=.TRUE. ) ! Use full domain
+ ALLOCATE( sh2(A2D(0),jpk) )
+ CALL zdf_sh2( Kbb, Kmm, avm_k, & ! <<== in
+ & sh2 ) ! ==>> out : shear production
+ IF( ln_tile ) CALL dom_tile_start( ldhold=.TRUE. ) ! Revert to tile domain
+ ENDIF
+ ENDIF
+ !
IF( l_zdfdrg ) THEN !== update top/bottom drag ==! (non-linear cases)
!
! !* bottom drag
@@ -276,11 +285,12 @@ CONTAINS
#if defined key_si3
IF ( ln_drgice_imp) THEN
IF ( ln_isfcav ) THEN
- DO_2D_OVR( 1, 1, 1, 1 )
+ DO_2D( 0, 0, 0, 0 )
rCdU_top(ji,jj) = rCdU_top(ji,jj) + ssmask(ji,jj) * tmask(ji,jj,1) * rCdU_ice(ji,jj)
END_2D
ELSE
- DO_2D_OVR( 1, 1, 1, 1 )
+ ! Needed on 1st halo points by dyn_zdf (if ln_drgice_imp or ln_isfcav)
+ DO_2D( 1, 1, 1, 1 )
rCdU_top(ji,jj) = rCdU_ice(ji,jj)
END_2D
ENDIF
@@ -291,23 +301,14 @@ CONTAINS
!
! !== Kz from chosen turbulent closure ==! (avm_k, avt_k)
!
- ! NOTE: [tiling] the closure schemes (zdf_tke etc) will update avm_k. With tiling, the calculation of zsh2 on adjacent tiles then uses both updated (next timestep) and non-updated (current timestep) values of avm_k. To preserve results, we save a read-only copy of the "now" avm_k to use in the calculation of zsh2.
- IF( l_zdfsh2 ) THEN !* shear production at w-points (energy conserving form)
- IF( ln_tile ) THEN
- IF( ntile == 1 ) avm_k_n(:,:,:) = avm_k(:,:,:) ! Preserve "now" avm_k for calculation of zsh2
- CALL zdf_sh2( Kbb, Kmm, avm_k_n, & ! <<== in
- & zsh2 ) ! ==>> out : shear production
- ELSE
- CALL zdf_sh2( Kbb, Kmm, avm_k, & ! <<== in
- & zsh2 ) ! ==>> out : shear production
- ENDIF
- ENDIF
- !
SELECT CASE ( nzdf_phy ) !* Vertical eddy viscosity and diffusivity coefficients at w-points
- CASE( np_RIC ) ; CALL zdf_ric( kt, Kmm, zsh2, avm_k, avt_k ) ! Richardson number dependent Kz
- CASE( np_TKE ) ; CALL zdf_tke( kt, Kbb, Kmm, zsh2, avm_k, avt_k ) ! TKE closure scheme for Kz
- CASE( np_GLS ) ; CALL zdf_gls( kt, Kbb, Kmm, zsh2, avm_k, avt_k ) ! GLS closure scheme for Kz
+ CASE( np_RIC ) ; CALL zdf_ric( kt, Kmm, sh2, avm_k, avt_k ) ! Richardson number dependent Kz
+ CASE( np_TKE ) ; CALL zdf_tke( kt, Kbb, Kmm, sh2, avm_k, avt_k ) ! TKE closure scheme for Kz
+ CASE( np_GLS ) ; CALL zdf_gls( kt, Kbb, Kmm, sh2, avm_k, avt_k ) ! GLS closure scheme for Kz
CASE( np_OSM ) ; CALL zdf_osm( kt, Kbb, Kmm, Krhs, avm_k, avt_k ) ! OSMOSIS closure scheme for Kz
+ ! ! clem: osmosis currently cannot work because
+ ! it uses qns and qsr that are only defined in the interior (A2D(0))
+ ! we should do calculations in the interior and put a lbc_lnk at the end
! CASE( np_CST ) ! Constant Kz (reset avt, avm to the background value)
! ! avt_k and avm_k set one for all at initialisation phase
!!gm avt(2:jpim1,2:jpjm1,1:jpkm1) = rn_avt0 * wmask(2:jpim1,2:jpjm1,1:jpkm1)
@@ -323,13 +324,13 @@ CONTAINS
#endif
!
! !* start from turbulent closure values
- DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 2, jpkm1 )
avt(ji,jj,jk) = avt_k(ji,jj,jk)
avm(ji,jj,jk) = avm_k(ji,jj,jk)
END_3D
!
IF( ln_rnf_mouth ) THEN !* increase diffusivity at rivers mouths
- DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, nkrnf )
+ DO_3D( 0, 0, 0, 0, 2, nkrnf )
avt(ji,jj,jk) = avt(ji,jj,jk) + 2._wp * rn_avt_rnf * rnfmsk(ji,jj) * wmask(ji,jj,jk)
END_3D
ENDIF
@@ -340,7 +341,7 @@ CONTAINS
IF( ln_zdfddm ) THEN ! update avt and compute avs
CALL zdf_ddm( kt, Kmm, avm, avt, avs )
ELSE ! same mixing on all tracers
- DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
avs(ji,jj,jk) = avt(ji,jj,jk)
END_3D
ENDIF
@@ -350,14 +351,14 @@ CONTAINS
IF( ln_zdfiwm ) CALL zdf_iwm( kt, Kmm, avm, avt, avs ) ! internal wave (de Lavergne et al 2017)
! !* Lateral boundary conditions (sign unchanged)
- IF(nn_hls==1) THEN ! if nn_hls==2 lbc_lnk done in stp routines
- IF( l_zdfsh2 ) THEN
- CALL lbc_lnk( 'zdfphy', avm_k, 'W', 1.0_wp , avt_k, 'W', 1.0_wp, &
- & avm , 'W', 1.0_wp , avt , 'W', 1.0_wp , avs , 'W', 1.0_wp )
- ELSE
- CALL lbc_lnk( 'zdfphy', avm , 'W', 1.0_wp , avt , 'W', 1.0_wp , avs , 'W', 1.0_wp )
- ENDIF
- !
+ ! Subroutines requiring halo points: zdf_sh2 (avm_k), dia_wri (rCdU_bot), dyn_zdf (avm, rCdU_bot, rCdU_top)
+ IF( .NOT. l_istiled .OR. ntile == nijtile ) THEN
+ CALL lbc_lnk( 'zdfphy', avm, 'W', 1.0_wp ) ! lbc_lnk for avm_k is in stp
+
+ ! TEMP: [zdfosm_avt_diag] Needed only to preserve diagnostics along the eastern half of the north fold (T-pivot)
+ IF( nn_hls == 1 .AND. ln_zdfosm .AND. ln_osm_mle ) &
+ & CALL lbc_lnk( 'zdfphy', avt, 'W', 1.0_wp, avs, 'W', 1.0_wp )
+
IF( l_zdfdrg ) THEN ! drag have been updated (non-linear cases)
IF( ln_isfcav ) THEN ; CALL lbc_lnk( 'zdfphy', rCdU_top, 'T', 1.0_wp , rCdU_bot, 'T', 1.0_wp ) ! top & bot drag
ELSE ; CALL lbc_lnk( 'zdfphy', rCdU_bot, 'T', 1.0_wp ) ! bottom drag only
@@ -377,12 +378,18 @@ CONTAINS
ENDIF
!
! diagnostics of energy dissipation
- IF( iom_use('avt_k') .OR. iom_use('avm_k') .OR. iom_use('eshear_k') .OR. iom_use('estrat_k') ) THEN
- IF( l_zdfsh2 ) THEN
- CALL iom_put( 'avt_k' , avt_k * wmask )
- CALL iom_put( 'avm_k' , avm_k * wmask )
- CALL iom_put( 'eshear_k', zsh2 * wmask )
- CALL iom_put( 'estrat_k', - avt_k * rn2 * wmask )
+ IF( l_zdfsh2 ) THEN
+ IF( iom_use('eshear_k') ) THEN
+ DO_3D( 0, 0, 0, 0, 2, jpkm1 )
+ sh2(ji,jj,jk) = sh2(ji,jj,jk) * wmask(ji,jj,jk)
+ END_3D
+ ENDIF
+ IF( .NOT. l_istiled .OR. ntile == nijtile ) THEN ! Do only on the last tile
+ IF( iom_use('avt_k' ) ) CALL iom_put( 'avt_k' , avt_k * wmask(A2D(0),:) )
+ IF( iom_use('avm_k' ) ) CALL iom_put( 'avm_k' , avm_k * wmask(:,: ,:) )
+ IF( iom_use('estrat_k') ) CALL iom_put( 'estrat_k', - avt_k * rn2(A2D(0),:) * wmask(A2D(0),:) )
+ IF( iom_use('eshear_k') ) CALL iom_put( 'eshear_k', sh2 )
+ DEALLOCATE( sh2 )
ENDIF
ENDIF
!
diff --git a/src/OCE/ZDF/zdfric.F90 b/src/OCE/ZDF/zdfric.F90
index 655cf49cd9aa011a59cae2dba1d7a0e922caac5e..3f1ab93d467bc0c089148e934aa9af9bc245eff1 100644
--- a/src/OCE/ZDF/zdfric.F90
+++ b/src/OCE/ZDF/zdfric.F90
@@ -145,18 +145,19 @@ CONTAINS
!! References : Pacanowski & Philander 1981, JPO, 1441-1451.
!! PFJ Lermusiaux 2001.
!!----------------------------------------------------------------------
- INTEGER , INTENT(in ) :: kt ! ocean time-step
- INTEGER , INTENT(in ) :: Kmm ! ocean time level index
- REAL(wp), DIMENSION(A2D(nn_hls),jpk), INTENT(in ) :: p_sh2 ! shear production term
- REAL(wp), DIMENSION(:,:,:) , INTENT(inout) :: p_avm, p_avt ! momentum and tracer Kz (w-points)
+ INTEGER , INTENT(in ) :: kt ! ocean time-step
+ INTEGER , INTENT(in ) :: Kmm ! ocean time level index
+ REAL(wp), DIMENSION(A2D(0) ,jpk), INTENT(in ) :: p_sh2 ! shear production term
+ REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: p_avm ! vertical eddy viscosity (w-points)
+ REAL(wp), DIMENSION(A2D(0) ,jpk), INTENT(inout) :: p_avt ! vertical eddy diffusivity (w-points)
!!
INTEGER :: ji, jj, jk ! dummy loop indices
REAL(wp) :: zcfRi, zav, zustar, zhek ! local scalars
- REAL(wp), DIMENSION(A2D(nn_hls)) :: zh_ekm ! 2D workspace
+ REAL(wp), DIMENSION(T2D(0)) :: zh_ekm ! 2D workspace
!!----------------------------------------------------------------------
!
! !== avm and avt = F(Richardson number) ==!
- DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) ! coefficient = F(richardson number) (avm-weighted Ri)
+ DO_3D( 0, 0, 0, 0, 2, jpkm1 ) ! coefficient = F(richardson number) (avm-weighted Ri)
zcfRi = 1._wp / ( 1._wp + rn_alp * MAX( 0._wp , avm(ji,jj,jk) * rn2(ji,jj,jk) / ( p_sh2(ji,jj,jk) + 1.e-20 ) ) )
zav = rn_avmri * zcfRi**nn_ric
! ! avm and avt coefficients
@@ -169,12 +170,12 @@ CONTAINS
!
IF( ln_mldw ) THEN !== set a minimum value in the Ekman layer ==!
!
- DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 )
+ DO_2D( 0, 0, 0, 0 )
zustar = SQRT( taum(ji,jj) * r1_rho0 )
zhek = rn_ekmfc * zustar / ( ABS( ff_t(ji,jj) ) + rsmall ) ! Ekman depth
zh_ekm(ji,jj) = MAX( rn_mldmin , MIN( zhek , rn_mldmax ) ) ! set allowed range
END_2D
- DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) !* minimum mixing coeff. within the Ekman layer
+ DO_3D( 0, 0, 0, 0, 2, jpkm1 ) !* minimum mixing coeff. within the Ekman layer
IF( gdept(ji,jj,jk,Kmm) < zh_ekm(ji,jj) ) THEN
p_avm(ji,jj,jk) = MAX( p_avm(ji,jj,jk), rn_wvmix ) * wmask(ji,jj,jk)
p_avt(ji,jj,jk) = MAX( p_avt(ji,jj,jk), rn_wtmix ) * wmask(ji,jj,jk)
diff --git a/src/OCE/ZDF/zdfsh2.F90 b/src/OCE/ZDF/zdfsh2.F90
index 1654a2e108794755cdf998476e0c3b505e01e364..786c6596d716ecd28e168ee89f91ae4f8e2c9bd9 100644
--- a/src/OCE/ZDF/zdfsh2.F90
+++ b/src/OCE/ZDF/zdfsh2.F90
@@ -54,17 +54,17 @@ CONTAINS
!! *****
!! References : Bruchard, OM 2002
!! ---------------------------------------------------------------------
- INTEGER , INTENT(in ) :: Kbb, Kmm ! ocean time level indices
- REAL(wp), DIMENSION(:,:,:) , INTENT(in ) :: p_avm ! vertical eddy viscosity (w-points)
- REAL(wp), DIMENSION(A2D(nn_hls),jpk) , INTENT( out) :: p_sh2 ! shear production of TKE (w-points)
+ INTEGER , INTENT(in ) :: Kbb, Kmm ! ocean time level indices
+ REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT(in ) :: p_avm ! vertical eddy viscosity (w-points)
+ REAL(wp), DIMENSION(A2D(0) ,jpk) , INTENT( out) :: p_sh2 ! shear production of TKE (w-points)
!
INTEGER :: ji, jj, jk ! dummy loop arguments
- REAL(wp), DIMENSION(A2D(nn_hls)) :: zsh2u, zsh2v ! 2D workspace
+ REAL(wp), DIMENSION(A2D(1)) :: zsh2u, zsh2v ! 2D workspace
!!--------------------------------------------------------------------
!
DO jk = 2, jpkm1 !* Shear production at uw- and vw-points (energy conserving form)
IF ( cpl_sdrftx .AND. ln_stshear ) THEN ! Surface Stokes Drift available ===>>> shear + stokes drift contibution
- DO_2D( nn_hls, nn_hls-1, nn_hls, nn_hls-1 )
+ DO_2D( 1, 0, 1, 0 )
zsh2u(ji,jj) = ( p_avm(ji+1,jj,jk) + p_avm(ji,jj,jk) ) &
& * ( uu (ji,jj,jk-1,Kmm) - uu (ji,jj,jk,Kmm) &
& + usd(ji,jj,jk-1) - usd(ji,jj,jk) ) &
@@ -77,7 +77,7 @@ CONTAINS
&/ ( e3vw(ji,jj,jk,Kmm) * e3vw(ji,jj,jk,Kbb) ) * wvmask(ji,jj,jk)
END_2D
ELSE
- DO_2D( nn_hls, nn_hls-1, nn_hls, nn_hls-1 ) !* 2 x shear production at uw- and vw-points (energy conserving form)
+ DO_2D( 1, 0, 1, 0 ) !* 2 x shear production at uw- and vw-points (energy conserving form)
zsh2u(ji,jj) = ( p_avm(ji+1,jj,jk) + p_avm(ji,jj,jk) ) &
& * ( uu(ji,jj,jk-1,Kmm) - uu(ji,jj,jk,Kmm) ) &
& * ( uu(ji,jj,jk-1,Kbb) - uu(ji,jj,jk,Kbb) ) &
@@ -90,12 +90,12 @@ CONTAINS
& * wvmask(ji,jj,jk)
END_2D
ENDIF
- DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) !* shear production at w-point ! coast mask: =2 at the coast ; =1 otherwise (NB: wmask useless as zsh2 are masked)
+ DO_2D( 0, 0, 0, 0 ) !* shear production at w-point ! coast mask: =2 at the coast ; =1 otherwise (NB: wmask useless as zsh2 are masked)
p_sh2(ji,jj,jk) = 0.25 * ( ( zsh2u(ji-1,jj) + zsh2u(ji,jj) ) * ( 2. - umask(ji-1,jj,jk) * umask(ji,jj,jk) ) &
& + ( zsh2v(ji,jj-1) + zsh2v(ji,jj) ) * ( 2. - vmask(ji,jj-1,jk) * vmask(ji,jj,jk) ) )
END_2D
END DO
- DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) ! set p_sh2 to 0 at the surface and bottom for output purpose
+ DO_2D( 0, 0, 0, 0 ) ! set p_sh2 to 0 at the surface and bottom for output purpose
p_sh2(ji,jj,1) = 0._wp
p_sh2(ji,jj,jpk) = 0._wp
END_2D
diff --git a/src/OCE/ZDF/zdfswm.F90 b/src/OCE/ZDF/zdfswm.F90
index 7c6f94d880a51483d01c0a01febba8e4f59b60cb..16b8d2726a6fa117962af108d18f7a2d4c60df80 100644
--- a/src/OCE/ZDF/zdfswm.F90
+++ b/src/OCE/ZDF/zdfswm.F90
@@ -53,17 +53,17 @@ CONTAINS
!!
!! reference : Qiao et al. GRL, 2004
!!---------------------------------------------------------------------
- INTEGER , INTENT(in ) :: kt ! ocean time step
- INTEGER , INTENT(in ) :: Kmm ! time level index
- REAL(wp), DIMENSION(:,:,:) , INTENT(inout) :: p_avm ! momentum Kz (w-points)
- REAL(wp), DIMENSION(:,:,:) , INTENT(inout) :: p_avt, p_avs ! tracer Kz (w-points)
+ INTEGER , INTENT(in ) :: kt ! ocean time step
+ INTEGER , INTENT(in ) :: Kmm ! time level index
+ REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: p_avm ! vertical eddy viscosity (w-points)
+ REAL(wp), DIMENSION(A2D(0) ,jpk), INTENT(inout) :: p_avt, p_avs ! vertical eddy diffusivity (w-points)
!
INTEGER :: ji, jj, jk ! dummy loop indices
REAL(wp):: zcoef, zqb ! local scalar
!!---------------------------------------------------------------------
!
zcoef = 1._wp * 0.353553_wp
- DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 2, jpkm1 )
zqb = zcoef * hsw(ji,jj) * tsd2d(ji,jj) * EXP( -3. * wnum(ji,jj) * gdepw(ji,jj,jk,Kmm) ) * wmask(ji,jj,jk)
!
p_avt(ji,jj,jk) = p_avt(ji,jj,jk) + zqb
diff --git a/src/OCE/ZDF/zdftke.F90 b/src/OCE/ZDF/zdftke.F90
index 68dd9f6ed89537ea357a57cb963ec863cfb94e1d..4435eb13ee1157b1542b58e7bf9444ed9080a3bc 100644
--- a/src/OCE/ZDF/zdftke.F90
+++ b/src/OCE/ZDF/zdftke.F90
@@ -42,7 +42,6 @@ MODULE zdftke
USE oce ! ocean: dynamics and active tracers variables
USE phycst ! physical constants
USE dom_oce ! domain: ocean
- USE domvvl ! domain: variable volume layer
USE sbc_oce ! surface boundary condition: ocean
USE zdfdrg ! vertical physics: top/bottom drag coef.
USE zdfmxl ! vertical physics: mixed layer
@@ -56,9 +55,7 @@ MODULE zdftke
USE in_out_manager ! I/O manager
USE iom ! I/O manager library
USE lib_mpp ! MPP library
- USE lbclnk ! ocean lateral boundary conditions (or mpp link)
USE prtctl ! Print control
- USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined)
USE sbcwave ! Surface boundary waves
IMPLICIT NONE
@@ -114,7 +111,7 @@ CONTAINS
!!----------------------------------------------------------------------
!! *** FUNCTION zdf_tke_alloc ***
!!----------------------------------------------------------------------
- ALLOCATE( htau(jpi,jpj) , dissl(jpi,jpj,jpk) , apdlr(jpi,jpj,jpk) , STAT= zdf_tke_alloc )
+ ALLOCATE( htau(A2D(0)) , dissl(A2D(0),jpk) , apdlr(A2D(0),jpk) , STAT= zdf_tke_alloc )
!
CALL mpp_sum ( 'zdftke', zdf_tke_alloc )
IF( zdf_tke_alloc /= 0 ) CALL ctl_stop( 'STOP', 'zdf_tke_alloc: failed to allocate arrays' )
@@ -167,10 +164,11 @@ CONTAINS
!! Axell, JGR, 2002
!! Bruchard OM 2002
!!----------------------------------------------------------------------
- INTEGER , INTENT(in ) :: kt ! ocean time step
- INTEGER , INTENT(in ) :: Kbb, Kmm ! ocean time level indices
- REAL(wp), DIMENSION(A2D(nn_hls),jpk), INTENT(in ) :: p_sh2 ! shear production term
- REAL(wp), DIMENSION(:,:,:) , INTENT(inout) :: p_avm, p_avt ! momentum and tracer Kz (w-points)
+ INTEGER , INTENT(in ) :: kt ! ocean time step
+ INTEGER , INTENT(in ) :: Kbb, Kmm ! ocean time level indices
+ REAL(wp), DIMENSION(A2D(0) ,jpk), INTENT(in ) :: p_sh2 ! shear production term
+ REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: p_avm ! vertical eddy viscosity (w-points)
+ REAL(wp), DIMENSION(A2D(0) ,jpk), INTENT(inout) :: p_avt ! vertical eddy diffusivity (w-points)
!!----------------------------------------------------------------------
!
CALL tke_tke( Kbb, Kmm, p_sh2, p_avm, p_avt ) ! now tke (en)
@@ -200,9 +198,10 @@ CONTAINS
!! ---------------------------------------------------------------------
USE zdf_oce , ONLY : en ! ocean vertical physics
!!
- INTEGER , INTENT(in ) :: Kbb, Kmm ! ocean time level indices
- REAL(wp), DIMENSION(A2D(nn_hls),jpk) , INTENT(in ) :: p_sh2 ! shear production term
- REAL(wp), DIMENSION(:,:,:) , INTENT(in ) :: p_avm, p_avt ! vertical eddy viscosity & diffusivity (w-points)
+ INTEGER , INTENT(in) :: Kbb, Kmm ! ocean time level indices
+ REAL(wp), DIMENSION(A2D(0) ,jpk), INTENT(in) :: p_sh2 ! shear production term
+ REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in) :: p_avm ! vertical eddy viscosity (w-points)
+ REAL(wp), DIMENSION(A2D(0) ,jpk), INTENT(in) :: p_avt ! vertical eddy diffusivity (w-points)
!
INTEGER :: ji, jj, jk ! dummy loop arguments
REAL(wp) :: zetop, zebot, zmsku, zmskv ! local scalars
@@ -210,14 +209,14 @@ CONTAINS
REAL(wp) :: zcdrag = 1.5e-3 ! drag coefficient
REAL(wp) :: zbbrau, zbbirau, zri ! local scalars
REAL(wp) :: zfact1, zfact2, zfact3 ! - -
- REAL(wp) :: ztx2 , zty2 , zcof ! - -
+ REAL(wp) :: zcof ! - -
REAL(wp) :: ztau , zdif ! - -
REAL(wp) :: zus , zwlc , zind ! - -
REAL(wp) :: zzd_up, zzd_lw ! - -
REAL(wp) :: ztaui, ztauj, z1_norm
- INTEGER , DIMENSION(A2D(nn_hls)) :: imlc
- REAL(wp), DIMENSION(A2D(nn_hls)) :: zice_fra, zhlc, zus3, zWlc2
- REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zpelc, zdiag, zd_up, zd_lw
+ INTEGER , DIMENSION(T2D(0)) :: imlc
+ REAL(wp), DIMENSION(T2D(0)) :: zice_fra, zhlc, zus3, zWlc2
+ REAL(wp), DIMENSION(T2D(0),jpk) :: zpelc, zdiag, zd_up, zd_lw
REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: ztmp ! for diags
!!--------------------------------------------------------------------
!
@@ -232,16 +231,16 @@ CONTAINS
! ice fraction considered for attenuation of langmuir & wave breaking
SELECT CASE ( nn_eice )
CASE( 0 ) ; zice_fra(:,:) = 0._wp
- CASE( 1 ) ; zice_fra(:,:) = TANH( fr_i(A2D(nn_hls)) * 10._wp )
- CASE( 2 ) ; zice_fra(:,:) = fr_i(A2D(nn_hls))
- CASE( 3 ) ; zice_fra(:,:) = MIN( 4._wp * fr_i(A2D(nn_hls)) , 1._wp )
+ CASE( 1 ) ; zice_fra(:,:) = TANH( fr_i(T2D(0)) * 10._wp )
+ CASE( 2 ) ; zice_fra(:,:) = fr_i(T2D(0))
+ CASE( 3 ) ; zice_fra(:,:) = MIN( 4._wp * fr_i(T2D(0)) , 1._wp )
END SELECT
!
! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
! ! Surface/top/bottom boundary condition on tke
! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
!
- DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 )
+ DO_2D( 0, 0, 0, 0 )
en(ji,jj,1) = MAX( rn_emin0, zbbrau * taum(ji,jj) )
zdiag(ji,jj,1) = 1._wp/en(ji,jj,1)
zd_lw(ji,jj,1) = 1._wp
@@ -258,7 +257,7 @@ CONTAINS
!
IF( .NOT.ln_drg_OFF ) THEN !== friction used as top/bottom boundary condition on TKE
!
- DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) ! bottom friction
+ DO_2D( 0, 0, 0, 0 ) ! bottom friction
zmsku = ( 2. - umask(ji-1,jj,mbkt(ji,jj)) * umask(ji,jj,mbkt(ji,jj)) )
zmskv = ( 2. - vmask(ji,jj-1,mbkt(ji,jj)) * vmask(ji,jj,mbkt(ji,jj)) )
! ! where 0.001875 = (rn_ebb0/rho0) * 0.5 = 3.75*0.5/1000. (CAUTION CdU<0)
@@ -267,7 +266,7 @@ CONTAINS
en(ji,jj,mbkt(ji,jj)+1) = MAX( zebot, rn_emin ) * ssmask(ji,jj)
END_2D
IF( ln_isfcav ) THEN
- DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) ! top friction
+ DO_2D( 0, 0, 0, 0 ) ! top friction
zmsku = ( 2. - umask(ji-1,jj,mikt(ji,jj)) * umask(ji,jj,mikt(ji,jj)) )
zmskv = ( 2. - vmask(ji,jj-1,mikt(ji,jj)) * vmask(ji,jj,mikt(ji,jj)) )
! ! where 0.001875 = (rn_ebb0/rho0) * 0.5 = 3.75*0.5/1000. (CAUTION CdU<0)
@@ -294,16 +293,16 @@ CONTAINS
! ! 1/2 (W_lc)^2 = MAX( u* u_s + v* v_s , 0 ) only the positive part
!!gm ! PS: currently we don't have neither the 2 stress components at t-point !nor the angle between u* and u_s
!!gm ! so we will overestimate the LC velocity.... !!gm I will do the work if !LC have an effect !
- DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 )
+ DO_2D( 0, 0, 0, 0 )
!!XC zWlc2(ji,jj) = 0.5_wp * SQRT( taum(ji,jj) * r1_rho0 * ( ut0sd(ji,jj)**2 +vt0sd(ji,jj)**2 ) )
zWlc2(ji,jj) = 0.5_wp * ( ut0sd(ji,jj)**2 +vt0sd(ji,jj)**2 )
END_2D
!
! Projection of Stokes drift in the wind stress direction
!
- DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 )
- ztaui = 0.5_wp * ( utau(ji,jj) + utau(ji-1,jj) )
- ztauj = 0.5_wp * ( vtau(ji,jj) + vtau(ji,jj-1) )
+ DO_2D( 0, 0, 0, 0 )
+ ztaui = utau(ji,jj)
+ ztauj = vtau(ji,jj)
z1_norm = 1._wp / MAX( SQRT(ztaui*ztaui+ztauj*ztauj), 1.e-12 ) * tmask(ji,jj,1)
zWlc2(ji,jj) = 0.5_wp * z1_norm * ( MAX( ut0sd(ji,jj)*ztaui + vt0sd(ji,jj)*ztauj, 0._wp ) )**2
END_2D
@@ -313,7 +312,7 @@ CONTAINS
! ! Wlc = 0.016 * [|tau|/(rho_air Cdrag) ]^1/2 and thus:
! ! 1/2 Wlc^2 = 0.5 * 0.016 * 0.016 |tau| /( rho_air Cdrag )
zcof = 0.5 * 0.016 * 0.016 / ( zrhoa * zcdrag ) ! to convert stress in 10m wind using a constant drag
- DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 )
+ DO_2D( 0, 0, 0, 0 )
zWlc2(ji,jj) = zcof * taum(ji,jj)
END_2D
!
@@ -321,30 +320,30 @@ CONTAINS
!
! !* Depth of the LC circulation (Axell 2002, Eq.47)
! !- LHS of Eq.47
- DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 )
+ DO_2D( 0, 0, 0, 0 )
zpelc(ji,jj,1) = MAX( rn2b(ji,jj,1), 0._wp ) * gdepw(ji,jj,1,Kmm) * e3w(ji,jj,1,Kmm)
END_2D
- DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpk )
+ DO_3D( 0, 0, 0, 0, 2, jpk )
zpelc(ji,jj,jk) = zpelc(ji,jj,jk-1) + &
& MAX( rn2b(ji,jj,jk), 0._wp ) * gdepw(ji,jj,jk,Kmm) * e3w(ji,jj,jk,Kmm)
END_3D
!
! !- compare LHS to RHS of Eq.47
- imlc(:,:) = mbkt(A2D(nn_hls)) + 1 ! Initialization to the number of w ocean point (=2 over land)
- DO_3DS( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, jpkm1, 2, -1 )
+ imlc(:,:) = mbkt(T2D(0)) + 1 ! Initialization to the number of w ocean point (=2 over land)
+ DO_3DS( 0, 0, 0, 0, jpkm1, 2, -1 )
IF( zpelc(ji,jj,jk) > zWlc2(ji,jj) ) imlc(ji,jj) = jk
END_3D
! ! finite LC depth
- DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 )
+ DO_2D( 0, 0, 0, 0 )
zhlc(ji,jj) = gdepw(ji,jj,imlc(ji,jj),Kmm)
END_2D
!
zcof = 0.016 / SQRT( zrhoa * zcdrag )
- DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 )
+ DO_2D( 0, 0, 0, 0 )
zus = SQRT( 2. * zWlc2(ji,jj) ) ! Stokes drift
zus3(ji,jj) = MAX( 0._wp, 1._wp - zice_fra(ji,jj) ) * zus * zus * zus * tmask(ji,jj,1) ! zus > 0. ok
END_2D
- DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) !* TKE Langmuir circulation source term added to en
+ DO_3D( 0, 0, 0, 0, 2, jpkm1 ) !* TKE Langmuir circulation source term added to en
IF ( zus3(ji,jj) /= 0._wp ) THEN
IF ( gdepw(ji,jj,jk,Kmm) - zhlc(ji,jj) < 0 .AND. wmask(ji,jj,jk) /= 0. ) THEN
! ! vertical velocity due to LC
@@ -365,7 +364,7 @@ CONTAINS
! ! zdiag : diagonal zd_up : upper diagonal zd_lw : lower diagonal
!
IF( nn_pdl == 1 ) THEN !* Prandtl number = F( Ri )
- DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 2, jpkm1 )
! ! local Richardson number
IF (rn2b(ji,jj,jk) <= 0.0_wp) then
zri = 0.0_wp
@@ -377,7 +376,7 @@ CONTAINS
END_3D
ENDIF
!
- DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) !* Matrix and right hand side in en
+ DO_3D( 0, 0, 0, 0, 2, jpkm1 ) !* Matrix and right hand side in en
zcof = zfact1 * tmask(ji,jj,jk)
! ! A minimum of 2.e-5 m2/s is imposed on TKE vertical
! ! eddy coefficient (ensure numerical stability)
@@ -406,14 +405,14 @@ CONTAINS
SELECT CASE (nn_bc_surf) ! Boundary Condition using surface TKE flux from waves
CASE ( 0 ) ! Dirichlet BC
- DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) ! en(1) = rn_ebb taum / rho0 (min value rn_emin0)
+ DO_2D( 0, 0, 0, 0 ) ! en(1) = rn_ebb taum / rho0 (min value rn_emin0)
IF ( phioc(ji,jj) < 0 ) phioc(ji,jj) = 0._wp
en(ji,jj,1) = MAX( rn_emin0, .5 * ( 15.8 * phioc(ji,jj) / rho0 )**(2./3.) ) * tmask(ji,jj,1)
zdiag(ji,jj,1) = 1._wp/en(ji,jj,1) ! choose to keep coherence with former estimation of
END_2D
CASE ( 1 ) ! Neumann BC
- DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 )
+ DO_2D( 0, 0, 0, 0 )
IF ( phioc(ji,jj) < 0 ) phioc(ji,jj) = 0._wp
en(ji,jj,2) = en(ji,jj,2) + ( rn_Dt * phioc(ji,jj) / rho0 ) /e3w(ji,jj,2,Kmm)
en(ji,jj,1) = en(ji,jj,2) + (2 * e3t(ji,jj,1,Kmm) * phioc(ji,jj)/rho0) / ( p_avm(ji,jj,1) + p_avm(ji,jj,2) )
@@ -427,23 +426,23 @@ CONTAINS
ENDIF
!
! !* Matrix inversion from level 2 (tke prescribed at level 1)
- DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) ! First recurrence : Dk = Dk - Lk * Uk-1 / Dk-1
+ DO_3D( 0, 0, 0, 0, 2, jpkm1 ) ! First recurrence : Dk = Dk - Lk * Uk-1 / Dk-1
zdiag(ji,jj,jk) = zdiag(ji,jj,jk) - zd_lw(ji,jj,jk) * zd_up(ji,jj,jk-1) / zdiag(ji,jj,jk-1)
END_3D
!XC : commented to allow for neumann boundary condition
! DO_2D( 0, 0, 0, 0 )
! zd_lw(ji,jj,2) = en(ji,jj,2) - zd_lw(ji,jj,2) * en(ji,jj,1) ! Surface boudary conditions on tke
! END_2D
- DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 2, jpkm1 )
zd_lw(ji,jj,jk) = en(ji,jj,jk) - zd_lw(ji,jj,jk) / zdiag(ji,jj,jk-1) *zd_lw(ji,jj,jk-1)
END_3D
- DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) ! thrid recurrence : Ek = ( Lk - Uk * Ek+1 ) / Dk
+ DO_2D( 0, 0, 0, 0 ) ! thrid recurrence : Ek = ( Lk - Uk * Ek+1 ) / Dk
en(ji,jj,jpkm1) = zd_lw(ji,jj,jpkm1) / zdiag(ji,jj,jpkm1)
END_2D
- DO_3DS_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, jpk-2, 2, -1 )
+ DO_3DS( 0, 0, 0, 0, jpk-2, 2, -1 )
en(ji,jj,jk) = ( zd_lw(ji,jj,jk) - zd_up(ji,jj,jk) * en(ji,jj,jk+1) ) / zdiag(ji,jj,jk)
END_3D
- DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) ! set the minimum value of tke
+ DO_3D( 0, 0, 0, 0, 2, jpkm1 ) ! set the minimum value of tke
en(ji,jj,jk) = MAX( en(ji,jj,jk), rn_emin ) * wmask(ji,jj,jk)
END_3D
!
@@ -451,11 +450,11 @@ CONTAINS
! ediss = Ce*sqrt(en)/L*en
! dissl = sqrt(en)/L
IF( iom_use('ediss_k') ) THEN
- ALLOCATE( ztmp(A2D(nn_hls),jpk) )
- DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpkm1 )
+ ALLOCATE( ztmp(T2D(0),jpk) )
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
ztmp(ji,jj,jk) = zfact3 * dissl(ji,jj,jk) * en(ji,jj,jk) * wmask(ji,jj,jk)
END_3D
- DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 )
+ DO_2D( 0, 0, 0, 0 )
ztmp(ji,jj,jpk) = 0._wp
END_2D
CALL iom_put( 'ediss_k', ztmp )
@@ -471,21 +470,19 @@ CONTAINS
! penetration is partly switched off below sea-ice if nn_eice/=0
!
IF( nn_etau == 1 ) THEN !* penetration below the mixed layer (rn_efr fraction)
- DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 2, jpkm1 )
en(ji,jj,jk) = en(ji,jj,jk) + rn_efr * en(ji,jj,1) * EXP( -gdepw(ji,jj,jk,Kmm) / htau(ji,jj) ) &
& * MAX( 0._wp, 1._wp - zice_fra(ji,jj) ) * wmask(ji,jj,jk) * tmask(ji,jj,1)
END_3D
ELSEIF( nn_etau == 2 ) THEN !* act only at the base of the mixed layer (jk=nmln) (rn_efr fraction)
- DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 )
+ DO_2D( 0, 0, 0, 0 )
jk = nmln(ji,jj)
en(ji,jj,jk) = en(ji,jj,jk) + rn_efr * en(ji,jj,1) * EXP( -gdepw(ji,jj,jk,Kmm) / htau(ji,jj) ) &
& * MAX( 0._wp, 1._wp - zice_fra(ji,jj) ) * wmask(ji,jj,jk) * tmask(ji,jj,1)
END_2D
ELSEIF( nn_etau == 3 ) THEN !* penetration belox the mixed layer (HF variability)
- DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 )
- ztx2 = utau(ji-1,jj ) + utau(ji,jj)
- zty2 = vtau(ji ,jj-1) + vtau(ji,jj)
- ztau = 0.5_wp * SQRT( ztx2 * ztx2 + zty2 * zty2 ) * tmask(ji,jj,1) ! module of the mean stress
+ DO_3D( 0, 0, 0, 0, 2, jpkm1 )
+ ztau = SQRT( utau(ji,jj)*utau(ji,jj) + vtau(ji,jj)*vtau(ji,jj) ) * tmask(ji,jj,1) ! module of the mean stress
zdif = taum(ji,jj) - ztau ! mean of modulus - modulus of the mean
zdif = rhftau_scl * MAX( 0._wp, zdif + rhftau_add ) ! apply some modifications...
en(ji,jj,jk) = en(ji,jj,jk) + zbbrau * zdif * EXP( -gdepw(ji,jj,jk,Kmm) / htau(ji,jj) ) &
@@ -532,14 +529,15 @@ CONTAINS
!!----------------------------------------------------------------------
USE zdf_oce , ONLY : en, avtb, avmb, avtb_2d ! ocean vertical physics
!!
- INTEGER , INTENT(in ) :: Kbb, Kmm ! ocean time level indices
- REAL(wp), DIMENSION(:,:,:), INTENT( out) :: p_avm, p_avt ! vertical eddy viscosity & diffusivity (w-points)
+ INTEGER , INTENT(in ) :: Kbb, Kmm ! ocean time level indices
+ REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(out) :: p_avm ! vertical eddy viscosity (w-points)
+ REAL(wp), DIMENSION(A2D(0) ,jpk), INTENT(out) :: p_avt ! vertical eddy diffusivity (w-points)
!
INTEGER :: ji, jj, jk ! dummy loop indices
REAL(wp) :: zrn2, zraug, zcoef, zav ! local scalars
REAL(wp) :: zdku, zdkv, zsqen ! - -
REAL(wp) :: zemxl, zemlm, zemlp, zmaxice ! - -
- REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zmxlm, zmxld ! 3D workspace
+ REAL(wp), DIMENSION(T2D(0),jpk) :: zmxlm, zmxld ! 3D workspace
!!--------------------------------------------------------------------
!
! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
@@ -563,25 +561,25 @@ CONTAINS
!
zraug = vkarmn * 2.e5_wp / ( rho0 * grav )
#if ! defined key_si3 && ! defined key_cice
- DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) ! No sea-ice
+ DO_2D( 0, 0, 0, 0 ) ! No sea-ice
zmxlm(ji,jj,1) = zraug * taum(ji,jj) * tmask(ji,jj,1)
END_2D
#else
SELECT CASE( nn_mxlice ) ! Type of scaling under sea-ice
!
CASE( 0 ) ! No scaling under sea-ice
- DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 )
+ DO_2D( 0, 0, 0, 0 )
zmxlm(ji,jj,1) = zraug * taum(ji,jj) * tmask(ji,jj,1)
END_2D
!
CASE( 1 ) ! scaling with constant sea-ice thickness
- DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 )
+ DO_2D( 0, 0, 0, 0 )
zmxlm(ji,jj,1) = ( ( 1._wp - fr_i(ji,jj) ) * zraug * taum(ji,jj) + &
& fr_i(ji,jj) * rn_mxlice ) * tmask(ji,jj,1)
END_2D
!
CASE( 2 ) ! scaling with mean sea-ice thickness
- DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 )
+ DO_2D( 0, 0, 0, 0 )
#if defined key_si3
zmxlm(ji,jj,1) = ( ( 1._wp - fr_i(ji,jj) ) * zraug * taum(ji,jj) + &
& fr_i(ji,jj) * hm_i(ji,jj) * 2._wp ) * tmask(ji,jj,1)
@@ -593,7 +591,7 @@ CONTAINS
END_2D
!
CASE( 3 ) ! scaling with max sea-ice thickness
- DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 )
+ DO_2D( 0, 0, 0, 0 )
zmaxice = MAXVAL( h_i(ji,jj,:) )
zmxlm(ji,jj,1) = ( ( 1._wp - fr_i(ji,jj) ) * zraug * taum(ji,jj) + &
& fr_i(ji,jj) * zmaxice ) * tmask(ji,jj,1)
@@ -602,7 +600,7 @@ CONTAINS
END SELECT
#endif
!
- DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 )
+ DO_2D( 0, 0, 0, 0 )
zmxlm(ji,jj,1) = MAX( rn_mxl0, zmxlm(ji,jj,1) )
END_2D
!
@@ -611,7 +609,7 @@ CONTAINS
ENDIF
ENDIF
!
- DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 2, jpkm1 )
zrn2 = MAX( rn2(ji,jj,jk), rsmall )
zmxlm(ji,jj,jk) = MAX( rmxl_min, SQRT( 2._wp * en(ji,jj,jk) / zrn2 ) )
END_3D
@@ -626,7 +624,7 @@ CONTAINS
!!gm Not sure of that coding for ISF....
! where wmask = 0 set zmxlm == e3w(:,:,:,Kmm)
CASE ( 0 ) ! bounded by the distance to surface and bottom
- DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 2, jpkm1 )
zemxl = MIN( gdepw(ji,jj,jk,Kmm) - gdepw(ji,jj,mikt(ji,jj),Kmm), zmxlm(ji,jj,jk), &
& gdepw(ji,jj,mbkt(ji,jj)+1,Kmm) - gdepw(ji,jj,jk,Kmm) )
! wmask prevent zmxlm = 0 if jk = mikt(ji,jj)
@@ -637,33 +635,33 @@ CONTAINS
END_3D
!
CASE ( 1 ) ! bounded by the vertical scale factor
- DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 2, jpkm1 )
zemxl = MIN( e3w(ji,jj,jk,Kmm), zmxlm(ji,jj,jk) )
zmxlm(ji,jj,jk) = zemxl
zmxld(ji,jj,jk) = zemxl
END_3D
!
CASE ( 2 ) ! |dk[xml]| bounded by e3t :
- DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) ! from the surface to the bottom :
+ DO_3D( 0, 0, 0, 0, 2, jpkm1 ) ! from the surface to the bottom :
zmxlm(ji,jj,jk) = &
& MIN( zmxlm(ji,jj,jk-1) + e3t(ji,jj,jk-1,Kmm), zmxlm(ji,jj,jk) )
END_3D
- DO_3DS( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, jpkm1, 2, -1 ) ! from the bottom to the surface :
+ DO_3DS( 0, 0, 0, 0, jpkm1, 2, -1 ) ! from the bottom to the surface :
zemxl = MIN( zmxlm(ji,jj,jk+1) + e3t(ji,jj,jk+1,Kmm), zmxlm(ji,jj,jk) )
zmxlm(ji,jj,jk) = zemxl
zmxld(ji,jj,jk) = zemxl
END_3D
!
CASE ( 3 ) ! lup and ldown, |dk[xml]| bounded by e3t :
- DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) ! from the surface to the bottom : lup
+ DO_3D( 0, 0, 0, 0, 2, jpkm1 ) ! from the surface to the bottom : lup
zmxld(ji,jj,jk) = &
& MIN( zmxld(ji,jj,jk-1) + e3t(ji,jj,jk-1,Kmm), zmxlm(ji,jj,jk) )
END_3D
- DO_3DS( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, jpkm1, 2, -1 ) ! from the bottom to the surface : ldown
+ DO_3DS( 0, 0, 0, 0, jpkm1, 2, -1 ) ! from the bottom to the surface : ldown
zmxlm(ji,jj,jk) = &
& MIN( zmxlm(ji,jj,jk+1) + e3t(ji,jj,jk+1,Kmm), zmxlm(ji,jj,jk) )
END_3D
- DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 2, jpkm1 )
zemlm = MIN ( zmxld(ji,jj,jk), zmxlm(ji,jj,jk) )
zemlp = SQRT( zmxld(ji,jj,jk) * zmxlm(ji,jj,jk) )
zmxlm(ji,jj,jk) = zemlm
@@ -675,7 +673,7 @@ CONTAINS
! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
! ! Vertical eddy viscosity and diffusivity (avm and avt)
! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
- DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpkm1 ) !* vertical eddy viscosity & diffivity at w-points
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 ) !* vertical eddy viscosity & diffivity at w-points
zsqen = SQRT( en(ji,jj,jk) )
zav = rn_ediff * zmxlm(ji,jj,jk) * zsqen
p_avm(ji,jj,jk) = MAX( zav, avmb(jk) ) * wmask(ji,jj,jk)
@@ -685,7 +683,7 @@ CONTAINS
!
!
IF( nn_pdl == 1 ) THEN !* Prandtl number case: update avt
- DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 2, jpkm1 )
p_avt(ji,jj,jk) = MAX( apdlr(ji,jj,jk) * p_avt(ji,jj,jk), avtb_2d(ji,jj) * avtb(jk) ) * wmask(ji,jj,jk)
END_3D
ENDIF
@@ -762,7 +760,8 @@ CONTAINS
CALL ctl_stop( 'zdf_tke_init: wrong value for nn_mxlice, should be 0,1,2,3 or 4')
END SELECT
IF ( (nn_mxlice>0).AND.(nn_ice==0) ) THEN
- CALL ctl_stop( 'zdf_tke_init: with no ice at all, nn_mxlice must be 0 ')
+ CALL ctl_warn( 'zdf_tke_init: with no ice at all, nn_mxlice is set to 0 ')
+ nn_mxlice = 0
ELSEIF ( (nn_mxlice>1).AND.(nn_ice==1) ) THEN
CALL ctl_stop( 'zdf_tke_init: with no ice model, nn_mxlice must be 0 or 1')
ENDIF
@@ -821,7 +820,7 @@ CONTAINS
CASE( 0 ) ! constant depth penetration (here 10 meters)
htau(:,:) = 10._wp
CASE( 1 ) ! F(latitude) : 0.5m to 30m poleward of 40 degrees
- htau(:,:) = MAX( 0.5_wp, MIN( 30._wp, 45._wp* ABS( SIN( rpi/180._wp * gphit(:,:) ) ) ) )
+ htau(:,:) = MAX( 0.5_wp, MIN( 30._wp, 45._wp* ABS( SIN( rpi/180._wp * gphit(A2D(0)) ) ) ) )
END SELECT
ENDIF
! !* read or initialize all required files
@@ -865,14 +864,14 @@ CONTAINS
ELSE ! start TKE from rest
IF(lwp) WRITE(numout,*)
IF(lwp) WRITE(numout,*) ' ==>>> previous run without TKE scheme, set en to background values'
- en (:,:,:) = rn_emin * wmask(:,:,:)
+ en (:,:,:) = rn_emin * wmask(A2D(0),:)
dissl(:,:,:) = 1.e-12_wp
! avt_k, avm_k already set to the background value in zdf_phy_init
ENDIF
ELSE !* Start from rest
IF(lwp) WRITE(numout,*)
IF(lwp) WRITE(numout,*) ' ==>>> start from rest: set en to the background value'
- en (:,:,:) = rn_emin * wmask(:,:,:)
+ en (:,:,:) = rn_emin * wmask(A2D(0),:)
dissl(:,:,:) = 1.e-12_wp
! avt_k, avm_k already set to the background value in zdf_phy_init
ENDIF
diff --git a/src/OCE/do_loop_substitute.h90 b/src/OCE/do_loop_substitute.h90
index f957d0741b54399e90fba13f4876ae152b2ea041..ad0ec3a2e6733c6c337565770f272590d5527773 100644
--- a/src/OCE/do_loop_substitute.h90
+++ b/src/OCE/do_loop_substitute.h90
@@ -56,25 +56,56 @@
! Nis0 = 1 + nn_hls Njs0 = 1 + nn_hls
! Nie0 = jpi - nn_hls Nje0 = jpj - nn_hls
!
+! Additionally, this file defines several macros for defining and accessing arrays.
+! These return index strides of the form i_lower:i_upper,j_lower:j_upper.
+! The macros mainly serve as substitutions for i-j shape declarations in DIMENSION and ALLOCATE
+! statements, but can also be used for inline stride indexing of arrays.
+! There are three types of macro:
+!
+! A1Di/A1Dj/A2D - used with arrays that are defined on the MPI domain
+! T1Di/T1Dj/T2D - used with arrays that are defined on the tile domain
+! AB2D - used with assumed shape array declarations
+!
+! The first two types have a similar specification to the DO loop macros, with arguments giving the
+! offset with respect to the internal part of the domain:
+!
+! A1Di(H) = Nis0-(H):Nie0+(H)
+! T1Di(H) = ntsi-(H):ntei+(H)
+!
+! The third type is used to specify an assumed shape declaration with defined lower bounds, and is used in wrapper
+! subroutines in conjunction with the lbnd_ij function to allow several possible dummy argument shapes:
+!
+! AB2D(B) = B(1):,B(2):
+!
#endif
-#define DO_2D(L, R, B, T) DO jj = ntsj-(B), ntej+(T) ; DO ji = ntsi-(L), ntei+(R)
-#define DO_2D_OVR(L, R, B, T) DO_2D(L-(L+R)*nthl, R-(R+L)*nthr, B-(B+T)*nthb, T-(T+B)*ntht)
-#define A1Di(H) ntsi-(H):ntei+(H)
-#define A1Dj(H) ntsj-(H):ntej+(H)
+#define A1Di(H) Nis0-(H):Nie0+(H)
+#define A1Dj(H) Njs0-(H):Nje0+(H)
#define A2D(H) A1Di(H),A1Dj(H)
-#define A1Di_T(T) (ntsi-nn_hls-1)*T+1:
-#define A1Dj_T(T) (ntsj-nn_hls-1)*T+1:
-#define A2D_T(T) A1Di_T(T),A1Dj_T(T)
+
+#define T1Di(H) ntsi-(H):ntei+(H)
+#define T1Dj(H) ntsj-(H):ntej+(H)
+#define T2D(H) T1Di(H),T1Dj(H)
+
+#define AB2D(B) B(1):,B(2):
#define JPK :
+#define JPT :
#define JPTS :
#define KJPT :
+#define DO_1Di(L, R) DO ji = ntsi-(L), ntei+(R)
+#define DO_1Dj(B, T) DO jj = ntsj-(B), ntej+(T)
+
+#define DO_2D(L, R, B, T) DO_1Dj(B, T) ; DO_1Di(L, R)
+#define DO_2Dik(L, R, ks, ke, ki) DO jk = ks, ke, ki ; DO_1Di(L, R)
+#define DO_2D_OVR(L, R, B, T) DO_2D(L-(L+R)*nthl, R-(R+L)*nthr, B-(B+T)*nthb, T-(T+B)*ntht)
+
#define DO_3D(L, R, B, T, ks, ke) DO jk = ks, ke ; DO_2D(L, R, B, T)
#define DO_3D_OVR(L, R, B, T, ks, ke) DO jk = ks, ke ; DO_2D_OVR(L, R, B, T)
#define DO_3DS(L, R, B, T, ks, ke, ki) DO jk = ks, ke, ki ; DO_2D(L, R, B, T)
#define DO_3DS_OVR(L, R, B, T, ks, ke, ki) DO jk = ks, ke, ki ; DO_2D_OVR(L, R, B, T)
+#define END_1D END DO
#define END_2D END DO ; END DO
-#define END_3D END DO ; END DO ; END DO
+#define END_3D END DO ; END DO ; END DO
\ No newline at end of file
diff --git a/src/OCE/lib_fortran.F90 b/src/OCE/lib_fortran.F90
index b621373e6eb7b7356db171bbc204f30793c73063..ded29e259a8577fe61084798a745f9299e5e0bd6 100644
--- a/src/OCE/lib_fortran.F90
+++ b/src/OCE/lib_fortran.F90
@@ -88,6 +88,22 @@ CONTAINS
# define DIM_3d
# include "lib_fortran_generic.h90"
# undef DIM_3d
+# define LOCALONLY
+# define DIM_2d
+# include "lib_fortran_generic.h90"
+# undef DIM_2d
+# define DIM_3d
+# include "lib_fortran_generic.h90"
+# undef DIM_3d
+# undef LOCALONLY
+# define VEC
+# define DIM_3d
+# include "lib_fortran_generic.h90"
+# undef DIM_3d
+# define DIM_4d
+# include "lib_fortran_generic.h90"
+# undef DIM_4d
+# undef VEC
# undef GLOBSUM_CODE
# define GLOBMINMAX_CODE
@@ -107,71 +123,26 @@ CONTAINS
# include "lib_fortran_generic.h90"
# undef OPERATION_GLOBMAX
# undef DIM_3
+# define VEC
+# define DIM_3d
+# define OPERATION_GLOBMIN
+# include "lib_fortran_generic.h90"
+# undef OPERATION_GLOBMIN
+# define OPERATION_GLOBMAX
+# include "lib_fortran_generic.h90"
+# undef OPERATION_GLOBMAX
+# undef DIM_3d
+# define DIM_4d
+# define OPERATION_GLOBMIN
+# include "lib_fortran_generic.h90"
+# undef OPERATION_GLOBMIN
+# define OPERATION_GLOBMAX
+# include "lib_fortran_generic.h90"
+# undef OPERATION_GLOBMAX
+# undef DIM_4d
+# undef VEC
# undef GLOBMINMAX_CODE
-! ! FUNCTION local_sum !
-
- FUNCTION local_sum_2d( ptab )
- !!----------------------------------------------------------------------
- REAL(wp), INTENT(in ) :: ptab(:,:) ! array on which operation is applied
- COMPLEX(dp) :: local_sum_2d
- !
- !!-----------------------------------------------------------------------
- !
- COMPLEX(dp):: ctmp
- REAL(wp) :: ztmp
- INTEGER :: ji, jj ! dummy loop indices
- INTEGER :: ipi, ipj ! dimensions
- !!-----------------------------------------------------------------------
- !
- ipi = SIZE(ptab,1) ! 1st dimension
- ipj = SIZE(ptab,2) ! 2nd dimension
- !
- ctmp = CMPLX( 0.e0, 0.e0, wp ) ! warning ctmp is cumulated
-
- DO jj = 1, ipj
- DO ji = 1, ipi
- ztmp = ptab(ji,jj) * tmask_i(ji,jj)
- CALL DDPDD( CMPLX( ztmp, 0.e0, dp ), ctmp )
- END DO
- END DO
- !
- local_sum_2d = ctmp
-
- END FUNCTION local_sum_2d
-
- FUNCTION local_sum_3d( ptab )
- !!----------------------------------------------------------------------
- REAL(wp), INTENT(in ) :: ptab(:,:,:) ! array on which operation is applied
- COMPLEX(dp) :: local_sum_3d
- !
- !!-----------------------------------------------------------------------
- !
- COMPLEX(dp):: ctmp
- REAL(wp) :: ztmp
- INTEGER :: ji, jj, jk ! dummy loop indices
- INTEGER :: ipi, ipj, ipk ! dimensions
- !!-----------------------------------------------------------------------
- !
- ipi = SIZE(ptab,1) ! 1st dimension
- ipj = SIZE(ptab,2) ! 2nd dimension
- ipk = SIZE(ptab,3) ! 3rd dimension
- !
- ctmp = CMPLX( 0.e0, 0.e0, wp ) ! warning ctmp is cumulated
-
- DO jk = 1, ipk
- DO jj = 1, ipj
- DO ji = 1, ipi
- ztmp = ptab(ji,jj,jk) * tmask_i(ji,jj)
- CALL DDPDD( CMPLX( ztmp, 0.e0, dp ), ctmp )
- END DO
- END DO
- END DO
- !
- local_sum_3d = ctmp
-
- END FUNCTION local_sum_3d
-
! ! FUNCTION sum3x3 !
SUBROUTINE sum3x3_2d( p2d )
@@ -191,11 +162,11 @@ CONTAINS
! work over the whole domain (guarantees all internal cells are set when nn_hls=2)
!
DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
- IF( MOD(mig(ji), 3) == MOD(nn_hls, 3) .AND. & ! 1st bottom left corner always at (Nis0-1, Njs0-1)
- & MOD(mjg(jj), 3) == MOD(nn_hls, 3) ) THEN ! bottom left corner of a 3x3 box
- ji2 = MIN(mig(ji)+2, jpiglo) - nimpp + 1 ! right position of the box
- jj2 = MIN(mjg(jj)+2, jpjglo) - njmpp + 1 ! upper position of the box
- IF( ji2 <= jpi .AND. jj2 <= jpj ) THEN ! the box is fully included in the local mpi domain
+ IF( MOD(mig(ji,nn_hls), 3) == MOD(nn_hls, 3) .AND. & ! 1st bottom left corner always at (Nis0-1, Njs0-1)
+ & MOD(mjg(jj,nn_hls), 3) == MOD(nn_hls, 3) ) THEN ! bottom left corner of a 3x3 box
+ ji2 = MIN(mig(ji,nn_hls)+2, jpiglo) - nimpp + 1 ! right position of the box
+ jj2 = MIN(mjg(jj,nn_hls)+2, jpjglo) - njmpp + 1 ! upper position of the box
+ IF( ji2 <= jpi .AND. jj2 <= jpj ) THEN ! the box is fully included in the local mpi domain
p2d(ji:ji2,jj:jj2) = SUM(p2d(ji:ji2,jj:jj2))
ENDIF
ENDIF
@@ -203,23 +174,23 @@ CONTAINS
CALL lbc_lnk( 'lib_fortran', p2d, 'T', 1.0_wp )
! no need for 2nd exchange when nn_hls > 1
IF( nn_hls == 1 ) THEN
- IF( mpiRnei(nn_hls,jpwe) > -1 ) THEN ! 1st column was changed during the previous call to lbc_lnk
- IF( MOD(mig( 1), 3) == 1 ) & ! 1st box start at i=1 -> column 1 to 3 correctly computed locally
- p2d( 1,:) = p2d( 2,:) ! previous lbc_lnk corrupted column 1 -> put it back using column 2
- IF( MOD(mig( 1), 3) == 2 ) & ! 1st box start at i=3 -> column 1 and 2 correctly computed on west neighbourh
- p2d( 2,:) = p2d( 1,:) ! previous lbc_lnk fix column 1 -> copy it to column 2
+ IF( mpiRnei(nn_hls,jpwe) > -1 ) THEN ! 1st column was changed during the previous call to lbc_lnk
+ IF( MOD(mig( 1,nn_hls), 3) == 1 ) & ! 1st box start at i=1 -> column 1 to 3 correctly computed locally
+ p2d( 1,:) = p2d( 2,:) ! previous lbc_lnk corrupted column 1 -> put it back using column 2
+ IF( MOD(mig( 1,nn_hls), 3) == 2 ) & ! 1st box start at i=3 -> column 1 and 2 correctly computed on w-neighbourh
+ p2d( 2,:) = p2d( 1,:) ! previous lbc_lnk fix column 1 -> copy it to column 2
ENDIF
IF( mpiRnei(nn_hls,jpea) > -1 ) THEN
- IF( MOD(mig(jpi-2), 3) == 1 ) p2d( jpi,:) = p2d(jpi-1,:)
- IF( MOD(mig(jpi-2), 3) == 0 ) p2d(jpi-1,:) = p2d( jpi,:)
+ IF( MOD(mig(jpi-2,nn_hls), 3) == 1 ) p2d( jpi,:) = p2d(jpi-1,:)
+ IF( MOD(mig(jpi-2,nn_hls), 3) == 0 ) p2d(jpi-1,:) = p2d( jpi,:)
ENDIF
IF( mpiRnei(nn_hls,jpso) > -1 ) THEN
- IF( MOD(mjg( 1), 3) == 1 ) p2d(:, 1) = p2d(:, 2)
- IF( MOD(mjg( 1), 3) == 2 ) p2d(:, 2) = p2d(:, 1)
+ IF( MOD(mjg( 1,nn_hls), 3) == 1 ) p2d(:, 1) = p2d(:, 2)
+ IF( MOD(mjg( 1,nn_hls), 3) == 2 ) p2d(:, 2) = p2d(:, 1)
ENDIF
IF( mpiRnei(nn_hls,jpno) > -1 ) THEN
- IF( MOD(mjg(jpj-2), 3) == 1 ) p2d(:, jpj) = p2d(:,jpj-1)
- IF( MOD(mjg(jpj-2), 3) == 0 ) p2d(:,jpj-1) = p2d(:, jpj)
+ IF( MOD(mjg(jpj-2,nn_hls), 3) == 1 ) p2d(:, jpj) = p2d(:,jpj-1)
+ IF( MOD(mjg(jpj-2,nn_hls), 3) == 0 ) p2d(:,jpj-1) = p2d(:, jpj)
ENDIF
CALL lbc_lnk( 'lib_fortran', p2d, 'T', 1.0_wp )
ENDIF
@@ -247,11 +218,11 @@ CONTAINS
! work over the whole domain (guarantees all internal cells are set when nn_hls=2)
!
DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
- IF( MOD(mig(ji), 3) == MOD(nn_hls, 3) .AND. & ! 1st bottom left corner always at (Nis0-1, Njs0-1)
- & MOD(mjg(jj), 3) == MOD(nn_hls, 3) ) THEN ! bottom left corner of a 3x3 box
- ji2 = MIN(mig(ji)+2, jpiglo) - nimpp + 1 ! right position of the box
- jj2 = MIN(mjg(jj)+2, jpjglo) - njmpp + 1 ! upper position of the box
- IF( ji2 <= jpi .AND. jj2 <= jpj ) THEN ! the box is fully included in the local mpi domain
+ IF( MOD(mig(ji,nn_hls), 3) == MOD(nn_hls, 3) .AND. & ! 1st bottom left corner always at (Nis0-1, Njs0-1)
+ & MOD(mjg(jj,nn_hls), 3) == MOD(nn_hls, 3) ) THEN ! bottom left corner of a 3x3 box
+ ji2 = MIN(mig(ji,nn_hls)+2, jpiglo) - nimpp + 1 ! right position of the box
+ jj2 = MIN(mjg(jj,nn_hls)+2, jpjglo) - njmpp + 1 ! upper position of the box
+ IF( ji2 <= jpi .AND. jj2 <= jpj ) THEN ! the box is fully included in the local mpi domain
p3d(ji:ji2,jj:jj2,jn) = SUM(p3d(ji:ji2,jj:jj2,jn))
ENDIF
ENDIF
@@ -260,204 +231,29 @@ CONTAINS
CALL lbc_lnk( 'lib_fortran', p3d, 'T', 1.0_wp )
! no need for 2nd exchange when nn_hls > 1
IF( nn_hls == 1 ) THEN
- IF( mpiRnei(nn_hls,jpwe) > -1 ) THEN ! 1st column was changed during the previous call to lbc_lnk
- IF( MOD(mig( 1), 3) == 1 ) & ! 1st box start at i=1 -> column 1 to 3 correctly computed locally
- p3d( 1,:,:) = p3d( 2,:,:) ! previous lbc_lnk corrupted column 1 -> put it back using column 2
- IF( MOD(mig( 1), 3) == 2 ) & ! 1st box start at i=3 -> column 1 and 2 correctly computed on west neighbourh
- p3d( 2,:,:) = p3d( 1,:,:) ! previous lbc_lnk fix column 1 -> copy it to column 2
+ IF( mpiRnei(nn_hls,jpwe) > -1 ) THEN ! 1st column was changed during the previous call to lbc_lnk
+ IF( MOD(mig( 1,nn_hls), 3) == 1 ) & ! 1st box start at i=1 -> column 1 to 3 correctly computed locally
+ p3d( 1,:,:) = p3d( 2,:,:) ! previous lbc_lnk corrupted column 1 -> put it back using column 2
+ IF( MOD(mig( 1,nn_hls), 3) == 2 ) & ! 1st box start at i=3 -> column 1 and 2 correctly computed on w-neighbourh
+ p3d( 2,:,:) = p3d( 1,:,:) ! previous lbc_lnk fix column 1 -> copy it to column 2
ENDIF
IF( mpiRnei(nn_hls,jpea) > -1 ) THEN
- IF( MOD(mig(jpi-2), 3) == 1 ) p3d( jpi,:,:) = p3d(jpi-1,:,:)
- IF( MOD(mig(jpi-2), 3) == 0 ) p3d(jpi-1,:,:) = p3d( jpi,:,:)
+ IF( MOD(mig(jpi-2,nn_hls), 3) == 1 ) p3d( jpi,:,:) = p3d(jpi-1,:,:)
+ IF( MOD(mig(jpi-2,nn_hls), 3) == 0 ) p3d(jpi-1,:,:) = p3d( jpi,:,:)
ENDIF
IF( mpiRnei(nn_hls,jpso) > -1 ) THEN
- IF( MOD(mjg( 1), 3) == 1 ) p3d(:, 1,:) = p3d(:, 2,:)
- IF( MOD(mjg( 1), 3) == 2 ) p3d(:, 2,:) = p3d(:, 1,:)
+ IF( MOD(mjg( 1,nn_hls), 3) == 1 ) p3d(:, 1,:) = p3d(:, 2,:)
+ IF( MOD(mjg( 1,nn_hls), 3) == 2 ) p3d(:, 2,:) = p3d(:, 1,:)
ENDIF
IF( mpiRnei(nn_hls,jpno) > -1 ) THEN
- IF( MOD(mjg(jpj-2), 3) == 1 ) p3d(:, jpj,:) = p3d(:,jpj-1,:)
- IF( MOD(mjg(jpj-2), 3) == 0 ) p3d(:,jpj-1,:) = p3d(:, jpj,:)
+ IF( MOD(mjg(jpj-2,nn_hls), 3) == 1 ) p3d(:, jpj,:) = p3d(:,jpj-1,:)
+ IF( MOD(mjg(jpj-2,nn_hls), 3) == 0 ) p3d(:,jpj-1,:) = p3d(:, jpj,:)
ENDIF
CALL lbc_lnk( 'lib_fortran', p3d, 'T', 1.0_wp )
ENDIF
END SUBROUTINE sum3x3_3d
-
- FUNCTION glob_sum_vec_3d( cdname, ptab ) RESULT( ptmp )
- !!----------------------------------------------------------------------
- CHARACTER(len=*), INTENT(in) :: cdname ! name of the calling subroutine
- REAL(wp), INTENT(in) :: ptab(:,:,:) ! array on which operation is applied
- REAL(wp), DIMENSION(SIZE(ptab,3)) :: ptmp
- !
- COMPLEX(dp), DIMENSION(:), ALLOCATABLE :: ctmp
- REAL(wp) :: ztmp
- INTEGER :: ji , jj , jk ! dummy loop indices
- INTEGER :: ipi, ipj, ipk ! dimensions
- INTEGER :: iis, iie, ijs, ije ! loop start and end
- !!-----------------------------------------------------------------------
- !
- ipi = SIZE(ptab,1) ! 1st dimension
- ipj = SIZE(ptab,2) ! 2nd dimension
- ipk = SIZE(ptab,3) ! 3rd dimension
- !
- IF( ipi == jpi .AND. ipj == jpj ) THEN ! do 2D loop only over the inner domain (-> avoid to use undefined values)
- iis = Nis0 ; iie = Nie0
- ijs = Njs0 ; ije = Nje0
- ELSE ! I think we are never in this case...
- iis = 1 ; iie = jpi
- ijs = 1 ; ije = jpj
- ENDIF
- !
- ALLOCATE( ctmp(ipk) )
- !
- DO jk = 1, ipk
- ctmp(jk) = CMPLX( 0.e0, 0.e0, dp ) ! warning ctmp is cumulated
- DO jj = ijs, ije
- DO ji = iis, iie
- ztmp = ptab(ji,jj,jk) * tmask_i(ji,jj)
- CALL DDPDD( CMPLX( ztmp, 0.e0, dp ), ctmp(jk) )
- END DO
- END DO
- END DO
- CALL mpp_sum( cdname, ctmp(:) ) ! sum over the global domain
- !
- ptmp = REAL( ctmp(:), wp )
- !
- DEALLOCATE( ctmp )
- !
- END FUNCTION glob_sum_vec_3d
-
- FUNCTION glob_sum_vec_4d( cdname, ptab ) RESULT( ptmp )
- !!----------------------------------------------------------------------
- CHARACTER(len=*), INTENT(in) :: cdname ! name of the calling subroutine
- REAL(wp), INTENT(in) :: ptab(:,:,:,:) ! array on which operation is applied
- REAL(wp), DIMENSION(SIZE(ptab,4)) :: ptmp
- !
- COMPLEX(dp), DIMENSION(:), ALLOCATABLE :: ctmp
- REAL(wp) :: ztmp
- INTEGER :: ji , jj , jk , jl ! dummy loop indices
- INTEGER :: ipi, ipj, ipk, ipl ! dimensions
- INTEGER :: iis, iie, ijs, ije ! loop start and end
- !!-----------------------------------------------------------------------
- !
- ipi = SIZE(ptab,1) ! 1st dimension
- ipj = SIZE(ptab,2) ! 2nd dimension
- ipk = SIZE(ptab,3) ! 3rd dimension
- ipl = SIZE(ptab,4) ! 4th dimension
- !
- IF( ipi == jpi .AND. ipj == jpj ) THEN ! do 2D loop only over the inner domain (-> avoid to use undefined values)
- iis = Nis0 ; iie = Nie0
- ijs = Njs0 ; ije = Nje0
- ELSE ! I think we are never in this case...
- iis = 1 ; iie = jpi
- ijs = 1 ; ije = jpj
- ENDIF
- !
- ALLOCATE( ctmp(ipl) )
- !
- DO jl = 1, ipl
- ctmp(jl) = CMPLX( 0.e0, 0.e0, dp ) ! warning ctmp is cumulated
- DO jk = 1, ipk
- DO jj = ijs, ije
- DO ji = iis, iie
- ztmp = ptab(ji,jj,jk,jl) * tmask_i(ji,jj)
- CALL DDPDD( CMPLX( ztmp, 0.e0, dp ), ctmp(jl) )
- END DO
- END DO
- END DO
- END DO
- CALL mpp_sum( cdname, ctmp(:) ) ! sum over the global domain
- !
- ptmp = REAL( ctmp(:), wp )
- !
- DEALLOCATE( ctmp )
- !
- END FUNCTION glob_sum_vec_4d
-
- FUNCTION glob_min_vec_3d( cdname, ptab ) RESULT( ptmp )
- !!----------------------------------------------------------------------
- CHARACTER(len=*), INTENT(in) :: cdname ! name of the calling subroutine
- REAL(wp), INTENT(in) :: ptab(:,:,:) ! array on which operation is applied
- REAL(wp), DIMENSION(SIZE(ptab,3)) :: ptmp
- !
- INTEGER :: jk ! dummy loop indice & dimension
- INTEGER :: ipk ! dimension
- !!-----------------------------------------------------------------------
- !
- ipk = SIZE(ptab,3)
- DO jk = 1, ipk
- ptmp(jk) = MINVAL( ptab(:,:,jk) * tmask_i(:,:) )
- ENDDO
- !
- CALL mpp_min( cdname, ptmp (:) )
- !
- END FUNCTION glob_min_vec_3d
-
- FUNCTION glob_min_vec_4d( cdname, ptab ) RESULT( ptmp )
- !!----------------------------------------------------------------------
- CHARACTER(len=*), INTENT(in) :: cdname ! name of the calling subroutine
- REAL(wp), INTENT(in) :: ptab(:,:,:,:) ! array on which operation is applied
- REAL(wp), DIMENSION(SIZE(ptab,4)) :: ptmp
- !
- INTEGER :: jk , jl ! dummy loop indice & dimension
- INTEGER :: ipk, ipl ! dimension
- !!-----------------------------------------------------------------------
- !
- ipk = SIZE(ptab,3)
- ipl = SIZE(ptab,4)
- DO jl = 1, ipl
- ptmp(jl) = MINVAL( ptab(:,:,1,jl) * tmask_i(:,:) )
- DO jk = 2, ipk
- ptmp(jl) = MIN( ptmp(jl), MINVAL( ptab(:,:,jk,jl) * tmask_i(:,:) ) )
- ENDDO
- ENDDO
- !
- CALL mpp_min( cdname, ptmp (:) )
- !
- END FUNCTION glob_min_vec_4d
-
- FUNCTION glob_max_vec_3d( cdname, ptab ) RESULT( ptmp )
- !!----------------------------------------------------------------------
- CHARACTER(len=*), INTENT(in) :: cdname ! name of the calling subroutine
- REAL(wp), INTENT(in) :: ptab(:,:,:) ! array on which operation is applied
- REAL(wp), DIMENSION(SIZE(ptab,3)) :: ptmp
- !
- INTEGER :: jk ! dummy loop indice & dimension
- INTEGER :: ipk ! dimension
- !!-----------------------------------------------------------------------
- !
- ipk = SIZE(ptab,3)
- DO jk = 1, ipk
- ptmp(jk) = MAXVAL( ptab(:,:,jk) * tmask_i(:,:) )
- ENDDO
- !
- CALL mpp_max( cdname, ptmp (:) )
- !
- END FUNCTION glob_max_vec_3d
-
- FUNCTION glob_max_vec_4d( cdname, ptab ) RESULT( ptmp )
- !!----------------------------------------------------------------------
- CHARACTER(len=*), INTENT(in) :: cdname ! name of the calling subroutine
- REAL(wp), INTENT(in) :: ptab(:,:,:,:) ! array on which operation is applied
- REAL(wp), DIMENSION(SIZE(ptab,4)) :: ptmp
- !
- INTEGER :: jk , jl ! dummy loop indice & dimension
- INTEGER :: ipk, ipl ! dimension
- !!-----------------------------------------------------------------------
- !
- ipk = SIZE(ptab,3)
- ipl = SIZE(ptab,4)
- DO jl = 1, ipl
- ptmp(jl) = MAXVAL( ptab(:,:,1,jl) * tmask_i(:,:) )
- DO jk = 2, ipk
- ptmp(jl) = MAX( ptmp(jl), MAXVAL( ptab(:,:,jk,jl) * tmask_i(:,:) ) )
- ENDDO
- ENDDO
- !
- CALL mpp_max( cdname, ptmp (:) )
- !
- END FUNCTION glob_max_vec_4d
SUBROUTINE DDPDD( ydda, yddb )
!!----------------------------------------------------------------------
diff --git a/src/OCE/lib_fortran_generic.h90 b/src/OCE/lib_fortran_generic.h90
index 5201ad6d014dda8259deaeca0042ab9f79a9a581..2b84ed31aa187d201ea01f5b4619f2bbc6f8b005 100644
--- a/src/OCE/lib_fortran_generic.h90
+++ b/src/OCE/lib_fortran_generic.h90
@@ -1,139 +1,205 @@
-#if defined GLOBSUM_CODE
-! ! FUNCTION FUNCTION_GLOBSUM !
+/**/
+/*-----------------------------*/
+/* DEFINE COMMON VARIABLES */
+/*-----------------------------*/
+/**/
# if defined DIM_1d
-# define XD 1d
-# define ARRAY_TYPE(i,j,k) REAL(wp) , INTENT(in ) :: ARRAY_IN(i,j,k)
-# define ARRAY_IN(i,j,k) ptab(i)
-# define ARRAY2_IN(i,j,k) ptab2(i)
-# define J_SIZE(ptab) 1
-# define K_SIZE(ptab) 1
-# define MASK_ARRAY(i,j) 1.
+# define XD 1d
+# define ARRAY_IN(i,j,k,l) ptab(i)
# endif
# if defined DIM_2d
-# define XD 2d
-# define ARRAY_TYPE(i,j,k) REAL(wp) , INTENT(in ) :: ARRAY_IN(i,j,k)
-# define ARRAY_IN(i,j,k) ptab(i,j)
-# define ARRAY2_IN(i,j,k) ptab2(i,j)
-# define J_SIZE(ptab) SIZE(ptab,2)
-# define K_SIZE(ptab) 1
-# define MASK_ARRAY(i,j) tmask_i(i,j)
+# define XD 2d
+# define ARRAY_IN(i,j,k,l) ptab(i,j)
+# define K_SIZE(ptab) 1
+# define L_SIZE(ptab) 1
+# define LAST_SIZE -1
# endif
# if defined DIM_3d
-# define XD 3d
-# define ARRAY_TYPE(i,j,k) REAL(wp) , INTENT(in ) :: ARRAY_IN(i,j,k)
-# define ARRAY_IN(i,j,k) ptab(i,j,k)
-# define ARRAY2_IN(i,j,k) ptab2(i,j,k)
-# define J_SIZE(ptab) SIZE(ptab,2)
-# define K_SIZE(ptab) SIZE(ptab,3)
-# define MASK_ARRAY(i,j) tmask_i(i,j)
-# endif
-
- FUNCTION glob_sum_/**/XD/**/( cdname, ptab )
+# define XD 3d
+# define ARRAY_IN(i,j,k,l) ptab(i,j,k)
+# define K_SIZE(ptab) SIZE(ptab,3)
+# define L_SIZE(ptab) 1
+# define LAST_SIZE SIZE(ptab,3)
+# endif
+# if defined DIM_4d
+# define XD 4d
+# define ARRAY_IN(i,j,k,l) ptab(i,j,k,l)
+# define K_SIZE(ptab) SIZE(ptab,3)
+# define L_SIZE(ptab) SIZE(ptab,4)
+# define LAST_SIZE SIZE(ptab,4)
+# endif
+# if defined VEC
+# define ISVEC _vec
+# else
+# define ISVEC
+# endif
+# if defined LOCALONLY
+# define TYPENAME local
+# else
+# define TYPENAME glob
+# endif
+/**/
+/*-------------------------------*/
+/* FUNCTION FUNCTION_GLOBSUM */
+/*-------------------------------*/
+/**/
+#if defined GLOBSUM_CODE
+/**/
+/* DEFINE LOCAL VARIABLES */
+/**/
+!
+# if defined LOCALONLY
+FUNCTION TYPENAME/**/_sum/**/ISVEC/**/_/**/XD/**/( ptab ) RESULT( ptmp )
!!----------------------------------------------------------------------
- CHARACTER(len=*), INTENT(in ) :: cdname ! name of the calling subroutine
- ARRAY_TYPE(:,:,:) ! array on which operation is applied
- REAL(wp) :: glob_sum_/**/XD
- !
- !!-----------------------------------------------------------------------
+# else
+FUNCTION TYPENAME/**/_sum/**/ISVEC/**/_/**/XD/**/( cdname, ptab ) RESULT( ptmp )
+ !!----------------------------------------------------------------------
+ CHARACTER(len=*), INTENT(in ) :: cdname ! name of the calling subroutine
+# endif
+ REAL(wp) , INTENT(in ) :: ARRAY_IN(:,:,:,:) ! array on which operation is applied
!
+# if defined VEC
+ REAL(wp) , DIMENSION(LAST_SIZE) :: ptmp
+ COMPLEX(dp), DIMENSION(LAST_SIZE) :: ctmp
+# else
+ REAL(wp) :: ptmp
COMPLEX(dp):: ctmp
- REAL(wp) :: ztmp
- INTEGER :: ji, jj, jk ! dummy loop indices
- INTEGER :: ipi,ipj, ipk ! dimensions
- INTEGER :: iis, iie, ijs, ije ! loop start and end
+# endif
+ INTEGER :: ji, jj, jk, jl ! dummy loop indices
+ INTEGER :: ipi, ipj, ipk, ipl ! dimensions
+ INTEGER :: iisht, ijsht
!!-----------------------------------------------------------------------
!
+# if defined DIM_1d
+ ctmp = CMPLX( 0.e0, 0.e0, dp ) ! warning ctmp is cumulated
+ DO ji = 1, SIZE(ptab,1)
+ CALL DDPDD( CMPLX( ptab(ji), 0.e0, dp ), ctmp )
+ END DO
+ !
+# else
ipi = SIZE(ptab,1) ! 1st dimension
- ipj = J_SIZE(ptab) ! 2nd dimension
+ ipj = SIZE(ptab,2) ! 2nd dimension
ipk = K_SIZE(ptab) ! 3rd dimension
+ ipl = L_SIZE(ptab) ! 4th dimension
!
- IF( ipi == jpi .AND. ipj == jpj ) THEN ! do 2D loop only over the inner domain (-> avoid to use undefined values)
- iis = Nis0 ; iie = Nie0
- ijs = Njs0 ; ije = Nje0
- ELSE
- iis = 1 ; iie = jpi
- ijs = 1 ; ije = jpj
- ENDIF
+ iisht = ( jpi - ipi ) / 2
+ ijsht = ( jpj - ipj ) / 2 ! should be the same as iisht...
!
ctmp = CMPLX( 0.e0, 0.e0, dp ) ! warning ctmp is cumulated
- DO jk = 1, ipk
- DO jj = ijs, ije
- DO ji = iis, iie
- ztmp = ARRAY_IN(ji,jj,jk) * MASK_ARRAY(ji,jj)
- CALL DDPDD( CMPLX( ztmp, 0.e0, dp ), ctmp )
- END DO
- END DO
+ !
+ DO jl = 1, ipl
+ DO jk = 1, ipk
+ DO_2D( 0, 0, 0, 0 )
+ ! warning tmask_i is defined over the full MPI domain but maybe not ptab
+# define ARRAY_LOOP ARRAY_IN(ji-iisht,jj-ijsht,jk,jl) * tmask_i(ji,jj)
+# if defined VEC && defined DIM_3d
+ CALL DDPDD( CMPLX( ARRAY_LOOP, 0.e0, dp ), ctmp(jk) )
+# endif
+# if defined VEC && defined DIM_4d
+ CALL DDPDD( CMPLX( ARRAY_LOOP, 0.e0, dp ), ctmp(jl) )
+# endif
+# if ! defined VEC
+ CALL DDPDD( CMPLX( ARRAY_LOOP, 0.e0, dp ), ctmp )
+# endif
+ END_2D
+ END DO
END DO
+ !
+# endif
+# if defined LOCALONLY
+ ptmp = ctmp
+# else
CALL mpp_sum( cdname, ctmp ) ! sum over the global domain
- glob_sum_/**/XD = REAL(ctmp,wp)
-
- END FUNCTION glob_sum_/**/XD
-
-#undef XD
-#undef ARRAY_TYPE
-#undef ARRAY2_TYPE
-#undef ARRAY_IN
-#undef ARRAY2_IN
-#undef J_SIZE
-#undef K_SIZE
-#undef MASK_ARRAY
+ ptmp = REAL(ctmp, wp)
+# endif
+ !
+ END FUNCTION TYPENAME/**/_sum/**/ISVEC/**/_/**/XD
!
# endif
+/**/
+/*----------------------------------*/
+/* FUNCTION FUNCTION_GLOBMINMAX */
+/*----------------------------------*/
+/**/
#if defined GLOBMINMAX_CODE
-! ! FUNCTION FUNCTION_GLOBMINMAX !
-# if defined DIM_2d
-# define XD 2d
-# define ARRAY_TYPE(i,j,k) REAL(wp) , INTENT(in ) :: ARRAY_IN(i,j,k)
-# define ARRAY_IN(i,j,k) ptab(i,j)
-# define ARRAY2_IN(i,j,k) ptab2(i,j)
-# define K_SIZE(ptab) 1
-# endif
-# if defined DIM_3d
-# define XD 3d
-# define ARRAY_TYPE(i,j,k) REAL(wp) , INTENT(in ) :: ARRAY_IN(i,j,k)
-# define ARRAY_IN(i,j,k) ptab(i,j,k)
-# define ARRAY2_IN(i,j,k) ptab2(i,j,k)
-# define K_SIZE(ptab) SIZE(ptab,3)
-# endif
+/**/
+/* DEFINE LOCAL VARIABLES */
+/**/
# if defined OPERATION_GLOBMIN
-# define OPER min
+# define OPER min
+# define DEFAULT HUGE(1._wp)
# endif
# if defined OPERATION_GLOBMAX
-# define OPER max
+# define OPER max
+# define DEFAULT -HUGE(1._wp)
# endif
-
- FUNCTION glob_/**/OPER/**/_/**/XD/**/( cdname, ptab )
+!
+# if defined LOCALONLY
+ FUNCTION TYPENAME/**/_/**/OPER/**//**/ISVEC/**/_/**/XD/**/( ptab ) RESULT( ptmp )
!!----------------------------------------------------------------------
- CHARACTER(len=*), INTENT(in ) :: cdname ! name of the calling subroutine
- ARRAY_TYPE(:,:,:) ! array on which operation is applied
- REAL(wp) :: glob_/**/OPER/**/_/**/XD
- !
- !!-----------------------------------------------------------------------
+# else
+ FUNCTION TYPENAME/**/_/**/OPER/**//**/ISVEC/**/_/**/XD/**/( cdname, ptab ) RESULT( ptmp )
+ !!----------------------------------------------------------------------
+ CHARACTER(len=*), INTENT(in ) :: cdname ! name of the calling subroutine
+# endif
+ REAL(wp) , INTENT(in ) :: ARRAY_IN(:,:,:,:) ! array on which operation is applied
!
- COMPLEX(dp):: ctmp
- REAL(wp) :: ztmp
- INTEGER :: jk ! dummy loop indices
- INTEGER :: ipk ! dimensions
+# if defined VEC
+ REAL(wp), DIMENSION(LAST_SIZE) :: ptmp
+# else
+ REAL(wp) :: ptmp
+# endif
+ INTEGER :: ji, jj, jk, jl ! dummy loop indices
+ INTEGER :: ipi, ipj, ipk, ipl ! dimensions
+ INTEGER :: iisht, ijsht
!!-----------------------------------------------------------------------
!
+ ipi = SIZE(ptab,1) ! 1st dimension
+ ipj = SIZE(ptab,2) ! 2nd dimension
ipk = K_SIZE(ptab) ! 3rd dimension
+ ipl = L_SIZE(ptab) ! 4th dimension
+ !
+ iisht = ( jpi - ipi ) / 2
+ ijsht = ( jpj - ipj ) / 2 ! should be the same as iisht...
!
- ztmp = OPER/**/val( ARRAY_IN(:,:,1)*tmask_i(:,:) )
- DO jk = 2, ipk
- ztmp = OPER/**/(ztmp, OPER/**/val( ARRAY_IN(:,:,jk)*tmask_i(:,:) ))
- ENDDO
-
- CALL mpp_/**/OPER/**/( cdname, ztmp)
-
- glob_/**/OPER/**/_/**/XD = ztmp
-
- END FUNCTION glob_/**/OPER/**/_/**/XD
-
+ ptmp = DEFAULT
+ !
+ DO jl = 1, ipl
+ DO jk = 1, ipk
+# define ARRAY_LOOP ARRAY_IN(Nis0-iisht:Nie0-iisht,Njs0-ijsht:Nje0-ijsht,jk,jl)*tmask_i(Nis0:Nie0,Njs0:Nje0)
+# if defined VEC && defined DIM_3d
+ ptmp(jk) = OPER/**/( ptmp(jk), OPER/**/val( ARRAY_LOOP ) )
+# endif
+# if defined VEC && defined DIM_4d
+ ptmp(jl) = OPER/**/( ptmp(jl), OPER/**/val( ARRAY_LOOP ) )
+# endif
+# if ! defined VEC
+ ptmp = OPER/**/( ptmp , OPER/**/val( ARRAY_LOOP ) )
+# endif
+ END DO
+ END DO
+ !
+# if ! defined LOCAL
+ CALL mpp_/**/OPER/**/( cdname, ptmp )
+# endif
+ !
+ END FUNCTION TYPENAME/**/_/**/OPER/**//**/ISVEC/**/_/**/XD
+!
+# undef DEFAULT
+# undef OPER
+# endif
+/**/
+/* */
+/* UNDEFINE COMMON VARIABLES */
+/* */
+/**/
#undef XD
-#undef ARRAY_TYPE
-#undef ARRAY2_TYPE
#undef ARRAY_IN
-#undef ARRAY2_IN
+# if ! defined DIM_1d
#undef K_SIZE
-#undef OPER
-# endif
+#undef L_SIZE
+#undef LAST_SIZE
+# endif
+#undef ISVEC
+#undef TYPENAME
+#undef ARRAY_LOOP
diff --git a/src/OCE/module_example.F90 b/src/OCE/module_example.F90
index 2620b2efc856344e2f204d727091a49c55104c44..b0198f02333a07c85e03c7f7b54a742bca946536 100644
--- a/src/OCE/module_example.F90
+++ b/src/OCE/module_example.F90
@@ -88,17 +88,17 @@ CONTAINS
!! References : Author et al., Short_name_review, Year
!! Give references if exist otherwise suppress these lines
!!----------------------------------------------------------------------
- INTEGER , INTENT(in ) :: kt ! short description
- INTEGER , INTENT(inout) :: pvar1 ! - -
- REAL(wp), INTENT( out) :: pvar2 ! - -
- REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: pvar2 ! - -
+ INTEGER , INTENT(in ) :: kt ! short description
+ INTEGER , INTENT(inout) :: pvar1 ! - -
+ REAL(wp), INTENT( out) :: pvar2 ! - -
+ REAL(wp), INTENT( out), DIMENSION(A2D(nn_hls)) :: pvar2 ! - -
!!
INTEGER :: ji, jj, jk ! dummy loop arguments (DOCTOR : start with j, but not jp)
INTEGER :: itoto, itata ! temporary integers (DOCTOR : start with i
REAL(wp) :: zmlmin, zbbrho ! temporary scalars (DOCTOR : start with z)
REAL(wp) :: zfact1, zfact2 ! do not use continuation lines in declaration
- REAL(wp), DIMENSION(A2D(nn_hls)) :: zwrk_2d ! 2D workspace
- REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zwrk_3d ! 3D workspace
+ REAL(wp), DIMENSION(T2D(nn_hls)) :: zwrk_2d ! 2D workspace
+ REAL(wp), DIMENSION(T2D(nn_hls),jpk) :: zwrk_3d ! 3D workspace
!!--------------------------------------------------------------------
!
IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile
diff --git a/src/OCE/nemogcm.F90 b/src/OCE/nemogcm.F90
index 7fd8bc84a7f28dce2a89ab3cd5d4b2e777062449..20fdf05cd721d78e7d1382e76377deeb3064a523 100644
--- a/src/OCE/nemogcm.F90
+++ b/src/OCE/nemogcm.F90
@@ -167,6 +167,7 @@ CONTAINS
!
DO WHILE( istp <= nitend .AND. nstop == 0 )
!
+ ncom_stp = istp
# if defined key_qco || defined key_linssh
# if defined key_RK3
CALL stp_RK3
@@ -400,13 +401,7 @@ CONTAINS
! ! mpp parameters and domain decomposition !
! !-----------------------------------------!
CALL mpp_init
-
-#if defined key_loop_fusion
- IF( nn_hls == 1 ) THEN
- CALL ctl_stop( 'STOP', 'nemogcm : Loop fusion can be used only with extra-halo' )
- ENDIF
-#endif
-
+ !
CALL halo_mng_init()
! Now we know the dimensions of the grid and numout has been set: we can allocate arrays
CALL nemo_alloc()
diff --git a/src/OCE/oce.F90 b/src/OCE/oce.F90
index c180833bbab0079b9986360001d11f9ddbbd5e98..70ae5ee8f44f9042f7a9343a6a813ab15eb70835 100644
--- a/src/OCE/oce.F90
+++ b/src/OCE/oce.F90
@@ -54,15 +54,6 @@ MODULE oce
REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ub2_i_b, vb2_i_b !: agrif time integrated fluxes
#endif
- !! interpolated gradient (only used in zps case)
- !! ---------------------
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: gtsu, gtsv !: horizontal gradient of T, S bottom u-point
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: gru , grv !: horizontal gradient of rd at bottom u-point
-
- !! (ISF) interpolated gradient (only used for ice shelf case)
- !! ---------------------
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: gtui, gtvi !: horizontal gradient of T, S and rd at top u-point
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: grui, grvi !: horizontal gradient of T, S and rd at top v-point
!! (ISF) ice load
REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: riceload
@@ -105,10 +96,6 @@ CONTAINS
ii = ii+1
ALLOCATE( ssh (jpi,jpj,jpt) , uu_b(jpi,jpj,jpt) , vv_b(jpi,jpj,jpt) , &
& ssh_frc(jpi,jpj) , &
- & gtsu(jpi,jpj,jpts) , gtsv(jpi,jpj,jpts) , &
- & gru (jpi,jpj) , grv (jpi,jpj) , &
- & gtui(jpi,jpj,jpts) , gtvi(jpi,jpj,jpts) , &
- & grui(jpi,jpj) , grvi(jpi,jpj) , &
& riceload(jpi,jpj) , STAT=ierr(ii) )
!
ii = ii+1
diff --git a/src/OCE/par_oce.F90 b/src/OCE/par_oce.F90
index f72dce4489875d625f007354ea52d9c622c951af..f6ef02fe90aa0aa82453f3a9feb8d01d526e8139 100644
--- a/src/OCE/par_oce.F90
+++ b/src/OCE/par_oce.F90
@@ -59,7 +59,8 @@ MODULE par_oce
INTEGER, PUBLIC :: jpj ! !: second dimension
INTEGER, PUBLIC :: jpk ! = jpkglo !: third dimension
INTEGER, PUBLIC :: jpkm1 ! = jpk-1 !: - - -
- INTEGER, PUBLIC :: jpij ! = jpi*jpj !: jpi x jpj
+ !INTEGER, PUBLIC :: jpij ! = jpi*jpj !: jpi x jpj
+ INTEGER, PUBLIC :: jpij ! = (jpi-2*nn_hls)*(jpj-2*nn_hls) !: jpi x jpj but without the halos
INTEGER, PUBLIC :: jpimax! = ( Ni0glo + jpni-1 ) / jpni + 2*nn_hls !: maximum jpi
INTEGER, PUBLIC :: jpjmax! = ( Nj0glo + jpnj-1 ) / jpnj + 2*nn_hls !: maximum jpj
diff --git a/src/OCE/step.F90 b/src/OCE/step.F90
deleted file mode 100644
index f2f790617348dfd3f9affd41343d0fe9f3b7c007..0000000000000000000000000000000000000000
--- a/src/OCE/step.F90
+++ /dev/null
@@ -1,452 +0,0 @@
-MODULE step
- !!======================================================================
- !! *** MODULE step ***
- !! Time-stepping : manager of the ocean, tracer and ice time stepping
- !!======================================================================
- !! History : OPA ! 1991-03 (G. Madec) Original code
- !! - ! 1991-11 (G. Madec)
- !! - ! 1992-06 (M. Imbard) add a first output record
- !! - ! 1996-04 (G. Madec) introduction of dynspg
- !! - ! 1996-04 (M.A. Foujols) introduction of passive tracer
- !! 8.0 ! 1997-06 (G. Madec) new architecture of call
- !! 8.2 ! 1997-06 (G. Madec, M. Imbard, G. Roullet) free surface
- !! - ! 1999-02 (G. Madec, N. Grima) hpg implicit
- !! - ! 2000-07 (J-M Molines, M. Imbard) Open Bondary Conditions
- !! NEMO 1.0 ! 2002-06 (G. Madec) free form, suppress macro-tasking
- !! - ! 2004-08 (C. Talandier) New trends organization
- !! - ! 2005-01 (C. Ethe) Add the KPP closure scheme
- !! - ! 2005-11 (G. Madec) Reorganisation of tra and dyn calls
- !! - ! 2006-01 (L. Debreu, C. Mazauric) Agrif implementation
- !! - ! 2006-07 (S. Masson) restart using iom
- !! 3.2 ! 2009-02 (G. Madec, R. Benshila) reintroduicing z*-coordinate
- !! - ! 2009-06 (S. Masson, G. Madec) TKE restart compatible with key_cpl
- !! 3.3 ! 2010-05 (K. Mogensen, A. Weaver, M. Martin, D. Lea) Assimilation interface
- !! - ! 2010-10 (C. Ethe, G. Madec) reorganisation of initialisation phase + merge TRC-TRA
- !! 3.4 ! 2011-04 (G. Madec, C. Ethe) Merge of dtatem and dtasal
- !! 3.6 ! 2012-07 (J. Simeon, G. Madec. C. Ethe) Online coarsening of outputs
- !! 3.6 ! 2014-04 (F. Roquet, G. Madec) New equations of state
- !! 3.6 ! 2014-10 (E. Clementi, P. Oddo) Add Qiao vertical mixing in case of waves
- !! 3.7 ! 2014-10 (G. Madec) LDF simplication
- !! - ! 2014-12 (G. Madec) remove KPP scheme
- !! - ! 2015-11 (J. Chanut) free surface simplification (remove filtered free surface)
- !! 4.0 ! 2017-05 (G. Madec) introduction of the vertical physics manager (zdfphy)
- !! 4.1 ! 2019-08 (A. Coward, D. Storkey) rewrite in preparation for new timestepping scheme
- !!----------------------------------------------------------------------
-
-#if defined key_qco || defined key_linssh
- !!----------------------------------------------------------------------
- !! 'key_qco' EMPTY MODULE Quasi-Eulerian vertical coordinate
- !! OR
- !! 'key_linssh EMPTY MODULE Fixed in time vertical coordinate
- !!----------------------------------------------------------------------
-#else
- !!----------------------------------------------------------------------
- !! stp : OCE system time-stepping
- !!----------------------------------------------------------------------
- USE step_oce ! time stepping definition modules
-
- IMPLICIT NONE
- PRIVATE
-
- PUBLIC stp ! called by nemogcm.F90
-
- ! !** time level indices **!
- INTEGER, PUBLIC :: Nbb, Nnn, Naa, Nrhs !: used by nemo_init
-
- !! * Substitutions
-# include "do_loop_substitute.h90"
- !!----------------------------------------------------------------------
- !! NEMO/OCE 4.0 , NEMO Consortium (2018)
- !! $Id: step.F90 15398 2021-10-19 08:49:42Z timgraham $
- !! Software governed by the CeCILL license (see ./LICENSE)
- !!----------------------------------------------------------------------
-CONTAINS
-
-#if defined key_agrif
- RECURSIVE SUBROUTINE stp( )
- INTEGER :: kstp ! ocean time-step index
-#else
- SUBROUTINE stp( kstp )
- INTEGER, INTENT(in) :: kstp ! ocean time-step index
-#endif
- !!----------------------------------------------------------------------
- !! *** ROUTINE stp ***
- !!
- !! ** Purpose : - Time stepping of OCE (momentum and active tracer eqs.)
- !! - Time stepping of SI3 (dynamic and thermodynamic eqs.)
- !! - Time stepping of TRC (passive tracer eqs.)
- !!
- !! ** Method : -1- Update forcings and data
- !! -2- Update ocean physics
- !! -3- Compute the t and s trends
- !! -4- Update t and s
- !! -5- Compute the momentum trends
- !! -6- Update the horizontal velocity
- !! -7- Compute the diagnostics variables (rd,N2, hdiv,w)
- !! -8- Outputs and diagnostics
- !!----------------------------------------------------------------------
- INTEGER :: ji, jj, jk, jtile ! dummy loop indice
- !! ---------------------------------------------------------------------
-#if defined key_agrif
- IF( nstop > 0 ) RETURN ! avoid to go further if an error was detected during previous time step (child grid)
- kstp = nit000 + Agrif_Nb_Step()
- Kbb_a = Nbb; Kmm_a = Nnn; Krhs_a = Nrhs ! agrif_oce module copies of time level indices
- IF( lk_agrif_debug ) THEN
- IF( Agrif_Root() .and. lwp) WRITE(*,*) '---'
- IF(lwp) WRITE(*,*) 'Grid Number', Agrif_Fixed(),' time step ', kstp, 'int tstep', Agrif_NbStepint()
- ENDIF
- IF( kstp == nit000 + 1 ) lk_agrif_fstep = .FALSE.
-# if defined key_xios
- IF( Agrif_Nbstepint() == 0 ) CALL iom_swap( cxios_context )
-# endif
-#endif
- !
- IF( ln_timing ) CALL timing_start('stp')
- !
- !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
- ! model timestep
- !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
- !
- IF( l_1st_euler ) THEN ! start or restart with Euler 1st time-step
- rDt = rn_Dt
- r1_Dt = 1._wp / rDt
- ENDIF
- !
- !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
- ! update I/O and calendar
- !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
- !
- IF( kstp == nit000 ) THEN ! initialize IOM context (must be done after nemo_init for AGRIF+XIOS+OASIS)
- CALL iom_init( cxios_context, ld_closedef=.FALSE. ) ! for model grid (including possible AGRIF zoom)
- IF( lk_diamlr ) CALL dia_mlr_iom_init ! with additional setup for multiple-linear-regression analysis
- CALL iom_init_closedef
- IF( ln_crs ) CALL iom_init( TRIM(cxios_context)//"_crs" ) ! for coarse grid
- ENDIF
- IF( kstp == nitrst .AND. lwxios ) THEN
- CALL iom_swap( cw_ocerst_cxt )
- CALL iom_init_closedef( cw_ocerst_cxt )
- CALL iom_setkt( kstp - nit000 + 1, cw_ocerst_cxt )
-#if defined key_top
- CALL iom_swap( cw_toprst_cxt )
- CALL iom_init_closedef( cw_toprst_cxt )
- CALL iom_setkt( kstp - nit000 + 1, cw_toprst_cxt )
-#endif
- ENDIF
- IF( kstp + nn_fsbc - 1 == nitrst .AND. lwxios ) THEN
-#if defined key_si3
- CALL iom_swap( cw_icerst_cxt )
- CALL iom_init_closedef( cw_icerst_cxt )
- CALL iom_setkt( kstp - nit000 + 1, cw_icerst_cxt )
-#endif
- IF( ln_abl ) THEN
- CALL iom_swap( cw_ablrst_cxt )
- CALL iom_init_closedef( cw_ablrst_cxt )
- CALL iom_setkt( kstp - nit000 + 1, cw_ablrst_cxt )
- ENDIF
- ENDIF
- IF( kstp /= nit000 ) CALL day( kstp ) ! Calendar (day was already called at nit000 in day_init)
- CALL iom_setkt( kstp - nit000 + 1, cxios_context ) ! tell IOM we are at time step kstp
- IF( ln_crs ) CALL iom_setkt( kstp - nit000 + 1, TRIM(cxios_context)//"_crs" ) ! tell IOM we are at time step kstp
-
- !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
- ! Update external forcing (tides, open boundaries, ice shelf interaction and surface boundary condition (including sea-ice)
- !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
- IF( ln_tide ) CALL tide_update( kstp ) ! update tide potential
- IF( ln_apr_dyn ) CALL sbc_apr ( kstp ) ! atmospheric pressure (NB: call before bdy_dta which needs ssh_ib)
- IF( ln_bdy ) CALL bdy_dta ( kstp, Nnn ) ! update dynamic & tracer data at open boundaries
- IF( ln_isf ) CALL isf_stp ( kstp, Nnn )
- CALL sbc ( kstp, Nbb, Nnn ) ! Sea Boundary Condition (including sea-ice)
-
- !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
- ! Update stochastic parameters and random T/S fluctuations
- !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
- IF( ln_sto_eos ) CALL sto_par( kstp ) ! Stochastic parameters
- IF( ln_sto_eos ) CALL sto_pts( ts(:,:,:,:,Nnn) ) ! Random T/S fluctuations
-
- !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
- ! Ocean physics update
- !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
- ! THERMODYNAMICS
- CALL eos_rab( ts(:,:,:,:,Nbb), rab_b, Nnn ) ! before local thermal/haline expension ratio at T-points
- CALL eos_rab( ts(:,:,:,:,Nnn), rab_n, Nnn ) ! now local thermal/haline expension ratio at T-points
- CALL bn2 ( ts(:,:,:,:,Nbb), rab_b, rn2b, Nnn ) ! before Brunt-Vaisala frequency
- CALL bn2 ( ts(:,:,:,:,Nnn), rab_n, rn2, Nnn ) ! now Brunt-Vaisala frequency
-
- ! VERTICAL PHYSICS
- ! lbc_lnk needed for zdf_sh2 when using nn_hls = 2, moved here to allow tiling in zdf_phy
- IF( nn_hls == 2 .AND. l_zdfsh2 ) CALL lbc_lnk( 'stp', avm_k, 'W', 1.0_wp )
-
- IF( ln_tile ) CALL dom_tile_start ! [tiling] ZDF tiling loop
- DO jtile = 1, nijtile
- IF( ln_tile ) CALL dom_tile( ntsi, ntsj, ntei, ntej, ktile = jtile )
-
- CALL zdf_phy( kstp, Nbb, Nnn, Nrhs ) ! vertical physics update (top/bot drag, avt, avs, avm + MLD)
- END DO
- IF( ln_tile ) CALL dom_tile_stop
-
- ! LATERAL PHYSICS
- !
- IF( ln_zps .OR. l_ldfslp ) CALL eos( ts(:,:,:,:,Nbb), rhd, gdept_0(:,:,:) ) ! before in situ density
-
- IF( ln_zps .AND. .NOT. ln_isfcav) &
- & CALL zps_hde ( kstp, jpts, ts(:,:,:,:,Nbb), gtsu, gtsv, & ! Partial steps: before horizontal gradient
- & rhd, gru , grv ) ! of t, s, rd at the last ocean level
-
- IF( ln_zps .AND. ln_isfcav) &
- & CALL zps_hde_isf( kstp, jpts, ts(:,:,:,:,Nbb), gtsu, gtsv, gtui, gtvi, & ! Partial steps for top cell (ISF)
- & rhd, gru , grv , grui, grvi ) ! of t, s, rd at the first ocean level
-
- IF( l_ldfslp ) THEN ! slope of lateral mixing
- IF( ln_traldf_triad ) THEN
- CALL ldf_slp_triad( kstp, Nbb, Nnn ) ! before slope for triad operator
- ELSE
- CALL ldf_slp ( kstp, rhd, rn2b, Nbb, Nnn ) ! before slope for standard operator
- ENDIF
- ENDIF
- ! ! eddy diffusivity coeff.
- IF( l_ldftra_time .OR. l_ldfeiv_time ) CALL ldf_tra( kstp, Nbb, Nnn ) ! and/or eiv coeff.
- IF( l_ldfdyn_time ) CALL ldf_dyn( kstp, Nbb ) ! eddy viscosity coeff.
-
- !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
- ! Ocean dynamics : hdiv, ssh, e3, u, v, w
- !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
-
- CALL ssh_nxt ( kstp, Nbb, Nnn, ssh, Naa ) ! after ssh (includes call to div_hor)
- IF( .NOT.ln_linssh ) &
- & CALL dom_vvl_sf_nxt( kstp, Nbb, Nnn, Naa ) ! after vertical scale factors
- CALL wzv ( kstp, Nbb, Nnn, Naa, ww ) ! now cross-level velocity
- IF( ln_zad_Aimp ) CALL wAimp ( kstp, Nnn ) ! Adaptive-implicit vertical advection partitioning
- CALL eos ( ts(:,:,:,:,Nnn), rhd, rhop, gdept(:,:,:,Nnn) ) ! now in situ density for hpg computation
-
-
- uu(:,:,:,Nrhs) = 0._wp ! set dynamics trends to zero
- vv(:,:,:,Nrhs) = 0._wp
-
- IF( ln_tile ) CALL dom_tile_start ! [tiling] DYN tiling loop (1)
- DO jtile = 1, nijtile
- IF( ln_tile ) CALL dom_tile( ntsi, ntsj, ntei, ntej, ktile = jtile )
-
- IF( lk_asminc .AND. ln_asmiau .AND. ln_dyninc ) &
- & CALL dyn_asm_inc ( kstp, Nbb, Nnn, uu, vv, Nrhs ) ! apply dynamics assimilation increment
- IF( ln_bkgwri ) CALL asm_bkg_wri( kstp, Nnn ) ! output background fields
- IF( ln_bdy ) CALL bdy_dyn3d_dmp ( kstp, Nbb, uu, vv, Nrhs ) ! bdy damping trends
-#if defined key_agrif
- END DO
- IF( ln_tile ) CALL dom_tile_stop
-
- IF(.NOT. Agrif_Root()) &
- & CALL Agrif_Sponge_dyn ! momentum sponge
-
- IF( ln_tile ) CALL dom_tile_start ! [tiling] DYN tiling loop (1, continued)
- DO jtile = 1, nijtile
- IF( ln_tile ) CALL dom_tile( ntsi, ntsj, ntei, ntej, ktile = jtile )
-#endif
- CALL dyn_adv( kstp, Nbb, Nnn , uu, vv, Nrhs ) ! advection (VF or FF) ==> RHS
- CALL dyn_vor( kstp, Nnn , uu, vv, Nrhs ) ! vorticity ==> RHS
- CALL dyn_ldf( kstp, Nbb, Nnn , uu, vv, Nrhs ) ! lateral mixing
- IF( ln_zdfosm ) CALL dyn_osm( kstp, Nnn , uu, vv, Nrhs ) ! OSMOSIS non-local velocity fluxes ==> RHS
- CALL dyn_hpg( kstp, Nnn , uu, vv, Nrhs ) ! horizontal gradient of Hydrostatic pressure
- END DO
- IF( ln_tile ) CALL dom_tile_stop
-
- CALL dyn_spg( kstp, Nbb, Nnn, Nrhs, uu, vv, ssh, uu_b, vv_b, Naa ) ! surface pressure gradient
-
- ! With split-explicit free surface, since now transports have been updated and ssh(:,:,Nrhs) as well
- IF( ln_dynspg_ts ) THEN ! vertical scale factors and vertical velocity need to be updated
- IF( ln_tile ) CALL dom_tile_start ! [tiling] DYN tiling loop (2- div_hor only)
- DO jtile = 1, nijtile
- IF( ln_tile ) CALL dom_tile( ntsi, ntsj, ntei, ntej, ktile = jtile )
-
- CALL div_hor ( kstp, Nbb, Nnn ) ! Horizontal divergence (2nd call in time-split case)
- END DO
- IF( ln_tile ) CALL dom_tile_stop
-
- IF(.NOT. ln_linssh) CALL dom_vvl_sf_nxt( kstp, Nbb, Nnn, Naa, kcall=2 ) ! after vertical scale factors (update depth average component)
- ENDIF
-
- IF( ln_tile ) CALL dom_tile_start ! [tiling] DYN tiling loop (3- dyn_zdf only)
- DO jtile = 1, nijtile
- IF( ln_tile ) CALL dom_tile( ntsi, ntsj, ntei, ntej, ktile = jtile )
-
- CALL dyn_zdf ( kstp, Nbb, Nnn, Nrhs, uu, vv, Naa ) ! vertical diffusion
- END DO
- IF( ln_tile ) CALL dom_tile_stop
-
- IF( ln_dynspg_ts ) THEN ! vertical scale factors and vertical velocity need to be updated
- CALL wzv ( kstp, Nbb, Nnn, Naa, ww ) ! Nnn cross-level velocity
- IF( ln_zad_Aimp ) CALL wAimp ( kstp, Nnn ) ! Adaptive-implicit vertical advection partitioning
- ENDIF
-
-
- !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
- ! cool skin
- !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
- IF ( ln_diurnal ) CALL diurnal_layers( kstp )
-
- !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
- ! diagnostics and outputs
- !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
- IF( ln_floats ) CALL flo_stp ( kstp, Nbb, Nnn ) ! drifting Floats
- IF( ln_diacfl ) CALL dia_cfl ( kstp, Nnn ) ! Courant number diagnostics
- CALL dia_hth ( kstp, Nnn ) ! Thermocline depth (20 degres isotherm depth)
- IF( ln_diadct ) CALL dia_dct ( kstp, Nnn ) ! Transports
- CALL dia_ar5 ( kstp, Nnn ) ! ar5 diag
- CALL dia_ptr ( kstp, Nnn ) ! Poleward adv/ldf TRansports diagnostics
- CALL dia_wri ( kstp, Nnn ) ! ocean model: outputs
- IF( ln_crs ) CALL crs_fld ( kstp, Nnn ) ! ocean model: online field coarsening & output
- IF( lk_diadetide ) CALL dia_detide( kstp ) ! Weights computation for daily detiding of model diagnostics
- IF( lk_diamlr ) CALL dia_mlr ! Update time used in multiple-linear-regression analysis
-
-#if defined key_top
- !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
- ! Passive Tracer Model
- !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
- CALL trc_stp ( kstp, Nbb, Nnn, Nrhs, Naa ) ! time-stepping
-#endif
-
- !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
- ! Active tracers
- !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
- ts(:,:,:,:,Nrhs) = 0._wp ! set tracer trends to zero
-
- IF( ln_tile ) CALL dom_tile_start ! [tiling] TRA tiling loop (1)
- DO jtile = 1, nijtile
- IF( ln_tile ) CALL dom_tile( ntsi, ntsj, ntei, ntej, ktile = jtile )
-
- IF( lk_asminc .AND. ln_asmiau .AND. &
- & ln_trainc ) CALL tra_asm_inc( kstp, Nbb, Nnn, ts, Nrhs ) ! apply tracer assimilation increment
- CALL tra_sbc ( kstp, Nnn, ts, Nrhs ) ! surface boundary condition
- IF( ln_traqsr ) CALL tra_qsr ( kstp, Nnn, ts, Nrhs ) ! penetrative solar radiation qsr
- IF( ln_isf ) CALL tra_isf ( kstp, Nnn, ts, Nrhs ) ! ice shelf heat flux
- IF( ln_trabbc ) CALL tra_bbc ( kstp, Nnn, ts, Nrhs ) ! bottom heat flux
- IF( ln_trabbl ) CALL tra_bbl ( kstp, Nbb, Nnn, ts, Nrhs ) ! advective (and/or diffusive) bottom boundary layer scheme
- IF( ln_tradmp ) CALL tra_dmp ( kstp, Nbb, Nnn, ts, Nrhs ) ! internal damping trends
- IF( ln_bdy ) CALL bdy_tra_dmp( kstp, Nbb, ts, Nrhs ) ! bdy damping trends
- END DO
- IF( ln_tile ) CALL dom_tile_stop
-
-#if defined key_agrif
- IF(.NOT. Agrif_Root() ) THEN
- CALL Agrif_Sponge_tra ! tracers sponge
- ENDIF
-#endif
-
- ! TEMP: [tiling] Separate loop over tile domains (due to tra_adv workarounds for tiling)
- IF( ln_tile ) CALL dom_tile_start ! [tiling] TRA tiling loop (2)
- DO jtile = 1, nijtile
- IF( ln_tile ) CALL dom_tile( ntsi, ntsj, ntei, ntej, ktile = jtile )
-
- CALL tra_adv ( kstp, Nbb, Nnn, Naa, ts, Nrhs ) ! hor. + vert. advection ==> RHS
- IF( ln_zdfmfc ) CALL tra_mfc ( kstp, Nbb, ts, Nrhs ) ! Mass Flux Convection
- IF( ln_zdfosm ) THEN
- CALL tra_osm ( kstp, Nnn, ts, Nrhs ) ! OSMOSIS non-local tracer fluxes ==> RHS
- IF( lrst_oce ) CALL osm_rst ( kstp, Nnn, 'WRITE' ) ! write OSMOSIS outputs + ww (so must do here) to restarts
- ENDIF
- CALL tra_ldf ( kstp, Nbb, Nnn, ts, Nrhs ) ! lateral mixing
-
- CALL tra_zdf ( kstp, Nbb, Nnn, Nrhs, ts, Naa ) ! vertical mixing and after tracer fields
- IF( ln_zdfnpc ) CALL tra_npc ( kstp, Nnn, Nrhs, ts, Naa ) ! update after fields by non-penetrative convection
- END DO
- IF( ln_tile ) CALL dom_tile_stop
-
- !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
- ! Set boundary conditions, time filter and swap time levels
- !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
-!!jc1: For agrif, it would be much better to finalize tracers/momentum here (e.g. bdy conditions) and move the swap
-!! (and time filtering) after Agrif update. Then restart would be done after and would contain updated fields.
-!! If so:
-!! (i) no need to call agrif update at initialization time
-!! (ii) no need to update "before" fields
-!!
-!! Apart from creating new tra_swp/dyn_swp routines, this however:
-!! (i) makes boundary conditions at initialization time computed from updated fields which is not the case between
-!! two restarts => restartability issue. One can circumvent this, maybe, by assuming "interface separation",
-!! e.g. a shift of the feedback interface inside child domain.
-!! (ii) requires that all restart outputs of updated variables by agrif (e.g. passive tracers/tke/barotropic arrays) are done at the same
-!! place.
-!!
-!!jc2: dynnxt must be the latest call. e3t(:,:,:,Nbb) are indeed updated in that routine
- CALL tra_atf ( kstp, Nbb, Nnn, Naa, ts ) ! time filtering of "now" tracer arrays
- CALL dyn_atf ( kstp, Nbb, Nnn, Naa, uu, vv, e3t, e3u, e3v ) ! time filtering of "now" velocities and scale factors
- CALL ssh_atf ( kstp, Nbb, Nnn, Naa, ssh ) ! time filtering of "now" sea surface height
- !
- ! Swap time levels
- Nrhs = Nbb
- Nbb = Nnn
- Nnn = Naa
- Naa = Nrhs
- !
- IF(.NOT.ln_linssh) CALL dom_vvl_sf_update( kstp, Nbb, Nnn, Naa ) ! recompute vertical scale factors
- !
- IF( ln_diahsb ) CALL dia_hsb ( kstp, Nbb, Nnn ) ! - ML - global conservation diagnostics
-
-!!gm : This does not only concern the dynamics ==>>> add a new title
-!!gm2: why ouput restart before AGRIF update?
-!!
-!!jc: That would be better, but see comment above
-!!
- IF( lrst_oce ) CALL rst_write ( kstp, Nbb, Nnn ) ! write output ocean restart file
- IF( ln_sto_eos ) CALL sto_rst_write( kstp ) ! write restart file for stochastic parameters
-
-#if defined key_agrif
- !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
- ! AGRIF recursive integration
- !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
- Kbb_a = Nbb; Kmm_a = Nnn; Krhs_a = Nrhs ! agrif_oce module copies of time level indices
- CALL Agrif_Integrate_ChildGrids( stp ) ! allows to finish all the Child Grids before updating
-
-#endif
- !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
- ! Control
- !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
- CALL stp_ctl ( kstp, Nnn )
-
-#if defined key_agrif
- !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
- ! AGRIF update
- !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
- IF( Agrif_NbStepint() == 0 .AND. nstop == 0 ) &
- & CALL Agrif_update_all( ) ! Update all components
-
-#endif
- IF( ln_diaobs .AND. nstop == 0 ) &
- & CALL dia_obs( kstp, Nnn ) ! obs-minus-model (assimilation) diags (after dynamics update)
-
- !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
- ! File manipulation at the end of the first time step
- !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
- IF( kstp == nit000 ) THEN ! 1st time step only
- CALL iom_close( numror ) ! close input ocean restart file
- IF( lrxios ) CALL iom_context_finalize( cr_ocerst_cxt )
- IF(lwm) CALL FLUSH ( numond ) ! flush output namelist oce
- IF(lwm .AND. numoni /= -1 ) CALL FLUSH ( numoni ) ! flush output namelist ice (if exist)
- ENDIF
-
- !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
- ! Coupled mode
- !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
- IF( lk_oasis .AND. nstop == 0 ) CALL sbc_cpl_snd( kstp, Nbb, Nnn ) ! coupled mode : field exchanges
- !
-#if defined key_xios
- !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
- ! Finalize contextes if end of simulation or error detected
- !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
- IF( kstp == nitend .OR. nstop > 0 ) THEN
- CALL iom_context_finalize( cxios_context ) ! needed for XIOS+AGRIF
- IF( ln_crs ) CALL iom_context_finalize( trim(cxios_context)//"_crs" ) !
- ENDIF
-#endif
- !
- IF( l_1st_euler ) THEN ! recover Leap-frog timestep
- rDt = 2._wp * rn_Dt
- r1_Dt = 1._wp / rDt
- l_1st_euler = .FALSE.
- ENDIF
- !
- IF( ln_timing ) CALL timing_stop('stp')
- !
- END SUBROUTINE stp
- !
-#endif
- !!======================================================================
-END MODULE step
diff --git a/src/OCE/step_oce.F90 b/src/OCE/step_oce.F90
index 38dda2a2f2ba1abe6ac7fe4e1ac7c1bce38c08b8..36d6d6baf588b992d0ba17dbf84128765fbb3b6f 100644
--- a/src/OCE/step_oce.F90
+++ b/src/OCE/step_oce.F90
@@ -32,8 +32,6 @@ MODULE step_oce
USE sshwzv ! vertical velocity and ssh (ssh_nxt routine)
! (ssh_swp routine)
! (wzv routine)
- USE domvvl ! variable vertical scale factors (dom_vvl_sf_nxt routine)
- ! (dom_vvl_sf_swp routine)
USE divhor ! horizontal divergence (div_hor routine)
USE dynadv ! advection (dyn_adv routine)
@@ -42,7 +40,7 @@ MODULE step_oce
USE dynldf ! lateral momentum diffusion (dyn_ldf routine)
USE dynzdf ! vertical diffusion (dyn_zdf routine)
USE dynspg ! surface pressure gradient (dyn_spg routine)
- USE dynatf ! time-filtering (dyn_atf routine)
+ USE dynatf_qco ! time-filtering (dyn_atf routine)
USE dyndmp ! current damping (dyn_dmp routine)
USE traqsr ! solar radiation penetration (tra_qsr routine)
@@ -54,7 +52,7 @@ MODULE step_oce
USE traadv ! advection scheme control (tra_adv_ctl routine)
USE traldf ! lateral mixing (tra_ldf routine)
USE trazdf ! vertical mixing (tra_zdf routine)
- USE traatf ! time filtering (tra_atf routine)
+ USE traatf_qco ! time filtering (tra_atf routine)
USE tranpc ! non-penetrative convection (tra_npc routine)
USE eosbn2 ! equation of state (eos_bn2 routine)
@@ -75,8 +73,6 @@ MODULE step_oce
USE diu_layers ! diurnal SST bulk and coolskin routines
USE sbc_oce ! surface fluxes
- USE zpshde ! partial step: hor. derivative (zps_hde routine)
-
USE diawri ! Standard run outputs (dia_wri routine)
USE diaptr ! poleward transports (dia_ptr routine)
USE diadct ! sections transports (dia_dct routine)
diff --git a/src/OCE/stp2d.F90 b/src/OCE/stp2d.F90
index 96170dc207405395a7248c429d57e8516a227d51..4c6b814eaa1a87f89e8894ac8af1c1168f7766ee 100644
--- a/src/OCE/stp2d.F90
+++ b/src/OCE/stp2d.F90
@@ -137,8 +137,15 @@ CONTAINS
CALL dyn_hpg( kt , Kbb , uu, vv, Krhs ) ! horizontal gradient of Hydrostatic pressure
!
! !* vertical averaging *!
+#if defined key_vco_1d
+ DO_2D( 0, 0, 0, 0 )
+ Ue_rhs(ji,jj) = SUM( e3u_0(ji,jj,:) * uu(ji,jj,:,Krhs) * umask(ji,jj,:) ) * r1_hu_0(ji,jj)
+ Ve_rhs(ji,jj) = SUM( e3v_0(ji,jj,:) * vv(ji,jj,:,Krhs) * vmask(ji,jj,:) ) * r1_hv_0(ji,jj)
+ END_2D
+#else
Ue_rhs(:,:) = SUM( e3u_0(:,:,:) * uu(:,:,:,Krhs) * umask(:,:,:), DIM=3 ) * r1_hu_0(:,:)
Ve_rhs(:,:) = SUM( e3v_0(:,:,:) * vv(:,:,:,Krhs) * vmask(:,:,:), DIM=3 ) * r1_hv_0(:,:)
+#endif
! !===========================!
! !== external 2D forcing ==!
@@ -151,14 +158,14 @@ CONTAINS
! !* wind forcing *!
IF( ln_bt_fw ) THEN
DO_2D( 0, 0, 0, 0 )
- Ue_rhs(ji,jj) = Ue_rhs(ji,jj) + r1_rho0 * utau(ji,jj) * r1_hu(ji,jj,Kbb)
- Ve_rhs(ji,jj) = Ve_rhs(ji,jj) + r1_rho0 * vtau(ji,jj) * r1_hv(ji,jj,Kbb)
+ Ue_rhs(ji,jj) = Ue_rhs(ji,jj) + r1_rho0 * utauU(ji,jj) * r1_hu(ji,jj,Kbb)
+ Ve_rhs(ji,jj) = Ve_rhs(ji,jj) + r1_rho0 * vtauV(ji,jj) * r1_hv(ji,jj,Kbb)
END_2D
ELSE
zztmp = r1_rho0 * r1_2
DO_2D( 0, 0, 0, 0 )
- Ue_rhs(ji,jj) = Ue_rhs(ji,jj) + zztmp * ( utau_b(ji,jj) + utau(ji,jj) ) * r1_hu(ji,jj,Kbb)
- Ve_rhs(ji,jj) = Ve_rhs(ji,jj) + zztmp * ( vtau_b(ji,jj) + vtau(ji,jj) ) * r1_hv(ji,jj,Kbb)
+ Ue_rhs(ji,jj) = Ue_rhs(ji,jj) + zztmp * ( utau_b(ji,jj) + utauU(ji,jj) ) * r1_hu(ji,jj,Kbb)
+ Ve_rhs(ji,jj) = Ve_rhs(ji,jj) + zztmp * ( vtau_b(ji,jj) + vtauV(ji,jj) ) * r1_hv(ji,jj,Kbb)
END_2D
ENDIF
!
@@ -172,10 +179,10 @@ CONTAINS
ELSE ! CENTRED integration: use kt-1/2 + kt+1/2 pressure (NOW)
zztmp = grav * r1_2
DO_2D( 0, 0, 0, 0 )
- Ue_rhs(ji,jj) = Ue_rhs(ji,jj) + zztmp * ( ssh_ib (ji+1,jj ) - ssh_ib (ji,jj) &
- & + ssh_ibb(ji+1,jj ) - ssh_ibb(ji,jj) ) * r1_e1u(ji,jj)
- Ve_rhs(ji,jj) = Ve_rhs(ji,jj) + zztmp * ( ssh_ib (ji ,jj+1) - ssh_ib (ji,jj) &
- & + ssh_ibb(ji ,jj+1) - ssh_ibb(ji,jj) ) * r1_e2v(ji,jj)
+ Ue_rhs(ji,jj) = Ue_rhs(ji,jj) + zztmp * ( ( ssh_ib (ji+1,jj ) - ssh_ib (ji,jj) ) & ! add () for NP repro
+ & + ( ssh_ibb(ji+1,jj ) - ssh_ibb(ji,jj) ) ) * r1_e1u(ji,jj)
+ Ve_rhs(ji,jj) = Ve_rhs(ji,jj) + zztmp * ( ( ssh_ib (ji ,jj+1) - ssh_ib (ji,jj) ) & ! add () for NP repro
+ & + ( ssh_ibb(ji ,jj+1) - ssh_ibb(ji,jj) ) ) * r1_e2v(ji,jj)
END_2D
ENDIF
ENDIF
diff --git a/src/OCE/stpctl.F90 b/src/OCE/stpctl.F90
index 96358bf94048c1bae16bd72d84b1f7cfb50e748d..b8cc8aaa185c33d60b3c496adf771dc85f7d5ecf 100644
--- a/src/OCE/stpctl.F90
+++ b/src/OCE/stpctl.F90
@@ -231,7 +231,7 @@ CONTAINS
iloc(1:3,3) = MINLOC( ts(:,:,:,jp_sal,Kmm) , mask = llmsk(:,:,:) )
iloc(1:3,4) = MAXLOC( ts(:,:,:,jp_sal,Kmm) , mask = llmsk(:,:,:) )
DO ji = 1, jptst ! local domain indices ==> global domain indices, excluding halos
- iloc(1:2,ji) = (/ mig0(iloc(1,ji)), mjg0(iloc(2,ji)) /)
+ iloc(1:2,ji) = (/ mig(iloc(1,ji),0), mjg(iloc(2,ji),0) /)
END DO
iareamin(:) = narea ; iareamax(:) = narea ; iareasum(:) = 1 ! this is local information
ENDIF
diff --git a/src/OCE/stpmlf.F90 b/src/OCE/stpmlf.F90
index 32eb6c8d5a7feb4f0aa9aebe0e834272bae4cbe7..04667fa6dee792e4059836f2559cdaa6028cfe08 100644
--- a/src/OCE/stpmlf.F90
+++ b/src/OCE/stpmlf.F90
@@ -93,7 +93,6 @@ CONTAINS
!! -8- Outputs and diagnostics
!!----------------------------------------------------------------------
INTEGER :: ji, jj, jk, jn, jtile ! dummy loop indice
- REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zgdept
!! ---------------------------------------------------------------------
#if defined key_agrif
IF( nstop > 0 ) RETURN ! avoid to go further if an error was detected during previous time step (child grid)
@@ -164,6 +163,8 @@ CONTAINS
IF( ln_bdy ) CALL bdy_dta ( kstp, Nnn ) ! update dynamic & tracer data at open boundaries
IF( ln_isf ) CALL isf_stp ( kstp, Nnn )
CALL sbc ( kstp, Nbb, Nnn ) ! Sea Boundary Condition (including sea-ice)
+!!$ IF( ln_isf ) CALL isf_stp ( kstp, Nnn )
+ !clem: problem with isf and cpl: sbcfwb needs isf but isf needs fwf from sbccpl
!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
! Update stochastic parameters and random T/S fluctuations
@@ -190,21 +191,12 @@ CONTAINS
! LATERAL PHYSICS
!
- IF( ln_zps .OR. l_ldfslp ) CALL eos( ts(:,:,:,:,Nbb), rhd, gdept_0(:,:,:) ) ! before in situ density
-
- IF( ln_zps .AND. .NOT. ln_isfcav) &
- & CALL zps_hde ( kstp, jpts, ts(:,:,:,:,Nbb), gtsu, gtsv, & ! Partial steps: before horizontal gradient
- & rhd, gru , grv ) ! of t, s, rd at the last ocean level
-
- IF( ln_zps .AND. ln_isfcav) &
- & CALL zps_hde_isf( kstp, jpts, ts(:,:,:,:,Nbb), gtsu, gtsv, gtui, gtvi, & ! Partial steps for top cell (ISF)
- & rhd, gru , grv , grui, grvi ) ! of t, s, rd at the first ocean level
-
IF( l_ldfslp ) THEN ! slope of lateral mixing
IF( ln_traldf_triad ) THEN
CALL ldf_slp_triad( kstp, Nbb, Nnn ) ! before slope for triad operator
ELSE
- CALL ldf_slp ( kstp, rhd, rn2b, Nbb, Nnn ) ! before slope for standard operator
+ CALL eos ( ts, Nbb, rhd ) ! before in situ density
+ CALL ldf_slp( kstp, rhd, rn2b, Nbb, Nnn ) ! before slope for standard operator
ENDIF
ENDIF
! ! eddy diffusivity coeff.
@@ -214,7 +206,7 @@ CONTAINS
!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
! Ocean dynamics : hdiv, ssh, e3, u, v, w
!<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
-
+
CALL ssh_nxt ( kstp, Nbb, Nnn, ssh, Naa ) ! after ssh (includes call to div_hor)
IF( .NOT.lk_linssh ) THEN
CALL dom_qco_r3c( ssh(:,:,Naa), r3t(:,:,Naa), r3u(:,:,Naa), r3v(:,:,Naa) ) ! "after" ssh/h_0 ratio at t,u,v pts
@@ -223,12 +215,7 @@ CONTAINS
ENDIF
CALL wzv ( kstp, Nbb, Nnn, Naa, ww ) ! Nnn cross-level velocity
IF( ln_zad_Aimp ) CALL wAimp ( kstp, Nnn ) ! Adaptive-implicit vertical advection partitioning
- ALLOCATE( zgdept(jpi,jpj,jpk) )
- DO jk = 1, jpk
- zgdept(:,:,jk) = gdept(:,:,jk,Nnn)
- END DO
- CALL eos ( ts(:,:,:,:,Nnn), rhd, rhop, zgdept ) ! now in situ density for hpg computation
- DEALLOCATE( zgdept )
+ CALL eos ( ts, Nnn, rhd, rhop ) ! now in situ density for hpg computation
uu(:,:,:,Nrhs) = 0._wp ! set dynamics trends to zero
vv(:,:,:,Nrhs) = 0._wp
@@ -554,8 +541,8 @@ CONTAINS
CALL lbc_lnk( 'finalize_lbc', puu(:,:,:, Kaa), 'U', -1., pvv(:,:,: ,Kaa), 'V', -1. &
& , pts(:,:,:,jp_tem,Kaa), 'T', 1., pts(:,:,:,jp_sal,Kaa), 'T', 1. )
!
- ! lbc_lnk needed for zdf_sh2 when using nn_hls = 2, moved here to allow tiling in zdf_phy
- IF( nn_hls == 2 .AND. l_zdfsh2 ) CALL lbc_lnk( 'stp', avm_k, 'W', 1.0_wp )
+ ! lbc_lnk needed for zdf_sh2, moved here to allow tiling in zdf_phy
+ IF( l_zdfsh2 ) CALL lbc_lnk( 'stp', avm_k, 'W', 1.0_wp )
! dom_qco_r3c defines over [nn_hls, nn_hls-1, nn_hls, nn_hls-1]
IF( nn_hls == 2 .AND. .NOT. lk_linssh ) THEN
diff --git a/src/OCE/stprk3.F90 b/src/OCE/stprk3.F90
index 337b55f62beb10f4c27aa80a4aa551ced1d860f7..e535e9e9628f0c52a51a63589187faf87b91b5e9 100644
--- a/src/OCE/stprk3.F90
+++ b/src/OCE/stprk3.F90
@@ -127,6 +127,8 @@ CONTAINS
IF( ln_bdy ) CALL bdy_dta ( kstp, Nbb ) ! update dynamic & tracer data at open boundaries
IF( ln_isf ) CALL isf_stp ( kstp, Nbb ) ! update iceshelf geometry
CALL sbc ( kstp, Nbb, Nbb ) ! Sea Boundary Condition (including sea-ice)
+!!$ IF( ln_isf ) CALL isf_stp ( kstp, Nbb ) ! update iceshelf geometry
+ !clem: problem with isf and cpl: sbcfwb needs isf but isf needs fwf from sbccpl
!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
! Update stochastic parameters and random T/S fluctuations
@@ -157,21 +159,12 @@ CONTAINS
!!gm gdep
! LATERAL PHYSICS
!
- IF( ln_zps .OR. l_ldfslp ) CALL eos( ts(:,:,:,:,Nbb), rhd, gdept_0(:,:,:) ) ! before in situ density
-
- IF( ln_zps .AND. .NOT. ln_isfcav) &
- & CALL zps_hde ( kstp, jpts, ts(:,:,:,:,Nbb), gtsu, gtsv, & ! Partial steps: before horizontal gradient
- & rhd, gru , grv ) ! of t, s, rd at the last ocean level
-
- IF( ln_zps .AND. ln_isfcav) &
- & CALL zps_hde_isf( kstp, jpts, ts(:,:,:,:,Nbb), gtsu, gtsv, gtui, gtvi, & ! Partial steps for top cell (ISF)
- & rhd, gru , grv , grui, grvi ) ! of t, s, rd at the first ocean level
-
IF( l_ldfslp ) THEN ! slope of lateral mixing
IF( ln_traldf_triad ) THEN
- CALL ldf_slp_triad( kstp, Nbb, Nbb ) ! before slope for triad operator
+ CALL ldf_slp_triad( kstp, Nbb, Nbb ) ! before slope for triad operator
ELSE
- CALL ldf_slp ( kstp, rhd, rn2b, Nbb, Nbb ) ! before slope for standard operator
+ CALL eos ( ts, Nbb, rhd ) ! before in situ density
+ CALL ldf_slp( kstp, rhd, rn2b, Nbb, Nbb ) ! before slope for standard operator
ENDIF
ENDIF
! ! eddy diffusivity coeff.
diff --git a/src/OCE/stprk3_stg.F90 b/src/OCE/stprk3_stg.F90
index e413a253838843634932a85a233ffe12ab7193cc..63395d5c34bce7a11bd35d46b8de00f6d3eb441d 100644
--- a/src/OCE/stprk3_stg.F90
+++ b/src/OCE/stprk3_stg.F90
@@ -317,7 +317,7 @@ CONTAINS
ts(:,:,:,jn,Krhs) = 0._wp ! set tracer trends to zero (:,:,:) needed otherwise it does not work (?)
END DO
- CALL eos( ts(:,:,:,:,Kmm), rhd, rhop, gdept_0 ) ! now in potential density for tra_mle computation
+ CALL eos( ts, Kmm, rhd, rhop ) ! now in potential density for tra_mle computation
!===>>> CAUTION here may be without GM velocity but stokes drift required ! 0 barotropic divergence for GM != 0 barotropic divergence for SD
!!st consistence 2D / 3D - flux de masse
CALL tra_adv( kstp, Kbb, Kmm, Kaa, ts, Krhs, zaU, zaV, ww ) ! hor. + vert. advection ==> RHS
@@ -428,14 +428,15 @@ CONTAINS
END SELECT
! !== correction of the barotropic (all stages) ==! at Kaa = N+1/3, N+1/2 or N+1
! ! barotropic velocity correction
- zub(A2D(0)) = uu_b(A2D(0),Kaa) - SUM( e3u_0(A2D(0),:)*uu(A2D(0),:,Kaa), 3 ) * r1_hu_0(A2D(0))
- zvb(A2D(0)) = vv_b(A2D(0),Kaa) - SUM( e3v_0(A2D(0),:)*vv(A2D(0),:,Kaa), 3 ) * r1_hv_0(A2D(0))
+ DO_2D( 0, 0, 0, 0 )
+ zub(ji,jj) = uu_b(ji,jj,Kaa) - SUM( e3u_0(ji,jj,:)*uu(ji,jj,:,Kaa) ) * r1_hu_0(ji,jj)
+ zvb(ji,jj) = vv_b(ji,jj,Kaa) - SUM( e3v_0(ji,jj,:)*vv(ji,jj,:,Kaa) ) * r1_hv_0(ji,jj)
+ END_2D
!
DO jk = 1, jpkm1 ! corrected horizontal velocity
- uu(A2D(0),jk,Kaa) = uu(A2D(0),jk,Kaa) + zub(A2D(0))*umask(A2D(0),jk)
- vv(A2D(0),jk,Kaa) = vv(A2D(0),jk,Kaa) + zvb(A2D(0))*vmask(A2D(0),jk)
+ uu(T2D(0),jk,Kaa) = uu(T2D(0),jk,Kaa) + zub(T2D(0))*umask(T2D(0),jk)
+ vv(T2D(0),jk,Kaa) = vv(T2D(0),jk,Kaa) + zvb(T2D(0))*vmask(T2D(0),jk)
END DO
-
!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
! Set boundary conditions
diff --git a/src/OCE/trc_oce.F90 b/src/OCE/trc_oce.F90
index f7b8309ee1cf970be0bbca6954d5c308ee667b70..28a2f7fcfe73fa0e72ce93a7599333da975615fe 100644
--- a/src/OCE/trc_oce.F90
+++ b/src/OCE/trc_oce.F90
@@ -43,6 +43,9 @@ MODULE trc_oce
!!----------------------------------------------------------------------
LOGICAL, PUBLIC, PARAMETER :: lk_top = .FALSE. !: TOP model
#endif
+
+ !! * Substitutions
+# include "do_loop_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
!! $Id: trc_oce.F90 13286 2020-07-09 15:48:29Z smasson $
@@ -54,7 +57,7 @@ CONTAINS
!!----------------------------------------------------------------------
!! *** trc_oce_alloc ***
!!----------------------------------------------------------------------
- ALLOCATE( etot3(jpi,jpj,jpk), oce_co2(jpi,jpj), qsr_mean(jpi,jpj), STAT=trc_oce_alloc )
+ ALLOCATE( etot3(A2D(0),jpk), oce_co2(A2D(0)), qsr_mean(A2D(0)), STAT=trc_oce_alloc )
IF( trc_oce_alloc /= 0 ) CALL ctl_warn('trc_oce_alloc: failed to allocate etot3 array')
!
@@ -247,7 +250,11 @@ CONTAINS
pjl = jpkm1
DO jk = jpkm1, 1, -1
IF(SUM(tmask(:,:,jk)) > 0 ) THEN
- zem = MAXVAL( gdepw_0(:,:,jk+1) * tmask(:,:,jk) )
+#if defined key_vco_3d
+ zem = MAXVAL( gdepw_3d(:,:,jk+1) * tmask(:,:,jk) )
+#else
+ zem = MAXVAL( gdepw_1d(jk+1) * tmask(:,:,jk) )
+#endif
IF( zem >= zhext ) pjl = jk ! last T-level reached by Qsr
ELSE
pjl = jk ! or regional sea-bed depth
diff --git a/src/OFF/dtadyn.F90 b/src/OFF/dtadyn.F90
index 3a68e3128e1e596f150662a3e74f17d1e957059d..aed7dfb5c9a29aa077fea2856deec25aa9901dde 100644
--- a/src/OFF/dtadyn.F90
+++ b/src/OFF/dtadyn.F90
@@ -24,8 +24,6 @@ MODULE dtadyn
USE dom_oce ! ocean domain: variables
#if defined key_qco
USE domqco ! variable volume
-#elif ! defined key_linssh
- USE domvvl
#endif
USE zdf_oce ! ocean vertical physics: variables
USE sbc_oce ! surface module: variables
@@ -38,7 +36,6 @@ MODULE dtadyn
USE zdfmxl ! vertical physics: mixed layer depth
USE eosbn2 ! equation of state - Brunt Vaisala frequency
USE lbclnk ! ocean lateral boundary conditions (or mpp link)
- USE zpshde ! z-coord. with partial steps: horizontal derivatives
USE in_out_manager ! I/O manager
USE iom ! I/O library
USE lib_mpp ! distributed memory computing library
@@ -80,7 +77,7 @@ MODULE dtadyn
INTEGER , SAVE :: jf_wnd ! index of wind speed
INTEGER , SAVE :: jf_ice ! index of sea ice cover
INTEGER , SAVE :: jf_rnf ! index of river runoff
- INTEGER , SAVE :: jf_fmf ! index of downward salt flux
+ INTEGER , SAVE :: jf_fwf ! index of downward freshwater flux
INTEGER , SAVE :: jf_ubl ! index of u-bbl coef
INTEGER , SAVE :: jf_vbl ! index of v-bbl coef
INTEGER , SAVE :: jf_div ! index of e3t
@@ -136,15 +133,15 @@ CONTAINS
!
IF( l_ldfslp .AND. .NOT.ln_c1d ) CALL dta_dyn_slp( kt, Kbb, Kmm ) ! Computation of slopes
!
- ts(:,:,:,jp_tem,Kmm) = sf_dyn(jf_tem)%fnow(:,:,:) * tmask(:,:,:) ! temperature
- ts(:,:,:,jp_sal,Kmm) = sf_dyn(jf_sal)%fnow(:,:,:) * tmask(:,:,:) ! salinity
- wndm(:,:) = sf_dyn(jf_wnd)%fnow(:,:,1) * tmask(:,:,1) ! wind speed - needed for gas exchange
- fmmflx(:,:) = sf_dyn(jf_fmf)%fnow(:,:,1) * tmask(:,:,1) ! downward salt flux (v3.5+)
- fr_i(:,:) = sf_dyn(jf_ice)%fnow(:,:,1) * tmask(:,:,1) ! Sea-ice fraction
- qsr (:,:) = sf_dyn(jf_qsr)%fnow(:,:,1) * tmask(:,:,1) ! solar radiation
- emp (:,:) = sf_dyn(jf_emp)%fnow(:,:,1) * tmask(:,:,1) ! E-P
+ ts(:,:,:,jp_tem,Kmm) = sf_dyn(jf_tem)%fnow(:,:,:) * tmask (:,:,:) ! temperature
+ ts(:,:,:,jp_sal,Kmm) = sf_dyn(jf_sal)%fnow(:,:,:) * tmask (:,:,:) ! salinity
+ wndm(:,:) = sf_dyn(jf_wnd)%fnow(:,:,1) * smask0(:,:) ! wind speed - needed for gas exchange
+ fwfice(:,:) = - sf_dyn(jf_fwf)%fnow(:,:,1) * smask0(:,:) ! ice-ocean freshwater flux (>0 to the ocean)
+ fr_i(:,:) = sf_dyn(jf_ice)%fnow(:,:,1) * tmask (:,:,1) ! Sea-ice fraction
+ qsr (:,:) = sf_dyn(jf_qsr)%fnow(:,:,1) * smask0(:,:) ! solar radiation
+ emp (:,:) = sf_dyn(jf_emp)%fnow(:,:,1) * tmask (:,:,1) ! E-P
IF( ln_dynrnf ) THEN
- rnf (:,:) = sf_dyn(jf_rnf)%fnow(:,:,1) * tmask(:,:,1) ! E-P
+ rnf (:,:) = sf_dyn(jf_rnf)%fnow(:,:,1) * tmask (:,:,1) ! rnf
IF( ln_dynrnf_depth .AND. .NOT. ln_linssh ) CALL dta_dyn_rnf( Kmm )
ENDIF
!
@@ -160,8 +157,8 @@ CONTAINS
#if defined key_qco
CALL dta_dyn_ssh( kt, zhdivtr, ssh(:,:,Kbb), zemp, ssh(:,:,Kaa) )
CALL dom_qco_r3c( ssh(:,:,Kaa), r3t(:,:,Kaa), r3u(:,:,Kaa), r3v(:,:,Kaa) )
-#else
- CALL dta_dyn_ssh( kt, zhdivtr, ssh(:,:,Kbb), zemp, ssh(:,:,Kaa), e3t(:,:,:,Kaa) ) != ssh, vertical scale factor
+#elif defined key_linssh
+ CALL dta_dyn_ssh( kt, zhdivtr, ssh(:,:,Kbb), zemp, ssh(:,:,Kaa) )
#endif
DEALLOCATE( zemp , zhdivtr )
! Write in the tracer restart file
@@ -175,16 +172,19 @@ CONTAINS
ENDIF
ENDIF
!
- CALL eos ( ts(:,:,:,:,Kmm), rhd, gdept_0(:,:,:) ) ! In any case, we need rhd
+ CALL eos ( ts(:,:,:,:,:), Kmm, rhd ) ! In any case, we need rhd
+!!st CALL eos ( ts(:,:,:,:,Kmm), rhd, gdept_0(:,:,:) ) ! In any case, we need rhd
CALL eos_rab( ts(:,:,:,:,Kmm), rab_n, Kmm ) ! now local thermal/haline expension ratio at T-points
CALL bn2 ( ts(:,:,:,:,Kmm), rab_n, rn2, Kmm ) ! before Brunt-Vaisala frequency need for zdfmxl
rn2b(:,:,:) = rn2(:,:,:) ! needed for zdfmxl
CALL zdf_mxl( kt, Kmm ) ! In any case, we need mxl
!
- hmld(:,:) = sf_dyn(jf_mld)%fnow(:,:,1) * tmask(:,:,1) ! mixed layer depht
- avt(:,:,:) = sf_dyn(jf_avt)%fnow(:,:,:) * tmask(:,:,:) ! vertical diffusive coefficient
- avs(:,:,:) = avt(:,:,:)
+ hmld(:,:) = sf_dyn(jf_mld)%fnow(:,:,1) * smask0(:,:) ! mixed layer depht
+ DO_3D( 0, 0, 0, 0, 1, jpk )
+ avt(ji,jj,jk) = sf_dyn(jf_avt)%fnow(ji,jj,jk) * tmask(ji,jj,jk) ! vertical diffusive coefficient
+ avs(ji,jj,jk) = avt(ji,jj,jk)
+ END_3D
!
IF( ln_trabbl .AND. .NOT.ln_c1d ) THEN ! diffusive Bottom boundary layer param
ahu_bbl(:,:) = sf_dyn(jf_ubl)%fnow(:,:,1) * umask(:,:,1) ! bbl diffusive coef
@@ -192,7 +192,8 @@ CONTAINS
ENDIF
!
!
- CALL eos( ts(:,:,:,:,Kmm), rhd, gdept_0(:,:,:) ) ! In any case, we need rhd
+ CALL eos ( ts(:,:,:,:,:), Kmm, rhd ) ! In any case, we need rhd
+!!st CALL eos( ts(:,:,:,:,Kmm), rhd, gdept_0(:,:,:) ) ! In any case, we need rhd
!
IF(sn_cfctl%l_prtctl) THEN ! print control
CALL prt_ctl(tab3d_1=ts(:,:,:,jp_tem,Kmm), clinfo1=' tn - : ', mask1=tmask )
@@ -224,20 +225,20 @@ CONTAINS
INTEGER :: jfld ! dummy loop arguments
INTEGER :: inum, idv, idimv ! local integer
INTEGER :: ios ! Local integer output status for namelist read
- INTEGER :: ji, jj, jk
+ INTEGER :: ji, jj, jk, ipk
!!
CHARACTER(len=100) :: cn_dir ! Root directory for location of core files
TYPE(FLD_N), DIMENSION(jpfld) :: slf_d ! array of namelist informations on the fields to read
TYPE(FLD_N) :: sn_uwd, sn_vwd, sn_wwd, sn_empb, sn_emp ! informations about the fields to be read
TYPE(FLD_N) :: sn_tem , sn_sal , sn_avt ! " "
- TYPE(FLD_N) :: sn_mld, sn_qsr, sn_wnd , sn_ice , sn_fmf ! " "
+ TYPE(FLD_N) :: sn_mld, sn_qsr, sn_wnd , sn_ice , sn_fwf ! " "
TYPE(FLD_N) :: sn_ubl, sn_vbl, sn_rnf ! " "
TYPE(FLD_N) :: sn_div ! informations about the fields to be read
!!
NAMELIST/namdta_dyn/cn_dir, ln_dynrnf, ln_dynrnf_depth, &
& sn_uwd, sn_vwd, sn_wwd, sn_emp, &
& sn_avt, sn_tem, sn_sal, sn_mld , sn_qsr , &
- & sn_wnd, sn_ice, sn_fmf, &
+ & sn_wnd, sn_ice, sn_fwf, &
& sn_ubl, sn_vbl, sn_rnf, &
& sn_empb, sn_div
!!----------------------------------------------------------------------
@@ -261,13 +262,13 @@ CONTAINS
!
jf_uwd = 1 ; jf_vwd = 2 ; jf_wwd = 3 ; jf_emp = 4 ; jf_avt = 5
jf_tem = 6 ; jf_sal = 7 ; jf_mld = 8 ; jf_qsr = 9
- jf_wnd = 10 ; jf_ice = 11 ; jf_fmf = 12 ; jfld = jf_fmf
+ jf_wnd = 10 ; jf_ice = 11 ; jf_fwf = 12 ; jfld = jf_fwf
!
slf_d(jf_uwd) = sn_uwd ; slf_d(jf_vwd) = sn_vwd ; slf_d(jf_wwd) = sn_wwd
slf_d(jf_emp) = sn_emp ; slf_d(jf_avt) = sn_avt
slf_d(jf_tem) = sn_tem ; slf_d(jf_sal) = sn_sal ; slf_d(jf_mld) = sn_mld
slf_d(jf_qsr) = sn_qsr ; slf_d(jf_wnd) = sn_wnd ; slf_d(jf_ice) = sn_ice
- slf_d(jf_fmf) = sn_fmf
+ slf_d(jf_fwf) = sn_fwf
!
IF( .NOT.ln_linssh ) THEN
jf_div = jfld + 1 ; jf_empb = jfld + 2 ; jfld = jf_empb
@@ -308,12 +309,15 @@ CONTAINS
idimv = iom_file ( sf_dyn(ifpr)%num )%ndims(idv) ! number of dimension for variable sdjf%clvar
CALL iom_close( sf_dyn(ifpr)%num ) ! close file if already open
ierr1=0
- IF( idimv == 3 ) THEN ! 2D variable
- ALLOCATE( sf_dyn(ifpr)%fnow(jpi,jpj,1) , STAT=ierr0 )
- IF( slf_d(ifpr)%ln_tint ) ALLOCATE( sf_dyn(ifpr)%fdta(jpi,jpj,1,2) , STAT=ierr1 )
- ELSE ! 3D variable
- ALLOCATE( sf_dyn(ifpr)%fnow(jpi,jpj,jpk) , STAT=ierr0 )
- IF( slf_d(ifpr)%ln_tint ) ALLOCATE( sf_dyn(ifpr)%fdta(jpi,jpj,jpk,2), STAT=ierr1 )
+ IF( idimv == 3 ) THEN ; ipk = 1 ! 2D variable
+ ELSE ; ipk = jpk ! 3D variable
+ ENDIF
+ IF( ifpr == jf_mld .OR. ifpr == jf_qsr .OR. ifpr == jf_wnd .OR. ifpr == jf_fwf .OR. ifpr == jf_avt ) THEN
+ ALLOCATE( sf_dyn(ifpr)%fnow(A2D(0),ipk) , STAT=ierr0 )
+ IF( slf_d(ifpr)%ln_tint ) ALLOCATE( sf_dyn(ifpr)%fdta(A2D(0),ipk,2) , STAT=ierr1 )
+ ELSE
+ ALLOCATE( sf_dyn(ifpr)%fnow(jpi,jpj,ipk) , STAT=ierr0 )
+ IF( slf_d(ifpr)%ln_tint ) ALLOCATE( sf_dyn(ifpr)%fdta(jpi,jpj,ipk,2), STAT=ierr1 )
ENDIF
IF( ierr0 + ierr1 > 0 ) THEN
CALL ctl_stop( 'dta_dyn_init : unable to allocate sf_dyn array structure' ) ; RETURN
@@ -349,14 +353,6 @@ CONTAINS
#if defined key_qco
CALL dom_qco_r3c( ssh(:,:,Kbb), r3t(:,:,Kbb), r3u(:,:,Kbb), r3v(:,:,Kbb) )
CALL dom_qco_r3c( ssh(:,:,Kmm), r3t(:,:,Kmm), r3u(:,:,Kmm), r3v(:,:,Kmm) )
-#else
- DO jk = 1, jpkm1
- e3t(:,:,jk,Kmm) = e3t_0(:,:,jk) * ( 1._wp + ssh(:,:,Kmm) * r1_ht_0(:,:) * tmask(:,:,jk) )
- e3t(:,:,jk,Kbb) = e3t_0(:,:,jk) * ( 1._wp + ssh(:,:,Kbb) * r1_ht_0(:,:) * tmask(:,:,jk) )
- ENDDO
-
- CALL dta_dyn_sf_interp( nit000, Kmm )
- CALL dta_dyn_sf_interp( nit000, Kbb )
#endif
#endif
ENDIF
@@ -392,47 +388,6 @@ CONTAINS
END SUBROUTINE dta_dyn_atf
-#if ! defined key_qco && ! defined key_linssh
-
- SUBROUTINE dta_dyn_sf_interp( kt, Kmm )
- !!---------------------------------------------------------------------
- !! *** ROUTINE dta_dyn_sf_interp ***
- !!
- !! ** Purpose : Calculate scale factors at U/V/W points and depths
- !! given the after e3t field
- !!---------------------------------------------------------------------
- INTEGER, INTENT(in) :: kt ! time step
- INTEGER, INTENT(in) :: Kmm ! ocean time level indices
- !
- INTEGER :: ji, jj, jk
- REAL(wp) :: zcoef
- !!---------------------------------------------------------------------
-
- ! Horizontal scale factor interpolations
- ! --------------------------------------
- CALL dom_vvl_interpol( e3t(:,:,:,Kmm), e3u(:,:,:,Kmm), 'U' )
- CALL dom_vvl_interpol( e3t(:,:,:,Kmm), e3v(:,:,:,Kmm), 'V' )
-
- ! Vertical scale factor interpolations
- ! ------------------------------------
- CALL dom_vvl_interpol( e3t(:,:,:,Kmm), e3w (:,:,:,Kmm), 'W' )
-
- ! t- and w- points depth
- ! ----------------------
- gdept(:,:,1,Kmm) = 0.5_wp * e3w(:,:,1,Kmm)
- gdepw(:,:,1,Kmm) = 0.0_wp
- !
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 2, jpk )
- zcoef = (tmask(ji,jj,jk) - wmask(ji,jj,jk))
- gdepw(ji,jj,jk,Kmm) = gdepw(ji,jj,jk-1,Kmm) + e3t(ji,jj,jk-1,Kmm)
- gdept(ji,jj,jk,Kmm) = zcoef * ( gdepw(ji,jj,jk ,Kmm) + 0.5 * e3w(ji,jj,jk,Kmm)) &
- & + (1-zcoef) * ( gdept(ji,jj,jk-1,Kmm) + e3w(ji,jj,jk,Kmm))
- END_3D
- !
- END SUBROUTINE dta_dyn_sf_interp
-
-#endif
-
SUBROUTINE dta_dyn_ssh( kt, phdivtr, psshb, pemp, pssha, pe3ta )
!!----------------------------------------------------------------------
!! *** ROUTINE dta_dyn_wzv ***
@@ -506,7 +461,7 @@ CONTAINS
CALL iom_close( inum ) ! close file
!
nk_rnf(:,:) = 0 ! set the number of level over which river runoffs are applied
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
IF( h_rnf(ji,jj) > 0._wp ) THEN
jk = 2
DO WHILE ( jk /= mbkt(ji,jj) .AND. gdept_0(ji,jj,jk) < h_rnf(ji,jj) ) ; jk = jk + 1
@@ -521,15 +476,17 @@ CONTAINS
END_2D
!
! set the associated depth
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
h_rnf(ji,jj) = 0._wp
DO jk = 1, nk_rnf(ji,jj)
h_rnf(ji,jj) = h_rnf(ji,jj) + e3t(ji,jj,jk,Kmm)
END DO
END_2D
ELSE ! runoffs applied at the surface
- nk_rnf(:,:) = 1
- h_rnf (:,:) = e3t(:,:,1,Kmm)
+ DO_2D( 0, 0, 0, 0 )
+ nk_rnf(ji,jj) = 1
+ h_rnf (ji,jj) = e3t(ji,jj,1,Kmm)
+ END_2D
ENDIF
nkrnf_max = MAXVAL( nk_rnf(:,:) )
hrnf_max = MAXVAL( h_rnf(:,:) )
@@ -557,7 +514,7 @@ CONTAINS
!!----------------------------------------------------------------------
!
! update the depth over which runoffs are distributed
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
h_rnf(ji,jj) = 0._wp
DO jk = 1, nk_rnf(ji,jj) ! recalculates h_rnf to be the depth in metres
h_rnf(ji,jj) = h_rnf(ji,jj) + e3t(ji,jj,jk,Kmm) ! to the bottom of the relevant grid box
@@ -576,7 +533,7 @@ CONTAINS
INTEGER, INTENT(in) :: kt ! time step
INTEGER, INTENT(in) :: Kbb, Kmm ! ocean time level indices
!
- INTEGER :: ji, jj ! dummy loop indices
+ INTEGER :: ji, jj, jk ! dummy loop indices
REAL(wp) :: ztinta ! ratio applied to after records when doing time interpolation
REAL(wp) :: ztintb ! ratio applied to before records when doing time interpolation
INTEGER :: iswap
@@ -589,8 +546,10 @@ CONTAINS
IF( kt == nit000 ) THEN
IF(lwp) WRITE(numout,*) ' Compute new slopes at kt = ', kt
zts(:,:,:,jp_tem) = sf_dyn(jf_tem)%fdta(:,:,:,sf_dyn(jf_tem)%nbb) * tmask(:,:,:) ! temperature
- zts(:,:,:,jp_sal) = sf_dyn(jf_sal)%fdta(:,:,:,sf_dyn(jf_sal)%nbb) * tmask(:,:,:) ! salinity
- avt(:,:,:) = sf_dyn(jf_avt)%fdta(:,:,:,sf_dyn(jf_avt)%nbb) * tmask(:,:,:) ! vertical diffusive coef.
+ zts(:,:,:,jp_sal) = sf_dyn(jf_sal)%fdta(:,:,:,sf_dyn(jf_sal)%nbb) * tmask(:,:,:) ! salinity
+ DO_3D( 0, 0, 0, 0, 1, jpk )
+ avt(ji,jj,jk) = sf_dyn(jf_avt)%fdta(ji,jj,jk,sf_dyn(jf_avt)%nbb) * tmask(ji,jj,jk) ! vertical diffusive coef.
+ END_3D
CALL compute_slopes( kt, zts, zuslp, zvslp, zwslpi, zwslpj, Kbb, Kmm )
uslpdta (:,:,:,1) = zuslp (:,:,:)
vslpdta (:,:,:,1) = zvslp (:,:,:)
@@ -599,7 +558,9 @@ CONTAINS
!
zts(:,:,:,jp_tem) = sf_dyn(jf_tem)%fdta(:,:,:,sf_dyn(jf_tem)%naa) * tmask(:,:,:) ! temperature
zts(:,:,:,jp_sal) = sf_dyn(jf_sal)%fdta(:,:,:,sf_dyn(jf_sal)%naa) * tmask(:,:,:) ! salinity
- avt(:,:,:) = sf_dyn(jf_avt)%fdta(:,:,:,sf_dyn(jf_avt)%naa) * tmask(:,:,:) ! vertical diffusive coef.
+ DO_3D( 0, 0, 0, 0, 1, jpk )
+ avt(ji,jj,jk) = sf_dyn(jf_avt)%fdta(ji,jj,jk,sf_dyn(jf_avt)%naa) * tmask(ji,jj,jk) ! vertical diffusive coef.
+ END_3D
CALL compute_slopes( kt, zts, zuslp, zvslp, zwslpi, zwslpj, Kbb, Kmm )
uslpdta (:,:,:,2) = zuslp (:,:,:)
vslpdta (:,:,:,2) = zvslp (:,:,:)
@@ -618,7 +579,9 @@ CONTAINS
!
zts(:,:,:,jp_tem) = sf_dyn(jf_tem)%fdta(:,:,:,sf_dyn(jf_tem)%naa) * tmask(:,:,:) ! temperature
zts(:,:,:,jp_sal) = sf_dyn(jf_sal)%fdta(:,:,:,sf_dyn(jf_sal)%naa) * tmask(:,:,:) ! salinity
- avt(:,:,:) = sf_dyn(jf_avt)%fdta(:,:,:,sf_dyn(jf_avt)%naa) * tmask(:,:,:) ! vertical diffusive coef.
+ DO_3D( 0, 0, 0, 0, 1, jpk )
+ avt(ji,jj,jk) = sf_dyn(jf_avt)%fdta(ji,jj,jk,sf_dyn(jf_avt)%naa) * tmask(ji,jj,jk) ! vertical diffusive coef.
+ END_3D
CALL compute_slopes( kt, zts, zuslp, zvslp, zwslpi, zwslpj, Kbb, Kmm )
!
uslpdta (:,:,:,2) = zuslp (:,:,:)
@@ -642,7 +605,9 @@ CONTAINS
ELSE
zts(:,:,:,jp_tem) = sf_dyn(jf_tem)%fnow(:,:,:) * tmask(:,:,:) ! temperature
zts(:,:,:,jp_sal) = sf_dyn(jf_sal)%fnow(:,:,:) * tmask(:,:,:) ! salinity
- avt(:,:,:) = sf_dyn(jf_avt)%fnow(:,:,:) * tmask(:,:,:) ! vertical diffusive coef.
+ DO_3D( 0, 0, 0, 0, 1, jpk )
+ avt(ji,jj,jk) = sf_dyn(jf_avt)%fnow(ji,jj,jk) * tmask(ji,jj,jk) ! vertical diffusive coef.
+ END_3D
CALL compute_slopes( kt, zts, zuslp, zvslp, zwslpi, zwslpj, Kbb, Kmm )
!
IF( l_ldfslp .AND. .NOT.ln_c1d ) THEN ! Computes slopes (here avt is used as workspace)
@@ -670,19 +635,17 @@ CONTAINS
INTEGER , INTENT(in ) :: Kbb, Kmm ! ocean time level indices
!!---------------------------------------------------------------------
!
+ INTEGER :: ji,jj, jk ! dummy loop indices
+ REAL(wp), DIMENSION(jpi,jpj,jpk) :: zdep0
+ !
+ DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpk )
+ zdep0(ji,jj,jk) = gdept_0(ji,jj,jk)
+ END_3D
IF( l_ldfslp .AND. .NOT.ln_c1d ) THEN ! Computes slopes (here avt is used as workspace)
- CALL eos ( pts, rhd, gdept_0(:,:,:) )
+ CALL eos ( pts, rhd, zdep0 )
CALL eos_rab( pts, rab_n, Kmm ) ! now local thermal/haline expension ratio at T-points
CALL bn2 ( pts, rab_n, rn2, Kmm ) ! now Brunt-Vaisala
- ! Partial steps: before Horizontal DErivative
- IF( ln_zps .AND. .NOT. ln_isfcav) &
- & CALL zps_hde ( kt, jpts, pts, gtsu, gtsv, & ! Partial steps: before horizontal gradient
- & rhd, gru , grv ) ! of t, s, rd at the last ocean level
- IF( ln_zps .AND. ln_isfcav) &
- & CALL zps_hde_isf( kt, jpts, pts, gtsu, gtsv, gtui, gtvi, & ! Partial steps for top cell (ISF)
- & rhd, gru , grv , grui, grvi ) ! of t, s, rd at the first ocean level
-
rn2b(:,:,:) = rn2(:,:,:) ! needed for zdfmxl
CALL zdf_mxl( kt, Kmm ) ! mixed layer depth
CALL ldf_slp( kt, rhd, rn2, Kbb, Kmm ) ! slopes
@@ -716,6 +679,8 @@ CONTAINS
INTEGER, INTENT(in) :: Kmm ! ocean time level index
!
!!----------------------------------------------------------------------
+ INTEGER :: ji,jj, jk ! dummy loop indices
+ REAL(wp), DIMENSION(jpi,jpj,jpk) :: zdep0
!
IF( ln_timing ) CALL timing_start( 'dta_dyn_sed')
!
@@ -729,7 +694,10 @@ CONTAINS
ts(:,:,:,jp_tem,Kmm) = sf_dyn(jf_tem)%fnow(:,:,:) * tmask(:,:,:) ! temperature
ts(:,:,:,jp_sal,Kmm) = sf_dyn(jf_sal)%fnow(:,:,:) * tmask(:,:,:) ! salinity
!
- CALL eos ( ts(:,:,:,:,Kmm), rhd, gdept_0(:,:,:) ) ! In any case, we need rhd
+ DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpk )
+ zdep0(ji,jj,jk) = gdept_0(ji,jj,jk)
+ END_3D
+ CALL eos ( ts(:,:,:,:,Kmm), rhd, zdep0 ) ! In any case, we need rhd
IF(sn_cfctl%l_prtctl) THEN ! print control
CALL prt_ctl(tab3d_1=ts(:,:,:,jp_tem,Kmm), clinfo1=' tn - : ', mask1=tmask )
diff --git a/src/OFF/nemogcm.F90 b/src/OFF/nemogcm.F90
index 9e83a72731fbf1f2ad7821634dbb064606b0e729..536f3348dc111c16307324edfca1f68e1ea44164 100644
--- a/src/OFF/nemogcm.F90
+++ b/src/OFF/nemogcm.F90
@@ -121,6 +121,7 @@ CONTAINS
CALL iom_init( cxios_context ) ! iom_put initialization (must be done after nemo_init for AGRIF+XIOS+OASIS)
!
DO WHILE ( istp <= nitend .AND. nstop == 0 ) !== OFF time-stepping ==!
+ ncom_stp = istp
IF( ln_timing ) THEN
zstptiming = MPI_Wtime()
IF ( istp == ( nit000 + 1 ) ) elapsed_time = zstptiming
@@ -323,12 +324,6 @@ CONTAINS
!
CALL mpp_init
-#if defined key_loop_fusion
- IF( nn_hls == 1 ) THEN
- CALL ctl_stop( 'STOP', 'nemogcm : Loop fusion can be used only with extra-halo' )
- ENDIF
-#endif
-
CALL halo_mng_init()
! Now we know the dimensions of the grid and numout has been set: we can allocate arrays
CALL nemo_alloc()
diff --git a/src/SAS/diawri.F90 b/src/SAS/diawri.F90
index 68c13c0b4bf688444072644edc48f3936fe620c1..8d0c2ece3c67635cd2aa4e3e619c95e181949c68 100644
--- a/src/SAS/diawri.F90
+++ b/src/SAS/diawri.F90
@@ -317,22 +317,22 @@ CONTAINS
!
ENDIF
!
+ CALL histdef( nid_T, "sozotaux", "Wind Stress along i-axis" , "N/m2" , & ! utau
+ & jpi, jpj, nh_T, 1 , 1, 1 , - 99, 32, clop, zsto, zout )
+ CALL histdef( nid_T, "sometauy", "Wind Stress along j-axis" , "N/m2" , & ! vtau
+ & jpi, jpj, nh_T, 1 , 1, 1 , - 99, 32, clop, zsto, zout )
CALL histend( nid_T, snc4chunks=snc4set )
! !!! nid_U : 3D
CALL histdef( nid_U, "ssu_m", "Velocity component in x-direction", "m/s" , & ! ssu
& jpi, jpj, nh_U, 1 , 1, 1 , - 99, 32, clop, zsto, zout )
- CALL histdef( nid_U, "sozotaux", "Wind Stress along i-axis" , "N/m2" , & ! utau
- & jpi, jpj, nh_U, 1 , 1, 1 , - 99, 32, clop, zsto, zout )
CALL histend( nid_U, snc4chunks=snc4set )
! !!! nid_V : 3D
CALL histdef( nid_V, "ssv_m", "Velocity component in y-direction", "m/s", & ! ssv_m
& jpi, jpj, nh_V, 1 , 1, 1 , - 99, 32, clop, zsto, zout )
- CALL histdef( nid_V, "sometauy", "Wind Stress along j-axis" , "N/m2" , & ! vtau
- & jpi, jpj, nh_V, 1 , 1, 1 , - 99, 32, clop, zsto, zout )
CALL histend( nid_V, snc4chunks=snc4set )
@@ -366,6 +366,8 @@ CONTAINS
CALL histwrite( nid_T, "soshfldo", it, qsr , ndim_hT, ndex_hT ) ! solar heat flux
CALL histwrite( nid_T, "soicecov", it, fr_i , ndim_hT, ndex_hT ) ! ice fraction
CALL histwrite( nid_T, "sowindsp", it, wndm , ndim_hT, ndex_hT ) ! wind speed
+ CALL histwrite( nid_T, "sozotaux", it, utau , ndim_hT, ndex_hT ) ! i-wind stress
+ CALL histwrite( nid_T, "sometauy", it, vtau , ndim_hT, ndex_hT ) ! j-wind stress
!
IF( ln_abl ) THEN
ALLOCATE( zw3d_abl(jpi,jpj,jpka) )
@@ -393,11 +395,9 @@ CONTAINS
! Write fields on U grid
CALL histwrite( nid_U, "ssu_m" , it, ssu_m , ndim_hU, ndex_hU ) ! i-current speed
- CALL histwrite( nid_U, "sozotaux", it, utau , ndim_hU, ndex_hU ) ! i-wind stress
! Write fields on V grid
CALL histwrite( nid_V, "ssv_m" , it, ssv_m , ndim_hV, ndex_hV ) ! j-current speed
- CALL histwrite( nid_V, "sometauy", it, vtau , ndim_hV, ndex_hV ) ! j-wind stress
! 3. Close all files
! ---------------------------------------
diff --git a/src/SAS/nemogcm.F90 b/src/SAS/nemogcm.F90
index ce1716e487cbe17cf518fa366ac65b8a90e36812..5a531137248bf597a957d42f4fbe5745398654e2 100644
--- a/src/SAS/nemogcm.F90
+++ b/src/SAS/nemogcm.F90
@@ -124,6 +124,7 @@ CONTAINS
#endif
!
DO WHILE( istp <= nitend .AND. nstop == 0 )
+ ncom_stp = istp
CALL stp
istp = istp + 1
END DO
@@ -217,7 +218,6 @@ CONTAINS
IF( lk_oasis ) THEN ; cxios_context = 'sas' ! when coupling SAS to OCE
ELSE ; cxios_context = 'nemo' !
ENDIF
- nn_hls = 1
!
l_SAS = .TRUE. ! used in domain:dom_nam
!
@@ -350,12 +350,6 @@ CONTAINS
! !-----------------------------------------!
CALL mpp_init
-#if defined key_loop_fusion
- IF( nn_hls == 1 ) THEN
- CALL ctl_stop( 'STOP', 'nemogcm : Loop fusion can be used only with extra-halo' )
- ENDIF
-#endif
-
CALL halo_mng_init()
! Now we know the dimensions of the grid and numout has been set: we can allocate arrays
CALL nemo_alloc()
@@ -390,6 +384,7 @@ CONTAINS
#if defined key_agrif
uu(:,:,:,:) = 0.0_wp ; vv(:,:,:,:) = 0.0_wp ; ts(:,:,:,:,:) = 0.0_wp ! needed for interp done at initialization phase
+ uu_b(:,:,:) = 0.0_wp ; vv_b(:,:,:) = 0.0_wp
#endif
! ! external forcing
CALL sbc_init( Nbb, Nnn, Naa ) ! Forcings : surface module
diff --git a/src/SAS/sbcssm.F90 b/src/SAS/sbcssm.F90
index bd72a97a2fce97df86563d71cf83918224b12e7f..0cef6ea839173dd64395a1e5ef8d11bfa40f54ab 100644
--- a/src/SAS/sbcssm.F90
+++ b/src/SAS/sbcssm.F90
@@ -18,7 +18,6 @@ MODULE sbcssm
USE phycst ! physical constants
USE eosbn2 ! equation of state - Brunt Vaisala frequency
USE lbclnk ! ocean lateral boundary conditions (or mpp link)
- USE zpshde ! z-coord. with partial steps: horizontal derivatives
USE closea ! for ln_closea
USE icb_oce ! for icebergs
!
@@ -55,6 +54,7 @@ MODULE sbcssm
TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_ssm_3d ! structure of input fields (file information, fields read)
TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_ssm_2d ! structure of input fields (file information, fields read)
+# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/SAS 4.0 , NEMO Consortium (2018)
!! $Id: sbcssm.F90 15023 2021-06-18 14:35:25Z gsamson $
diff --git a/src/SAS/stpctl.F90 b/src/SAS/stpctl.F90
index 6de0e1dbf128f3d44694577e6813bd3f10e7ca15..7157843f95096a73306355a92999a0f22a686502 100644
--- a/src/SAS/stpctl.F90
+++ b/src/SAS/stpctl.F90
@@ -36,6 +36,9 @@ MODULE stpctl
INTEGER, PARAMETER :: jpvar = 3
INTEGER :: nrunid ! netcdf file id
INTEGER, DIMENSION(jpvar) :: nvarid ! netcdf variable id
+
+ !! * Substitutions
+# include "do_loop_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/SAS 4.0 , NEMO Consortium (2018)
!! $Id: stpctl.F90 14433 2021-02-11 08:06:49Z smasson $
@@ -77,8 +80,8 @@ CONTAINS
IF( nstop > 0 .AND. ngrdstop > -1 ) RETURN ! stpctl was already called by a child grid
!
ll_wrtstp = ( MOD( kt-nit000, sn_cfctl%ptimincr ) == 0 ) .OR. ( kt == nitend )
- ll_colruns = ll_wrtstp .AND. sn_cfctl%l_runstat .AND. jpnij > 1
- ll_wrtruns = ( ll_colruns .OR. jpnij == 1 ) .AND. lwm
+ ll_colruns = sn_cfctl%l_runstat .AND. ll_wrtstp .AND. jpnij > 1
+ ll_wrtruns = sn_cfctl%l_runstat .AND. ll_wrtstp .AND. lwm
!
IF( kt == nit000 ) THEN
!
@@ -132,7 +135,7 @@ CONTAINS
!
zmax(1) = MAXVAL( vt_i (:,:) , mask = llmsk ) ! max ice thickness
zmax(2) = MAXVAL( ABS( u_ice(:,:) ) , mask = llmsk ) ! max ice velocity (zonal only)
- zmax(3) = MAXVAL( -tm_i (:,:) + rt0, mask = llmsk ) ! min ice temperature (in degC)
+ zmax(3) = MAXVAL( -tm_i (:,:) + rt0, mask = llmsk(A2D(0)) ) ! min ice temperature (in degC)
zmax(jpvar+1) = REAL( nstop, wp ) ! stop indicator
!
! !== get global extrema ==!
@@ -172,9 +175,9 @@ CONTAINS
! first: close the netcdf file, so we can read it
IF( lwm .AND. kt /= nitend ) istatus = NF90_CLOSE(nrunid)
! get global loc on the min/max
- CALL mpp_maxloc( 'stpctl', vt_i(:,:) , llmsk, zzz, iloc(1:2,1) ) ! mpp_maxloc ok if mask = F
- CALL mpp_maxloc( 'stpctl',ABS( u_ice(:,:) ) , llmsk, zzz, iloc(1:2,2) )
- CALL mpp_minloc( 'stpctl', tm_i(:,:) - rt0, llmsk, zzz, iloc(1:2,3) )
+ CALL mpp_maxloc( 'stpctl', vt_i(:,:) , llmsk , zzz, iloc(1:2,1) ) ! mpp_maxloc ok if mask = F
+ CALL mpp_maxloc( 'stpctl',ABS( u_ice(:,:) ) , llmsk , zzz, iloc(1:2,2) )
+ CALL mpp_minloc( 'stpctl', tm_i(:,:) - rt0, llmsk(A2D(0)), zzz, iloc(1:2,3) )
! find which subdomain has the max.
iareamin(:) = jpnij+1 ; iareamax(:) = 0 ; iareasum(:) = 0
DO ji = 1, jptst
@@ -187,11 +190,11 @@ CONTAINS
CALL mpp_sum( "stpctl", iareasum ) ! sum over the global domain
ELSE ! find local min and max locations:
! if we are here, this means that the subdomain contains some oce points -> no need to test the mask used in maxloc
- iloc(1:2,1) = MAXLOC( vt_i(:,:) , mask = llmsk )
- iloc(1:2,2) = MAXLOC( ABS( u_ice(:,:) ) , mask = llmsk )
- iloc(1:2,3) = MINLOC( tm_i(:,:) - rt0, mask = llmsk )
+ iloc(1:2,1) = MAXLOC( vt_i(:,:) , mask = llmsk )
+ iloc(1:2,2) = MAXLOC( ABS( u_ice(:,:) ) , mask = llmsk )
+ iloc(1:2,3) = MINLOC( tm_i(:,:) - rt0, mask = llmsk(A2D(0)) )
DO ji = 1, jptst ! local domain indices ==> global domain indices, excluding halos
- iloc(1:2,ji) = (/ mig0(iloc(1,ji)), mjg0(iloc(2,ji)) /)
+ iloc(1:2,ji) = (/ mig(iloc(1,ji),0), mjg(iloc(2,ji),0) /)
END DO
iareamin(:) = narea ; iareamax(:) = narea ; iareasum(:) = 1 ! this is local information
ENDIF
@@ -209,11 +212,11 @@ CONTAINS
CALL dia_wri_state( Kmm, 'output.abort' ) ! create an output.abort file
!
IF( ll_colruns .OR. jpnij == 1 ) THEN ! all processes synchronized -> use lwp to print in opened ocean.output files
- IF(lwp) THEN ; CALL ctl_stop( ctmp1, ' ', ctmp2, ctmp3, ctmp4, ctmp5, ' ', ctmp6 )
+ IF(lwp) THEN ; CALL ctl_stop( ctmp1, ' ', ctmp2, ctmp3, ctmp4, ' ', ctmp6 )
ELSE ; nstop = MAX(1, nstop) ! make sure nstop > 0 (automatically done when calling ctl_stop)
ENDIF
ELSE ! only mpi subdomains with errors are here -> STOP now
- CALL ctl_stop( 'STOP', ctmp1, ' ', ctmp2, ctmp3, ctmp4, ctmp5, ' ', ctmp6 )
+ CALL ctl_stop( 'STOP', ctmp1, ' ', ctmp2, ctmp3, ctmp4, ' ', ctmp6 )
ENDIF
!
ENDIF
diff --git a/src/SWE/domzgr_substitute.h90 b/src/SWE/domzgr_substitute.h90
index fb57c1cc4a9759537abf87ad0830d5d532ed932a..79de7ea06768a38f435a7263176f0e7de6c55103 100644
--- a/src/SWE/domzgr_substitute.h90
+++ b/src/SWE/domzgr_substitute.h90
@@ -10,6 +10,38 @@
!! $Id$
!! Software governed by the CeCILL license (see ./LICENSE)
!!----------------------------------------------------------------------
+#if defined key_vco_1d || defined key_vco_1d3d
+# define gdept_0(i,j,k) gdept_1d(k)
+# define gdepw_0(i,j,k) gdepw_1d(k)
+# define e3w_0(i,j,k) e3w_1d(k)
+# define e3uw_0(i,j,k) e3w_1d(k)
+# define e3vw_0(i,j,k) e3w_1d(k)
+# if defined key_vco_1d
+# define e3t_0(i,j,k) e3t_1d(k)
+# define e3u_0(i,j,k) e3t_1d(k)
+# define e3v_0(i,j,k) e3t_1d(k)
+# define e3f_0(i,j,k) e3t_1d(k)
+# elif defined key_vco_1d3d
+# define e3t_0(i,j,k) e3t_3d(i,j,k)
+# define e3u_0(i,j,k) e3t_3d(i,j,k)
+# define e3v_0(i,j,k) e3t_3d(i,j,k)
+# define e3f_0(i,j,k) e3t_3d(i,j,k)
+# endif
+#elif defined key_vco_3d
+# define gdept_0(i,j,k) gdept_3d(i,j,k)
+# define gdepw_0(i,j,k) gdepw_3d(i,j,k)
+# define e3w_0(i,j,k) e3w_3d(i,j,k)
+# define e3uw_0(i,j,k) e3w_3d(i,j,k)
+# define e3vw_0(i,j,k) e3w_3d(i,j,k)
+!
+# define e3t_0(i,j,k) e3t_3d(i,j,k)
+# define e3u_0(i,j,k) e3t_3d(i,j,k)
+# define e3v_0(i,j,k) e3t_3d(i,j,k)
+# define e3f_0(i,j,k) e3t_3d(i,j,k)
+#else
+ E-R-R-O-R : key_vco_1d, key_vco_1d3d, or key_vco_3d ABSOLUTELY need to be defined in your cpp_* file !
+#endif
+!
#if defined key_qco
# define e3t(i,j,k,t) (e3t_0(i,j,k)*(1._wp+r3t(i,j,t)))
# define e3u(i,j,k,t) (e3u_0(i,j,k)*(1._wp+r3u(i,j,t)))
@@ -19,13 +51,13 @@
# define e3w(i,j,k,t) (e3w_0(i,j,k)*(1._wp+r3t(i,j,t)))
# define e3uw(i,j,k,t) (e3uw_0(i,j,k)*(1._wp+r3u(i,j,t)))
# define e3vw(i,j,k,t) (e3vw_0(i,j,k)*(1._wp+r3v(i,j,t)))
-# define ht(i,j) (ht_0(i,j)+ssh(i,j,Kmm))
+# define ht(i,j,t) (ht_0(i,j)+ssh(i,j,t))
# define hu(i,j,t) (hu_0(i,j)*(1._wp+r3u(i,j,t)))
# define hv(i,j,t) (hv_0(i,j)*(1._wp+r3v(i,j,t)))
# define r1_hu(i,j,t) (r1_hu_0(i,j)/(1._wp+r3u(i,j,t)))
# define r1_hv(i,j,t) (r1_hv_0(i,j)/(1._wp+r3v(i,j,t)))
# define gdept(i,j,k,t) (gdept_0(i,j,k)*(1._wp+r3t(i,j,t)))
# define gdepw(i,j,k,t) (gdepw_0(i,j,k)*(1._wp+r3t(i,j,t)))
-# define gde3w(i,j,k) (gdept_0(i,j,k)*(1._wp+r3t(i,j,Kmm))-ssh(i,j,Kmm))
+# define gdept_z0(i,j,k,t) (gdept(i,j,k,t)-ssh(i,j,t))
#endif
!!----------------------------------------------------------------------
diff --git a/src/SWE/nemogcm.F90 b/src/SWE/nemogcm.F90
index 4ab150e6437b0de66bbba082914e551c9242421b..e943cc2f30e4748e9460fb45d5189b70cc022c66 100644
--- a/src/SWE/nemogcm.F90
+++ b/src/SWE/nemogcm.F90
@@ -274,11 +274,9 @@ CONTAINS
! !-----------------------------------------!
CALL mpp_init
-#if defined key_loop_fusion
IF( nn_hls == 1 ) THEN
CALL ctl_stop( 'STOP', 'nemogcm : Loop fusion can be used only with extra-halo' )
ENDIF
-#endif
CALL halo_mng_init()
! Now we know the dimensions of the grid and numout has been set: we can allocate arrays
diff --git a/src/SWE/stp_oce.F90 b/src/SWE/stp_oce.F90
index 17c05584273bb6b7577ec90c83b0fcc318d38bc3..adeff53e21722f9d21afbaaa11734af687050542 100644
--- a/src/SWE/stp_oce.F90
+++ b/src/SWE/stp_oce.F90
@@ -30,10 +30,7 @@ MODULE stp_oce
USE sshwzv ! vertical velocity and ssh (ssh_nxt routine)
! (ssh_swp routine)
- ! (wzv routine)
- USE domvvl ! variable vertical scale factors (dom_vvl_sf_nxt routine)
- ! (dom_vvl_sf_swp routine)
-
+
USE divhor ! horizontal divergence (div_hor routine)
USE dynadv ! advection (dyn_adv routine)
USE dynvor ! vorticity term (dyn_vor routine)
@@ -41,7 +38,7 @@ MODULE stp_oce
USE dynldf ! lateral momentum diffusion (dyn_ldf routine)
USE dynzdf ! vertical diffusion (dyn_zdf routine)
USE dynspg ! surface pressure gradient (dyn_spg routine)
- USE dynatf ! time-filtering (dyn_atf routine)
+ USE dynatf_qco ! time-filtering (dyn_atf routine)
USE traqsr ! solar radiation penetration (tra_qsr routine)
USE traisf ! ice shelf (tra_isf routine)
@@ -52,7 +49,7 @@ MODULE stp_oce
USE traadv ! advection scheme control (tra_adv_ctl routine)
USE traldf ! lateral mixing (tra_ldf routine)
USE trazdf ! vertical mixing (tra_zdf routine)
- USE traatf ! time filtering (tra_atf routine)
+ USE traatf_qco ! time filtering (tra_atf routine)
USE tranpc ! non-penetrative convection (tra_npc routine)
USE eosbn2 ! equation of state (eos_bn2 routine)
@@ -72,8 +69,6 @@ MODULE stp_oce
USE diu_layers ! diurnal SST bulk and coolskin routines
USE sbc_oce ! surface fluxes
- USE zpshde ! partial step: hor. derivative (zps_hde routine)
-
USE diawri ! Standard run outputs (dia_wri routine)
USE diaptr ! poleward transports (dia_ptr routine)
USE diadct ! sections transports (dia_dct routine)
diff --git a/src/SWE/stpctl.F90 b/src/SWE/stpctl.F90
index 74def0eef9b1afa208f1f481d91e82f2946c1625..633e73c8854f3a1fb4174b0fc279cfeef0e84212 100644
--- a/src/SWE/stpctl.F90
+++ b/src/SWE/stpctl.F90
@@ -32,6 +32,9 @@ MODULE stpctl
INTEGER, PARAMETER :: jpvar = 2
INTEGER :: nrunid ! netcdf file id
INTEGER, DIMENSION(jpvar) :: nvarid ! netcdf variable id
+
+ !! * Substitutions
+# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
!! $Id: stpctl.F90 14143 2020-12-09 21:26:04Z techene $
@@ -75,8 +78,8 @@ CONTAINS
IF( nstop > 0 .AND. ngrdstop > -1 ) RETURN ! stpctl was already called by a child grid
!
ll_wrtstp = ( MOD( kt-nit000, sn_cfctl%ptimincr ) == 0 ) .OR. ( kt == nitend )
- ll_colruns = ll_wrtstp .AND. sn_cfctl%l_runstat .AND. jpnij > 1
- ll_wrtruns = ( ll_colruns .OR. jpnij == 1 ) .AND. lwm
+ ll_colruns = sn_cfctl%l_runstat .AND. ll_wrtstp .AND. jpnij > 1
+ ll_wrtruns = sn_cfctl%l_runstat .AND. ll_wrtstp .AND. lwm
!
IF( kt == nit000 ) THEN
!
@@ -185,7 +188,7 @@ CONTAINS
llmsk(Nis0:Nie0,Njs0:Nje0,:) = umask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp ! define only the inner domain
iloc(1:3,2) = MAXLOC( ABS( uu(:,:,:, Kmm)), mask = llmsk(:,:,:) )
DO ji = 1, jptst ! local domain indices ==> global domain indices, excluding halos
- iloc(1:2,ji) = (/ mig0(iloc(1,ji)), mjg0(iloc(2,ji)) /)
+ iloc(1:2,ji) = (/ mig(iloc(1,ji),0), mjg(iloc(2,ji),0) /)
END DO
iareamin(:) = narea ; iareamax(:) = narea ; iareasum(:) = 1 ! this is local information
ENDIF
diff --git a/src/SWE/stpmlf.F90 b/src/SWE/stpmlf.F90
index 5494248c2da3d7d583c2377f3228ce1d73cbae4c..4c49e55aaaab7aa745a49bcbfee63991a4c92743 100644
--- a/src/SWE/stpmlf.F90
+++ b/src/SWE/stpmlf.F90
@@ -114,9 +114,9 @@ CONTAINS
zrhs_u = - grav * ( ssh(ji+1,jj,Nnn) - ssh(ji,jj,Nnn) ) * r1_e1u(ji,jj)
zrhs_v = - grav * ( ssh(ji,jj+1,Nnn) - ssh(ji,jj,Nnn) ) * r1_e2v(ji,jj)
! ! wind stress and layer friction
- zrhs_u = zrhs_u + z1_2rho0 * ( utau_b(ji,jj) + utau(ji,jj) ) / e3u(ji,jj,jk,Nnn) &
+ zrhs_u = zrhs_u + z1_2rho0 * ( utau_b(ji,jj) + utauU(ji,jj) ) / e3u(ji,jj,jk,Nnn) &
& - rn_rfr * uu(ji,jj,jk,Nbb)
- zrhs_v = zrhs_v + z1_2rho0 * ( vtau_b(ji,jj) + vtau(ji,jj) ) / e3v(ji,jj,jk,Nnn) &
+ zrhs_v = zrhs_v + z1_2rho0 * ( vtau_b(ji,jj) + vtauV(ji,jj) ) / e3v(ji,jj,jk,Nnn) &
& - rn_rfr * vv(ji,jj,jk,Nbb)
! ! ==> RHS
uu(ji,jj,jk,Nrhs) = uu(ji,jj,jk,Nrhs) + zrhs_u
diff --git a/src/SWE/stprk3.F90 b/src/SWE/stprk3.F90
index 0e1a1910fc971a67837aafea9430c53efa272d2e..2fded6aea76692509a6c7d870a9c91b6497f4928 100644
--- a/src/SWE/stprk3.F90
+++ b/src/SWE/stprk3.F90
@@ -135,9 +135,9 @@ CONTAINS
zrhs_v = - grav * ( ssh(ji,jj+1,Nbb) - ssh(ji,jj,Nbb) ) * r1_e2v(ji,jj)
#if defined key_RK3all
! ! wind stress and layer friction
- zrhs_u = zrhs_u + r1_rho0 * ( z5_6*utau_b(ji,jj) + (1._wp - z5_6)*utau(ji,jj) ) / e3u(ji,jj,jk,Nbb) &
+ zrhs_u = zrhs_u + r1_rho0 * ( z5_6*utau_b(ji,jj) + (1._wp - z5_6)*utauU(ji,jj) ) / e3u(ji,jj,jk,Nbb) &
& - rn_rfr * uu(ji,jj,jk,Nbb)
- zrhs_v = zrhs_v + r1_rho0 * ( z5_6*vtau_b(ji,jj) + (1._wp - z5_6)*vtau(ji,jj) ) / e3v(ji,jj,jk,Nbb) &
+ zrhs_v = zrhs_v + r1_rho0 * ( z5_6*vtau_b(ji,jj) + (1._wp - z5_6)*vtauV(ji,jj) ) / e3v(ji,jj,jk,Nbb) &
& - rn_rfr * vv(ji,jj,jk,Nbb)
#endif
! ! ==> RHS
@@ -201,9 +201,9 @@ CONTAINS
zrhs_v = - grav * ( ssh(ji,jj+1,Nnn) - ssh(ji,jj,Nnn) ) * r1_e2v(ji,jj)
#if defined key_RK3all
! ! wind stress and layer friction
- zrhs_u = zrhs_u + r1_rho0 * ( z3_4*utau_b(ji,jj) + (1._wp - z3_4)*utau(ji,jj) ) / e3u(ji,jj,jk,Nnn) &
+ zrhs_u = zrhs_u + r1_rho0 * ( z3_4*utau_b(ji,jj) + (1._wp - z3_4)*utauU(ji,jj) ) / e3u(ji,jj,jk,Nnn) &
& - rn_rfr * uu(ji,jj,jk,Nbb)
- zrhs_v = zrhs_v + r1_rho0 * ( z3_4*vtau_b(ji,jj) + (1._wp - z3_4)*vtau(ji,jj) ) / e3v(ji,jj,jk,Nnn) &
+ zrhs_v = zrhs_v + r1_rho0 * ( z3_4*vtau_b(ji,jj) + (1._wp - z3_4)*vtauV(ji,jj) ) / e3v(ji,jj,jk,Nnn) &
& - rn_rfr * vv(ji,jj,jk,Nbb)
#endif
! ! ==> RHS
@@ -265,9 +265,9 @@ CONTAINS
zrhs_u = - grav * ( ssh(ji+1,jj,Nnn) - ssh(ji,jj,Nnn) ) * r1_e1u(ji,jj)
zrhs_v = - grav * ( ssh(ji,jj+1,Nnn) - ssh(ji,jj,Nnn) ) * r1_e2v(ji,jj)
! ! wind stress and layer friction
- zrhs_u = zrhs_u + z1_2rho0 * ( utau_b(ji,jj) + utau(ji,jj) ) / e3u(ji,jj,jk,Nnn) &
+ zrhs_u = zrhs_u + z1_2rho0 * ( utau_b(ji,jj) + utauU(ji,jj) ) / e3u(ji,jj,jk,Nnn) &
& - rn_rfr * uu(ji,jj,jk,Nbb)
- zrhs_v = zrhs_v + z1_2rho0 * ( vtau_b(ji,jj) + vtau(ji,jj) ) / e3v(ji,jj,jk,Nnn) &
+ zrhs_v = zrhs_v + z1_2rho0 * ( vtau_b(ji,jj) + vtauV(ji,jj) ) / e3v(ji,jj,jk,Nnn) &
& - rn_rfr * vv(ji,jj,jk,Nbb)
! ! ==> RHS
uu(ji,jj,jk,Nrhs) = uu(ji,jj,jk,Nrhs) + zrhs_u
diff --git a/src/TOP/AGE/trcsms_age.F90 b/src/TOP/AGE/trcsms_age.F90
index 8e793d23ce463e05bcf721d18aabff3fb2ac7e57..c862523be807d9834960b80b6b4c23a4aaf88911 100644
--- a/src/TOP/AGE/trcsms_age.F90
+++ b/src/TOP/AGE/trcsms_age.F90
@@ -46,7 +46,7 @@ CONTAINS
!!----------------------------------------------------------------------
INTEGER, INTENT(in) :: kt ! ocean time-step index
INTEGER, INTENT(in) :: Kbb, Kmm, Krhs ! ocean time level
- INTEGER :: jn, jk ! dummy loop index
+ INTEGER :: jk ! dummy loop index
!!----------------------------------------------------------------------
!
IF( ln_timing ) CALL timing_start('trc_sms_age')
@@ -68,7 +68,7 @@ CONTAINS
tr(:,:,jk,jp_age,Krhs) = tmask(:,:,jk) * rryear
END DO
!
- IF( l_trdtrc ) CALL trd_trc( tr(:,:,:,jp_age,Krhs), jn, jptra_sms, kt, Kmm ) ! save trends
+ IF( l_trdtrc ) CALL trd_trc( tr(:,:,:,jp_age,Krhs), jp_age, jptra_sms, kt, Kmm ) ! save trends
!
IF( ln_timing ) CALL timing_stop('trc_sms_age')
!
diff --git a/src/TOP/AGE/trcwri_age.F90 b/src/TOP/AGE/trcwri_age.F90
index 98b7c6863ed6ba0d6eac44a892864fc0a6980dc3..3df7b3e7e99e766d7d7f4bd5f7f57555bbfb9998 100644
--- a/src/TOP/AGE/trcwri_age.F90
+++ b/src/TOP/AGE/trcwri_age.F90
@@ -28,7 +28,6 @@ CONTAINS
!!---------------------------------------------------------------------
INTEGER, INTENT(in) :: Kmm ! time level indices
CHARACTER (len=20) :: cltra
- INTEGER :: jn
!!---------------------------------------------------------------------
! write the tracer concentrations in the file
diff --git a/src/TOP/C14/sms_c14.F90 b/src/TOP/C14/sms_c14.F90
index bdea777651132bc10a238c54f572e344b5614de7..a9971f6a2c4a2bb6d957d9c82bc53fcbba36f99d 100644
--- a/src/TOP/C14/sms_c14.F90
+++ b/src/TOP/C14/sms_c14.F90
@@ -51,6 +51,8 @@ MODULE sms_c14
REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) :: spco2 ! Atmospheric CO2
REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) :: tyrco2 ! Time (yr) atmospheric CO2 data
+ !! * Substitutions
+# include "do_loop_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/TOP 4.0 , NEMO Consortium (2018)
!! $Id: sms_c14.F90 10071 2018-08-28 14:49:04Z nicolasmartin $
@@ -64,9 +66,9 @@ CONTAINS
!! *** ROUTINE trc_sms_c14_alloc ***
!!----------------------------------------------------------------------
sms_c14_alloc = 0
- ALLOCATE( exch_c14(jpi,jpj) , exch_co2(jpi,jpj) , &
- & qtr_c14(jpi,jpj) , qint_c14(jpi,jpj) , &
- & c14sbc(jpi,jpj) , STAT = sms_c14_alloc )
+ ALLOCATE( exch_c14(A2D(0)) , exch_co2(A2D(0)) , &
+ & qtr_c14(A2D(0)) , qint_c14(A2D(0)) , &
+ & c14sbc(A2D(0)) , STAT = sms_c14_alloc )
!
!
END FUNCTION sms_c14_alloc
diff --git a/src/TOP/C14/trcatm_c14.F90 b/src/TOP/C14/trcatm_c14.F90
index 54a768067d674bf9b1bdd44bb6a9b5d092a9dd9f..d09dcf5df473af5308d9ba09e79ffa06a97caa53 100644
--- a/src/TOP/C14/trcatm_c14.F90
+++ b/src/TOP/C14/trcatm_c14.F90
@@ -59,6 +59,13 @@ CONTAINS
!
tyrc14_now = 0._wp ! initialize
!
+ IF( kc14typ == 0) THEN
+ co2sbc=pco2at
+ DO_2D( 0, 0, 0, 0 )
+ c14sbc(ji,jj) = rc14at
+ END_2D
+ ENDIF
+ !
IF(kc14typ >= 1) THEN ! Transient atmospheric forcing: CO2
!
clfile = TRIM( cfileco2 )
@@ -116,10 +123,10 @@ CONTAINS
! Linear interpolation of the C-14 source fonction
! in linear latitude bands (20N,40N) and (20S,40S)
!------------------------------------------------------
- ALLOCATE( fareaz (jpi,jpj ,nc14zon) , STAT=ierr3 )
+ ALLOCATE( fareaz(A2D(0) ,nc14zon) , STAT=ierr3 )
IF( ierr3 /= 0 ) CALL ctl_stop( 'STOP', 'trc_atm_c14_ini: unable to allocate fareaz' )
!
- DO_2D( 1, 1, 1, 1 ) ! from C14b package
+ DO_2D( 0, 0, 0, 0 ) ! from C14b package
IF( gphit(ji,jj) >= yn40 ) THEN
fareaz(ji,jj,1) = 0.
fareaz(ji,jj,2) = 0.
@@ -205,9 +212,9 @@ CONTAINS
!! ** Action : atmospheric values interpolated at time-step kt
!!----------------------------------------------------------------------
INTEGER , INTENT(in ) :: kt ! ocean time-step
- REAL(wp), DIMENSION(:,:), INTENT( out) :: c14sbc ! atm c14 ratio
+ REAL(wp), DIMENSION(A2D(0)), INTENT( out) :: c14sbc ! atm c14 ratio
REAL(wp), INTENT( out) :: co2sbc ! atm co2 p
- INTEGER :: jz ! dummy loop indice
+ INTEGER :: ji, jj, jz ! dummy loop indice
REAL(wp) :: zdint,zint ! work
REAL(wp), DIMENSION(nc14zon) :: zonbc14 ! work
!
@@ -215,10 +222,6 @@ CONTAINS
!
IF( ln_timing ) CALL timing_start('trc_atm_c14')
!
- IF( kc14typ == 0) THEN
- co2sbc=pco2at
- c14sbc(:,:)=rc14at
- ENDIF
!
IF(kc14typ >= 1) THEN ! Transient C14 & CO2
!
diff --git a/src/TOP/C14/trcsms_c14.F90 b/src/TOP/C14/trcsms_c14.F90
index 9ce0a584a8b0bff04ceeaedaf1516f6a01aab9cc..0135dc8c934aca0e0e90a07362ff5bd08c87cfd3 100644
--- a/src/TOP/C14/trcsms_c14.F90
+++ b/src/TOP/C14/trcsms_c14.F90
@@ -80,7 +80,7 @@ CONTAINS
! CO2 solubility (Weiss, 1974; Wanninkhof, 2014)
! -------------------------------------------------------------------
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
IF( tmask(ji,jj,1) > 0. ) THEN
!
zt = MIN( 40. , ts(ji,jj,1,jp_tem,Kmm) )
@@ -121,21 +121,21 @@ CONTAINS
!
! Flux of C-14 from air-to-sea; units: (C14/C ratio) x m/s
! already masked
- qtr_c14(:,:) = exch_c14(:,:) * ( c14sbc(:,:) - tr(:,:,1,jp_c14,Kbb) )
+ DO_2D( 0, 0, 0, 0 )
+ qtr_c14(ji,jj) = exch_c14(ji,jj) * ( c14sbc(ji,jj) - tr(ji,jj,1,jp_c14,Kbb) )
+ END_2D
! cumulation of air-to-sea flux at each time step
qint_c14(:,:) = qint_c14(:,:) + qtr_c14(:,:) * rn_Dt
!
! Add the surface flux to the trend of jp_c14
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
tr(ji,jj,1,jp_c14,Krhs) = tr(ji,jj,1,jp_c14,Krhs) + qtr_c14(ji,jj) / e3t(ji,jj,1,Kmm)
END_2D
!
! Computation of decay effects on jp_c14
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpk )
- !
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
tr(ji,jj,jk,jp_c14,Krhs) = tr(ji,jj,jk,jp_c14,Krhs) - rlam14 * tr(ji,jj,jk,jp_c14,Kbb) * tmask(ji,jj,jk)
- !
END_3D
!
IF( lrst_trc ) THEN
diff --git a/src/TOP/C14/trcwri_c14.F90 b/src/TOP/C14/trcwri_c14.F90
index 7f3de9f0c0a731479a0743e0c927443087b26c65..7fcda51a3696560d6d6c0034d4ec6ddaf77925a4 100644
--- a/src/TOP/C14/trcwri_c14.F90
+++ b/src/TOP/C14/trcwri_c14.F90
@@ -38,8 +38,8 @@ CONTAINS
CHARACTER (len=20) :: cltra ! short title for tracer
INTEGER :: ji,jj,jk,jn ! dummy loop indexes
REAL(wp) :: zage,zarea,ztemp ! temporary
- REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zres, z2d ! temporary storage 2D
- REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: z3d , zz3d ! temporary storage 3D
+ REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: z2d ! temporary storage 2D
+ REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: z3d ! temporary storage 3D
!!---------------------------------------------------------------------
! write the tracer concentrations in the file
@@ -49,41 +49,35 @@ CONTAINS
! compute and write the tracer diagnostic in the file
! ---------------------------------------
+ IF( iom_use("qtr_c14") ) CALL iom_put( "qtr_c14" , rsiyea * qtr_c14(:,:) ) ! Radiocarbon surf flux [./m2/yr]
+ CALL iom_put( "qint_c14", qint_c14(:,:) ) ! cumulative flux [./m2]
IF( iom_use("DeltaC14") .OR. iom_use("C14Age") .OR. iom_use("RAge") ) THEN
!
- ALLOCATE( z2d(jpi,jpj), zres(jpi,jpj) )
- ALLOCATE( z3d(jpi,jpj,jpk), zz3d(jpi,jpj,jpk) )
+ ALLOCATE( z2d(A2D(0)), z3d(A2D(0),jpk) )
!
zage = -1._wp / rlam14 / rsiyea ! factor for radioages in year
z3d(:,:,:) = 1._wp
- zz3d(:,:,:) = 0._wp
!
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
IF( tmask(ji,jj,jk) > 0._wp) THEN
- z3d (ji,jj,jk) = tr(ji,jj,jk,jp_c14,Kmm)
- zz3d(ji,jj,jk) = LOG( z3d(ji,jj,jk) )
+ z3d(ji,jj,jk) = tr(ji,jj,jk,jp_c14,Kmm)
ENDIF
END_3D
- zres(:,:) = z3d(:,:,1)
+ CALL iom_put( "C14Age", zage * LOG( z3d(:,:,:) ) ) ! Radiocarbon age [yr]
! Reservoir age [yr]
- z2d(:,:) =0._wp
- jk = 1
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
- ztemp = zres(ji,jj) / c14sbc(ji,jj)
- IF( ztemp > 0._wp .AND. tmask(ji,jj,jk) > 0._wp ) z2d(ji,jj) = LOG( ztemp )
+ z2d(:,:) = 0._wp
+ DO_2D( 0, 0, 0, 0 )
+ ztemp = z3d(ji,jj,1) / c14sbc(ji,jj)
+ IF( ztemp > 0._wp .AND. tmask(ji,jj,1) > 0._wp ) z2d(ji,jj) = LOG( ztemp )
END_2D
+ CALL iom_put( "RAge" , zage * z2d(:,:) ) ! Reservoir age [yr]
!
z3d(:,:,:) = 1.d03 * ( z3d(:,:,:) - 1._wp )
CALL iom_put( "DeltaC14" , z3d(:,:,:) ) ! Delta C14 [permil]
- CALL iom_put( "C14Age" , zage * zz3d(:,:,:) ) ! Radiocarbon age [yr]
-
- CALL iom_put( "qtr_c14", rsiyea * qtr_c14(:,:) ) ! Radiocarbon surf flux [./m2/yr]
- CALL iom_put( "qint_c14" , qint_c14 ) ! cumulative flux [./m2]
- CALL iom_put( "RAge" , zage * z2d(:,:) ) ! Reservoir age [yr]
!
- DEALLOCATE( z2d, zres, z3d, zz3d )
+ DEALLOCATE( z2d, z3d )
!
ENDIF
!
@@ -91,23 +85,35 @@ CONTAINS
!
CALL iom_put( "AtmCO2", co2sbc ) ! global atmospheric CO2 [ppm]
- IF( iom_use("AtmC14") ) THEN
- zarea = glob_sum( 'trcwri_c14', e1e2t(:,:) ) ! global ocean surface
- ztemp = glob_sum( 'trcwri_c14', c14sbc(:,:) * e1e2t(:,:) )
- ztemp = ( ztemp / zarea - 1._wp ) * 1000._wp
- CALL iom_put( "AtmC14" , ztemp ) ! Global atmospheric DeltaC14 [permil]
- ENDIF
- IF( iom_use("K_C14") ) THEN
- ztemp = glob_sum ( 'trcwri_c14', exch_c14(:,:) * e1e2t(:,:) )
- ztemp = rsiyea * ztemp / zarea
- CALL iom_put( "K_C14" , ztemp ) ! global mean exchange velocity for C14/C ratio [m/yr]
- ENDIF
- IF( iom_use("K_CO2") ) THEN
+ IF( iom_use("AtmC14") .OR. iom_use("K_C14") .OR. iom_use("K_CO2") ) THEN
zarea = glob_sum( 'trcwri_c14', e1e2t(:,:) ) ! global ocean surface
- ztemp = glob_sum ( 'trcwri_c14', exch_co2(:,:) * e1e2t(:,:) )
- ztemp = 360000._wp * ztemp / zarea ! cm/h units: directly comparable with literature
- CALL iom_put( "K_CO2", ztemp ) ! global mean CO2 piston velocity [cm/hr]
- ENDIF
+ ALLOCATE( z2d(A2D(0)) )
+ IF( iom_use("AtmC14") ) THEN
+ DO_2D( 0, 0, 0, 0 )
+ z2d(ji,jj) = c14sbc(ji,jj) * e1e2t(ji,jj)
+ END_2D
+ ztemp = glob_sum( 'trcwri_c14', z2d(:,:) )
+ ztemp = ( ztemp / zarea - 1._wp ) * 1000._wp
+ CALL iom_put( "AtmC14" , ztemp ) ! Global atmospheric DeltaC14 [permil]
+ ENDIF
+ IF( iom_use("K_C14") ) THEN
+ DO_2D( 0, 0, 0, 0 )
+ z2d(ji,jj) = exch_c14(ji,jj) * e1e2t(ji,jj)
+ END_2D
+ ztemp = glob_sum( 'trcwri_c14', z2d(:,:) )
+ ztemp = rsiyea * ztemp / zarea
+ CALL iom_put( "K_C14" , ztemp ) ! global mean exchange velocity for C14/C ratio [m/yr]
+ ENDIF
+ IF( iom_use("K_CO2") ) THEN
+ DO_2D( 0, 0, 0, 0 )
+ z2d(ji,jj) = exch_co2(ji,jj) * e1e2t(ji,jj)
+ END_2D
+ ztemp = glob_sum( 'trcwri_c14', z2d(:,:) )
+ ztemp = 360000._wp * ztemp / zarea ! cm/h units: directly comparable with literature
+ CALL iom_put( "K_CO2", ztemp ) ! global mean CO2 piston velocity [cm/hr]
+ ENDIF
+ DEALLOCATE( z2d )
+ END IF
IF( iom_use("C14Inv") ) THEN
ztemp = glob_sum( 'trcwri_c14', tr(:,:,:,jp_c14,Kmm) * cvol(:,:,:) )
ztemp = atomc14 * xdicsur * ztemp
diff --git a/src/TOP/CFC/trcini_cfc.F90 b/src/TOP/CFC/trcini_cfc.F90
index cacfee0815d0d70f416da87c07a1167c27484b01..5d759a1364d1540c4f7317f1195aedcce03be7cb 100644
--- a/src/TOP/CFC/trcini_cfc.F90
+++ b/src/TOP/CFC/trcini_cfc.F90
@@ -131,7 +131,7 @@ CONTAINS
! Linear interpolation between 2 hemispheric function of latitud between ylats and ylatn
!---------------------------------------------------------------------------------------
zyd = ylatn - ylats
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
IF( gphit(ji,jj) >= ylatn ) THEN ; xphem(ji,jj) = 1.e0
ELSEIF( gphit(ji,jj) <= ylats ) THEN ; xphem(ji,jj) = 0.e0
ELSE ; xphem(ji,jj) = ( gphit(ji,jj) - ylats) / zyd
diff --git a/src/TOP/CFC/trcsms_cfc.F90 b/src/TOP/CFC/trcsms_cfc.F90
index 32e9b63eb19fec4005f8c6e05213681866a466c2..e473c088c8e6d807c85d9aa97d8d8680727d4d17 100644
--- a/src/TOP/CFC/trcsms_cfc.F90
+++ b/src/TOP/CFC/trcsms_cfc.F90
@@ -124,9 +124,9 @@ CONTAINS
& + atm_cfc(iyear_end, jm, jl) * REAL(im2, wp) ) / 12.
END DO
- ! !------------!
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) ! i-j loop !
- ! !------------!
+ ! !------------!
+ DO_2D( 0, 0, 0, 0 ) ! i-j loop !
+ ! !------------!
! space interpolation
zpp_cfc = xphem(ji,jj) * zpatm(1,jl) &
& + ( 1.- xphem(ji,jj) ) * zpatm(2,jl)
@@ -309,8 +309,8 @@ CONTAINS
!!----------------------------------------------------------------------
!! *** ROUTINE trc_sms_cfc_alloc ***
!!----------------------------------------------------------------------
- ALLOCATE( xphem (jpi,jpj) , atm_cfc(jpyear,jphem,jp_cfc) , &
- & qtr_cfc (jpi,jpj,jp_cfc) , qint_cfc(jpi,jpj,jp_cfc) , &
+ ALLOCATE( xphem (A2D(0)) , atm_cfc(jpyear,jphem,jp_cfc) , &
+ & qtr_cfc (A2D(0),jp_cfc) , qint_cfc(A2D(0),jp_cfc) , &
& soa(4,jp_cfc) , sob(3,jp_cfc) , sca(5,jp_cfc) , &
& STAT=trc_sms_cfc_alloc )
!
diff --git a/src/TOP/PISCES/P2Z/p2zbio.F90 b/src/TOP/PISCES/P2Z/p2zbio.F90
index ecbfc9f47f8ae64ed1ce18cc35da0fc76bcd5dd5..4100534f899bafbc79999a5531bc38bcd0f3594b 100644
--- a/src/TOP/PISCES/P2Z/p2zbio.F90
+++ b/src/TOP/PISCES/P2Z/p2zbio.F90
@@ -104,7 +104,6 @@ CONTAINS
!
IF( ln_timing ) CALL timing_start('p2z_bio')
!
- IF( lk_iomput ) ALLOCATE( zw2d(jpi,jpj,17), zw3d(jpi,jpj,jpk,3) )
IF( kt == nittrc000 ) THEN
IF(lwp) WRITE(numout,*)
@@ -112,18 +111,18 @@ CONTAINS
IF(lwp) WRITE(numout,*) ' ~~~~~~~'
ENDIF
- xksi(:,:) = 0.e0 ! zooplakton closure ( fbod)
IF( lk_iomput ) THEN
- zw2d (:,:,:) = 0._wp
- zw3d(:,:,:,:) = 0._wp
+ ALLOCATE( zw3d(A2D(0),jpk,3) ) ; zw3d(:,:,jpk,:) = 0._wp
+ ALLOCATE( zw2d(A2D(0),17) ) ; zw2d(:,:,:) = 0._wp
ENDIF
+ !
+ xksi(:,:) = 0.e0 ! zooplakton closure ( fbod)
! ! -------------------------- !
- DO jk = 1, jpkbm1 ! Upper ocean (bio-layers) !
+ DO_3D( 0, 0, 0, 0, 1, jpkbm1 ) ! Upper ocean (bio-layers) !
! ! -------------------------- !
- DO_2D( 0, 0, 0, 0 )
- ! trophic variables( det, zoo, phy, no3, nh4, dom)
- ! ------------------------------------------------
+ ! trophic variables( det, zoo, phy, no3, nh4, dom)
+ ! ------------------------------------------------
! negative trophic variables DO not contribute to the fluxes
zdet = MAX( 0.e0, tr(ji,jj,jk,jpdet,Kmm) )
@@ -235,13 +234,11 @@ CONTAINS
zw3d(ji,jj,jk,3) = znh4no3 * 86400
!
ENDIF
- END_2D
- END DO
+ END_3D
! ! -------------------------- !
- DO jk = jpkb, jpkm1 ! Upper ocean (bio-layers) !
+ DO_3D( 0, 0, 0, 0, jpkb, jpkm1 ) ! Upper ocean (bio-layers) !
! ! -------------------------- !
- DO_2D( 0, 0, 0, 0 )
! remineralisation of all quantities towards nitrate
! trophic variables( det, zoo, phy, no3, nh4, dom)
@@ -334,12 +331,9 @@ CONTAINS
zw3d(ji,jj,jk,3) = znh4no3 * 86400._wp
!
ENDIF
- END_2D
- END DO
+ END_3D
!
IF( lk_iomput ) THEN
- CALL lbc_lnk( 'p2zbio', zw2d(:,:,:),'T', 1.0_wp )
- CALL lbc_lnk( 'p2zbio', zw3d(:,:,:,1),'T', 1.0_wp, zw3d(:,:,:,2),'T', 1.0_wp, zw3d(:,:,:,3),'T', 1.0_wp )
! Save diagnostics
CALL iom_put( "TNO3PHY", zw2d(:,:,1) )
CALL iom_put( "TNH4PHY", zw2d(:,:,2) )
@@ -362,6 +356,8 @@ CONTAINS
CALL iom_put( "FNH4PHY", zw3d(:,:,:,2) )
CALL iom_put( "FNH4NO3", zw3d(:,:,:,3) )
!
+ DEALLOCATE( zw2d, zw3d )
+ !
ENDIF
IF(sn_cfctl%l_prttrc) THEN ! print mean trends (used for debugging)
@@ -370,8 +366,6 @@ CONTAINS
CALL prt_ctl(tab4d_1=tr(:,:,:,:,Krhs), mask1=tmask, clinfo=ctrcnm)
ENDIF
!
- IF( lk_iomput ) DEALLOCATE( zw2d, zw3d )
- !
IF( ln_timing ) CALL timing_stop('p2z_bio')
!
END SUBROUTINE p2z_bio
diff --git a/src/TOP/PISCES/P2Z/p2zexp.F90 b/src/TOP/PISCES/P2Z/p2zexp.F90
index d5fe6fe115e4f4348607a6c1557d1cbb2971c8a8..71ed7709e6751cff80e933e9508211dc38062736 100644
--- a/src/TOP/PISCES/P2Z/p2zexp.F90
+++ b/src/TOP/PISCES/P2Z/p2zexp.F90
@@ -65,7 +65,7 @@ CONTAINS
!!
INTEGER :: ji, jj, jk, jl, ikt
REAL(wp) :: zgeolpoc, zfact, zwork, ze3t, zsedpocd, zmaskt
- REAL(wp), DIMENSION(jpi,jpj) :: zsedpoca
+ REAL(wp), DIMENSION(A2D(0)) :: zsedpoca
CHARACTER (len=25) :: charout
!!---------------------------------------------------------------------
!
@@ -106,7 +106,7 @@ CONTAINS
tr(ji,jj,1,jpno3,Krhs) = tr(ji,jj,1,jpno3,Krhs) + zgeolpoc * cmask(ji,jj) / areacot / e3t(ji,jj,1,Kmm)
END_2D
- CALL lbc_lnk( 'p2zexp', sedpocn, 'T', 1.0_wp )
+! CALL lbc_lnk( 'p2zexp', sedpocn, 'T', 1.0_wp )
! Oa & Ek: diagnostics depending on jpdia2d ! left as example
IF( lk_iomput ) CALL iom_put( "SEDPOC" , sedpocn )
@@ -120,7 +120,7 @@ CONTAINS
!
ELSE
!
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
zsedpocd = zsedpoca(ji,jj) - 2. * sedpocn(ji,jj) + sedpocb(ji,jj) ! time laplacian on tracers
sedpocb(ji,jj) = sedpocn(ji,jj) + rn_atfp * zsedpocd ! sedpocb <-- filtered sedpocn
sedpocn(ji,jj) = zsedpoca(ji,jj) ! sedpocn <-- sedpoca
@@ -156,8 +156,8 @@ CONTAINS
INTEGER, INTENT(in) :: Kmm ! time level index
INTEGER :: ji, jj, jk
REAL(wp) :: zmaskt, zfluo, zfluu
- REAL(wp), DIMENSION(jpi,jpj ) :: zrro
- REAL(wp), DIMENSION(jpi,jpj,jpk) :: zdm0
+ REAL(wp), DIMENSION(A2D(0) ) :: zrro, zarea
+ REAL(wp), DIMENSION(A2D(0),jpk) :: zdm0
!!---------------------------------------------------------------------
!
IF(lwp) THEN
@@ -171,9 +171,9 @@ CONTAINS
! Calculate vertical distribution of newly formed biogenic poc
! in the water column in the case of max. possible bottom depth
! ------------------------------------------------------------
- zdm0 = 0._wp
- zrro = 1._wp
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, jpkb, jpkm1 )
+ zdm0(:,:,:) = 0._wp
+ zrro(:,:) = 1._wp
+ DO_3D( 0, 0, 0, 0, jpkb, jpkm1 )
zfluo = ( gdepw(ji,jj,jk ,Kmm) / gdepw(ji,jj,jpkb,Kmm) )**xhr
zfluu = ( gdepw(ji,jj,jk+1,Kmm) / gdepw(ji,jj,jpkb,Kmm) )**xhr
IF( zfluo.GT.1. ) zfluo = 1._wp
@@ -190,14 +190,14 @@ CONTAINS
! ----------------------------------------------------------------------
dminl(:,:) = 0._wp
dmin3(:,:,:) = zdm0
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpk )
+ DO_3D( 0, 0, 0, 0, 1, jpk )
IF( tmask(ji,jj,jk) == 0._wp ) THEN
dminl(ji,jj) = dminl(ji,jj) + dmin3(ji,jj,jk)
dmin3(ji,jj,jk) = 0._wp
ENDIF
END_3D
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
IF( tmask(ji,jj,1) == 0 ) dmin3(ji,jj,1) = 0._wp
END_2D
@@ -209,8 +209,11 @@ CONTAINS
IF( zmaskt == 0. ) cmask(ji,jj) = 1._wp
END IF
END_2D
- CALL lbc_lnk( 'p2zexp', cmask , 'T', 1.0_wp ) ! lateral boundary conditions on cmask (sign unchanged)
- areacot = glob_sum( 'p2zexp', e1e2t(:,:) * cmask(:,:) )
+! CALL lbc_lnk( 'p2zexp', cmask , 'T', 1.0_wp ) ! lateral boundary conditions on cmask (sign unchanged)
+ DO_2D( 0, 0, 0, 0 )
+ zarea(ji,jj) = e1e2t(ji,jj) * cmask(ji,jj)
+ END_2D
+ areacot = glob_sum( 'p2zexp', zarea(:,:) )
!
IF( ln_rsttr ) THEN
CALL iom_get( numrtr, jpdom_auto, 'SEDB'//ctrcnm(jpdet), sedpocb(:,:) )
@@ -226,8 +229,8 @@ CONTAINS
!!----------------------------------------------------------------------
!! *** ROUTINE p2z_exp_alloc ***
!!----------------------------------------------------------------------
- ALLOCATE( cmask(jpi,jpj) , dminl(jpi,jpj) , dmin3(jpi,jpj,jpk), &
- & sedpocb(jpi,jpj) , sedpocn(jpi,jpj), STAT=p2z_exp_alloc )
+ ALLOCATE( cmask(A2D(0)) , dminl(A2D(0)) , dmin3(A2D(0),jpk), &
+ & sedpocb(A2D(0)) , sedpocn(A2D(0)), STAT=p2z_exp_alloc )
IF( p2z_exp_alloc /= 0 ) CALL ctl_stop( 'STOP', 'p2z_exp_alloc : failed to allocate arrays.' )
!
END FUNCTION p2z_exp_alloc
diff --git a/src/TOP/PISCES/P2Z/p2zopt.F90 b/src/TOP/PISCES/P2Z/p2zopt.F90
index 85f8b3e2aeea2ce5423a4f1e5e4f6b9dc01f5036..4c8268dea0cdb4abbb1f51f1c3eb7e95ddeaa49d 100644
--- a/src/TOP/PISCES/P2Z/p2zopt.F90
+++ b/src/TOP/PISCES/P2Z/p2zopt.F90
@@ -70,8 +70,8 @@ CONTAINS
REAL(wp) :: zpig ! log of the total pigment
REAL(wp) :: zkr, zkg ! total absorption coefficient in red and green
REAL(wp) :: zcoef ! temporary scalar
- REAL(wp), DIMENSION(jpi,jpj ) :: zpar100, zpar0m
- REAL(wp), DIMENSION(jpi,jpj,jpk) :: zparr, zparg
+ REAL(wp), DIMENSION(A2D(0) ) :: zpar100, zpar0m
+ REAL(wp), DIMENSION(A2D(0),jpk) :: zparr, zparg
!!---------------------------------------------------------------------
!
IF( ln_timing ) CALL timing_start('p2z_opt')
@@ -85,8 +85,14 @@ CONTAINS
! ! surface irradiance
! ! ------------------
- IF( ln_dm2dc ) THEN ; zpar0m(:,:) = qsr_mean(:,:) * 0.43
- ELSE ; zpar0m(:,:) = qsr (:,:) * 0.43
+ IF( ln_dm2dc ) THEN
+ DO_2D( 0, 0, 0, 0 )
+ zpar0m(ji,jj) = qsr_mean(ji,jj) * 0.43
+ END_2D
+ ELSE
+ DO_2D( 0, 0, 0, 0 )
+ zpar0m(ji,jj) = qsr(ji,jj) * 0.43
+ END_2D
ENDIF
zpar100(:,:) = zpar0m(:,:) * 0.01
zparr (:,:,1) = zpar0m(:,:) * 0.5
@@ -94,14 +100,14 @@ CONTAINS
! ! Photosynthetically Available Radiation (PAR)
zcoef = 12 * redf / rcchl / rpig ! --------------------------------------
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 2, jpk )
+ DO_3D( 0, 0, 0, 0, 2, jpk )
zpig = LOG( MAX( TINY(0.), tr(ji,jj,jk-1,jpphy,Kmm) ) * zcoef )
zkr = xkr0 + xkrp * EXP( xlr * zpig )
zkg = xkg0 + xkgp * EXP( xlg * zpig )
zparr(ji,jj,jk) = zparr(ji,jj,jk-1) * EXP( -zkr * e3t(ji,jj,jk-1,Kmm) )
zparg(ji,jj,jk) = zparg(ji,jj,jk-1) * EXP( -zkg * e3t(ji,jj,jk-1,Kmm) )
END_3D
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) ! mean par at t-levels
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 ) ! mean par at t-levels
zpig = LOG( MAX( TINY(0.), tr(ji,jj,jk,jpphy,Kmm) ) * zcoef )
zkr = xkr0 + xkrp * EXP( xlr * zpig )
zkg = xkg0 + xkgp * EXP( xlg * zpig )
@@ -113,11 +119,11 @@ CONTAINS
! ! Euphotic layer
! ! --------------
neln(:,:) = 1 ! euphotic layer level
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) ! (i.e. 1rst T-level strictly below EL bottom)
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 ) ! (i.e. 1rst T-level strictly below EL bottom)
IF( etot(ji,jj,jk) >= zpar100(ji,jj) ) neln(ji,jj) = jk + 1
END_3D
! ! Euphotic layer depth
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
heup(ji,jj) = gdepw(ji,jj,neln(ji,jj),Kmm)
END_2D
diff --git a/src/TOP/PISCES/P2Z/p2zsed.F90 b/src/TOP/PISCES/P2Z/p2zsed.F90
index 66f24308ccef21d867ad1435c0b85a906091d4f6..50d7e76964333e2daf8bad5bf48c2832f138cca0 100644
--- a/src/TOP/PISCES/P2Z/p2zsed.F90
+++ b/src/TOP/PISCES/P2Z/p2zsed.F90
@@ -61,10 +61,11 @@ CONTAINS
INTEGER, INTENT( in ) :: kt ! ocean time-step index
INTEGER, INTENT( in ) :: Kmm, Krhs ! time level indices
!
- INTEGER :: ji, jj, jk, jl, ierr
+ INTEGER :: ji, jj, jk
CHARACTER (len=25) :: charout
REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zw2d
- REAL(wp), DIMENSION(jpi,jpj,jpk) :: zwork, ztra
+ REAL(wp), DIMENSION(A2D(0),jpk) :: zwork
+ REAL(wp) :: ztra
!!---------------------------------------------------------------------
!
IF( ln_timing ) CALL timing_start('p2z_sed')
@@ -83,22 +84,26 @@ CONTAINS
zwork(:,:,jpk) = 0.e0 ! bottom value set to zero
! tracer flux at w-point: we use -vsed (downward flux) with simplification : no e1*e2
- DO jk = 2, jpkm1
- zwork(:,:,jk) = -vsed * tr(:,:,jk-1,jpdet,Kmm)
- END DO
+ DO_3D( 0, 0, 0, 0, 2, jpkm1 )
+ zwork(ji,jj,jk) = -vsed * tr(ji,jj,jk-1,jpdet,Kmm)
+ END_3D
! tracer flux divergence at t-point added to the general trend
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 )
- ztra(ji,jj,jk) = - ( zwork(ji,jj,jk) - zwork(ji,jj,jk+1) ) / e3t(ji,jj,jk,Kmm)
- tr(ji,jj,jk,jpdet,Krhs) = tr(ji,jj,jk,jpdet,Krhs) + ztra(ji,jj,jk)
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
+ ztra = - ( zwork(ji,jj,jk) - zwork(ji,jj,jk+1) ) / e3t(ji,jj,jk,Kmm)
+ tr(ji,jj,jk,jpdet,Krhs) = tr(ji,jj,jk,jpdet,Krhs) + ztra
END_3D
IF( lk_iomput ) THEN
IF( iom_use( "TDETSED" ) ) THEN
- ALLOCATE( zw2d(jpi,jpj) )
- zw2d(:,:) = ztra(:,:,1) * e3t(:,:,1,Kmm) * 86400._wp
+ ALLOCATE( zw2d(A2D(0)) )
+ DO_2D( 0, 0, 0, 0 )
+ zw2d(ji,jj) = - ( zwork(ji,jj,1) - zwork(ji,jj,2) ) * 86400._wp
+ END_2D
DO jk = 2, jpkm1
- zw2d(:,:) = zw2d(:,:) + ztra(:,:,jk) * e3t(:,:,jk,Kmm) * 86400._wp
+ DO_2D( 0, 0, 0, 0 )
+ zw2d(ji,jj) = zw2d(ji,jj) - ( zwork(ji,jj,jk) - zwork(ji,jj,jk+1) ) * 86400._wp
+ END_2D
END DO
CALL iom_put( "TDETSED", zw2d )
DEALLOCATE( zw2d )
diff --git a/src/TOP/PISCES/P4Z/p4zagg.F90 b/src/TOP/PISCES/P4Z/p4zagg.F90
index 6eb5208f391449efa894387b1e48091d33329cfc..9c16b164791712b8966b24c246bd03e943facb70 100644
--- a/src/TOP/PISCES/P4Z/p4zagg.F90
+++ b/src/TOP/PISCES/P4Z/p4zagg.F90
@@ -70,7 +70,7 @@ CONTAINS
! PISCES part
IF( ln_p4z ) THEN
!
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
!
zfact = xstep * xdiss(ji,jj,jk)
! Part I : Coagulation dependent on turbulence
@@ -117,7 +117,7 @@ CONTAINS
ELSE ! ln_p5z
! PISCES-QUOTA part
!
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
!
zfact = xstep * xdiss(ji,jj,jk)
! Part I : Coagulation dependent on turbulence
diff --git a/src/TOP/PISCES/P4Z/p4zbc.F90 b/src/TOP/PISCES/P4Z/p4zbc.F90
index f649f91f75e3215b1d348a08e704f4573de7a93a..c05ae9a10d4ad3891846c094efcf35d81dce094a 100644
--- a/src/TOP/PISCES/P4Z/p4zbc.F90
+++ b/src/TOP/PISCES/P4Z/p4zbc.F90
@@ -13,6 +13,7 @@ MODULE p4zbc
USE sms_pisces ! PISCES Source Minus Sink variables
USE iom ! I/O manager
USE fldread ! time interpolation
+ USE prtctl ! print control for debugging
USE trcbc
IMPLICIT NONE
@@ -36,7 +37,6 @@ MODULE p4zbc
LOGICAL , PUBLIC :: ll_river !: boolean for river input of nutrients
LOGICAL , PUBLIC :: ll_ndepo !: boolean for atmospheric deposition of N
TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_dust ! structure of input dust
- TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_ironsed ! structure of input iron from sediment
TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_hydrofe ! structure of input iron from sediment
REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: dust !: dust fields
@@ -74,6 +74,8 @@ CONTAINS
REAL(wp) :: zcoef, zwdust, zrivdin, zdustdep, zndep
!
CHARACTER (len=25) :: charout
+ REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zw3d
+ REAL(wp), ALLOCATABLE, DIMENSION(:,: ) :: zw2d
!!---------------------------------------------------------------------
!
IF( ln_timing ) CALL timing_start('p4z_bc')
@@ -84,7 +86,9 @@ CONTAINS
IF( ll_dust ) THEN
!
CALL fld_read( kt, 1, sf_dust )
- dust(:,:) = MAX( rtrn, sf_dust(1)%fnow(:,:,1) )
+ DO_2D( 0, 0, 0, 0 )
+ dust(ji,jj) = MAX( rtrn, sf_dust(1)%fnow(ji,jj,1) )
+ END_2D
!
! Iron solubilization of particles in the water column
! dust in kg/m2/s ---> 1/55.85 to put in mol/Fe ; wdust in m/d
@@ -99,7 +103,7 @@ CONTAINS
! Atmospheric input of Iron dissolves in the water column
IF ( ln_trc_sbc(jpfer) ) THEN
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 2, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 2, jpkm1 )
zdustdep = dust(ji,jj) * zwdust * rfact * EXP( -gdept(ji,jj,jk,Kmm) /( 250. * wdust ) )
!
tr(ji,jj,jk,jpfer,Krhs) = tr(ji,jj,jk,jpfer,Krhs) + zdustdep * mfrac / mMass_Fe
@@ -107,16 +111,18 @@ CONTAINS
IF( lk_iomput ) THEN
! surface downward dust depo of iron
+ ALLOCATE( zw2d(A2D(0)) )
jl = n_trc_indsbc(jpfer)
- CALL iom_put( "Irondep", ( rf_trsfac(jl) * sf_trcsbc(jl)%fnow(:,:,1) / rn_sbc_time ) * 1.e+3 * tmask(:,:,1) )
-
+ zw2d(A2D(0)) = rf_trsfac(jl) * ( sf_trcsbc(jl)%fnow(A2D(0),1) / rn_sbc_time ) * 1.e+3 * tmask(A2D(0),1)
+ CALL iom_put( "Irondep", zw2d )
+ DEALLOCATE( zw2d )
ENDIF
ENDIF
! Atmospheric input of PO4 dissolves in the water column
IF ( ln_trc_sbc(jppo4) ) THEN
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 2, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 2, jpkm1 )
zdustdep = dust(ji,jj) * zwdust * rfact * EXP( -gdept(ji,jj,jk,Kmm) /( 250. * wdust ) )
!
tr(ji,jj,jk,jppo4,Krhs) = tr(ji,jj,jk,jppo4,Krhs) + zdustdep * 1.e-3 / mMass_P
@@ -125,7 +131,7 @@ CONTAINS
! Atmospheric input of Si dissolves in the water column
IF ( ln_trc_sbc(jpsil) ) THEN
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 2, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 2, jpkm1 )
zdustdep = dust(ji,jj) * zwdust * rfact * EXP( -gdept(ji,jj,jk,Kmm) /( 250. * wdust ) )
!
tr(ji,jj,jk,jpsil,Krhs) = tr(ji,jj,jk,jpsil,Krhs) + zdustdep * 0.269 / mMass_Si
@@ -135,7 +141,10 @@ CONTAINS
!
IF( lk_iomput ) THEN
! dust concentration at surface
- CALL iom_put( "pdust" , dust(:,:) / ( wdust / rday ) * tmask(:,:,1) ) ! dust concentration at surface
+ ALLOCATE( zw2d(A2D(0)) )
+ zw2d(A2D(0)) = dust(A2D(0)) / ( wdust / rday ) * tmask(A2D(0),1)
+ CALL iom_put( "pdust", zw2d )
+ DEALLOCATE( zw2d )
ENDIF
ENDIF
@@ -144,7 +153,7 @@ CONTAINS
! ----------------------------------------------------------
IF( ll_river ) THEN
jl = n_trc_indcbc(jpno3)
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
DO jk = 1, nk_rnf(ji,jj)
zcoef = rn_rfact / ( e1e2t(ji,jj) * h_rnf(ji,jj) * rn_cbc_time ) * tmask(ji,jj,1)
zrivdin = rf_trcfac(jl) * sf_trccbc(jl)%fnow(ji,jj,1) * zcoef
@@ -158,14 +167,14 @@ CONTAINS
IF( ll_ndepo ) THEN
IF( ln_trc_sbc(jpno3) ) THEN
jl = n_trc_indsbc(jpno3)
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
zndep = rf_trsfac(jl) * sf_trcsbc(jl)%fnow(ji,jj,1) / e3t(ji,jj,1,Kmm) / rn_sbc_time
tr(ji,jj,1,jptal,Krhs) = tr(ji,jj,1,jptal,Krhs) - rno3 * zndep * rfact
END_2D
ENDIF
IF( ln_trc_sbc(jpnh4) ) THEN
jl = n_trc_indsbc(jpnh4)
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
zndep = rf_trsfac(jl) * sf_trcsbc(jl)%fnow(ji,jj,1) / e3t(ji,jj,1,Kmm) / rn_sbc_time
tr(ji,jj,1,jptal,Krhs) = tr(ji,jj,1,jptal,Krhs) + rno3 * zndep * rfact
END_2D
@@ -183,41 +192,71 @@ CONTAINS
! Simple parameterization assuming a fixed constant concentration in
! sea-ice (icefeinput)
! ------------------------------------------------------------------
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
zdep = rfact / e3t(ji,jj,1,Kmm)
- zwflux = fmmflx(ji,jj) / 1000._wp
- zironice = MAX( -0.99 * tr(ji,jj,1,jpfer,Kbb), -zwflux * icefeinput * zdep )
+ zwflux = fwfice(ji,jj) / 1000._wp
+ zironice = MAX( -0.99 * tr(ji,jj,1,jpfer,Kbb), zwflux * icefeinput * zdep )
tr(ji,jj,1,jpfer,Krhs) = tr(ji,jj,1,jpfer,Krhs) + zironice
END_2D
!
- ! iron flux from ice
- IF( lk_iomput ) &
- & CALL iom_put( "Ironice", MAX( -0.99 * tr(:,:,1,jpfer,Kbb), (-1.*fmmflx(:,:)/1000._wp )*icefeinput*1.e+3*tmask(:,:,1)) )
+ IF( lk_iomput ) THEN
+ ! iron flux from ice
+ ALLOCATE( zw2d(A2D(0)) )
+ zw2d(A2D(0)) = MAX( -0.99 * tr(A2D(0),1,jpfer,Kbb), (fwfice(:,:)/1000._wp )*icefeinput*1.e+3*tmask(A2D(0),1))
+ CALL iom_put( "Ironice", zw2d )
+ DEALLOCATE( zw2d )
+ ENDIF
!
ENDIF
! Add the external input of iron from sediment mobilization
! ------------------------------------------------------
IF( ln_ironsed .AND. .NOT.lk_sed ) THEN
- tr(:,:,:,jpfer,Krhs) = tr(:,:,:,jpfer,Krhs) + ironsed(:,:,:) * rfact
- !
- IF( lk_iomput ) CALL iom_put( "Ironsed", ironsed(:,:,:) * 1.e+3 * tmask(:,:,:) )
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
+ tr(ji,jj,jk,jpfer,Krhs) = tr(ji,jj,jk,jpfer,Krhs) + ironsed(ji,jj,jk) * rfact
+ END_3D
+ !
+ IF( lk_iomput ) THEN
+ ALLOCATE( zw3d(A2D(0),jpk) ) ; zw3d(A2D(0),jpk) = 0._wp
+ zw3d(A2D(0),1:jpkm1) = ironsed(A2D(0),1:jpkm1) * 1.e+3 * tmask(A2D(0),1:jpkm1)
+ CALL iom_put( "Ironsed", zw3d )
+ DEALLOCATE( zw3d )
+ ENDIF
ENDIF
! Add the external input of iron from hydrothermal vents
! ------------------------------------------------------
IF( ln_hydrofe ) THEN
CALL fld_read( kt, 1, sf_hydrofe )
- DO jk = 1, jpk
- hydrofe(:,:,jk) = ( MAX( rtrn, sf_hydrofe(1)%fnow(:,:,jk) ) * hratio ) &
- & / ( e1e2t(:,:) * e3t(:,:,jk,Kmm) * ryyss + rtrn ) / 1000._wp &
- & * tmask(:,:,jk)
- ENDDO
- tr(:,:,:,jpfer,Krhs) = tr(:,:,:,jpfer,Krhs) + hydrofe(:,:,:) * rfact
- IF( ln_ligand ) tr(:,:,:,jplgw,Krhs) = tr(:,:,:,jplgw,Krhs) + ( hydrofe(:,:,:) * lgw_rath ) * rfact
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
+ hydrofe(ji,jj,jk) = ( MAX( rtrn, sf_hydrofe(1)%fnow(ji,jj,jk) ) * hratio ) &
+ & / ( e1e2t(ji,jj) * e3t(ji,jj,jk,Kmm) * ryyss + rtrn ) / 1000._wp &
+ & * tmask(ji,jj,jk)
+ END_3D
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
+ tr(ji,jj,jk,jpfer,Krhs) = tr(ji,jj,jk,jpfer,Krhs) + hydrofe(ji,jj,jk) * rfact
+ END_3D
+ IF( ln_ligand ) THEN
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
+ tr(ji,jj,jk,jplgw,Krhs) = tr(ji,jj,jk,jplgw,Krhs) + ( hydrofe(ji,jj,jk) * lgw_rath ) * rfact
+ END_3D
+ ENDIF
!
- IF( lk_iomput ) CALL iom_put( "HYDR", hydrofe(:,:,:) * 1.e+3 * tmask(:,:,:) ) ! hydrothermal iron input
+ IF( lk_iomput ) THEN
+ ! hydrothermal iron input
+ ALLOCATE( zw3d(A2D(0),jpk) ) ; zw3d(A2D(0),jpk) = 0._wp
+ zw3d(A2D(0),1:jpkm1) = hydrofe(A2D(0),1:jpkm1) * 1.e+3 * tmask(A2D(0),1:jpkm1)
+ CALL iom_put( "HYDR", zw3d )
+ DEALLOCATE( zw3d )
+ ENDIF
ENDIF
+ !
+ IF(sn_cfctl%l_prttrc) THEN ! print mean trends (used for debugging)
+ WRITE(charout, FMT="('bc')")
+ CALL prt_ctl_info( charout, cdcomp = 'top' )
+ CALL prt_ctl(tab4d_1=tr(:,:,:,:,Krhs), mask1=tmask, clinfo=ctrcnm)
+ ENDIF
+ !
IF( ln_timing ) CALL timing_stop('p4z_bc')
!
END SUBROUTINE p4z_bc
@@ -303,7 +342,7 @@ CONTAINS
IF(lwp) WRITE(numout,*) ' initialize dust input from atmosphere '
IF(lwp) WRITE(numout,*) ' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ '
!
- ALLOCATE( dust(jpi,jpj) )
+ ALLOCATE( dust(A2D(0)) )
!
ALLOCATE( sf_dust(1), STAT=ierr ) !* allocate and fill sf_sst (forcing structure) with sn_sst
IF( ierr > 0 ) CALL ctl_stop( 'STOP', 'p4z_bc_init: unable to allocate sf_dust structure' )
@@ -321,7 +360,7 @@ CONTAINS
IF(lwp) WRITE(numout,*)
IF(lwp) WRITE(numout,*) ' ==>>> ln_ironsed=T , computation of an island mask to enhance coastal supply of iron'
!
- ALLOCATE( ironsed(jpi,jpj,jpk) ) ! allocation
+ ALLOCATE( ironsed(A2D(0),jpk) ) ! allocation
!
CALL iom_open ( TRIM( sn_ironsed%clname ), numiron )
ALLOCATE( zcmask(jpi,jpj,jpk) )
@@ -350,7 +389,7 @@ CONTAINS
!
CALL lbc_lnk( 'p4zbc', zcmask , 'T', 1.0_wp ) ! lateral boundary conditions on cmask (sign unchanged)
!
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpk )
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
zexpide = MIN( 8.,( gdept(ji,jj,jk,Kmm) / 500. )**(-1.5) )
zdenitide = -0.9543 + 0.7662 * LOG( zexpide ) - 0.235 * LOG( zexpide )**2
zcmask(ji,jj,jk) = zcmask(ji,jj,jk) * MIN( 1., EXP( zdenitide ) / 0.5 )
@@ -358,9 +397,9 @@ CONTAINS
! Coastal supply of iron
! -------------------------
ironsed(:,:,jpk) = 0._wp
- DO jk = 1, jpkm1
- ironsed(:,:,jk) = sedfeinput * zcmask(:,:,jk) / ( e3t_0(:,:,jk) * rday )
- END DO
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
+ ironsed(ji,jj,jk) = sedfeinput * zcmask(ji,jj,jk) / ( e3t_0(ji,jj,jk) * rday )
+ END_3D
DEALLOCATE( zcmask)
ENDIF
!
@@ -371,7 +410,7 @@ CONTAINS
IF(lwp) WRITE(numout,*)
IF(lwp) WRITE(numout,*) ' ==>>> ln_hydrofe=T , Input of iron from hydrothermal vents'
!
- ALLOCATE( hydrofe(jpi,jpj,jpk) ) ! allocation
+ ALLOCATE( hydrofe(A2D(0),jpk) ) ! allocation
!
ALLOCATE( sf_hydrofe(1), STAT=ierr ) !* allocate and fill sf_sst (forcing structure) with sn_sst
IF( ierr > 0 ) CALL ctl_stop( 'STOP', 'p4z_bc_init: unable to allocate sf_hydro structure' )
diff --git a/src/TOP/PISCES/P4Z/p4zbio.F90 b/src/TOP/PISCES/P4Z/p4zbio.F90
index d2a21ea1cd049af3a7c8ae96ce5feadaf2e14ff0..65f61f4f90552a637b0f6c8f53b2058bc9b708fa 100644
--- a/src/TOP/PISCES/P4Z/p4zbio.F90
+++ b/src/TOP/PISCES/P4Z/p4zbio.F90
@@ -72,7 +72,7 @@ CONTAINS
! OF PHYTOPLANKTON AND DETRITUS. Shear rate is supposed to equal 1
! in the mixed layer and 0.1 below the mixed layer.
xdiss(:,:,:) = 1.
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 2, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 2, jpkm1 )
IF( gdepw(ji,jj,jk+1,Kmm) > hmld(ji,jj) ) xdiss(ji,jj,jk) = 0.01
END_3D
diff --git a/src/TOP/PISCES/P4Z/p4zche.F90 b/src/TOP/PISCES/P4Z/p4zche.F90
index a71f9350e553ee336f81d980f64d96bb9fcf2935..8d9f68fe00e0bced44695e0264ace39e8bebd288 100644
--- a/src/TOP/PISCES/P4Z/p4zche.F90
+++ b/src/TOP/PISCES/P4Z/p4zche.F90
@@ -168,9 +168,13 @@ CONTAINS
! practical salinity
! -------------------------------------------------------------
IF (neos == -1) THEN
- salinprac(:,:,:) = ts(:,:,:,jp_sal,Kmm) * 35.0 / 35.16504
+ DO_3D( 0, 0, 0, 0, 1, jpk )
+ salinprac(ji,jj,jk) = ts(ji,jj,jk,jp_sal,Kmm) * 35.0 / 35.16504
+ END_3D
ELSE
- salinprac(:,:,:) = ts(:,:,:,jp_sal,Kmm)
+ DO_3D( 0, 0, 0, 0, 1, jpk )
+ salinprac(ji,jj,jk) = ts(ji,jj,jk,jp_sal,Kmm)
+ END_3D
ENDIF
!
@@ -179,7 +183,7 @@ CONTAINS
! potential temperature to in situ temperature. The errors is less than
! 0.04°C relative to an exact computation
! ---------------------------------------------------------------------
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpk )
+ DO_3D( 0, 0, 0, 0, 1, jpk )
zpres = gdept(ji,jj,jk,Kmm) / 1000.
za1 = 0.04 * ( 1.0 + 0.185 * ts(ji,jj,jk,jp_tem,Kmm) + 0.035 * (salinprac(ji,jj,jk) - 35.0) )
za2 = 0.0075 * ( 1.0 - ts(ji,jj,jk,jp_tem,Kmm) / 30.0 )
@@ -188,7 +192,7 @@ CONTAINS
!
! CHEMICAL CONSTANTS - SURFACE LAYER
! ----------------------------------
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
! ! SET ABSOLUTE TEMPERATURE
ztkel = tempis(ji,jj,1) + 273.15
zt = ztkel * 0.01
@@ -216,7 +220,7 @@ CONTAINS
! OXYGEN SOLUBILITY - DEEP OCEAN
! -------------------------------
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpk )
+ DO_3D( 0, 0, 0, 0, 1, jpk )
ztkel = tempis(ji,jj,jk) + 273.15
zsal = salinprac(ji,jj,jk) + ( 1.- tmask(ji,jj,jk) ) * 35.
zsal2 = zsal * zsal
@@ -235,7 +239,7 @@ CONTAINS
! CHEMICAL CONSTANTS - DEEP OCEAN
! -------------------------------
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpk )
+ DO_3D( 0, 0, 0, 0, 1, jpk )
! SET PRESSION ACCORDING TO SAUNDER (1980)
zplat = SIN ( ABS(gphit(ji,jj)*3.141592654/180.) )
zc1 = 5.92E-3 + zplat**2 * 5.25E-3
@@ -452,7 +456,7 @@ CONTAINS
!! and the 2nd order approximation does not have
!! a solution
!!---------------------------------------------------------------------
- REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(OUT) :: p_hini
+ REAL(wp), DIMENSION(A2D(0),jpk), INTENT(OUT) :: p_hini
INTEGER, INTENT(in) :: Kbb ! time level indices
INTEGER :: ji, jj, jk
REAL(wp) :: zca1, zba1
@@ -463,7 +467,7 @@ CONTAINS
IF( ln_timing ) CALL timing_start('ahini_for_at')
!
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpk )
+ DO_3D( 0, 0, 0, 0, 1, jpk )
zrhd = 1._wp / ( rhd(ji,jj,jk) + 1. )
p_alkcb = tr(ji,jj,jk,jptal,Kbb) * zrhd
p_dictot = tr(ji,jj,jk,jpdic,Kbb) * zrhd
@@ -512,13 +516,13 @@ CONTAINS
! inf(TA - [OH-] + [H+]) and sup(TA - [OH-] + [H+])
! Argument variables
- REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(OUT) :: p_alknw_inf
- REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(OUT) :: p_alknw_sup
+ REAL(wp), DIMENSION(A2D(0),jpk), INTENT(OUT) :: p_alknw_inf
+ REAL(wp), DIMENSION(A2D(0),jpk), INTENT(OUT) :: p_alknw_sup
INTEGER, INTENT(in) :: Kbb ! time level indices
INTEGER :: ji, jj, jk
REAL(wp) :: zrhd
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpk )
+ DO_3D( 0, 0, 0, 0, 1, jpk )
zrhd = 1._wp / ( rhd(ji,jj,jk) + 1. )
p_alknw_inf(ji,jj,jk) = -tr(ji,jj,jk,jppo4,Kbb) * zrhd - sulfat(ji,jj,jk) &
& - fluorid(ji,jj,jk)
@@ -536,8 +540,8 @@ CONTAINS
! Argument variables
!--------------------
- REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(IN) :: p_hini
- REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(OUT) :: zhi
+ REAL(wp), DIMENSION(A2D(0),jpk), INTENT(IN) :: p_hini
+ REAL(wp), DIMENSION(A2D(0),jpk), INTENT(OUT) :: zhi
INTEGER, INTENT(in) :: Kbb ! time level indices
! Local variables
@@ -557,17 +561,17 @@ CONTAINS
REAL(wp) :: zrhd, p_alktot, zdic, zbot, zpt, zst, zft, zsit
LOGICAL :: l_exitnow
REAL(wp), PARAMETER :: pz_exp_threshold = 1.0
- REAL(wp), DIMENSION(jpi,jpj,jpk) :: zalknw_inf, zalknw_sup, rmask, zh_min, zh_max, zeqn_absmin
+ REAL(wp), DIMENSION(A2D(0),jpk) :: zalknw_inf, zalknw_sup, rmask, zh_min, zh_max, zeqn_absmin
IF( ln_timing ) CALL timing_start('solve_at_general')
CALL anw_infsup( zalknw_inf, zalknw_sup, Kbb )
- rmask(:,:,:) = tmask(:,:,:)
+ rmask(A2D(0),1:jpk) = tmask(A2D(0),1:jpk)
zhi(:,:,:) = 0.
! TOTAL H+ scale: conversion factor for Htot = aphscale * Hfree
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpk )
+ DO_3D( 0, 0, 0, 0, 1, jpk )
IF (rmask(ji,jj,jk) == 1.) THEN
zrhd = 1._wp / ( rhd(ji,jj,jk) + 1. )
p_alktot = tr(ji,jj,jk,jptal,Kbb) * zrhd
@@ -597,7 +601,7 @@ CONTAINS
zeqn_absmin(:,:,:) = HUGE(1._wp)
DO jn = 1, jp_maxniter_atgen
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpk )
+ DO_3D( 0, 0, 0, 0, 1, jpk )
IF (rmask(ji,jj,jk) == 1.) THEN
zrhd = 1._wp / ( rhd(ji,jj,jk) + 1. )
p_alktot = tr(ji,jj,jk,jptal,Kbb) * zrhd
@@ -797,17 +801,17 @@ CONTAINS
ierr(:) = 0
- ALLOCATE( sio3eq(jpi,jpj,jpk), fekeq(jpi,jpj,jpk), chemc(jpi,jpj,3), chemo2(jpi,jpj,jpk), STAT=ierr(1) )
+ ALLOCATE( sio3eq(A2D(0),jpk), fekeq(A2D(0),jpk), chemc(A2D(0),3), chemo2(A2D(0),jpk), STAT=ierr(1) )
- ALLOCATE( akb3(jpi,jpj,jpk) , tempis(jpi, jpj, jpk), &
- & akw3(jpi,jpj,jpk) , borat (jpi,jpj,jpk) , &
- & aks3(jpi,jpj,jpk) , akf3(jpi,jpj,jpk) , &
- & ak1p3(jpi,jpj,jpk) , ak2p3(jpi,jpj,jpk) , &
- & ak3p3(jpi,jpj,jpk) , aksi3(jpi,jpj,jpk) , &
- & fluorid(jpi,jpj,jpk) , sulfat(jpi,jpj,jpk) , &
- & salinprac(jpi,jpj,jpk), STAT=ierr(2) )
+ ALLOCATE( akb3(A2D(0),jpk) , tempis(A2D(0),jpk), &
+ & akw3(A2D(0),jpk) , borat (A2D(0),jpk) , &
+ & aks3(A2D(0),jpk) , akf3(A2D(0),jpk) , &
+ & ak1p3(A2D(0),jpk) , ak2p3(A2D(0),jpk) , &
+ & ak3p3(A2D(0),jpk) , aksi3(A2D(0),jpk) , &
+ & fluorid(A2D(0),jpk) , sulfat(A2D(0),jpk) , &
+ & salinprac(A2D(0),jpk), STAT=ierr(2) )
- ALLOCATE( fesol(jpi,jpj,jpk,5), STAT=ierr(3) )
+ ALLOCATE( fesol(A2D(0),jpk,5), STAT=ierr(3) )
!* Variable for chemistry of the CO2 cycle
p4z_che_alloc = MAXVAL( ierr )
diff --git a/src/TOP/PISCES/P4Z/p4zfechem.F90 b/src/TOP/PISCES/P4Z/p4zfechem.F90
index 2598766485bdad722d29f17aaab666676789cfb7..2e05446d88970f7fd86247538b54ac8a789340a6 100644
--- a/src/TOP/PISCES/P4Z/p4zfechem.F90
+++ b/src/TOP/PISCES/P4Z/p4zfechem.F90
@@ -31,6 +31,7 @@ MODULE p4zfechem
REAL(wp), PUBLIC :: kfep !: rate constant for nanoparticle formation
REAL(wp), PUBLIC :: scaveff !: Fraction of scavenged iron that is considered as being subject to solubilization
+ LOGICAL :: l_dia_fechem
!! * Substitutions
# include "do_loop_substitute.h90"
# include "domzgr_substitute.h90"
@@ -58,36 +59,41 @@ CONTAINS
REAL(wp) :: zkeq, zfesatur, fe3sol, zligco
REAL(wp) :: zscave, zaggdfea, zaggdfeb, ztrc, zdust, zklight
REAL(wp) :: ztfe, zhplus, zxlam, zaggliga, zaggligb
- REAL(wp) :: zprecip, zprecipno3, zconsfe, za1
+ REAL(wp) :: zprecip, zprecipno3, zconsfe, za1, ztl1, zfel1
REAL(wp) :: zrfact2
CHARACTER (len=25) :: charout
- REAL(wp), DIMENSION(jpi,jpj,jpk) :: zTL1, zFe3, ztotlig, zfeprecip, zFeL1, zfecoll
- REAL(wp), DIMENSION(jpi,jpj,jpk) :: zcoll3d, zscav3d, zlcoll3d
+ REAL(wp), DIMENSION(A2D(0),jpk) :: zFe3, ztotlig, zfecoll
+ REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zw3d, zcoll3d, zscav3d, zfeprecip
!!---------------------------------------------------------------------
!
IF( ln_timing ) CALL timing_start('p4z_fechem')
!
- zFe3 (:,:,jpk) = 0.
- zFeL1 (:,:,jpk) = 0.
- zTL1 (:,:,jpk) = 0.
- zfeprecip(:,:,jpk) = 0.
- zcoll3d (:,:,jpk) = 0.
- zscav3d (:,:,jpk) = 0.
- zlcoll3d (:,:,jpk) = 0.
- zfecoll (:,:,jpk) = 0.
- xfecolagg(:,:,jpk) = 0.
- xcoagfe (:,:,jpk) = 0.
+ IF( kt == nittrc000 ) &
+ l_dia_fechem = iom_use( "Fe3" ) .OR. iom_use( "FeL1" ) .OR. iom_use( "TL1" ) .OR. &
+ & iom_use( "Totlig" ) .OR. iom_use( "Biron" ) .OR. iom_use( "FESCAV" ) .OR. &
+ & iom_use( "FECOLL" ) .OR. iom_use( "FEPREC" )
+
+ IF( l_dia_fechem ) ALLOCATE( zcoll3d(A2D(0),jpk), zscav3d(A2D(0),jpk), zfeprecip(A2D(0),jpk) )
!
! Total ligand concentration : Ligands can be chosen to be constant or variable
! Parameterization from Pham and Ito (2018)
! -------------------------------------------------
- xfecolagg(:,:,:) = ligand * 1E9 + MAX(0., chemo2(:,:,:) - tr(:,:,:,jpoxy,Kbb) ) / 400.E-6
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
+ xfecolagg(ji,jj,jk) = ligand * 1E9 + MAX(0., chemo2(ji,jj,jk) - tr(ji,jj,jk,jpoxy,Kbb) ) / 400.E-6
+ END_3D
+ !
IF( ln_ligvar ) THEN
- ztotlig(:,:,:) = 0.09 * 0.667 * tr(:,:,:,jpdoc,Kbb) * 1E6 + xfecolagg(:,:,:)
- ztotlig(:,:,:) = MIN( ztotlig(:,:,:), 10. )
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
+ ztotlig(ji,jj,jk) = 0.09 * 0.667 * tr(ji,jj,jk,jpdoc,Kbb) * 1E6 + xfecolagg(ji,jj,jk)
+ ztotlig(ji,jj,jk) = MIN( ztotlig(ji,jj,jk), 10. )
+ END_3D
ELSE
- IF( ln_ligand ) THEN ; ztotlig(:,:,:) = tr(:,:,:,jplgw,Kbb) * 1E9
- ELSE ; ztotlig(:,:,:) = ligand * 1E9
+ IF( ln_ligand ) THEN
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
+ ztotlig(ji,jj,jk) = tr(ji,jj,jk,jplgw,Kbb) * 1E9
+ END_3D
+ ELSE
+ ztotlig(:,:,:) = ligand * 1E9
ENDIF
ENDIF
@@ -96,20 +102,22 @@ CONTAINS
! This model is based on one ligand, Fe2+ and Fe3+
! Chemistry is supposed to be fast enough to be at equilibrium
! ------------------------------------------------------------
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1)
- zTL1(ji,jj,jk) = ztotlig(ji,jj,jk)
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
+ ztl1 = ztotlig(ji,jj,jk)
zkeq = fekeq(ji,jj,jk)
zklight = 4.77E-7 * etot(ji,jj,jk) * 0.5 / ( 10**(-6.3) )
zconsfe = consfe3(ji,jj,jk) / ( 10**(-6.3) )
- zfesatur = zTL1(ji,jj,jk) * 1E-9
+ zfesatur = ztl1 * 1E-9
ztfe = (1.0 + zklight) * tr(ji,jj,jk,jpfer,Kbb)
! Fe' is the root of a 2nd order polynom
za1 = 1. + zfesatur * zkeq + zklight + zconsfe - zkeq * tr(ji,jj,jk,jpfer,Kbb)
zFe3 (ji,jj,jk) = ( -1 * za1 + SQRT( za1**2 + 4. * ztfe * zkeq) ) / ( 2. * zkeq + rtrn )
- zFeL1(ji,jj,jk) = MAX( 0., tr(ji,jj,jk,jpfer,Kbb) - zFe3(ji,jj,jk) )
END_3D
!
- plig(:,:,:) = MAX( 0., ( zFeL1(:,:,:) / ( tr(:,:,:,jpfer,Kbb) + rtrn ) ) )
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
+ zfel1 = MAX( 0., tr(ji,jj,jk,jpfer,Kbb) - zFe3(ji,jj,jk) )
+ plig(ji,jj,jk) = MAX( 0., ( zfel1 / ( tr(ji,jj,jk,jpfer,Kbb) + rtrn ) ) )
+ END_3D
!
zdust = 0. ! if no dust available
@@ -125,16 +133,27 @@ CONTAINS
! to coagulate
! ----------------------------------------------------------------------
IF (ln_ligand) THEN
- zfecoll(:,:,:) = 0.5 * zFeL1(:,:,:) * MAX(0., tr(:,:,:,jplgw,Kbb) - xfecolagg(:,:,:) * 1.0E-9 ) / ( tr(:,:,:,jplgw,Kbb) + rtrn )
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
+ zfel1 = MAX( 0., tr(ji,jj,jk,jpfer,Kbb) - zFe3(ji,jj,jk) )
+ zfecoll(ji,jj,jk) = 0.5 * zfel1 * MAX(0., ztotlig(ji,jj,jk) - xfecolagg(ji,jj,jk) ) &
+ & / ( ztotlig(ji,jj,jk) + rtrn )
+ END_3D
ELSE
IF (ln_ligvar) THEN
- zfecoll(:,:,:) = 0.5 * zFeL1(:,:,:) * MAX(0., tr(:,:,:,jplgw,Kbb) - xfecolagg(:,:,:) * 1.0E-9 ) / ( tr(:,:,:,jplgw,Kbb) + rtrn )
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
+ zfel1 = MAX( 0., tr(ji,jj,jk,jpfer,Kbb) - zFe3(ji,jj,jk) )
+ zfecoll(ji,jj,jk) = 0.5 * zfel1 * MAX(0., ztotlig(ji,jj,jk) - xfecolagg(ji,jj,jk) ) &
+ & / ( ztotlig(ji,jj,jk) + rtrn )
+ END_3D
ELSE
- zfecoll(:,:,:) = 0.5 * zFeL1(:,:,:)
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
+ zfel1 = MAX( 0., tr(ji,jj,jk,jpfer,Kbb) - zFe3(ji,jj,jk) )
+ zfecoll(ji,jj,jk) = 0.5 * zfel1
+ END_3D
ENDIF
ENDIF
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1)
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
! Scavenging rate of iron. This scavenging rate depends on the load of particles of sea water.
! This parameterization assumes a simple second order kinetics (k[Particles][Fe]).
! Scavenging onto dust is also included as evidenced from the DUNE experiments.
@@ -150,8 +169,6 @@ CONTAINS
! This occurs in anoxic waters only
zprecipno3 = 2.0 * 130.0 * tr(ji,jj,jk,jpno3,Kbb) * nitrfac(ji,jj,jk) * xstep * zFe3(ji,jj,jk)
!
- zfeprecip(ji,jj,jk) = zprecip + zprecipno3
- !
ztrc = ( tr(ji,jj,jk,jppoc,Kbb) + tr(ji,jj,jk,jpgoc,Kbb) + tr(ji,jj,jk,jpcal,Kbb) + tr(ji,jj,jk,jpgsi,Kbb) ) * 1.e6
ztrc = MAX( rtrn, ztrc )
IF( ll_dust ) zdust = dust(ji,jj) / ( wdust / rday ) * tmask(ji,jj,jk)
@@ -173,7 +190,7 @@ CONTAINS
xcoagfe(ji,jj,jk) = zlam1a + zlam1b
!
tr(ji,jj,jk,jpfer,Krhs) = tr(ji,jj,jk,jpfer,Krhs) - zscave - zaggdfea - zaggdfeb &
- & - zfeprecip(ji,jj,jk)
+ & - ( zprecip + zprecipno3 )
tr(ji,jj,jk,jpsfe,Krhs) = tr(ji,jj,jk,jpsfe,Krhs) + zscave * scaveff * tr(ji,jj,jk,jppoc,Kbb) / ztrc
tr(ji,jj,jk,jpbfe,Krhs) = tr(ji,jj,jk,jpbfe,Krhs) + zscave * scaveff * tr(ji,jj,jk,jppoc,Kbb) / ztrc
@@ -192,27 +209,56 @@ CONTAINS
tr(ji,jj,jk,jpsfe,Krhs) = tr(ji,jj,jk,jpsfe,Krhs) + zaggdfea
tr(ji,jj,jk,jpbfe,Krhs) = tr(ji,jj,jk,jpbfe,Krhs) + zaggdfeb
!
- zscav3d(ji,jj,jk) = zscave
- zcoll3d(ji,jj,jk) = zaggdfea + zaggdfeb
+ IF( l_dia_fechem ) THEN
+ zscav3d(ji,jj,jk) = zscave
+ zcoll3d(ji,jj,jk) = zaggdfea + zaggdfeb
+ zfeprecip(ji,jj,jk) = zprecip + zprecipno3
+ ENDIF
!
END_3D
!
! Define the bioavailable fraction of iron
! ----------------------------------------
- biron(:,:,:) = tr(:,:,:,jpfer,Kbb)
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
+ biron(ji,jj,jk) = tr(ji,jj,jk,jpfer,Kbb)
+ END_3D
!
! Output of some diagnostics variables
! ---------------------------------
- IF( lk_iomput .AND. knt == nrdttrc ) THEN
- zrfact2 = 1.e3 * rfact2r ! conversion from mol/L/timestep into mol/m3/s
- IF( iom_use("Fe3") ) CALL iom_put("Fe3" , zFe3 (:,:,:) * tmask(:,:,:) ) ! Fe3+
- IF( iom_use("FeL1") ) CALL iom_put("FeL1" , zFeL1 (:,:,:) * tmask(:,:,:) ) ! FeL1
- IF( iom_use("TL1") ) CALL iom_put("TL1" , zTL1 (:,:,:) * tmask(:,:,:) ) ! TL1
- IF( iom_use("Totlig") ) CALL iom_put("Totlig" , ztotlig(:,:,:) * tmask(:,:,:) ) ! TL
- IF( iom_use("Biron") ) CALL iom_put("Biron" , biron (:,:,:) * 1e9 * tmask(:,:,:) ) ! biron
- IF( iom_use("FESCAV") ) CALL iom_put("FESCAV" , zscav3d(:,:,:) * 1e9 * tmask(:,:,:) * zrfact2 )
- IF( iom_use("FECOLL") ) CALL iom_put("FECOLL" , zcoll3d(:,:,:) * 1e9 * tmask(:,:,:) * zrfact2 )
- IF( iom_use("FEPREC") ) CALL iom_put("FEPREC" , zfeprecip(:,:,:) *1e9*tmask(:,:,:)*zrfact2 )
+ IF( lk_iomput .AND. knt == nrdttrc ) THEN
+ !
+ IF( l_dia_fechem ) THEN
+ zrfact2 = 1.e3 * rfact2r ! conversion from mol/L/timestep into mol/m3/s
+ ALLOCATE( zw3d(A2D(0),jpk) ) ; zw3d(A2D(0),jpk) = 0._wp
+ ! Fe3+
+ zw3d(A2D(0),1:jpkm1) = zFe3(A2D(0),1:jpkm1) * tmask(A2D(0),1:jpkm1)
+ CALL iom_put( "Fe3", zw3d )
+ ! FeL1
+ zw3d(A2D(0),1:jpkm1) = MAX( 0., tr(A2D(0),1:jpkm1,jpfer,Kbb) - zFe3(A2D(0),1:jpkm1) ) * tmask(A2D(0),1:jpkm1)
+ CALL iom_put( "FeL1", zw3d )
+ ! TL1 = Totlig
+ zw3d(A2D(0),1:jpkm1) = ztotlig(A2D(0),1:jpkm1) * tmask(A2D(0),1:jpkm1)
+ CALL iom_put( "TL1", zw3d )
+ ! Totlig
+ zw3d(A2D(0),1:jpkm1) = ztotlig(A2D(0),1:jpkm1) * tmask(A2D(0),1:jpkm1)
+ CALL iom_put( "Totlig", zw3d )
+ ! biron
+ zw3d(A2D(0),1:jpkm1) = biron(A2D(0),1:jpkm1) * tmask(A2D(0),1:jpkm1)
+ CALL iom_put( "Biron", zw3d )
+ ! FESCAV
+ zw3d(A2D(0),1:jpkm1) = zscav3d(A2D(0),1:jpkm1) * tmask(A2D(0),1:jpkm1) * zrfact2
+ CALL iom_put( "FESCAV", zw3d )
+ ! FECOLL
+ zw3d(A2D(0),1:jpkm1) = zcoll3d(A2D(0),1:jpkm1) * tmask(A2D(0),1:jpkm1) * zrfact2
+ CALL iom_put( "FECOLL", zw3d )
+ ! FEPREC
+ zw3d(A2D(0),1:jpkm1) = zfeprecip(A2D(0),1:jpkm1) * tmask(A2D(0),1:jpkm1) * zrfact2
+ CALL iom_put( "FEPREC", zw3d )
+ !
+ DEALLOCATE( zcoll3d, zscav3d, zfeprecip, zw3d )
+ !
+ ENDIF
+ !
ENDIF
IF(sn_cfctl%l_prttrc) THEN ! print mean trends (used for debugging)
diff --git a/src/TOP/PISCES/P4Z/p4zflx.F90 b/src/TOP/PISCES/P4Z/p4zflx.F90
index 051985ba2037053eb13b4094b8a8aff532c7f2de..243abb8289785ce4e2cd483be0859fb83c940080 100644
--- a/src/TOP/PISCES/P4Z/p4zflx.F90
+++ b/src/TOP/PISCES/P4Z/p4zflx.F90
@@ -52,6 +52,9 @@ MODULE p4zflx
REAL(wp) :: xconv = 0.01_wp / 3600._wp !: coefficients for conversion
+ LOGICAL :: l_dia_cflx, l_dia_tcflx
+ LOGICAL :: l_dia_oflx, l_dia_kg
+
!! * Substitutions
# include "do_loop_substitute.h90"
# include "domzgr_substitute.h90"
@@ -83,11 +86,20 @@ CONTAINS
REAL(wp) :: zph, zdic, zsch_o2, zsch_co2
REAL(wp) :: zyr_dec, zdco2dt
CHARACTER (len=25) :: charout
- REAL(wp), DIMENSION(jpi,jpj) :: zkgco2, zkgo2, zh2co3, zoflx, zpco2atm, zpco2oce
+ REAL(wp), DIMENSION(A2D(0)) :: zkgco2, zkgo2, zh2co3, zoflx, zpco2atm, zpco2oce
+ REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zw2d
!!---------------------------------------------------------------------
!
IF( ln_timing ) CALL timing_start('p4z_flx')
!
+ IF( kt == nittrc000 ) THEN
+ l_dia_cflx = iom_use( "Cflx" ) .OR. iom_use( "Dpco2" ) &
+ & .OR. iom_use( "pCO2sea" ) .OR. iom_use( "AtmCo2" )
+ l_dia_oflx = iom_use( "Oflx" ) .OR. iom_use( "Dpo2" )
+ l_dia_tcflx = iom_use( "tcflx" ) .OR. iom_use( "tcflxcum" )
+ l_dia_kg = iom_use( "Kg" )
+ ENDIF
+
! SURFACE CHEMISTRY (PCO2 AND [H+] IN
! SURFACE LAYER); THE RESULT OF THIS CALCULATION
! IS USED TO COMPUTE AIR-SEA FLUX OF CO2
@@ -108,9 +120,13 @@ CONTAINS
satmco2(:,:) = atcco2
ENDIF
- IF( l_co2cpl ) satmco2(:,:) = atm_co2(:,:)
+ IF( l_co2cpl ) THEN
+ DO_2D( 0, 0, 0, 0 )
+ satmco2(ji,jj) = atm_co2(ji,jj)
+ END_2D
+ ENDIF
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
! DUMMY VARIABLES FOR DIC, H+, AND BORATE
zrhd = rhd(ji,jj,1) + 1._wp
zdic = tr(ji,jj,1,jpdic,Kbb)
@@ -126,7 +142,7 @@ CONTAINS
! FIRST COMPUTE GAS EXCHANGE COEFFICIENTS
! -------------------------------------------
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
ztc = MIN( 35., ts(ji,jj,1,jp_tem,Kmm) )
ztc2 = ztc * ztc
ztc3 = ztc * ztc2
@@ -145,7 +161,7 @@ CONTAINS
END_2D
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
ztkel = tempis(ji,jj,1) + 273.15
zsal = salinprac(ji,jj,1) + ( 1.- tmask(ji,jj,1) ) * 35.
zvapsw = EXP(24.4543 - 67.4509*(100.0/ztkel) - 4.8489*LOG(ztkel/100) - 0.000544*zsal)
@@ -170,12 +186,16 @@ CONTAINS
tr(ji,jj,1,jpoxy,Krhs) = tr(ji,jj,1,jpoxy,Krhs) + zoflx(ji,jj) * rfact2 / e3t(ji,jj,1,Kmm)
END_2D
- IF( iom_use("tcflx") .OR. iom_use("tcflxcum") .OR. kt == nitrst &
- & .OR. (ln_check_mass .AND. kt == nitend) ) &
- t_oce_co2_flx = glob_sum( 'p4zflx', oce_co2(:,:) * e1e2t(:,:) * 1000. ) ! Total Flux of Carbon
- t_oce_co2_flx_cum = t_oce_co2_flx_cum + t_oce_co2_flx ! Cumulative Total Flux of Carbon
-! t_atm_co2_flx = glob_sum( 'p4zflx', satmco2(:,:) * e1e2t(:,:) ) ! Total atmospheric pCO2
- t_atm_co2_flx = atcco2 ! Total atmospheric pCO2
+ IF( l_dia_tcflx .OR. kt == nitrst &
+ & .OR. (ln_check_mass .AND. kt == nitend) ) THEN
+ ALLOCATE( zw2d(A2D(0)) )
+ zw2d(A2D(0)) = oce_co2(A2D(0)) * e1e2t(A2D(0)) * 1000._wp
+ t_oce_co2_flx = glob_sum( 'p4zflx', zw2d(:,:) ) ! Total Flux of Carbon
+ t_oce_co2_flx_cum = t_oce_co2_flx_cum + t_oce_co2_flx ! Cumulative Total Flux of Carbon
+! t_atm_co2_flx = glob_sum( 'p4zflx', satmco2(:,:) * e1e2t(:,:) ) ! Total atmospheric pCO2
+ t_atm_co2_flx = atcco2 ! Total atmospheric pCO2
+ DEALLOCATE( zw2d )
+ ENDIF
IF(sn_cfctl%l_prttrc) THEN ! print mean trends (used for debugging)
WRITE(charout, FMT="('flx ')")
@@ -184,15 +204,47 @@ CONTAINS
ENDIF
IF( lk_iomput .AND. knt == nrdttrc ) THEN
- CALL iom_put( "AtmCo2" , satmco2(:,:) * tmask(:,:,1) ) ! Atmospheric CO2 concentration
- CALL iom_put( "Cflx" , oce_co2(:,:) * 1000. )
- CALL iom_put( "Oflx" , zoflx(:,:) * 1000. )
- CALL iom_put( "Kg" , zkgco2(:,:) * tmask(:,:,1) )
- CALL iom_put( "Dpco2" , ( zpco2atm(:,:) - zpco2oce(:,:) ) * tmask(:,:,1) )
- CALL iom_put( "pCO2sea" , zpco2oce(:,:) * tmask(:,:,1) )
- CALL iom_put( "Dpo2" , ( atcox * patm(:,:) - atcox * tr(:,:,1,jpoxy,Kbb) / ( chemo2(:,:,1) + rtrn ) ) * tmask(:,:,1) )
- CALL iom_put( "tcflx" , t_oce_co2_flx ) ! molC/s
- CALL iom_put( "tcflxcum", t_oce_co2_flx_cum ) ! molC
+ !
+ IF( l_dia_cflx ) THEN
+ ALLOCATE( zw2d(A2D(0)) )
+ ! Atmospheric CO2 concentration
+ zw2d(A2D(0)) = satmco2(A2D(0)) * tmask(A2D(0),1)
+ CALL iom_put( "AtmCo2", zw2d )
+ ! Carbon flux
+ zw2d(A2D(0)) = oce_co2(A2D(0)) * 1000._wp
+ CALL iom_put( "Cflx", zw2d )
+ ! atmospheric Dpco2
+ zw2d(A2D(0)) = ( zpco2atm(A2D(0)) - zpco2oce(A2D(0)) ) * tmask(A2D(0),1)
+ CALL iom_put( "Dpco2", zw2d )
+ ! oceanic Dpco2
+ zw2d(A2D(0)) = zpco2oce(A2D(0)) * tmask(A2D(0),1)
+ CALL iom_put( "pCO2sea", zw2d )
+ !
+ DEALLOCATE( zw2d )
+ ENDIF
+ !
+ IF( l_dia_oflx ) THEN
+ ALLOCATE( zw2d(A2D(0)) )
+ ! oxygen flux
+ CALL iom_put( "Oflx", zoflx * 1000._wp )
+ ! Dpo2
+ zw2d(A2D(0)) = ( atcox * patm(A2D(0)) - atcox * tr(A2D(0),1,jpoxy,Kbb) &
+ / ( chemo2(A2D(0),1) + rtrn ) ) * tmask(A2D(0),1)
+ CALL iom_put( "Dpo2", zw2d )
+ DEALLOCATE( zw2d )
+ ENDIF
+ !
+ IF( l_dia_kg ) THEN
+ ALLOCATE( zw2d(A2D(0)) )
+ zw2d(A2D(0)) = zkgco2(A2D(0)) * tmask(A2D(0),1)
+ CALL iom_put( "Kg", zw2d )
+ DEALLOCATE( zw2d )
+ ENDIF
+ IF( l_dia_tcflx ) THEN
+ CALL iom_put( "tcflx" , t_oce_co2_flx ) ! global flux of carbon
+ CALL iom_put( "tcflxcum", t_oce_co2_flx_cum ) ! Cumulative flux of carbon
+ ENDIF
+ !
ENDIF
!
IF( ln_timing ) CALL timing_stop('p4z_flx')
@@ -267,7 +319,7 @@ CONTAINS
IF(lwp) WRITE(numout,*) ' Spatialized Atmospheric pCO2 from an external file'
ENDIF
!
- oce_co2(:,:) = 0._wp ! Initialization of Flux of Carbon
+! oce_co2(:,:) = 0._wp ! Initialization of Flux of Carbon
t_oce_co2_flx = 0._wp
t_atm_co2_flx = 0._wp
!
@@ -288,6 +340,7 @@ CONTAINS
CHARACTER(len=100) :: cn_dir ! Root directory for location of ssr files
TYPE(FLD_N) :: sn_patm ! informations about the fields to be read
TYPE(FLD_N) :: sn_atmco2 ! informations about the fields to be read
+ INTEGER :: ji, jj
!!
NAMELIST/nampisatm/ ln_presatm, ln_presatmco2, sn_patm, sn_atmco2, cn_dir
!!----------------------------------------------------------------------
@@ -337,12 +390,16 @@ CONTAINS
!
IF( ln_presatm ) THEN
CALL fld_read( kt, 1, sf_patm ) !* input Patm provided at kt + 1/2
- patm(:,:) = sf_patm(1)%fnow(:,:,1)/101325.0 ! atmospheric pressure
+ DO_2D( 0, 0, 0, 0 )
+ patm(ji,jj) = sf_patm(1)%fnow(ji,jj,1)/101325.0 ! atmospheric pressure
+ END_2D
ENDIF
!
IF( ln_presatmco2 ) THEN
CALL fld_read( kt, 1, sf_atmco2 ) !* input atmco2 provided at kt + 1/2
- satmco2(:,:) = sf_atmco2(1)%fnow(:,:,1) ! atmospheric pressure
+ DO_2D( 0, 0, 0, 0 )
+ satmco2(ji,jj) = sf_atmco2(1)%fnow(ji,jj,1) ! atmospheric pressure
+ END_2D
ELSE
satmco2(:,:) = atcco2 ! Initialize atmco2 if no reading from a file
ENDIF
@@ -354,7 +411,7 @@ CONTAINS
!!----------------------------------------------------------------------
!! *** ROUTINE p4z_flx_alloc ***
!!----------------------------------------------------------------------
- ALLOCATE( satmco2(jpi,jpj), patm(jpi,jpj), STAT=p4z_flx_alloc )
+ ALLOCATE( satmco2(A2D(0)), patm(A2D(0)), STAT=p4z_flx_alloc )
!
IF( p4z_flx_alloc /= 0 ) CALL ctl_stop( 'STOP', 'p4z_flx_alloc : failed to allocate arrays' )
!
diff --git a/src/TOP/PISCES/P4Z/p4zint.F90 b/src/TOP/PISCES/P4Z/p4zint.F90
index 9b95c2e495b9e7c38277d993010743d8e9e560b2..c0243fc4c3446046d6544f3fcf29de78d0f99c8a 100644
--- a/src/TOP/PISCES/P4Z/p4zint.F90
+++ b/src/TOP/PISCES/P4Z/p4zint.F90
@@ -44,16 +44,18 @@ CONTAINS
!
! Computation of phyto and zoo metabolic rate
! -------------------------------------------
- ! Generic temperature dependence (Eppley, 1972)
- tgfunc (:,:,:) = EXP( 0.0631 * ts(:,:,:,jp_tem,Kmm) )
- ! Temperature dependence of mesozooplankton (Buitenhuis et al. (2005))
- tgfunc2(:,:,:) = EXP( 0.0761 * ts(:,:,:,jp_tem,Kmm) )
+ DO_3D( 0, 0, 0, 0, 1, jpk )
+ ! Generic temperature dependence (Eppley, 1972)
+ tgfunc (ji,jj,jk) = EXP( 0.0631 * ts(ji,jj,jk,jp_tem,Kmm) )
+ ! Temperature dependence of mesozooplankton (Buitenhuis et al. (2005))
+ tgfunc2(ji,jj,jk) = EXP( 0.0761 * ts(ji,jj,jk,jp_tem,Kmm) )
+ END_3D
! Computation of the silicon dependant half saturation constant for silica uptake
! This is based on an old study by Pondaven et al. (1998)
! --------------------------------------------------------------------------------
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
zvar = tr(ji,jj,1,jpsil,Kbb) * tr(ji,jj,1,jpsil,Kbb)
xksimax(ji,jj) = MAX( xksimax(ji,jj), ( 1.+ 7.* zvar / ( xksilim * xksilim + zvar ) ) * 1e-6 )
END_2D
@@ -73,14 +75,14 @@ CONTAINS
zcodel = ASIN( SIN( zrum * rpi * 2._wp ) * SIN( rad * 23.5_wp ) )
! day length in hours
- strn(:,:) = 0.
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+! strn(:,:) = 0.
+ DO_2D( 0, 0, 0, 0 )
zargu = TAN( zcodel ) * TAN( gphit(ji,jj) * rad )
zargu = MAX( -1., MIN( 1., zargu ) )
strn(ji,jj) = MAX( 0.0, 24. - 2. * ACOS( zargu ) / rad / 15. )
END_2D
!
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
! denitrification factor computed from O2 levels
! This factor diagnoses below which level of O2 denitrification
! is active
diff --git a/src/TOP/PISCES/P4Z/p4zligand.F90 b/src/TOP/PISCES/P4Z/p4zligand.F90
index 07ce54c431ee750ec0a6df0bd602d0c03871b924..40fe75fd45d336d96e198b89ba1969e5aaecb78f 100644
--- a/src/TOP/PISCES/P4Z/p4zligand.F90
+++ b/src/TOP/PISCES/P4Z/p4zligand.F90
@@ -26,6 +26,8 @@ MODULE p4zligand
REAL(wp), PUBLIC :: prlgw !: Photochemical of weak ligand
REAL(wp), PUBLIC :: xklig !: 1/2 saturation constant of photolysis
+ LOGICAL :: l_dia_ligand
+
!! * Substitutions
# include "do_loop_substitute.h90"
!!----------------------------------------------------------------------
@@ -44,62 +46,117 @@ CONTAINS
INTEGER, INTENT(in) :: kt, knt ! ocean time step
INTEGER, INTENT(in) :: Kbb, Krhs ! time level indices
!
- INTEGER :: ji, jj, jk
- REAL(wp) :: zlgwp, zlgwpr, zlgwr, zlablgw
- REAL(wp) :: zlam1a, zlam1b, zaggliga, zligco
- REAL(wp), DIMENSION(jpi,jpj,jpk) :: zligrem, zligpr, zligprod, zlcoll3d
+ INTEGER :: ji, jj, jk
+ REAL(wp) :: zlgwp, zlgwpr, zlgwr, zlablgw
+ REAL(wp) :: zlam1a, zlam1b, zaggliga, zligco
+ REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zligrem, zligpr, zligprod, zlcoll3d
CHARACTER (len=25) :: charout
!!---------------------------------------------------------------------
!
+ IF( kt == nittrc000 ) &
+ & l_dia_ligand = iom_use( "LIGREM" ) .OR. iom_use( "LIGPR" ) &
+ & .OR. iom_use( "LPRODR" ) .OR. iom_use( "LGWCOLL" )
+
IF( ln_timing ) CALL timing_start('p4z_ligand')
!
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1)
- !
- ! ------------------------------------------------------------------
- ! Remineralization of iron ligands
- ! ------------------------------------------------------------------
- ! production from remineralisation of organic matter
+ ! ------------------------------------------------------------------
+ ! Remineralization of iron ligands
+ ! ------------------------------------------------------------------
+
+ ! production from remineralisation of organic matter
+ IF( l_dia_ligand ) THEN
+ ALLOCATE( zligprod(A2D(0),jpk) ) ; zligprod(A2D(0),jpk) = 0._wp
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
+ zligprod(ji,jj,jk) = tr(ji,jj,jk,jplgw,Krhs)
+ END_3D
+ ENDIF
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
zlgwp = orem(ji,jj,jk) * rlig
- ! decay of weak ligand
- ! This is based on the idea that as LGW is lower
- ! there is a larger fraction of refractory OM
+ tr(ji,jj,jk,jplgw,Krhs) = tr(ji,jj,jk,jplgw,Krhs) + zlgwp
+ !
+ END_3D
+ !
+ IF( l_dia_ligand .AND. ( lk_iomput .AND. knt == nrdttrc ) ) THEN
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
+ zligprod(ji,jj,jk) = ( tr(ji,jj,jk,jplgw,Krhs) - zligprod(ji,jj,jk) ) &
+ & * 1e9 * 1.e+3 * rfact2r * tmask(ji,jj,jk)
+ END_3D
+ CALL iom_put( "LPRODR", zligprod )
+ DEALLOCATE( zligprod )
+ ENDIF
+
+ ! Decay of weak ligand
+ ! This is based on the idea that as LGW is lower
+ ! there is a larger fraction of refractory OM
+ IF( l_dia_ligand ) THEN
+ ALLOCATE( zligrem(A2D(0),jpk) ) ; zligrem(A2D(0),jpk) = 0._wp
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
+ zligrem(ji,jj,jk) = tr(ji,jj,jk,jplgw,Krhs)
+ END_3D
+ ENDIF
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
zlgwr = ( 1.0 / rlgs * MAX(0., tr(ji,jj,jk,jplgw,Kbb) - xfecolagg(ji,jj,jk) * 1.0E-9 ) &
& + 1.0 / rlgw * xfecolagg(ji,jj,jk) * 1.0E-9 ) / ( rtrn + tr(ji,jj,jk,jplgw,Kbb) )
zlgwr = zlgwr * tgfunc(ji,jj,jk) * ( xstep / nyear_len(1) ) * blim(ji,jj,jk) * tr(ji,jj,jk,jplgw,Kbb)
- ! photochem loss of weak ligand
+ tr(ji,jj,jk,jplgw,Krhs) = tr(ji,jj,jk,jplgw,Krhs) - zlgwr
+ END_3D
+ !
+ IF( l_dia_ligand .AND. ( lk_iomput .AND. knt == nrdttrc ) ) THEN
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
+ zligrem(ji,jj,jk) = - ( tr(ji,jj,jk,jplgw,Krhs) - zligrem(ji,jj,jk) ) &
+ & * 1e9 * 1.e+3 * rfact2r * tmask(ji,jj,jk)
+ END_3D
+ CALL iom_put( "LIGREM", zligrem )
+ DEALLOCATE( zligrem )
+ ENDIF
+
+ ! photochem loss of weak ligand
+ IF( l_dia_ligand ) THEN
+ ALLOCATE( zligpr(A2D(0),jpk) ) ; zligpr(A2D(0),jpk) = 0._wp
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
+ zligpr(ji,jj,jk) = tr(ji,jj,jk,jplgw,Krhs)
+ END_3D
+ ENDIF
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
zlgwpr = prlgw * xstep * etot(ji,jj,jk) * tr(ji,jj,jk,jplgw,Kbb)**3 * (1. - fr_i(ji,jj)) &
& / ( tr(ji,jj,jk,jplgw,Kbb)**2 + (xklig)**2)
- ! Coagulation of ligands due to various processes (Brownian, shear, diff. sedimentation
- ! xcoagfe is computed in p4zfechem
- ! -------------------------------------------------------------------------------------
- ! 50% of the ligands are supposed to be in the colloidal size fraction
- ! as for FeL
+
+ tr(ji,jj,jk,jplgw,Krhs) = tr(ji,jj,jk,jplgw,Krhs) - zlgwpr
+ END_3D
+ !
+ IF( l_dia_ligand .AND. ( lk_iomput .AND. knt == nrdttrc ) ) THEN
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
+ zligpr(ji,jj,jk) = - ( tr(ji,jj,jk,jplgw,Krhs) - zligpr(ji,jj,jk) ) &
+ & * 1e9 * 1.e+3 * rfact2r * tmask(ji,jj,jk)
+ END_3D
+ CALL iom_put( "LIGPR", zligpr )
+ DEALLOCATE( zligpr )
+ ENDIF
+
+ ! Coagulation of ligands due to various processes (Brownian, shear, diff. sedimentation
+ ! xcoagfe is computed in p4zfechem
+ ! -------------------------------------------------------------------------------------
+ ! 50% of the ligands are supposed to be in the colloidal size fraction as for FeL
+ IF( l_dia_ligand ) THEN
+ ALLOCATE( zlcoll3d(A2D(0),jpk) ) ; zlcoll3d(A2D(0),jpk) = 0._wp
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
+ zlcoll3d(ji,jj,jk) = tr(ji,jj,jk,jplgw,Krhs)
+ END_3D
+ ENDIF
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
zligco = 0.5 * MAX(0., tr(ji,jj,jk,jplgw,Kbb) - xfecolagg(ji,jj,jk) * 1.0E-9 )
zaggliga = xcoagfe(ji,jj,jk) * xstep * zligco
- tr(ji,jj,jk,jplgw,Krhs) = tr(ji,jj,jk,jplgw,Krhs) + zlgwp - zlgwr - zlgwpr - zaggliga
- !
- zligrem(ji,jj,jk) = zlgwr
- zligpr(ji,jj,jk) = zlgwpr
- zligprod(ji,jj,jk) = zlgwp
- zlcoll3d(ji,jj,jk) = zaggliga
+ tr(ji,jj,jk,jplgw,Krhs) = tr(ji,jj,jk,jplgw,Krhs) - zaggliga
END_3D
!
- ! Output of some diagnostics variables
- ! ---------------------------------
- IF( lk_iomput .AND. knt == nrdttrc ) THEN
- IF( iom_use( "LIGREM" ) ) THEN
- zligrem(:,:,jpk) = 0. ; CALL iom_put( "LIGREM", zligrem(:,:,:) * 1e9 * 1.e+3 * rfact2r * tmask(:,:,:) )
- ENDIF
- IF( iom_use( "LIGPR" ) ) THEN
- zligpr(:,:,jpk) = 0. ; CALL iom_put( "LIGPR" , zligpr(:,:,:) * 1e9 * 1.e+3 * rfact2r * tmask(:,:,:) )
- ENDIF
- IF( iom_use( "LPRODR" ) ) THEN
- zligprod(:,:,jpk) = 0. ; CALL iom_put( "LPRODR", zligprod(:,:,:) * 1e9 * 1.e+3 * rfact2r * tmask(:,:,:) )
- ENDIF
- IF( iom_use( "LGWCOLL" ) ) THEN
- zlcoll3d(:,:,jpk) = 0. ; CALL iom_put( "LGWCOLL", zlcoll3d(:,:,:) * 1.e9 * 1.e+3 * rfact2r * tmask(:,:,:) )
- ENDIF
+ IF( l_dia_ligand .AND. ( lk_iomput .AND. knt == nrdttrc ) ) THEN
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
+ zlcoll3d(ji,jj,jk) = - ( tr(ji,jj,jk,jplgw,Krhs) - zlcoll3d(ji,jj,jk) ) &
+ & * 1e9 * 1.e+3 * rfact2r * tmask(ji,jj,jk)
+ END_3D
+ CALL iom_put( "LGWCOLL", zlcoll3d )
+ DEALLOCATE( zlcoll3d )
ENDIF
!
IF(sn_cfctl%l_prttrc) THEN ! print mean trends (used for debugging)
diff --git a/src/TOP/PISCES/P4Z/p4zlim.F90 b/src/TOP/PISCES/P4Z/p4zlim.F90
index 4e227808aad4e067b9348d662bcf0637977d7b93..d388955fb93955e90ba22509528b639817db1222 100644
--- a/src/TOP/PISCES/P4Z/p4zlim.F90
+++ b/src/TOP/PISCES/P4Z/p4zlim.F90
@@ -68,6 +68,8 @@ MODULE p4zlim
REAL(wp) :: xcoef2 = 1.21E-5 * 14. / 55.85 / 7.3125 * 0.5 * 1.5
REAL(wp) :: xcoef3 = 1.15E-4 * 14. / 55.85 / 7.3125 * 0.5
+ LOGICAL :: l_dia_nut_lim, l_dia_iron_lim, l_dia_size_lim, l_dia_fracal
+
!! * Substitutions
# include "do_loop_substitute.h90"
!!----------------------------------------------------------------------
@@ -98,13 +100,21 @@ CONTAINS
REAL(wp) :: zconc1d, zconc1dnh4, zconc0n, zconc0nnh4
REAL(wp) :: fananof, fadiatf, znutlim, zfalim
REAL(wp) :: znutlimtot, zlimno3, zlimnh4, zbiron
+ REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zw3d
!!---------------------------------------------------------------------
!
IF( ln_timing ) CALL timing_start('p4z_lim')
!
+ IF( kt == nittrc000 ) THEN
+ l_dia_nut_lim = iom_use( "LNnut" ) .OR. iom_use( "LDnut" )
+ l_dia_iron_lim = iom_use( "LNFe" ) .OR. iom_use( "LDFe" )
+ l_dia_size_lim = iom_use( "SIZEN" ) .OR. iom_use( "SIZED" )
+ l_dia_fracal = iom_use( "xfracal" )
+ ENDIF
+ !
sizena(:,:,:) = 1.0 ; sizeda(:,:,:) = 1.0
!
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1)
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
! Computation of a variable Ks for iron on diatoms taking into account
! that increasing biomass is made of generally bigger cells
@@ -219,7 +229,7 @@ CONTAINS
! Size estimation of phytoplankton based on total biomass
! Assumes that larger biomass implies addition of larger cells
! ------------------------------------------------------------
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1)
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
zcoef = tr(ji,jj,jk,jpphy,Kbb) - MIN(xsizephy, tr(ji,jj,jk,jpphy,Kbb) )
sizena(ji,jj,jk) = 1. + ( xsizern -1.0 ) * zcoef / ( xsizephy + zcoef )
zcoef = tr(ji,jj,jk,jpdia,Kbb) - MIN(xsizedia, tr(ji,jj,jk,jpdia,Kbb) )
@@ -231,7 +241,7 @@ CONTAINS
! This is a purely adhoc formulation described in Aumont et al. (2015)
! This fraction depends on nutrient limitation, light, temperature
! --------------------------------------------------------------------
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1)
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
zlim1 = xnanonh4(ji,jj,jk) + xnanono3(ji,jj,jk)
zlim2 = tr(ji,jj,jk,jppo4,Kbb) / ( tr(ji,jj,jk,jppo4,Kbb) + concnnh4 )
zlim3 = tr(ji,jj,jk,jpfer,Kbb) / ( tr(ji,jj,jk,jpfer,Kbb) + 6.E-11 )
@@ -250,7 +260,7 @@ CONTAINS
xfracal(ji,jj,jk) = MAX( 0.02, xfracal(ji,jj,jk) )
END_3D
!
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1)
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
! denitrification factor computed from O2 levels
nitrfac(ji,jj,jk) = MAX( 0.e0, 0.4 * ( 6.e-6 - tr(ji,jj,jk,jpoxy,Kbb) ) &
& / ( oxymin + tr(ji,jj,jk,jpoxy,Kbb) ) )
@@ -263,13 +273,41 @@ CONTAINS
END_3D
!
IF( lk_iomput .AND. knt == nrdttrc ) THEN ! save output diagnostics
- CALL iom_put( "xfracal", xfracal(:,:,:) * tmask(:,:,:) ) ! euphotic layer deptht
- CALL iom_put( "LNnut" , xlimphy(:,:,:) * tmask(:,:,:) ) ! Nutrient limitation term
- CALL iom_put( "LDnut" , xlimdia(:,:,:) * tmask(:,:,:) ) ! Nutrient limitation term
- CALL iom_put( "LNFe" , xlimnfe(:,:,:) * tmask(:,:,:) ) ! Iron limitation term
- CALL iom_put( "LDFe" , xlimdfe(:,:,:) * tmask(:,:,:) ) ! Iron limitation term
- CALL iom_put( "SIZEN" , sizen (:,:,:) * tmask(:,:,:) ) ! Iron limitation term
- CALL iom_put( "SIZED" , sized (:,:,:) * tmask(:,:,:) ) ! Iron limitation term
+ !
+ IF( l_dia_fracal ) THEN ! fraction of calcifiers
+ ALLOCATE( zw3d(A2D(0),jpk) ) ; zw3d(A2D(0),jpk) = 0._wp
+ zw3d(A2D(0),1:jpkm1) = xfracal(A2D(0),1:jpkm1) * tmask(A2D(0),1:jpkm1)
+ CALL iom_put( "xfracal", zw3d)
+ DEALLOCATE( zw3d )
+ ENDIF
+ !
+ IF( l_dia_nut_lim ) THEN ! Nutrient limitation term
+ ALLOCATE( zw3d(A2D(0),jpk) ) ; zw3d(A2D(0),jpk) = 0._wp
+ zw3d(A2D(0),1:jpkm1) = xlimphy(A2D(0),1:jpkm1) * tmask(A2D(0),1:jpkm1)
+ CALL iom_put( "LNnut", zw3d)
+ zw3d(A2D(0),1:jpkm1) = xlimdia(A2D(0),1:jpkm1) * tmask(A2D(0),1:jpkm1)
+ CALL iom_put( "LDnut", zw3d)
+ DEALLOCATE( zw3d )
+ ENDIF
+ !
+ IF( l_dia_iron_lim ) THEN ! Iron limitation term
+ ALLOCATE( zw3d(A2D(0),jpk) ) ; zw3d(A2D(0),jpk) = 0._wp
+ zw3d(A2D(0),1:jpkm1) = xlimnfe(A2D(0),1:jpkm1) * tmask(A2D(0),1:jpkm1)
+ CALL iom_put( "LNFe", zw3d)
+ zw3d(A2D(0),1:jpkm1) = xlimdfe(A2D(0),1:jpkm1) * tmask(A2D(0),1:jpkm1)
+ CALL iom_put( "LDFe", zw3d)
+ DEALLOCATE( zw3d )
+ ENDIF
+ !
+ IF( l_dia_size_lim ) THEN ! Size limitation term
+ ALLOCATE( zw3d(A2D(0),jpk) ) ; zw3d(A2D(0),jpk) = 0._wp
+ zw3d(A2D(0),1:jpkm1) = sizen(A2D(0),1:jpkm1) * tmask(A2D(0),1:jpkm1)
+ CALL iom_put( "SIZEN", zw3d)
+ zw3d(A2D(0),1:jpkm1) = sized(A2D(0),1:jpkm1) * tmask(A2D(0),1:jpkm1)
+ CALL iom_put( "SIZED", zw3d)
+ DEALLOCATE( zw3d )
+ ENDIF
+ !
ENDIF
!
IF( ln_timing ) CALL timing_stop('p4z_lim')
@@ -355,16 +393,16 @@ CONTAINS
!!----------------------------------------------------------------------
!* Biological arrays for phytoplankton growth
- ALLOCATE( xnanono3(jpi,jpj,jpk), xdiatno3(jpi,jpj,jpk), &
- & xnanonh4(jpi,jpj,jpk), xdiatnh4(jpi,jpj,jpk), &
- & xnanopo4(jpi,jpj,jpk), xdiatpo4(jpi,jpj,jpk), &
- & xnanofer(jpi,jpj,jpk), xdiatfer(jpi,jpj,jpk), &
- & xlimphy (jpi,jpj,jpk), xlimdia (jpi,jpj,jpk), &
- & xlimnfe (jpi,jpj,jpk), xlimdfe (jpi,jpj,jpk), &
- & xlimbac (jpi,jpj,jpk), xlimbacl(jpi,jpj,jpk), &
- & concnfe (jpi,jpj,jpk), concdfe (jpi,jpj,jpk), &
- & xqfuncfecn(jpi,jpj,jpk), xqfuncfecd(jpi,jpj,jpk), &
- & xlimsi (jpi,jpj,jpk), STAT=p4z_lim_alloc )
+ ALLOCATE( xnanono3(A2D(0),jpk), xdiatno3(A2D(0),jpk), &
+ & xnanonh4(A2D(0),jpk), xdiatnh4(A2D(0),jpk), &
+ & xnanopo4(A2D(0),jpk), xdiatpo4(A2D(0),jpk), &
+ & xnanofer(A2D(0),jpk), xdiatfer(A2D(0),jpk), &
+ & xlimphy (A2D(0),jpk), xlimdia (A2D(0),jpk), &
+ & xlimnfe (A2D(0),jpk), xlimdfe (A2D(0),jpk), &
+ & xlimbac (A2D(0),jpk), xlimbacl(A2D(0),jpk), &
+ & concnfe (A2D(0),jpk), concdfe (A2D(0),jpk), &
+ & xqfuncfecn(A2D(0),jpk), xqfuncfecd(A2D(0),jpk), &
+ & xlimsi (A2D(0),jpk), STAT=p4z_lim_alloc )
!
IF( p4z_lim_alloc /= 0 ) CALL ctl_stop( 'STOP', 'p4z_lim_alloc : failed to allocate arrays.' )
!
diff --git a/src/TOP/PISCES/P4Z/p4zlys.F90 b/src/TOP/PISCES/P4Z/p4zlys.F90
index 007835e179b9aed11fd54f31bedf6e3bc42d167e..61db35c30dcab30254202d2bd1b12ce82b438ed9 100644
--- a/src/TOP/PISCES/P4Z/p4zlys.F90
+++ b/src/TOP/PISCES/P4Z/p4zlys.F90
@@ -32,7 +32,8 @@ MODULE p4zlys
REAL(wp), PUBLIC :: kdca !: diss. rate constant calcite
REAL(wp), PUBLIC :: nca !: order of reaction for calcite dissolution
- INTEGER :: rmtss ! number of seconds per month
+ INTEGER :: rmtss ! number of seconds per month
+ LOGICAL :: l_dia
!! * Module variables
REAL(wp) :: calcon = 1.03E-2 !: mean calcite concentration [Ca2+] in sea water [mole/kg solution]
@@ -63,23 +64,36 @@ CONTAINS
INTEGER, INTENT(in) :: Kbb, Krhs ! time level indices
!
INTEGER :: ji, jj, jk, jn
- REAL(wp) :: zdispot, zrhd, zcalcon
+ REAL(wp) :: zdispot, zrhd, zcalcon, ztra
REAL(wp) :: zomegaca, zexcess, zexcess0, zkd
CHARACTER (len=25) :: charout
- REAL(wp), DIMENSION(jpi,jpj,jpk) :: zco3, zcaldiss, zhinit, zhi, zco3sat
+ REAL(wp), DIMENSION(A2D(0),jpk) :: zhinit, zhi, zco3
+ REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zw3d
!!---------------------------------------------------------------------
!
IF( ln_timing ) CALL timing_start('p4z_lys')
!
-
- zhinit (:,:,:) = hi(:,:,:) / ( rhd(:,:,:) + 1._wp )
+ IF( kt == nittrc000 ) &
+ & l_dia = iom_use( "PH" ) .OR. iom_use( "CO3" ) .OR. iom_use( "CO3sat" ) .OR. iom_use( "DCAL" )
+
+ IF( l_dia ) THEN !* Save ta and sa trends
+ ALLOCATE( zw3d(A2D(0),jpk) ) ; zw3d(A2D(0),jpk) = 0._wp
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
+ zw3d(ji,jj,jk) = tr(ji,jj,jk,jpdic,Krhs) ! we be used to compute DCAL if needed
+ END_3D
+ ENDIF
+ !
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
+ zhinit(ji,jj,jk) = hi(ji,jj,jk) / ( rhd(ji,jj,jk) + 1._wp )
+ END_3D
!
! -------------------------------------------
! COMPUTE [CO3--] and [H+] CONCENTRATIONS
! -------------------------------------------
CALL solve_at_general( zhinit, zhi, Kbb )
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1)
+
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
zco3(ji,jj,jk) = tr(ji,jj,jk,jpdic,Kbb) * ak13(ji,jj,jk) * ak23(ji,jj,jk) / (zhi(ji,jj,jk)**2 &
& + ak13(ji,jj,jk) * zhi(ji,jj,jk) + ak13(ji,jj,jk) * ak23(ji,jj,jk) + rtrn )
hi (ji,jj,jk) = zhi(ji,jj,jk) * ( rhd(ji,jj,jk) + 1._wp )
@@ -91,14 +105,13 @@ CONTAINS
! MGCO3)
! ---------------------------------------------------------
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1)
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
! DEVIATION OF [CO3--] FROM SATURATION VALUE
! Salinity dependance in zomegaca and divide by rhd to have good units
zcalcon = calcon * ( salinprac(ji,jj,jk) / 35._wp )
zrhd = rhd(ji,jj,jk) + 1._wp
zomegaca = ( zcalcon * zco3(ji,jj,jk) ) / ( aksp(ji,jj,jk) * zrhd + rtrn )
- zco3sat(ji,jj,jk) = aksp(ji,jj,jk) * zrhd / ( zcalcon + rtrn )
! SET DEGREE OF UNDER-/SUPERSATURATION
excess(ji,jj,jk) = 1._wp - zomegaca
@@ -116,25 +129,42 @@ CONTAINS
! CHANGE OF [CO3--] , [ALK], PARTICULATE [CACO3],
! AND [SUM(CO2)] DUE TO CACO3 DISSOLUTION/PRECIPITATION
- zcaldiss(ji,jj,jk) = zdispot * rfact2 / rmtss ! calcite dissolution
+ ztra = zdispot * rfact2 / rmtss ! calcite dissolution
!
- tr(ji,jj,jk,jptal,Krhs) = tr(ji,jj,jk,jptal,Krhs) + 2. * zcaldiss(ji,jj,jk)
- tr(ji,jj,jk,jpcal,Krhs) = tr(ji,jj,jk,jpcal,Krhs) - zcaldiss(ji,jj,jk)
- tr(ji,jj,jk,jpdic,Krhs) = tr(ji,jj,jk,jpdic,Krhs) + zcaldiss(ji,jj,jk)
+ tr(ji,jj,jk,jptal,Krhs) = tr(ji,jj,jk,jptal,Krhs) + 2. * ztra
+ tr(ji,jj,jk,jpcal,Krhs) = tr(ji,jj,jk,jpcal,Krhs) - ztra
+ tr(ji,jj,jk,jpdic,Krhs) = tr(ji,jj,jk,jpdic,Krhs) + ztra
END_3D
!
- IF( lk_iomput .AND. knt == nrdttrc ) THEN
- CALL iom_put( "PH" , -1. * LOG10( MAX( hi(:,:,:), rtrn ) ) * tmask(:,:,:) )
- IF( iom_use( "CO3" ) ) THEN
- zco3(:,:,jpk) = 0. ; CALL iom_put( "CO3" , zco3(:,:,:) * 1.e+3 * tmask(:,:,:) )
+ IF( l_dia .AND. knt == nrdttrc ) THEN
+ IF( iom_use( "DCAL" ) ) THEN ! calcite dissolution
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
+ zw3d(ji,jj,jk) = ( tr(ji,jj,jk,jpdic,Krhs) - zw3d(ji,jj,jk) ) * 1.e+3 * rfact2r * tmask(ji,jj,jk)
+ END_3D
+ CALL iom_put( "DCAL", zw3d )
+ ENDIF
+ IF( iom_use( "PH" ) ) THEN
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
+ zw3d(ji,jj,jk) = -1. * LOG10( MAX( hi(ji,jj,jk), rtrn ) ) * tmask(ji,jj,jk)
+ END_3D
+ CALL iom_put( "PH" , zw3d )
ENDIF
- IF( iom_use( "CO3sat" ) ) THEN
- zco3sat(:,:,jpk) = 0. ; CALL iom_put( "CO3sat", zco3sat(:,:,:) * 1.e+3 * tmask(:,:,:) )
+ IF( iom_use( "CO3" ) ) THEN ! bicarbonate
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
+ zw3d(ji,jj,jk) = zco3(ji,jj,jk) * 1.e+3 * tmask(ji,jj,jk)
+ END_3D
+ CALL iom_put( "CO3", zw3d )
ENDIF
- IF( iom_use( "DCAL" ) ) THEN
- zcaldiss(:,:,jpk) = 0. ; CALL iom_put( "DCAL" , zcaldiss(:,:,:) * 1.e+3 * rfact2r * tmask(:,:,:) )
- ENDIF
+ IF( iom_use( "CO3sat" ) ) THEN ! calcite saturation
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
+ zrhd = rhd(ji,jj,jk) + 1._wp
+ zw3d(ji,jj,jk) = aksp(ji,jj,jk) * zrhd / ( calcon * ( salinprac(ji,jj,jk) / 35._wp ) + rtrn ) &
+ & * 1.e+3 * tmask(ji,jj,jk)
+ END_3D
+ CALL iom_put( "CO3sat", zw3d )
+ ENDIF
+ DEALLOCATE( zw3d )
ENDIF
!
IF(sn_cfctl%l_prttrc) THEN ! print mean trends (used for debugging)
@@ -185,6 +215,9 @@ CONTAINS
! Number of seconds per month
rmtss = nyear_len(1) * rday / raamo
!
+ ! CE not really needed ; tempory, shoub be removed when quotan( A2D(0),jpk )
+ excess(:,:,:) = 0._wp
+ !
END SUBROUTINE p4z_lys_init
!!======================================================================
diff --git a/src/TOP/PISCES/P4Z/p4zmeso.F90 b/src/TOP/PISCES/P4Z/p4zmeso.F90
index 0033e0b8939a11324152aeec6fe0a82eeb086f71..d13609af7b0a9933c43c3e72e6f838ad3149dc82 100644
--- a/src/TOP/PISCES/P4Z/p4zmeso.F90
+++ b/src/TOP/PISCES/P4Z/p4zmeso.F90
@@ -52,6 +52,7 @@ MODULE p4zmeso
REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: depmig !: DVM of mesozooplankton : migration depth
INTEGER , ALLOCATABLE, SAVE, DIMENSION(:,:) :: kmig !: Vertical indice of the the migration depth
+ LOGICAL :: l_dia_fezoo2, l_dia_graz2, l_dia_lprodz2
!! * Substitutions
# include "do_loop_substitute.h90"
# include "domzgr_substitute.h90"
@@ -89,16 +90,30 @@ CONTAINS
REAL(wp) :: zgrazfffp, zgrazfffg, zgrazffep, zgrazffeg, zrum, zcodel, zargu, zval, zdep
REAL(wp) :: zsigma, zdiffdn, ztmp1, ztmp2, ztmp3, ztmp4, ztmptot, zmigthick
CHARACTER (len=25) :: charout
- REAL(wp), DIMENSION(jpi,jpj,jpk) :: zgrazing, zfezoo2
- REAL(wp), DIMENSION(jpi,jpj,jpk) :: zgrarem, zgraref, zgrapoc, zgrapof, zgrabsi
+ REAL(wp), DIMENSION(A2D(0),jpk) :: zgrarem, zgraref, zgrapoc, zgrapof, zgrabsi
REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zgramigrem, zgramigref, zgramigpoc, zgramigpof
REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zgramigbsi
+ REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zgrazing2, zfezoo2, zzligprod2, zw3d
!!---------------------------------------------------------------------
!
IF( ln_timing ) CALL timing_start('p4z_meso')
!
- zgrazing(:,:,:) = 0._wp ; zgrapoc(:,:,:) = 0._wp
- zfezoo2 (:,:,:) = 0._wp ; zgrarem(:,:,:) = 0._wp
+ IF( kt == nittrc000 ) THEN
+ l_dia_graz2 = iom_use( "GRAZ2" )
+ l_dia_fezoo2 = iom_use( "FEZOO2" )
+ l_dia_lprodz2 = ln_ligand .AND. iom_use( "LPRODZ2" )
+ ENDIF
+ IF( l_dia_lprodz2 ) THEN
+ ALLOCATE( zzligprod2(A2D(0),jpk) )
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
+ zzligprod2(ji,jj,jk) = tr(ji,jj,jk,jplgw,Krhs)
+ END_3D
+ ENDIF
+ IF( l_dia_graz2 ) THEN
+ ALLOCATE( zgrazing2(A2D(0),jpk) )
+ ENDIF
+ !
+ zgrapoc(:,:,:) = 0._wp ; zgrarem(:,:,:) = 0._wp
zgraref (:,:,:) = 0._wp ; zgrapof(:,:,:) = 0._wp
zgrabsi (:,:,:) = 0._wp
!
@@ -108,7 +123,7 @@ CONTAINS
! ---------------------------------------------
IF (ln_dvm_meso) CALL p4z_meso_depmig( Kbb, Kmm )
!
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1)
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
zcompam = MAX( ( tr(ji,jj,jk,jpmes,Kbb) - 1.e-9 ), 0.e0 )
zfact = xstep * tgfunc2(ji,jj,jk) * zcompam
@@ -210,6 +225,7 @@ CONTAINS
zgrazfffp = zgrazffep * tr(ji,jj,jk,jpsfe,Kbb) / (tr(ji,jj,jk,jppoc,Kbb) + rtrn)
!
zgraztotc = zgrazdc + zgrazz + zgraznc + zgrazpoc + zgrazffep + zgrazffeg
+
! Compute the proportion of filter feeders. It is assumed steady state.
! ---------------------------------------------------------------------
zproport = 0._wp
@@ -247,14 +263,13 @@ CONTAINS
! Total ingestion rates in C, N, Fe
- zgraztotc = zgrazdc + zgrazz + zgraznc + zgrazpoc + zgrazffep + zgrazffeg
+ zgraztotc = zgrazdc + zgrazz + zgraznc + zgrazpoc + zgrazffep + zgrazffeg ! grazing by mesozooplankton
+ IF( l_dia_graz2 ) zgrazing2(ji,jj,jk) = zgraztotc
+
zgraztotn = zgrazdc * quotad(ji,jj,jk) + zgrazz + zgraznc * quotan(ji,jj,jk) &
& + zgrazpoc + zgrazffep + zgrazffeg
zgraztotf = zgrazdf + zgraznf + zgrazz * feratz + zgrazpof + zgrazfffp + zgrazfffg
- ! Total grazing ( grazing by microzoo is already computed in p4zmicro )
- zgrazing(ji,jj,jk) = zgraztotc
-
! Mesozooplankton efficiency.
! We adopt a formulation proposed by Mitra et al. (2007)
! The gross growth efficiency is controled by the most limiting nutrient.
@@ -345,7 +360,7 @@ CONTAINS
! This fraction is sumed over the euphotic zone and is removed from
! the fluxes driven by mesozooplankton in the euphotic zone.
! --------------------------------------------------------------------
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpk)
+ DO_3D( 0, 0, 0, 0, 1, jpk)
zmigreltime = (1. - strn(ji,jj))
zmigthick = (1. - zmigreltime ) * e3t(ji,jj,jk,Kmm) * tmask(ji,jj,jk)
IF ( gdept(ji,jj,jk,Kmm) <= heup(ji,jj) ) THEN
@@ -366,7 +381,7 @@ CONTAINS
! The inorganic and organic fluxes induced by migrating organisms are added at the
! the migration depth (corresponding indice is set by kmig)
! --------------------------------------------------------------------------------
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
IF( tmask(ji,jj,1) == 1.) THEN
jkt = kmig(ji,jj)
zdep = 1. / e3t(ji,jj,jkt,Kmm)
@@ -387,7 +402,7 @@ CONTAINS
! Update the arrays TRA which contain the biological sources and sinks
! This only concerns the variables which are affected by DVM (inorganic
! nutrients, DOC agands, and particulate organic carbon).
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpk)
+ DO_3D( 0, 0, 0, 0, 1, jpk)
tr(ji,jj,jk,jppo4,Krhs) = tr(ji,jj,jk,jppo4,Krhs) + zgrarem(ji,jj,jk) * sigma2
tr(ji,jj,jk,jpnh4,Krhs) = tr(ji,jj,jk,jpnh4,Krhs) + zgrarem(ji,jj,jk) * sigma2
tr(ji,jj,jk,jpdoc,Krhs) = tr(ji,jj,jk,jpdoc,Krhs) + zgrarem(ji,jj,jk) * ( 1. - sigma2 )
@@ -397,7 +412,6 @@ CONTAINS
!
tr(ji,jj,jk,jpoxy,Krhs) = tr(ji,jj,jk,jpoxy,Krhs) - o2ut * zgrarem(ji,jj,jk) * sigma2
tr(ji,jj,jk,jpfer,Krhs) = tr(ji,jj,jk,jpfer,Krhs) + zgraref(ji,jj,jk)
- zfezoo2(ji,jj,jk) = zgraref(ji,jj,jk)
tr(ji,jj,jk,jpdic,Krhs) = tr(ji,jj,jk,jpdic,Krhs) + zgrarem(ji,jj,jk) * sigma2
tr(ji,jj,jk,jptal,Krhs) = tr(ji,jj,jk,jptal,Krhs) + rno3 * zgrarem(ji,jj,jk) * sigma2
tr(ji,jj,jk,jpgoc,Krhs) = tr(ji,jj,jk,jpgoc,Krhs) + zgrapoc(ji,jj,jk)
@@ -408,11 +422,45 @@ CONTAINS
!
! Write the output
IF( lk_iomput .AND. knt == nrdttrc ) THEN
- CALL iom_put( "PCAL" , prodcal(:,:,:) * 1.e+3 * rfact2r * tmask(:,:,:) ) ! Calcite production
- CALL iom_put( "GRAZ2" , zgrazing(:,:,:) * 1.e+3 * rfact2r * tmask(:,:,:) ) ! Total grazing of phyto by zoo
- CALL iom_put( "FEZOO2", zfezoo2(:,:,:) * 1e9 * 1.e+3 * rfact2r * tmask(:,:,:) )
- IF( ln_ligand ) &
- & CALL iom_put( "LPRODZ2", zgrarem(ji,jj,jk) * ( 1. - sigma2 ) * ldocz * 1e9 * 1.e+3 * rfact2r * tmask(:,:,:) )
+ !
+ IF( iom_use ( "PCAL" ) ) THEN ! Calcite production
+ ALLOCATE( zw3d(A2D(0),jpk) ) ; zw3d(A2D(0),jpk) = 0._wp
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
+ zw3d(ji,jj,jk) = prodcal(ji,jj,jk) * 1.e+3 * rfact2r * tmask(ji,jj,jk)
+ END_3D
+ CALL iom_put( "PCAL", zw3d )
+ DEALLOCATE( zw3d )
+ ENDIF
+ !
+ !
+ IF( l_dia_graz2 ) THEN ! Total grazing of phyto by zooplankton
+ zgrazing2(A2D(0),jpk) = 0._wp
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
+ zgrazing2(ji,jj,jk) = zgrazing2(ji,jj,jk) * 1.e+3 * rfact2r * tmask(ji,jj,jk) ! conversion in mol/m2/s
+ END_3D
+ CALL iom_put( "GRAZ2" , zgrazing2 )
+ DEALLOCATE( zgrazing2 )
+ ENDIF
+ !
+ IF( l_dia_fezoo2 ) THEN
+ ALLOCATE( zfezoo2(A2D(0),jpk) ) ; zfezoo2(A2D(0),jpk) = 0._wp
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
+ zfezoo2(ji,jj,jk) = zgraref(ji,jj,jk) * 1e9 * 1.e+3 * rfact2r * tmask(ji,jj,jk) ! conversion in nmol/m2/s
+ END_3D
+ CALL iom_put( "FEZOO2", zfezoo2 )
+ DEALLOCATE( zfezoo2 )
+ ENDIF
+ !
+ IF( l_dia_lprodz2 ) THEN
+ zzligprod2(A2D(0),jpk) = 0._wp
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
+ zzligprod2(ji,jj,jk) = ( tr(ji,jj,jk,jplgw,Krhs) - zzligprod2(ji,jj,jk) ) &
+ & * 1e9 * 1.e+3 * rfact2r * tmask(ji,jj,jk) ! conversion in nmol/m2/s
+ END_3D
+ CALL iom_put( "LPRODZ2", zzligprod2 )
+ DEALLOCATE( zzligprod2 )
+ ENDIF
+ !
ENDIF
!
IF(sn_cfctl%l_prttrc) THEN ! print mean trends (used for debugging)
@@ -502,7 +550,7 @@ CONTAINS
INTEGER :: ji, jj, jk
!
REAL(wp) :: ztotchl, z1dep
- REAL(wp), DIMENSION(jpi,jpj) :: oxymoy, tempmoy, zdepmoy
+ REAL(wp), DIMENSION(A2D(0)) :: oxymoy, tempmoy, zdepmoy
!!---------------------------------------------------------------------
!
@@ -517,7 +565,7 @@ CONTAINS
! Compute the averaged values of oxygen, temperature over the domain
! 150m to 500 m depth.
! ------------------------------------------------------------------
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpk)
+ DO_3D( 0, 0, 0, 0, 1, jpk)
IF( tmask(ji,jj,jk) == 1.) THEN
IF( gdept(ji,jj,jk,Kmm) >= 150. .AND. gdept(ji,jj,jk,kmm) <= 500.) THEN
oxymoy(ji,jj) = oxymoy(ji,jj) + tr(ji,jj,jk,jpoxy,Kbb) * 1E6 * e3t(ji,jj,jk,Kmm)
@@ -530,7 +578,7 @@ CONTAINS
! Compute the difference between surface values and the mean values in the mesopelagic
! domain
! ------------------------------------------------------------------------------------
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
z1dep = 1. / ( zdepmoy(ji,jj) + rtrn )
oxymoy(ji,jj) = tr(ji,jj,1,jpoxy,Kbb) * 1E6 - oxymoy(ji,jj) * z1dep
tempmoy(ji,jj) = ts(ji,jj,1,jp_tem,Kmm) - tempmoy(ji,jj) * z1dep
@@ -539,7 +587,7 @@ CONTAINS
! Computation of the migration depth based on the parameterization of
! Bianchi et al. (2013)
! -------------------------------------------------------------------
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
IF( tmask(ji,jj,1) == 1. ) THEN
ztotchl = ( tr(ji,jj,1,jpnch,Kbb) + tr(ji,jj,1,jpdch,Kbb) ) * 1E6
depmig(ji,jj) = 398. - 0.56 * oxymoy(ji,jj) -115. * log10(ztotchl) + 0.36 * hmld(ji,jj) -2.4 * tempmoy(ji,jj)
@@ -548,7 +596,7 @@ CONTAINS
!
! Computation of the corresponding jk indice
! ------------------------------------------
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1)
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
IF( depmig(ji,jj) >= gdepw(ji,jj,jk,Kmm) .AND. depmig(ji,jj) < gdepw(ji,jj,jk+1,Kmm) ) THEN
kmig(ji,jj) = jk
ENDIF
@@ -560,7 +608,7 @@ CONTAINS
! to 0. Thus, to avoid that problem, the migration depth is adjusted so
! that it falls above the OMZ
! -----------------------------------------------------------------------
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
IF( tr(ji,jj,kmig(ji,jj),jpoxy,Kbb) < 5E-6 ) THEN
DO jk = kmig(ji,jj),1,-1
IF( tr(ji,jj,jk,jpoxy,Kbb) >= 5E-6 .AND. tr(ji,jj,jk+1,jpoxy,Kbb) < 5E-6) THEN
@@ -580,7 +628,7 @@ CONTAINS
!! *** ROUTINE p4z_meso_alloc ***
!!----------------------------------------------------------------------
!
- ALLOCATE( depmig(jpi,jpj), kmig(jpi,jpj), STAT= p4z_meso_alloc )
+ ALLOCATE( depmig(A2D(0)), kmig(A2D(0)), STAT= p4z_meso_alloc )
!
IF( p4z_meso_alloc /= 0 ) CALL ctl_stop( 'STOP', 'p4z_meso_alloc : failed to allocate arrays.' )
!
diff --git a/src/TOP/PISCES/P4Z/p4zmicro.F90 b/src/TOP/PISCES/P4Z/p4zmicro.F90
index f91b04d7f185c17ab3e6145823c730a9b39a334e..a18a41e354263d91c56b7975815781a2d21240b9 100644
--- a/src/TOP/PISCES/P4Z/p4zmicro.F90
+++ b/src/TOP/PISCES/P4Z/p4zmicro.F90
@@ -44,6 +44,8 @@ MODULE p4zmicro
REAL(wp), PUBLIC :: xsigma !: Width of the grazing window
REAL(wp), PUBLIC :: xsigmadel !: Maximum additional width of the grazing window at low food density
+ LOGICAL :: l_dia_fezoo, l_dia_graz1, l_dia_lprodz
+
!! * Substitutions
# include "do_loop_substitute.h90"
!!----------------------------------------------------------------------
@@ -78,20 +80,35 @@ CONTAINS
REAL(wp) :: zrespz, ztortz, zgrasratf, zgrasratn
REAL(wp) :: zgraznc, zgrazpoc, zgrazdc, zgrazpof, zgrazdf, zgraznf
REAL(wp) :: zsigma, zdiffdn, ztmp1, ztmp2, ztmp3, ztmptot, zproport
- REAL(wp), DIMENSION(jpi,jpj,jpk) :: zgrazing, zfezoo
- REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zzligprod
+ REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zgrazing, zfezoo, zzligprod
CHARACTER (len=25) :: charout
!!---------------------------------------------------------------------
!
IF( ln_timing ) CALL timing_start('p4z_micro')
!
- IF (ln_ligand) THEN
- ALLOCATE( zzligprod(jpi,jpj,jpk) )
- zzligprod(:,:,:) = 0._wp
+ IF( kt == nittrc000 ) THEN
+ l_dia_graz1 = iom_use( "GRAZ1" )
+ l_dia_fezoo = iom_use( "FEZOO" )
+ l_dia_lprodz = ln_ligand .AND. iom_use( "LPRODZ" )
+ ENDIF
+ IF( l_dia_lprodz ) THEN
+ ALLOCATE( zzligprod(A2D(0),jpk) )
+ DO_3D( 0, 0, 0, 0, 1, jpk)
+ zzligprod(ji,jj,jk) = tr(ji,jj,jk,jplgw,Krhs)
+ END_3D
+ ENDIF
+ IF( l_dia_fezoo ) THEN
+ ALLOCATE( zfezoo(A2D(0),jpk) )
+ DO_3D( 0, 0, 0, 0, 1, jpk)
+ zfezoo(ji,jj,jk) = tr(ji,jj,jk,jpfer,Krhs)
+ END_3D
+ ENDIF
+ IF( l_dia_graz1 ) THEN
+ ALLOCATE( zgrazing(A2D(0),jpk) )
ENDIF
!
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1)
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
zcompaz = MAX( ( tr(ji,jj,jk,jpzoo,Kbb) - 1.e-9 ), 0.e0 )
zfact = xstep * tgfunc2(ji,jj,jk) * zcompaz
@@ -170,14 +187,12 @@ CONTAINS
zgrazdf = zgrazdc * tr(ji,jj,jk,jpdfe,Kbb) / (tr(ji,jj,jk,jpdia,Kbb) + rtrn)
!
! Total ingestion rate in C, Fe, N units
- zgraztotc = zgraznc + zgrazpoc + zgrazdc
+ zgraztotc = zgraznc + zgrazpoc + zgrazdc ! grazing by microzooplankton
+ IF( l_dia_graz1 ) zgrazing(ji,jj,jk) = zgraztotc
+
zgraztotf = zgraznf + zgrazdf + zgrazpof
zgraztotn = zgraznc * quotan(ji,jj,jk) + zgrazpoc + zgrazdc * quotad(ji,jj,jk)
- ! Grazing by microzooplankton
- zgrazing(ji,jj,jk) = zgraztotc
-
-
! Microzooplankton efficiency.
! We adopt a formulation proposed by Mitra et al. (2007)
! The gross growth efficiency is controled by the most limiting nutrient.
@@ -215,12 +230,10 @@ CONTAINS
!
IF( ln_ligand ) THEN
tr(ji,jj,jk,jplgw,Krhs) = tr(ji,jj,jk,jplgw,Krhs) + (zgrarem - zgrarsig) * ldocz
- zzligprod(ji,jj,jk) = (zgrarem - zgrarsig) * ldocz
ENDIF
!
tr(ji,jj,jk,jpoxy,Krhs) = tr(ji,jj,jk,jpoxy,Krhs) - o2ut * zgrarsig
tr(ji,jj,jk,jpfer,Krhs) = tr(ji,jj,jk,jpfer,Krhs) + zgrafer
- zfezoo(ji,jj,jk) = zgrafer
tr(ji,jj,jk,jppoc,Krhs) = tr(ji,jj,jk,jppoc,Krhs) + zgrapoc
prodpoc(ji,jj,jk) = prodpoc(ji,jj,jk) + zgrapoc
tr(ji,jj,jk,jpsfe,Krhs) = tr(ji,jj,jk,jpsfe,Krhs) + zgraztotf * unass
@@ -257,15 +270,36 @@ CONTAINS
END_3D
!
IF( lk_iomput .AND. knt == nrdttrc ) THEN
- IF( iom_use("GRAZ1") ) THEN ! Total grazing of phyto by zooplankton
- zgrazing(:,:,jpk) = 0._wp ; CALL iom_put( "GRAZ1" , zgrazing(:,:,:) * 1.e+3 * rfact2r * tmask(:,:,:) )
- ENDIF
- IF( iom_use("FEZOO") ) THEN
- zfezoo (:,:,jpk) = 0._wp ; CALL iom_put( "FEZOO", zfezoo(:,:,:) * 1e9 * 1.e+3 * rfact2r * tmask(:,:,:) )
- ENDIF
- IF( ln_ligand ) THEN
- zzligprod(:,:,jpk) = 0._wp ; CALL iom_put( "LPRODZ", zzligprod(:,:,:) * 1e9 * 1.e+3 * rfact2r * tmask(:,:,:))
- ENDIF
+ !
+ IF( l_dia_graz1 ) THEN ! Total grazing of phyto by zooplankton
+ zgrazing(A2D(0),jpk) = 0._wp
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
+ zgrazing(ji,jj,jk) = zgrazing(ji,jj,jk) * 1.e+3 * rfact2r * tmask(ji,jj,jk) ! conversion in mol/m2/s
+ END_3D
+ CALL iom_put( "GRAZ1" , zgrazing )
+ DEALLOCATE( zgrazing )
+ ENDIF
+ !
+ IF( l_dia_fezoo ) THEN
+ zfezoo(A2D(0),jpk) = 0._wp
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
+ zfezoo(ji,jj,jk) = ( tr(ji,jj,jk,jpfer,Krhs) - zfezoo(ji,jj,jk) ) &
+ & * 1e9 * 1.e+3 * rfact2r * tmask(ji,jj,jk) ! conversion in nmol/m2/s
+ END_3D
+ CALL iom_put( "FEZOO", zfezoo )
+ DEALLOCATE( zfezoo )
+ ENDIF
+ !
+ IF( l_dia_lprodz ) THEN
+ zzligprod(A2D(0),jpk) = 0._wp
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
+ zzligprod(ji,jj,jk) = ( tr(ji,jj,jk,jplgw,Krhs) - zzligprod(ji,jj,jk) ) &
+ & * 1e9 * 1.e+3 * rfact2r * tmask(ji,jj,jk) ! conversion in nmol/m2/s
+ END_3D
+ CALL iom_put( "LPRODZ", zzligprod )
+ DEALLOCATE( zzligprod )
+ ENDIF
+ !
ENDIF
!
IF(sn_cfctl%l_prttrc) THEN ! print mean trends (used for debugging)
diff --git a/src/TOP/PISCES/P4Z/p4zmort.F90 b/src/TOP/PISCES/P4Z/p4zmort.F90
index 5a32dd99e4341c5d454219a9586fdec6bb3b7449..3c3903e748d7ef659c834daf32842ee664dceac2 100644
--- a/src/TOP/PISCES/P4Z/p4zmort.F90
+++ b/src/TOP/PISCES/P4Z/p4zmort.F90
@@ -74,7 +74,7 @@ CONTAINS
IF( ln_timing ) CALL timing_start('p4z_mort_nano')
!
prodcal(:,:,:) = 0._wp ! calcite production variable set to zero
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1)
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
zcompaph = MAX( ( tr(ji,jj,jk,jpphy,Kbb) - 1e-9 ), 0.e0 )
! Quadratic mortality of nano due to aggregation during
@@ -152,7 +152,7 @@ CONTAINS
! This is due to the production of EPS by stressed cells
! -------------------------------------------------------------
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1)
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
zcompadi = MAX( ( tr(ji,jj,jk,jpdia,Kbb) - 1e-9), 0. )
diff --git a/src/TOP/PISCES/P4Z/p4zopt.F90 b/src/TOP/PISCES/P4Z/p4zopt.F90
index 8daf2edf7158c96c2bc66a17c5225e52ba819a7a..8ff01e2ce7be882b02c7d689b7c3e9a2d4156b68 100644
--- a/src/TOP/PISCES/P4Z/p4zopt.F90
+++ b/src/TOP/PISCES/P4Z/p4zopt.F90
@@ -36,7 +36,9 @@ MODULE p4zopt
INTEGER :: ntimes_par ! number of time steps in a file
REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: par_varsw ! PAR fraction of shortwave
REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: ekb, ekg, ekr ! wavelength (Red-Green-Blue)
-
+
+ LOGICAL :: l_dia_heup, l_dia_par
+
!! * Substitutions
# include "do_loop_substitute.h90"
# include "domzgr_substitute.h90"
@@ -63,21 +65,28 @@ CONTAINS
INTEGER :: irgb
REAL(wp) :: zchl
REAL(wp) :: zc0 , zc1 , zc2, zc3, z1_dep
- REAL(wp), ALLOCATABLE, DIMENSION(:,: ) :: zetmp5
- REAL(wp), DIMENSION(jpi,jpj ) :: zdepmoy, zetmp1, zetmp2, zetmp3, zetmp4
- REAL(wp), DIMENSION(jpi,jpj ) :: zqsr100, zqsr_corr
- REAL(wp), DIMENSION(jpi,jpj,jpk) :: zpar, ze0, ze1, ze2, ze3
+ REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zetmp5
+ REAL(wp), DIMENSION(A2D(0) ) :: zdepmoy, zetmp1, zetmp2, zetmp3, zetmp4
+ REAL(wp), DIMENSION(A2D(0) ) :: zqsr100, zqsr_corr
+ REAL(wp), DIMENSION(A2D(0),jpk) :: zpar, ze0, ze1, ze2, ze3
+ REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zw3d
+ REAL(wp), ALLOCATABLE, DIMENSION(:,: ) :: zw2d
!!---------------------------------------------------------------------
!
IF( ln_timing ) CALL timing_start('p4z_opt')
+ IF( kt == nittrc000 ) THEN
+ l_dia_heup = iom_use( "Heup")
+ l_dia_par = iom_use( "PAR" )
+ ENDIF
+
IF( knt == 1 .AND. ln_varpar ) CALL p4z_opt_sbc( kt )
! Initialisation of variables used to compute PAR
! -----------------------------------------------
- ze1(:,:,:) = 0._wp
- ze2(:,:,:) = 0._wp
- ze3(:,:,:) = 0._wp
+! ze1(:,:,:) = 0._wp
+! ze2(:,:,:) = 0._wp
+! ze3(:,:,:) = 0._wp
!
! Attenuation coef. function of Chlorophyll and wavelength (Red-Green-Blue)
@@ -88,7 +97,7 @@ CONTAINS
!
! Computation of the light attenuation parameters based on a
! look-up table
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1)
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
zchl = ( tr(ji,jj,jk,jpnch,Kbb) + tr(ji,jj,jk,jpdch,Kbb) + rtrn ) * 1.e6
IF( ln_p5z ) zchl = zchl + tr(ji,jj,jk,jppch,Kbb) * 1.e6
zchl = MIN( 10. , MAX( 0.05, zchl ) )
@@ -116,36 +125,40 @@ CONTAINS
! not fully correct with LIM3 and SI3 but no information is
! currently available to do a better job. SHould be improved in the
! (near) future.
- zqsr_corr(:,:) = qsr_mean(:,:) / ( 1.-fr_i(:,:) + rtrn )
+ DO_2D( 0, 0, 0, 0 )
+ zqsr_corr(ji,jj) = qsr_mean(ji,jj) / ( 1.-fr_i(ji,jj) + rtrn )
+ END_2D
!
CALL p4z_opt_par( kt, Kmm, zqsr_corr, ze1, ze2, ze3, pqsr100 = zqsr100 )
!
! Used PAR is computed for each phytoplankton species
! etot_ndcy is PAR at level jk averaged over 24h.
! Due to their size, they have different light absorption characteristics
- DO jk = 1, nksr
- etot_ndcy(:,:,jk) = ze1(:,:,jk) + ze2(:,:,jk) + ze3(:,:,jk)
- END DO
+ DO_3D( 0, 0, 0, 0, 1, nksr )
+ etot_ndcy(ji,jj,jk) = ze1(ji,jj,jk) + ze2(ji,jj,jk) + ze3(ji,jj,jk)
+ END_3D
!
! SW over the ice free zone of the grid cell. This assumes that
! SW is zero below sea ice which is a very crude assumption that is
! not fully correct with LIM3 and SI3 but no information is
! currently available to do a better job. SHould be improved in the
! (near) future.
- zqsr_corr(:,:) = qsr(:,:) / ( 1.-fr_i(:,:) + rtrn )
+ DO_2D( 0, 0, 0, 0 )
+ zqsr_corr(ji,jj) = qsr(ji,jj) / ( 1.-fr_i(ji,jj) + rtrn )
+ END_2D
!
CALL p4z_opt_par( kt, Kmm, zqsr_corr, ze1, ze2, ze3 )
!
! Total PAR computation at level jk that includes the diurnal cycle
- DO jk = 1, nksr
- etot (:,:,jk) = ze1(:,:,jk) + ze2(:,:,jk) + ze3(:,:,jk)
- enano(:,:,jk) = 1.85 * ze1(:,:,jk) + 0.69 * ze2(:,:,jk) + 0.46 * ze3(:,:,jk)
- ediat(:,:,jk) = 1.62 * ze1(:,:,jk) + 0.74 * ze2(:,:,jk) + 0.63 * ze3(:,:,jk)
- END DO
+ DO_3D( 0, 0, 0, 0, 1, nksr )
+ etot (ji,jj,jk) = ze1(ji,jj,jk) + ze2(ji,jj,jk) + ze3(ji,jj,jk)
+ enano(ji,jj,jk) = 1.85 * ze1(ji,jj,jk) + 0.69 * ze2(ji,jj,jk) + 0.46 * ze3(ji,jj,jk)
+ ediat(ji,jj,jk) = 1.62 * ze1(ji,jj,jk) + 0.74 * ze2(ji,jj,jk) + 0.63 * ze3(ji,jj,jk)
+ END_3D
IF( ln_p5z ) THEN
- DO jk = 1, nksr
- epico (:,:,jk) = 1.94 * ze1(:,:,jk) + 0.66 * ze2(:,:,jk) + 0.4 * ze3(:,:,jk)
- END DO
+ DO_3D( 0, 0, 0, 0, 1, nksr )
+ epico(ji,jj,jk) = 1.94 * ze1(ji,jj,jk) + 0.66 * ze2(ji,jj,jk) + 0.4 * ze3(ji,jj,jk)
+ END_3D
ENDIF
ELSE ! No diurnal cycle in PISCES
@@ -157,22 +170,24 @@ CONTAINS
! not fully correct with LIM3 and SI3 but no information is
! currently available to do a better job. SHould be improved in the
! (near) future.
- zqsr_corr(:,:) = qsr_mean(:,:) / ( 1.-fr_i(:,:) + rtrn )
+ DO_2D( 0, 0, 0, 0 )
+ zqsr_corr(ji,jj) = qsr_mean(ji,jj) / ( 1.-fr_i(ji,jj) + rtrn )
+ END_2D
!
CALL p4z_opt_par( kt, Kmm, zqsr_corr, ze1, ze2, ze3, pqsr100 = zqsr100 )
!
! Used PAR is computed for each phytoplankton species
! etot_ndcy is PAR at level jk averaged over 24h.
! Due to their size, they have different light absorption characteristics
- DO jk = 1, nksr
- etot_ndcy(:,:,jk) = ze1(:,:,jk) + ze2(:,:,jk) + ze3(:,:,jk)
- enano (:,:,jk) = 1.85 * ze1(:,:,jk) + 0.69 * ze2(:,:,jk) + 0.46 * ze3(:,:,jk)
- ediat (:,:,jk) = 1.62 * ze1(:,:,jk) + 0.74 * ze2(:,:,jk) + 0.63 * ze3(:,:,jk)
- END DO
+ DO_3D( 0, 0, 0, 0, 1, nksr )
+ etot_ndcy(ji,jj,jk) = ze1(ji,jj,jk) + ze2(ji,jj,jk) + ze3(ji,jj,jk)
+ enano (ji,jj,jk) = 1.85 * ze1(ji,jj,jk) + 0.69 * ze2(ji,jj,jk) + 0.46 * ze3(ji,jj,jk)
+ ediat (ji,jj,jk) = 1.62 * ze1(ji,jj,jk) + 0.74 * ze2(ji,jj,jk) + 0.63 * ze3(ji,jj,jk)
+ END_3D
IF( ln_p5z ) THEN
- DO jk = 1, nksr
- epico (:,:,jk) = 1.94 * ze1(:,:,jk) + 0.66 * ze2(:,:,jk) + 0.4 * ze3(:,:,jk)
- END DO
+ DO_3D( 0, 0, 0, 0, 1, nksr )
+ epico(ji,jj,jk) = 1.94 * ze1(ji,jj,jk) + 0.66 * ze2(ji,jj,jk) + 0.4 * ze3(ji,jj,jk)
+ END_3D
ENDIF
!
! SW over the ice free zone of the grid cell. This assumes that
@@ -180,14 +195,16 @@ CONTAINS
! not fully correct with LIM3 and SI3 but no information is
! currently available to do a better job. SHould be improved in the
! (near) future.
- zqsr_corr(:,:) = qsr(:,:) / ( 1.-fr_i(:,:) + rtrn )
+ DO_2D( 0, 0, 0, 0 )
+ zqsr_corr(ji,jj) = qsr(ji,jj) / ( 1.-fr_i(ji,jj) + rtrn )
+ END_2D
!
CALL p4z_opt_par( kt, Kmm, zqsr_corr, ze1, ze2, ze3 )
!
! Total PAR computation at level jk that includes the diurnal cycle
- DO jk = 1, nksr
- etot(:,:,jk) = ze1(:,:,jk) + ze2(:,:,jk) + ze3(:,:,jk)
- END DO
+ DO_3D( 0, 0, 0, 0, 1, nksr )
+ etot(ji,jj,jk) = ze1(ji,jj,jk) + ze2(ji,jj,jk) + ze3(ji,jj,jk)
+ END_3D
ENDIF
!
ELSE ! no diurnal cycle
@@ -198,22 +215,24 @@ CONTAINS
! not fully correct with LIM3 and SI3 but no information is
! currently available to do a better job. SHould be improved in the
! (near) future.
- zqsr_corr(:,:) = qsr(:,:) / ( 1.-fr_i(:,:) + rtrn )
+ DO_2D( 0, 0, 0, 0 )
+ zqsr_corr(ji,jj) = qsr(ji,jj) / ( 1.-fr_i(ji,jj) + rtrn )
+ END_2D
!
CALL p4z_opt_par( kt, Kmm, zqsr_corr, ze1, ze2, ze3, pqsr100 = zqsr100 )
!
! Used PAR is computed for each phytoplankton species
! Due to their size, they have different light absorption characteristics
- DO jk = 1, nksr
- etot (:,:,jk) = ze1(:,:,jk) + ze2(:,:,jk) + ze3(:,:,jk) ! Total PAR
- enano(:,:,jk) = 1.85 * ze1(:,:,jk) + 0.69 * ze2(:,:,jk) + 0.46 * ze3(:,:,jk) ! Nanophytoplankton
- ediat(:,:,jk) = 1.62 * ze1(:,:,jk) + 0.74 * ze2(:,:,jk) + 0.63 * ze3(:,:,jk) ! Diatoms
- END DO
+ DO_3D( 0, 0, 0, 0, 1, nksr )
+ etot (ji,jj,jk) = ze1(ji,jj,jk) + ze2(ji,jj,jk) + ze3(ji,jj,jk)
+ enano(ji,jj,jk) = 1.85 * ze1(ji,jj,jk) + 0.69 * ze2(ji,jj,jk) + 0.46 * ze3(ji,jj,jk)
+ ediat(ji,jj,jk) = 1.62 * ze1(ji,jj,jk) + 0.74 * ze2(ji,jj,jk) + 0.63 * ze3(ji,jj,jk)
+ END_3D
IF( ln_p5z ) THEN
- DO jk = 1, nksr
- epico(:,:,jk) = 1.94 * ze1(:,:,jk) + 0.66 * ze2(:,:,jk) + 0.4 * ze3(:,:,jk) ! Picophytoplankton (PISCES-QUOTA)
- END DO
+ DO_3D( 0, 0, 0, 0, 1, nksr )
+ epico(ji,jj,jk) = 1.94 * ze1(ji,jj,jk) + 0.66 * ze2(ji,jj,jk) + 0.4 * ze3(ji,jj,jk) ! Picophytoplankton (PISCES-QUOTA)
+ END_3D
ENDIF
etot_ndcy(:,:,:) = etot(:,:,:)
ENDIF
@@ -224,10 +243,12 @@ CONTAINS
! ! ------------------------
CALL p4z_opt_par( kt, Kmm, qsr, ze1, ze2, ze3, pe0=ze0 )
!
- etot3(:,:,1) = qsr(:,:) * tmask(:,:,1)
- DO jk = 2, nksr + 1
- etot3(:,:,jk) = ( ze0(:,:,jk) + ze1(:,:,jk) + ze2(:,:,jk) + ze3(:,:,jk) ) * tmask(:,:,jk)
- END DO
+ DO_2D( 0, 0, 0, 0 )
+ etot3(ji,jj,1) = qsr(ji,jj) * tmask(ji,jj,1)
+ END_2D
+ DO_3D( 0, 0, 0, 0, 2, nksr+1 )
+ etot3(ji,jj,jk) = ( ze0(ji,jj,jk) + ze1(ji,jj,jk) + ze2(ji,jj,jk) + ze3(ji,jj,jk) ) * tmask(ji,jj,jk)
+ END_3D
! ! ------------------------
ENDIF
@@ -236,11 +257,13 @@ CONTAINS
! (1) The classical definition based on the relative threshold value
! (2) An alternative definition based on a absolute threshold value.
! -------------------------------------------------------------------
- neln(:,:) = 1
- heup (:,:) = gdepw(:,:,2,Kmm)
- heup_01(:,:) = gdepw(:,:,2,Kmm)
+ DO_2D( 0, 0, 0, 0 )
+ neln (ji,jj) = 1
+ heup (ji,jj) = gdepw(ji,jj,2,Kmm)
+ heup_01(ji,jj) = gdepw(ji,jj,2,Kmm)
+ END_2D
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 2, nksr)
+ DO_3D( 0, 0, 0, 0, 2, nksr)
IF( etot_ndcy(ji,jj,jk) * tmask(ji,jj,jk) >= zqsr100(ji,jj) ) THEN
neln(ji,jj) = jk+1 ! Euphotic level : 1rst T-level strictly below Euphotic layer
! ! nb: ensure the compatibility with nmld_trc definition in trd_mld_trc_zint
@@ -261,7 +284,7 @@ CONTAINS
zetmp1 (:,:) = 0.e0
zetmp2 (:,:) = 0.e0
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, nksr)
+ DO_3D( 0, 0, 0, 0, 1, nksr)
IF( gdepw(ji,jj,jk+1,Kmm) <= hmld(ji,jj) ) THEN
zetmp1 (ji,jj) = zetmp1 (ji,jj) + etot (ji,jj,jk) * e3t(ji,jj,jk,Kmm) ! Actual PAR for remineralisation
zetmp2 (ji,jj) = zetmp2 (ji,jj) + etot_ndcy(ji,jj,jk) * e3t(ji,jj,jk,Kmm) ! Par averaged over 24h for production
@@ -272,7 +295,7 @@ CONTAINS
emoy(:,:,:) = etot(:,:,:) ! remineralisation
zpar(:,:,:) = etot_ndcy(:,:,:) ! diagnostic : PAR with no diurnal cycle
!
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, nksr)
+ DO_3D( 0, 0, 0, 0, 1, nksr)
IF( gdepw(ji,jj,jk+1,Kmm) <= hmld(ji,jj) ) THEN
z1_dep = 1. / ( zdepmoy(ji,jj) + rtrn )
emoy (ji,jj,jk) = zetmp1(ji,jj) * z1_dep
@@ -286,7 +309,7 @@ CONTAINS
zetmp3 (:,:) = 0.e0
zetmp4 (:,:) = 0.e0
!
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, nksr)
+ DO_3D( 0, 0, 0, 0, 1, nksr)
IF( gdepw(ji,jj,jk+1,Kmm) <= MIN(hmld(ji,jj), heup_01(ji,jj)) ) THEN
zetmp3 (ji,jj) = zetmp3 (ji,jj) + enano (ji,jj,jk) * e3t(ji,jj,jk,Kmm) ! Nanophytoplankton
zetmp4 (ji,jj) = zetmp4 (ji,jj) + ediat (ji,jj,jk) * e3t(ji,jj,jk,Kmm) ! Diatoms
@@ -296,7 +319,7 @@ CONTAINS
enanom(:,:,:) = enano(:,:,:)
ediatm(:,:,:) = ediat(:,:,:)
!
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, nksr)
+ DO_3D( 0, 0, 0, 0, 1, nksr)
IF( gdepw(ji,jj,jk+1,Kmm) <= hmld(ji,jj) ) THEN
z1_dep = 1. / ( zdepmoy(ji,jj) + rtrn )
enanom(ji,jj,jk) = zetmp3(ji,jj) * z1_dep
@@ -306,8 +329,8 @@ CONTAINS
!
IF( ln_p5z ) THEN
! Picophytoplankton when using PISCES-QUOTA
- ALLOCATE( zetmp5(jpi,jpj) ) ; zetmp5 (:,:) = 0.e0
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, nksr)
+ ALLOCATE( zetmp5(A2D(0)) ) ; zetmp5 (:,:) = 0.e0
+ DO_3D( 0, 0, 0, 0, 1, nksr)
IF( gdepw(ji,jj,jk+1,Kmm) <= MIN(hmld(ji,jj), heup_01(ji,jj)) ) THEN
zetmp5(ji,jj) = zetmp5 (ji,jj) + epico(ji,jj,jk) * e3t(ji,jj,jk,Kmm)
ENDIF
@@ -315,7 +338,7 @@ CONTAINS
!
epicom(:,:,:) = epico(:,:,:)
!
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, nksr)
+ DO_3D( 0, 0, 0, 0, 1, nksr)
IF( gdepw(ji,jj,jk+1,Kmm) <= hmld(ji,jj) ) THEN
z1_dep = 1. / ( zdepmoy(ji,jj) + rtrn )
epicom(ji,jj,jk) = zetmp5(ji,jj) * z1_dep
@@ -325,10 +348,24 @@ CONTAINS
ENDIF
!
IF( lk_iomput .AND. knt == nrdttrc ) THEN
- CALL iom_put( "Heup" , heup(:,: ) * tmask(:,:,1) ) ! euphotic layer deptht
- IF( iom_use( "PAR" ) ) THEN
- zpar(:,:,1) = zpar(:,:,1) * ( 1._wp - fr_i(:,:) )
- CALL iom_put( "PAR", zpar(:,:,:) * tmask(:,:,:) ) ! Photosynthetically Available Radiation
+ IF( l_dia_heup ) THEN
+ ALLOCATE( zw2d(A2D(0)) )
+ DO_2D( 0, 0, 0, 0 )
+ zw2d(ji,jj) = heup(ji,jj) * tmask(ji,jj,1)
+ END_2D
+ CALL iom_put( "Heup", zw2d ) ! Euphotic layer depth
+ DEALLOCATE( zw2d )
+ ENDIF
+ IF( l_dia_par ) THEN
+ ALLOCATE( zw3d(A2D(0),jpk) ) ; zw3d(A2D(0),jpk) = 0._wp
+ DO_2D( 0, 0, 0, 0 )
+ zw3d(ji,jj,1) = zpar(ji,jj,1) * ( 1._wp - fr_i(ji,jj) ) * tmask(ji,jj,1)
+ END_2D
+ DO_3D( 0, 0, 0, 0, 2, jpkm1)
+ zw3d(ji,jj,jk) = zpar(ji,jj,jk) * tmask(ji,jj,jk)
+ END_3D
+ CALL iom_put( "PAR", zw3d ) ! Photosynthetically Available Radiation
+ DEALLOCATE( zw3d )
ENDIF
ENDIF
!
@@ -345,15 +382,15 @@ CONTAINS
!! for a given shortwave radiation
!!
!!----------------------------------------------------------------------
- INTEGER , INTENT(in) :: kt ! ocean time-step
- INTEGER , INTENT(in) :: Kmm ! ocean time-index
- REAL(wp), DIMENSION(jpi,jpj) , INTENT(in ) :: pqsr ! shortwave
- REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pe1 , pe2 , pe3 ! PAR ( R-G-B)
- REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout), OPTIONAL :: pe0 !
- REAL(wp), DIMENSION(jpi,jpj) , INTENT( out), OPTIONAL :: pqsr100 !
+ INTEGER , INTENT(in) :: kt ! ocean time-step
+ INTEGER , INTENT(in) :: Kmm ! ocean time-index
+ REAL(wp), DIMENSION(A2D(0)) , INTENT(in ) :: pqsr ! shortwave
+ REAL(wp), DIMENSION(A2D(0),jpk), INTENT(inout) :: pe1 , pe2 , pe3 ! PAR ( R-G-B)
+ REAL(wp), DIMENSION(A2D(0),jpk), INTENT(inout), OPTIONAL :: pe0 !
+ REAL(wp), DIMENSION(A2D(0)) , INTENT( out), OPTIONAL :: pqsr100 !
!
INTEGER :: ji, jj, jk ! dummy loop indices
- REAL(wp), DIMENSION(jpi,jpj) :: zqsr ! shortwave
+ REAL(wp), DIMENSION(A2D(0)) :: zqsr ! shortwave
!!----------------------------------------------------------------------
! Real shortwave
@@ -371,7 +408,7 @@ CONTAINS
pe2(:,:,1) = zqsr(:,:)
pe3(:,:,1) = zqsr(:,:)
!
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 2, nksr + 1)
+ DO_3D( 0, 0, 0, 0, 2, nksr + 1)
pe0(ji,jj,jk) = pe0(ji,jj,jk-1) * EXP( -e3t(ji,jj,jk-1,Kmm) * xsi0r )
pe1(ji,jj,jk) = pe1(ji,jj,jk-1) * EXP( -ekb (ji,jj,jk-1 ) )
pe2(ji,jj,jk) = pe2(ji,jj,jk-1) * EXP( -ekg (ji,jj,jk-1 ) )
@@ -384,7 +421,7 @@ CONTAINS
pe2(:,:,1) = zqsr(:,:) * EXP( -0.5 * ekg(:,:,1) )
pe3(:,:,1) = zqsr(:,:) * EXP( -0.5 * ekr(:,:,1) )
!
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 2, nksr)
+ DO_3D( 0, 0, 0, 0, 2, nksr)
pe1(ji,jj,jk) = pe1(ji,jj,jk-1) * EXP( -0.5 * ( ekb(ji,jj,jk-1) + ekb(ji,jj,jk) ) )
pe2(ji,jj,jk) = pe2(ji,jj,jk-1) * EXP( -0.5 * ( ekg(ji,jj,jk-1) + ekg(ji,jj,jk) ) )
pe3(ji,jj,jk) = pe3(ji,jj,jk-1) * EXP( -0.5 * ( ekr(ji,jj,jk-1) + ekr(ji,jj,jk) ) )
@@ -419,7 +456,9 @@ CONTAINS
IF( ln_varpar ) THEN
IF( kt == nit000 .OR. ( kt /= nit000 .AND. ntimes_par > 1 ) ) THEN
CALL fld_read( kt, 1, sf_par )
- par_varsw(:,:) = ( sf_par(1)%fnow(:,:,1) ) / 3.0
+ DO_2D( 0, 0, 0, 0 )
+ par_varsw(ji,jj) = ( sf_par(1)%fnow(ji,jj,1) ) / 3.0
+ END_2D
ENDIF
ENDIF
!
@@ -479,7 +518,7 @@ CONTAINS
IF(lwp) WRITE(numout,*)
IF(lwp) WRITE(numout,*) ' ==>>> initialize variable par fraction (ln_varpar=T)'
!
- ALLOCATE( par_varsw(jpi,jpj) )
+ ALLOCATE( par_varsw(A2D(0)) )
!
ALLOCATE( sf_par(1), STAT=ierr ) !* allocate and fill sf_sst (forcing structure) with sn_sst
IF( ierr > 0 ) CALL ctl_stop( 'STOP', 'p4z_opt_init: unable to allocate sf_par structure' )
@@ -510,8 +549,7 @@ CONTAINS
!! *** ROUTINE p4z_opt_alloc ***
!!----------------------------------------------------------------------
!
- ALLOCATE( ekb(jpi,jpj,jpk), ekr(jpi,jpj,jpk), &
- ekg(jpi,jpj,jpk), STAT= p4z_opt_alloc )
+ ALLOCATE( ekb(A2D(0),jpk), ekr(A2D(0),jpk), ekg(A2D(0),jpk), STAT= p4z_opt_alloc )
!
IF( p4z_opt_alloc /= 0 ) CALL ctl_stop( 'STOP', 'p4z_opt_alloc : failed to allocate arrays.' )
!
diff --git a/src/TOP/PISCES/P4Z/p4zpoc.F90 b/src/TOP/PISCES/P4Z/p4zpoc.F90
index 54b8f202e626b8367f6da45d6a2181337bf2f339..823d416a856829fef852d7616d780b6d50aeaf6c 100644
--- a/src/TOP/PISCES/P4Z/p4zpoc.F90
+++ b/src/TOP/PISCES/P4Z/p4zpoc.F90
@@ -38,6 +38,8 @@ MODULE p4zpoc
REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: alphan, reminp !: variable lability of POC and initial distribution
REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: alphap !: lability distribution of small particles
+ REAL(wp ) :: solgoc
+ LOGICAL :: l_dia_remin_part
!! * Substitutions
# include "do_loop_substitute.h90"
@@ -70,40 +72,32 @@ CONTAINS
INTEGER :: ji, jj, jk, jn
REAL(wp) :: zremip, zremig, zdep, zorem, zorem2, zofer
REAL(wp) :: zopon, zopop, zopoc, zopoc2, zopon2, zopop2
- REAL(wp) :: zsizek, zsizek1, alphat, remint, solgoc, zpoc
+ REAL(wp) :: zsizek, zsizek1, alphat, remint, zpoc, zremipart
REAL(wp) :: zofer2, zofer3
- REAL(wp) :: zrfact2
CHARACTER (len=25) :: charout
- REAL(wp), DIMENSION(jpi,jpj ) :: totprod, totthick, totcons
- REAL(wp), DIMENSION(jpi,jpj,jpk) :: zremipoc, zremigoc, zorem3, ztremint, zfolimi
- REAL(wp), DIMENSION(jpi,jpj,jpk,jcpoc) :: alphag
+ REAL(wp), DIMENSION(A2D(0) ) :: totprod, totthick, totcons
+ REAL(wp), DIMENSION(A2D(0),jpk) :: zorem3, ztremint
+ REAL(wp), DIMENSION(A2D(0),jpk,jcpoc) :: alphag
+ REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zremipoc, zremigoc, zfolimi
!!---------------------------------------------------------------------
!
IF( ln_timing ) CALL timing_start('p4z_poc')
!
- ! Initialization of local variables
- ! ---------------------------------
-
- ! Here we compute the GOC -> POC rate due to the shrinking
- ! of the fecal pellets/aggregates as a result of bacterial
- ! solubilization
- ! This is based on a fractal dimension of 2.56 and a spectral
- ! slope of -3.6 (identical to what is used in p4zsink to compute
- ! aggregation
- solgoc = 0.04/ 2.56 * 1./ ( 1.-50**(-0.04) )
-
+ IF( kt == nittrc000 ) &
+ & l_dia_remin_part = iom_use( "REMINP" ) .OR. iom_use( "REMING" ) .OR. iom_use( "REMINF" )
+ !
+ IF( l_dia_remin_part ) THEN
+ ALLOCATE( zfolimi (A2D(0),jpk) ) ; zfolimi (A2D(0),jpk) = 0._wp
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
+ zfolimi (ji,jj,jk) = tr(ji,jj,jk,jpfer,Krhs)
+ END_3D
+ ENDIF
! Initialisation of temporary arrays
- IF( ln_p4z ) THEN
- zremipoc(:,:,:) = xremip
- zremigoc(:,:,:) = xremip
- ELSE ! ln_p5z
- zremipoc(:,:,:) = xremipc
- zremigoc(:,:,:) = xremipc
+ IF( ln_p4z ) THEN ; ztremint(:,:,:) = xremip
+ ELSE ; ztremint(:,:,:) = xremipc ! ln_p5z
ENDIF
zorem3(:,:,:) = 0.
orem (:,:,:) = 0.
- ztremint(:,:,:) = 0.
- zfolimi (:,:,:) = 0.
! Initialisation of the lability distributions that are set to
! the distribution of newly produced organic particles
@@ -117,8 +111,7 @@ CONTAINS
! lability class is specified in the namelist, this is equivalent to
! a standard parameterisation with a constant lability
! -----------------------------------------------------------------------
- ztremint(:,:,:) = zremigoc(:,:,:)
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1)
+ DO_3D( 0, 0, 0, 0, 2, jpkm1)
IF (tmask(ji,jj,jk) == 1.) THEN
zdep = hmld(ji,jj)
!
@@ -197,19 +190,23 @@ CONTAINS
ENDIF
ENDIF
END_3D
-
- IF( ln_p4z ) THEN ; zremigoc(:,:,:) = MIN( xremip , ztremint(:,:,:) )
- ELSE ; zremigoc(:,:,:) = MIN( xremipc, ztremint(:,:,:) )
- ENDIF
-
- IF( ln_p4z ) THEN
+ !
+ IF( l_dia_remin_part ) THEN
+ ALLOCATE( zremigoc(A2D(0),jpk) ) ; zremigoc(A2D(0),jpk) = 0._wp
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
+ zremigoc(ji,jj,jk) = tr(ji,jj,jk,jpdoc,Krhs)
+ END_3D
+ ENDIF
+ !
+ IF( ln_p4z ) THEN
! The standard PISCES part
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1)
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
! POC degradation by bacterial activity. It is a function
! of the mean lability and of temperature. This also includes
! shrinking of particles due to the bacterial activity
! -----------------------------------------------------------
- zremig = zremigoc(ji,jj,jk) * xstep * tgfunc(ji,jj,jk)
+ zremipart = MIN( xremip, ztremint(ji,jj,jk) )
+ zremig = zremipart * xstep * tgfunc(ji,jj,jk)
zorem2 = zremig * tr(ji,jj,jk,jpgoc,Kbb)
orem(ji,jj,jk) = zorem2
zorem3(ji,jj,jk) = zremig * solgoc * tr(ji,jj,jk,jpgoc,Kbb)
@@ -223,15 +220,15 @@ CONTAINS
tr(ji,jj,jk,jpbfe,Krhs) = tr(ji,jj,jk,jpbfe,Krhs) - zofer2 - zofer3
tr(ji,jj,jk,jpdoc,Krhs) = tr(ji,jj,jk,jpdoc,Krhs) + zorem2
tr(ji,jj,jk,jpfer,Krhs) = tr(ji,jj,jk,jpfer,Krhs) + zofer2
- zfolimi(ji,jj,jk) = zofer2
END_3D
ELSE
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1)
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
! POC degradation by bacterial activity. It is a function
! of the mean lability and of temperature. This also includes
! shrinking of particles due to the bacterial activity
! --------------------------------------------------------
- zremig = zremigoc(ji,jj,jk) * xstep * tgfunc(ji,jj,jk)
+ zremipart = MIN( xremipc, ztremint(ji,jj,jk) )
+ zremig = zremipart * xstep * tgfunc(ji,jj,jk)
zopoc2 = zremig * tr(ji,jj,jk,jpgoc,Kbb)
orem(ji,jj,jk) = zopoc2
zorem3(ji,jj,jk) = zremig * solgoc * tr(ji,jj,jk,jpgoc,Kbb)
@@ -252,7 +249,12 @@ CONTAINS
tr(ji,jj,jk,jpgon,Krhs) = tr(ji,jj,jk,jpgon,Krhs) - zopon2 * (1. + solgoc)
tr(ji,jj,jk,jpgop,Krhs) = tr(ji,jj,jk,jpgop,Krhs) - zopop2 * (1. + solgoc)
tr(ji,jj,jk,jpbfe,Krhs) = tr(ji,jj,jk,jpbfe,Krhs) - zofer2 * (1. + solgoc)
- zfolimi(ji,jj,jk) = zofer2
+ END_3D
+ ENDIF
+ IF( l_dia_remin_part ) THEN
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
+ zremigoc(ji,jj,jk) = ( tr(ji,jj,jk,jpdoc,Krhs) - zremigoc(ji,jj,jk) ) / &
+ ( xstep * tgfunc(ji,jj,jk) * tr(ji,jj,jk,jpgoc,Kbb) + rtrn ) * tmask(ji,jj,jk) ! =zremipart
END_3D
ENDIF
@@ -274,7 +276,7 @@ CONTAINS
! intregrated production and consumption of POC in the mixed layer
! ----------------------------------------------------------------
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1)
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
zdep = hmld(ji,jj)
IF (tmask(ji,jj,jk) == 1. .AND. gdept(ji,jj,jk,Kmm) <= zdep ) THEN
totprod(ji,jj) = totprod(ji,jj) + prodpoc(ji,jj,jk) * e3t(ji,jj,jk,Kmm) * rday/ rfact2
@@ -289,8 +291,7 @@ CONTAINS
! layer, this spectrum is supposed to be uniform as a result of intense
! mixing.
! ---------------------------------------------------------------------
- ztremint(:,:,:) = zremipoc(:,:,:)
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1)
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
IF (tmask(ji,jj,jk) == 1.) THEN
zdep = hmld(ji,jj)
alphat = 0.0
@@ -313,9 +314,6 @@ CONTAINS
ENDIF
END_3D
!
- IF( ln_p4z ) THEN ; zremipoc(:,:,:) = MIN( xremip , ztremint(:,:,:) )
- ELSE ; zremipoc(:,:,:) = MIN( xremipc, ztremint(:,:,:) )
- ENDIF
! The lability parameterization is used here. The code is here
! almost identical to what is done for big particles. The only difference
@@ -323,7 +321,7 @@ CONTAINS
! that since we need the lability spectrum of GOC, GOC spectrum
! should be determined before.
! -----------------------------------------------------------------------
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 2, jpkm1)
+ DO_3D( 0, 0, 0, 0, 2, jpkm1)
IF (tmask(ji,jj,jk) == 1.) THEN
zdep = hmld(ji,jj)
IF( gdept(ji,jj,jk,Kmm) > zdep ) THEN
@@ -392,19 +390,22 @@ CONTAINS
ENDIF
END_3D
- IF( ln_p4z ) THEN ; zremipoc(:,:,:) = MIN( xremip , ztremint(:,:,:) )
- ELSE ; zremipoc(:,:,:) = MIN( xremipc, ztremint(:,:,:) )
+ IF( l_dia_remin_part ) THEN
+ ALLOCATE( zremipoc(A2D(0),jpk) ) ; zremipoc(A2D(0),jpk) = 0._wp
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
+ zremipoc(ji,jj,jk) = tr(ji,jj,jk,jpdoc,Krhs)
+ END_3D
ENDIF
-
IF( ln_p4z ) THEN
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1)
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
IF (tmask(ji,jj,jk) == 1.) THEN
! POC disaggregation by turbulence and bacterial activity.It is a function
! of the mean lability and of temperature
! --------------------------------------------------------
- zremip = zremipoc(ji,jj,jk) * xstep * tgfunc(ji,jj,jk)
- zorem = zremip * tr(ji,jj,jk,jppoc,Kbb)
- zofer = zremip * tr(ji,jj,jk,jpsfe,Kbb)
+ zremipart = MIN( xremip, ztremint(ji,jj,jk) )
+ zremip = zremipart * xstep * tgfunc(ji,jj,jk)
+ zorem = zremip * tr(ji,jj,jk,jppoc,Kbb)
+ zofer = zremip * tr(ji,jj,jk,jpsfe,Kbb)
! Update of the TRA arrays
tr(ji,jj,jk,jpdoc,Krhs) = tr(ji,jj,jk,jpdoc,Krhs) + zorem
@@ -412,15 +413,15 @@ CONTAINS
tr(ji,jj,jk,jpfer,Krhs) = tr(ji,jj,jk,jpfer,Krhs) + zofer
tr(ji,jj,jk,jppoc,Krhs) = tr(ji,jj,jk,jppoc,Krhs) - zorem
tr(ji,jj,jk,jpsfe,Krhs) = tr(ji,jj,jk,jpsfe,Krhs) - zofer
- zfolimi(ji,jj,jk) = zfolimi(ji,jj,jk) + zofer
ENDIF
END_3D
ELSE
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1)
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
! POC disaggregation by turbulence and bacterial activity.It is a function
! of the mean lability and of temperature
!--------------------------------------------------------
- zremip = zremipoc(ji,jj,jk) * xstep * tgfunc(ji,jj,jk)
+ zremipart = MIN( xremipc, ztremint(ji,jj,jk) )
+ zremip = zremipart * xstep * tgfunc(ji,jj,jk)
zopoc = zremip * tr(ji,jj,jk,jppoc,Kbb)
orem(ji,jj,jk) = orem(ji,jj,jk) + zopoc
zopon = xremipn / xremipc * zremip * tr(ji,jj,jk,jppon,Kbb)
@@ -436,16 +437,22 @@ CONTAINS
tr(ji,jj,jk,jpdon,Krhs) = tr(ji,jj,jk,jpdon,Krhs) + zopon
tr(ji,jj,jk,jpdop,Krhs) = tr(ji,jj,jk,jpdop,Krhs) + zopop
tr(ji,jj,jk,jpfer,Krhs) = tr(ji,jj,jk,jpfer,Krhs) + zofer
- zfolimi(ji,jj,jk) = zfolimi(ji,jj,jk) + zofer
END_3D
ENDIF
+ IF( l_dia_remin_part ) THEN
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
+ zremipoc(ji,jj,jk) = ( tr(ji,jj,jk,jpdoc,Krhs) - zremipoc(ji,jj,jk) ) / &
+ ( xstep * tgfunc(ji,jj,jk) * tr(ji,jj,jk,jppoc,Kbb) + rtrn ) * tmask(ji,jj,jk)
+ zfolimi (ji,jj,jk) = ( tr(ji,jj,jk,jpfer,Krhs) - zfolimi (ji,jj,jk) ) * tmask(ji,jj,jk)
+ END_3D
+ ENDIF
- IF( lk_iomput ) THEN
- IF( knt == nrdttrc ) THEN
- zrfact2 = 1.e3 * rfact2r
- CALL iom_put( "REMINP" , zremipoc(:,:,:) * tmask(:,:,:) ) ! Remineralisation rate of small particles
- CALL iom_put( "REMING" , zremigoc(:,:,:) * tmask(:,:,:) ) ! Remineralisation rate of large particles
- CALL iom_put( "REMINF" , zfolimi(:,:,:) * tmask(:,:,:) * 1.e+9 * zrfact2 ) ! Remineralisation of biogenic particulate iron
+ IF( lk_iomput .AND. knt == nrdttrc ) THEN
+ IF( l_dia_remin_part ) THEN
+ CALL iom_put( "REMINP", zremipoc ) ! Remineralisation rate of small particles
+ CALL iom_put( "REMING", zremigoc ) ! Remineralisation rate of large particles
+ CALL iom_put( "REMINF", zfolimi * 1.e+9 * 1.e3 * rfact2r ) ! Remineralisation of biogenic particulate iron
+ DEALLOCATE ( zremipoc, zremigoc, zfolimi )
ENDIF
ENDIF
@@ -508,7 +515,7 @@ CONTAINS
! Discretization along the lability space
! ---------------------------------------
!
- ALLOCATE( alphan(jcpoc) , reminp(jcpoc) , alphap(jpi,jpj,jpk,jcpoc) )
+ ALLOCATE( alphan(jcpoc) , reminp(jcpoc) , alphap(A2D(0),jpk,jcpoc) )
!
IF (jcpoc > 1) THEN ! Case when more than one lability class is used
!
@@ -543,6 +550,14 @@ CONTAINS
alphap(:,:,:,jn) = alphan(jn)
END DO
+ ! Here we compute the GOC -> POC rate due to the shrinking
+ ! of the fecal pellets/aggregates as a result of bacterial
+ ! solubilization
+ ! This is based on a fractal dimension of 2.56 and a spectral
+ ! slope of -3.6 (identical to what is used in p4zsink to compute
+ ! aggregation
+ solgoc = 0.04/ 2.56 * 1./ ( 1.-50**(-0.04) )
+
END SUBROUTINE p4z_poc_init
diff --git a/src/TOP/PISCES/P4Z/p4zprod.F90 b/src/TOP/PISCES/P4Z/p4zprod.F90
index 59ca90ccc62b5933ddad31ffff1460965cfc528d..6a89fb6a0cc7f4acee4169a3db544176e4db8168 100644
--- a/src/TOP/PISCES/P4Z/p4zprod.F90
+++ b/src/TOP/PISCES/P4Z/p4zprod.F90
@@ -45,6 +45,8 @@ MODULE p4zprod
REAL(wp) :: texcretn ! 1 - excretn
REAL(wp) :: texcretd ! 1 - excretd
+ LOGICAL :: l_dia_ppphy, l_dia_ppnew, l_dia_ppbfe, l_dia_ppbsi
+ LOGICAL :: l_dia_mu, l_dia_light, l_dia_lprod
!! * Substitutions
# include "do_loop_substitute.h90"
# include "domzgr_substitute.h90"
@@ -75,32 +77,38 @@ CONTAINS
REAL(wp) :: zproddoc, zprodsil, zprodfer, zprodlig
REAL(wp) :: zpislopen, zpisloped, zfact
REAL(wp) :: zratiosi, zmaxsi, zlimfac, zsizetmp, zfecnm, zfecdm
- REAL(wp) :: zprod, zval
+ REAL(wp) :: zprod, zval, zmxl_fac, zmxl_chl, zpronewn, zpronewd
CHARACTER (len=25) :: charout
- REAL(wp), DIMENSION(jpi,jpj,jpk) :: zprmaxn,zprmaxd
- REAL(wp), DIMENSION(jpi,jpj,jpk) :: zpislopeadn, zpislopeadd, zysopt
- REAL(wp), DIMENSION(jpi,jpj,jpk) :: zprdia, zprbio, zprchld, zprchln
- REAL(wp), DIMENSION(jpi,jpj,jpk) :: zprorcan, zprorcad, zprofed, zprofen
- REAL(wp), DIMENSION(jpi,jpj,jpk) :: zpronewn, zpronewd
- REAL(wp), DIMENSION(jpi,jpj,jpk) :: zmxl_fac, zmxl_chl
- REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zpligprod
+ REAL(wp), DIMENSION(A2D(0),jpk) :: zprmax, zmxl
+ REAL(wp), DIMENSION(A2D(0),jpk) :: zpislopeadn, zpislopeadd, zysopt
+ REAL(wp), DIMENSION(A2D(0),jpk) :: zprdia, zprbio, zprchld, zprchln
+ REAL(wp), DIMENSION(A2D(0),jpk) :: zprorcan, zprorcad
+ REAL(wp), DIMENSION(A2D(0),jpk) :: zprofed, zprofen
+ REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zw3d
!!---------------------------------------------------------------------
!
IF( ln_timing ) CALL timing_start('p4z_prod')
!
- ! Allocate temporary workspace
- !
- zprorcan(:,:,:) = 0._wp ; zprorcad(:,:,:) = 0._wp ; zprofed(:,:,:) = 0._wp
- zprofen (:,:,:) = 0._wp ; zysopt (:,:,:) = 0._wp
- zpronewn(:,:,:) = 0._wp ; zpronewd(:,:,:) = 0._wp ; zprdia(:,:,:) = 0._wp
- zprbio (:,:,:) = 0._wp ; zprchld (:,:,:) = 0._wp ; zprchln(:,:,:) = 0._wp
- zmxl_fac(:,:,:) = 0._wp ; zmxl_chl(:,:,:) = 0._wp
+ IF( kt == nittrc000 ) THEN
+ l_dia_ppphy = iom_use( "PPPHYN" ) .OR. iom_use( "PPPHYD" ) .OR. iom_use( "TPP" )
+ l_dia_ppnew = iom_use( "PPNEWN" ) .OR. iom_use( "PPNEWD" ) .OR. iom_use( "TPNEW")
+ l_dia_ppbfe = iom_use( "PFeN" ) .OR. iom_use( "PFeD" ) .OR. iom_use( "TPBFE")
+ l_dia_ppbsi = iom_use( "PBSi" )
+ l_dia_mu = iom_use( "Mumax" ) .OR. iom_use( "MuN" ) .OR. iom_use( "MuD")
+ l_dia_light = iom_use( "LNlight") .OR. iom_use( "LDlight")
+ l_dia_lprod = ln_ligand .AND. ( iom_use( "LPRODP") .OR. iom_use( "LDETP") )
+ ENDIF
+
+ ! Initialize the local arrays
+ zprorcan(:,:,:) = 0._wp ; zprorcad(:,:,:) = 0._wp
+ zprofen (:,:,:) = 0._wp ; zprofed (:,:,:) = 0._wp
+ zprchld (:,:,:) = 0._wp ; zprchln (:,:,:) = 0._wp
+ zprbio (:,:,:) = 0._wp ; zprdia (:,:,:) = 0._wp
+ zmxl (:,:,:) = 0._wp ; zysopt (:,:,:) = 0._wp
! Computation of the maximimum production. Based on a Q10 description
- ! of the thermal dependency
- ! Parameters are taken from Bissinger et al. (2008)
- zprmaxn(:,:,:) = 0.65_wp * r1_rday * tgfunc(:,:,:)
- zprmaxd(:,:,:) = zprmaxn(:,:,:)
+ ! of the thermal dependency. Parameters are taken from Bissinger et al. (2008)
+ zprmax(:,:,:) = 0.65_wp * r1_rday * tgfunc(:,:,:)
! Intermittency is supposed to have a similar effect on production as
! day length (Shatwell et al., 2012). The correcting factor is zmxl_fac.
@@ -109,39 +117,39 @@ CONTAINS
! absolute light level definition of the euphotic zone
! -------------------------------------------------------------------------
IF ( ln_p4z_dcyc ) THEN ! Diurnal cycle in PISCES
-
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1)
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
IF( etot_ndcy(ji,jj,jk) > 1.E-3 ) THEN
IF( gdepw(ji,jj,jk+1,Kmm) <= hmld(ji,jj) ) THEN
zval = MIN(1., heup_01(ji,jj) / ( hmld(ji,jj) + rtrn ))
ENDIF
- zmxl_chl(ji,jj,jk) = zval / 24.
- zmxl_fac(ji,jj,jk) = 1.0 - exp( -0.26 * zval )
+ zmxl(ji,jj,jk) = zval
ENDIF
END_3D
-
ELSE ! No diurnal cycle in PISCES
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1)
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
IF( etot_ndcy(ji,jj,jk) > 1.E-3 ) THEN
zval = MAX( 1., strn(ji,jj) )
IF( gdepw(ji,jj,jk+1,Kmm) <= hmld(ji,jj) ) THEN
zval = zval * MIN(1., heup_01(ji,jj) / ( hmld(ji,jj) + rtrn ))
ENDIF
- zmxl_chl(ji,jj,jk) = zval / 24.
- zmxl_fac(ji,jj,jk) = 1.0 - exp( -0.26 * zval )
+ zmxl(ji,jj,jk) = zval
ENDIF
END_3D
-
ENDIF
- zprbio(:,:,:) = zprmaxn(:,:,:) * zmxl_fac(:,:,:)
- zprdia(:,:,:) = zprmaxd(:,:,:) * zmxl_fac(:,:,:)
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
+ IF( etot_ndcy(ji,jj,jk) > 1.E-3 ) THEN
+ zmxl_fac = 1.0 - EXP( -0.26 * zmxl(ji,jj,jk) )
+ zprbio(ji,jj,jk) = zprmax(ji,jj,jk) * zmxl_fac
+ zprdia(ji,jj,jk) = zprmax(ji,jj,jk) * zmxl_fac
+ ENDIF
+ END_3D
! The formulation proposed by Geider et al. (1997) has been modified
! to exclude the effect of nutrient limitation and temperature in the PI
! curve following Vichi et al. (2007)
! -----------------------------------------------------------------------
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1)
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
IF( etot_ndcy(ji,jj,jk) > 1.E-3 ) THEN
ztn = MAX( 0., ts(ji,jj,jk,jp_tem,Kmm) - 15. )
zadap = xadap * ztn / ( 2.+ ztn )
@@ -160,18 +168,17 @@ CONTAINS
! Diatoms
zpislopeadd(ji,jj,jk) = (pislopen * zconctemp2 + pisloped * zconctemp) / ( tr(ji,jj,jk,jpdia,Kbb) + rtrn ) &
& * tr(ji,jj,jk,jpdch,Kbb) /( tr(ji,jj,jk,jpdia,Kbb) * 12. + rtrn)
- ENDIF
- END_3D
-
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1)
- IF( etot_ndcy(ji,jj,jk) > 1.E-3 ) THEN
+ !
! Computation of production function for Carbon
! Actual light levels are used here
! ----------------------------------------------
+ zmxl_fac = 1.0 - EXP( -0.26 * zmxl(ji,jj,jk) )
+ zmxl_chl = zmxl(ji,jj,jk) / 24.
+ !
zpislopen = zpislopeadn(ji,jj,jk) / ( ( r1_rday + bresp * r1_rday ) &
- & * zmxl_fac(ji,jj,jk) * rday + rtrn)
+ & * zmxl_fac * rday + rtrn)
zpisloped = zpislopeadd(ji,jj,jk) / ( ( r1_rday + bresp * r1_rday ) &
- & * zmxl_fac(ji,jj,jk) * rday + rtrn)
+ & * zmxl_fac * rday + rtrn)
zprbio(ji,jj,jk) = zprbio(ji,jj,jk) * ( 1.- EXP( -zpislopen * enano(ji,jj,jk) ) )
zprdia(ji,jj,jk) = zprdia(ji,jj,jk) * ( 1.- EXP( -zpisloped * ediat(ji,jj,jk) ) )
@@ -180,28 +187,27 @@ CONTAINS
! is used here (acclimation is in general slower than
! the characteristic time scales of vertical mixing)
! ------------------------------------------------------
- zpislopen = zpislopeadn(ji,jj,jk) / ( zprmaxn(ji,jj,jk) * zmxl_chl(ji,jj,jk) * rday + rtrn )
- zpisloped = zpislopeadd(ji,jj,jk) / ( zprmaxd(ji,jj,jk) * zmxl_chl(ji,jj,jk) * rday + rtrn )
- zprchln(ji,jj,jk) = zprmaxn(ji,jj,jk) * ( 1.- EXP( -zpislopen * enanom(ji,jj,jk) ) )
- zprchld(ji,jj,jk) = zprmaxd(ji,jj,jk) * ( 1.- EXP( -zpisloped * ediatm(ji,jj,jk) ) )
+ zpislopen = zpislopeadn(ji,jj,jk) / ( zprmax(ji,jj,jk) * zmxl_chl * rday + rtrn )
+ zpisloped = zpislopeadd(ji,jj,jk) / ( zprmax(ji,jj,jk) * zmxl_chl * rday + rtrn )
+ zprchln(ji,jj,jk) = zprmax(ji,jj,jk) * ( 1.- EXP( -zpislopen * enanom(ji,jj,jk) ) )
+ zprchld(ji,jj,jk) = zprmax(ji,jj,jk) * ( 1.- EXP( -zpisloped * ediatm(ji,jj,jk) ) )
ENDIF
END_3D
! Computation of a proxy of the N/C quota from nutrient limitation
! and light limitation. Steady state is assumed to allow the computation
! ----------------------------------------------------------------------
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1)
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
zval = MIN( xnanopo4(ji,jj,jk), ( xnanonh4(ji,jj,jk) + xnanono3(ji,jj,jk) ) ) &
- & * zprmaxn(ji,jj,jk) / ( zprbio(ji,jj,jk) + rtrn )
+ & * zprmax(ji,jj,jk) / ( zprbio(ji,jj,jk) + rtrn )
quotan(ji,jj,jk) = MIN( 1., 0.3 + 0.7 * zval )
zval = MIN( xdiatpo4(ji,jj,jk), ( xdiatnh4(ji,jj,jk) + xdiatno3(ji,jj,jk) ) ) &
- & * zprmaxd(ji,jj,jk) / ( zprdia(ji,jj,jk) + rtrn )
+ & * zprmax(ji,jj,jk) / ( zprdia(ji,jj,jk) + rtrn )
quotad(ji,jj,jk) = MIN( 1., 0.3 + 0.7 * zval )
END_3D
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1)
-
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
IF( etot_ndcy(ji,jj,jk) > 1.E-3 ) THEN
! Si/C of diatoms
! ------------------------
@@ -213,7 +219,7 @@ CONTAINS
! proposed by Gurney and Davidson (1999).
! -----------------------------------------------------------------------
zlim = tr(ji,jj,jk,jpsil,Kbb) / ( tr(ji,jj,jk,jpsil,Kbb) + xksi1 )
- zsilim = xlimdia(ji,jj,jk) * zprdia(ji,jj,jk) / ( zprmaxd(ji,jj,jk) + rtrn )
+ zsilim = xlimdia(ji,jj,jk) * zprdia(ji,jj,jk) / ( zprmax(ji,jj,jk) + rtrn )
zsiborn = tr(ji,jj,jk,jpsil,Kbb) * tr(ji,jj,jk,jpsil,Kbb) * tr(ji,jj,jk,jpsil,Kbb)
IF (gphit(ji,jj) < -30 ) THEN
zsilfac = 1. + 2. * zsiborn / ( zsiborn + xksi2**3 )
@@ -234,20 +240,18 @@ CONTAINS
! Sea-ice effect on production
! No production is assumed below sea ice
! --------------------------------------
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1)
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
zprbio(ji,jj,jk) = zprbio(ji,jj,jk) * ( 1. - fr_i(ji,jj) )
zprdia(ji,jj,jk) = zprdia(ji,jj,jk) * ( 1. - fr_i(ji,jj) )
END_3D
! Computation of the various production and nutrient uptake terms
! ---------------------------------------------------------------
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1)
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
IF( etot_ndcy(ji,jj,jk) > 1.E-3 ) THEN
! production terms for nanophyto. (C)
zprorcan(ji,jj,jk) = zprbio(ji,jj,jk) * xlimphy(ji,jj,jk) * tr(ji,jj,jk,jpphy,Kbb) * rfact2
- ! New production (uptake of NO3)
- zpronewn(ji,jj,jk) = zprorcan(ji,jj,jk)* xnanono3(ji,jj,jk) / ( xnanono3(ji,jj,jk) + xnanonh4(ji,jj,jk) + rtrn )
!
! Size computation
! Size is made a function of the limitation of of phytoplankton growth
@@ -255,7 +259,7 @@ CONTAINS
! size at time step t+1 and is thus updated at the end of the
! current time step
! --------------------------------------------------------------------
- zlimfac = xlimphy(ji,jj,jk) * zprchln(ji,jj,jk) / ( zprmaxn(ji,jj,jk) + rtrn )
+ zlimfac = xlimphy(ji,jj,jk) * zprchln(ji,jj,jk) / ( zprmax(ji,jj,jk) + rtrn )
zsizetmp = 1.0 + 1.3 * ( xsizern - 1.0 ) * zlimfac**3/(0.3 + zlimfac**3)
sizena(ji,jj,jk) = min(xsizern, max( sizena(ji,jj,jk), zsizetmp ) )
@@ -266,15 +270,13 @@ CONTAINS
zfecnm = xqfuncfecn(ji,jj,jk) + ( fecnm - xqfuncfecn(ji,jj,jk) ) * ( xnanono3(ji,jj,jk) + xnanonh4(ji,jj,jk) )
zratio = 1.0 - MIN(1.0,tr(ji,jj,jk,jpnfe,Kbb) / ( tr(ji,jj,jk,jpphy,Kbb) * zfecnm + rtrn ) )
zmax = MAX( 0., MIN( 1.0, zratio**2/ (0.05**2+zratio**2) ) )
- zprofen(ji,jj,jk) = zfecnm * zprmaxn(ji,jj,jk) * ( 1.0 - fr_i(ji,jj) ) &
+ zprofen(ji,jj,jk) = zfecnm * zprmax(ji,jj,jk) * ( 1.0 - fr_i(ji,jj) ) &
& * (1. + 0.8 * xnanono3(ji,jj,jk) / ( rtrn + xnanono3(ji,jj,jk) &
& + xnanonh4(ji,jj,jk) ) * (1. - xnanofer(ji,jj,jk) ) ) &
& * xnanofer(ji,jj,jk) * zmax * tr(ji,jj,jk,jpphy,Kbb) * rfact2
! production terms of diatoms (C)
zprorcad(ji,jj,jk) = zprdia(ji,jj,jk) * xlimdia(ji,jj,jk) * tr(ji,jj,jk,jpdia,Kbb) * rfact2
- ! New production (uptake of NO3)
- zpronewd(ji,jj,jk) = zprorcad(ji,jj,jk) * xdiatno3(ji,jj,jk) / ( xdiatno3(ji,jj,jk) + xdiatnh4(ji,jj,jk) + rtrn )
! Size computation
! Size is made a function of the limitation of of phytoplankton growth
@@ -282,7 +284,7 @@ CONTAINS
! size at time step t+1 and is thus updated at the end of the
! current time step.
! --------------------------------------------------------------------
- zlimfac = zprchld(ji,jj,jk) * xlimdia(ji,jj,jk) / ( zprmaxd(ji,jj,jk) + rtrn )
+ zlimfac = zprchld(ji,jj,jk) * xlimdia(ji,jj,jk) / ( zprmax(ji,jj,jk) + rtrn )
zsizetmp = 1.0 + 1.3 * ( xsizerd - 1.0 ) * zlimfac**3/(0.3 + zlimfac**3)
sizeda(ji,jj,jk) = min(xsizerd, max( sizeda(ji,jj,jk), zsizetmp ) )
@@ -293,7 +295,7 @@ CONTAINS
zfecdm = xqfuncfecd(ji,jj,jk) + ( fecdm - xqfuncfecd(ji,jj,jk) ) * ( xdiatno3(ji,jj,jk) + xdiatnh4(ji,jj,jk) )
zratio = 1.0 - MIN(1.0, tr(ji,jj,jk,jpdfe,Kbb) / ( tr(ji,jj,jk,jpdia,Kbb) * zfecdm + rtrn ) )
zmax = MAX( 0., MIN( 1.0, zratio**2/ (0.05**2+zratio**2) ) )
- zprofed(ji,jj,jk) = zfecdm * zprmaxd(ji,jj,jk) * (1.0 - fr_i(ji,jj) ) &
+ zprofed(ji,jj,jk) = zfecdm * zprmax(ji,jj,jk) * (1.0 - fr_i(ji,jj) ) &
& * (1. + 0.8 * xdiatno3(ji,jj,jk) / ( rtrn + xdiatno3(ji,jj,jk) &
& + xdiatnh4(ji,jj,jk) ) * (1. - xdiatfer(ji,jj,jk) ) ) &
& * xdiatfer(ji,jj,jk) * zmax * tr(ji,jj,jk,jpdia,Kbb) * rfact2
@@ -303,17 +305,18 @@ CONTAINS
! Computation of the chlorophyll production terms
! The parameterization is taken from Geider et al. (1997)
! -------------------------------------------------------
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1)
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
IF( etot_ndcy(ji,jj,jk) > 1.E-3 ) THEN
+ zmxl_chl = zmxl(ji,jj,jk) / 24.
! production terms for nanophyto. ( chlorophyll )
- znanotot = enanom(ji,jj,jk) / ( zmxl_chl(ji,jj,jk) + rtrn )
+ znanotot = enanom(ji,jj,jk) / ( zmxl_chl + rtrn )
zprod = rday * zprorcan(ji,jj,jk) * zprchln(ji,jj,jk) * xlimphy(ji,jj,jk)
zprochln = chlcmin * 12. * zprorcan (ji,jj,jk)
zprochln = zprochln + (chlcnm - chlcmin) * 12. * zprod / &
& ( zpislopeadn(ji,jj,jk) * znanotot +rtrn)
! production terms for diatoms ( chlorophyll )
- zdiattot = ediatm(ji,jj,jk) / ( zmxl_chl(ji,jj,jk) + rtrn )
+ zdiattot = ediatm(ji,jj,jk) / ( zmxl_chl + rtrn )
zprod = rday * zprorcad(ji,jj,jk) * zprchld(ji,jj,jk) * xlimdia(ji,jj,jk)
zprochld = chlcmin * 12. * zprorcad(ji,jj,jk)
zprochld = zprochld + (chlcdm - chlcmin) * 12. * zprod / &
@@ -326,12 +329,16 @@ CONTAINS
END_3D
! Update the arrays TRA which contain the biological sources and sinks
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1)
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
IF( etot_ndcy(ji,jj,jk) > 1.E-3 ) THEN
+ ! New production (uptake of NO3)
+ zpronewn = zprorcan(ji,jj,jk) * xnanono3(ji,jj,jk) / ( xnanono3(ji,jj,jk) + xnanonh4(ji,jj,jk) + rtrn )
+ zpronewd = zprorcad(ji,jj,jk) * xdiatno3(ji,jj,jk) / ( xdiatno3(ji,jj,jk) + xdiatnh4(ji,jj,jk) + rtrn )
+ !
zpptot = zprorcan(ji,jj,jk) + zprorcad(ji,jj,jk)
- zpnewtot = zpronewn(ji,jj,jk) + zpronewd(ji,jj,jk)
+ zpnewtot = zpronewn + zpronewd
zpregtot = zpptot - zpnewtot
- zprodsil = zprmaxd(ji,jj,jk) * zysopt(ji,jj,jk) * rfact2 * tr(ji,jj,jk,jpdia,Kbb)
+ zprodsil = zprmax(ji,jj,jk) * zysopt(ji,jj,jk) * rfact2 * tr(ji,jj,jk,jpdia,Kbb)
zproddoc = excretd * zprorcad(ji,jj,jk) + excretn * zprorcan(ji,jj,jk)
zprodfer = texcretn * zprofen(ji,jj,jk) + texcretd * zprofed(ji,jj,jk)
!
@@ -362,7 +369,7 @@ CONTAINS
! Shaked et al. (2020)
! -------------------------------------------------------------------------
IF( ln_ligand ) THEN
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1)
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
IF( etot_ndcy(ji,jj,jk) > 1.E-3 ) THEN
zproddoc = excretd * zprorcad(ji,jj,jk) + excretn * zprorcan(ji,jj,jk)
zprodfer = texcretn * zprofen(ji,jj,jk) + texcretd * zprofed(ji,jj,jk)
@@ -373,41 +380,121 @@ CONTAINS
END_3D
ENDIF
-
- ! Output of the diagnostics
! Total primary production per year
- IF( iom_use( "tintpp" ) .OR. ( ln_check_mass .AND. kt == nitend .AND. knt == nrdttrc ) ) &
- & tpp = glob_sum( 'p4zprod', ( zprorcan(:,:,:) + zprorcad(:,:,:) ) * cvol(:,:,:) )
-
+ IF( l_dia_ppphy .OR. ( ln_check_mass .AND. kt == nitend .AND. knt == nrdttrc ) ) THEN
+ ALLOCATE( zw3d(A2D(0),jpk) ) ; zw3d(A2D(0),jpk) = 0._wp
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
+ zw3d(ji,jj,jk) = ( zprorcan(ji,jj,jk) + zprorcad(ji,jj,jk) ) * cvol(ji,jj,jk)
+ END_3D
+ tpp = glob_sum( 'p4zprod', zw3d )
+ DEALLOCATE ( zw3d )
+ ENDIF
+
IF( lk_iomput .AND. knt == nrdttrc ) THEN
- zfact = 1.e+3 * rfact2r ! conversion from mol/l/kt to mol/m3/s
!
- CALL iom_put( "PPPHYN" , zprorcan(:,:,:) * zfact * tmask(:,:,:) ) ! primary production by nanophyto
- CALL iom_put( "PPPHYD" , zprorcad(:,:,:) * zfact * tmask(:,:,:) ) ! primary production by diatomes
- CALL iom_put( "PPNEWN" , zpronewn(:,:,:) * zfact * tmask(:,:,:) ) ! new primary production by nanophyto
- CALL iom_put( "PPNEWD" , zpronewd(:,:,:) * zfact * tmask(:,:,:) ) ! new primary production by diatomes
- CALL iom_put( "PBSi" , zprorcad(:,:,:) * zfact * tmask(:,:,:) * zysopt(:,:,:) ) ! biogenic silica production
- CALL iom_put( "PFeN" , zprofen(:,:,:) * zfact * tmask(:,:,:) ) ! biogenic iron production by nanophyto
- CALL iom_put( "PFeD" , zprofed(:,:,:) * zfact * tmask(:,:,:) ) ! biogenic iron production by diatomes
- IF( ln_ligand .AND. ( iom_use( "LPRODP" ) .OR. iom_use( "LDETP" ) ) ) THEN
- ALLOCATE( zpligprod(jpi,jpj,jpk) )
- zpligprod(:,:,:) = excretd * zprorcad(:,:,:) + excretn * zprorcan(:,:,:)
- CALL iom_put( "LPRODP" , zpligprod(:,:,:) * ldocp * 1e9 * zfact * tmask(:,:,:) )
- !
- zpligprod(:,:,:) = ( texcretn * zprofen(:,:,:) + texcretd * zprofed(:,:,:) ) &
- & * plig(:,:,:) / ( rtrn + plig(:,:,:) + 75.0 * (1.0 - plig(:,:,:) ) )
- CALL iom_put( "LDETP" , zpligprod(:,:,:) * lthet * 1e9 * zfact * tmask(:,:,:) )
- DEALLOCATE( zpligprod )
+ IF( l_dia_ppphy ) THEN
+ zfact = 1.e+3 * rfact2r ! conversion from mol/l/kt to mol/m3/s
+ ALLOCATE( zw3d(A2D(0),jpk) ) ; zw3d(A2D(0),jpk) = 0._wp
+ ! primary production by nanophyto
+ zw3d(A2D(0),1:jpkm1) = zprorcan(A2D(0),1:jpkm1) * zfact * tmask(A2D(0),1:jpkm1)
+ CALL iom_put( "PPPHYN", zw3d )
+ ! primary production by diatomes
+ zw3d(A2D(0),1:jpkm1) = zprorcad(A2D(0),1:jpkm1) * zfact * tmask(A2D(0),1:jpkm1)
+ CALL iom_put( "PPPHYD", zw3d )
+ ! total primary production
+ zw3d(A2D(0),1:jpkm1) = ( zprorcan(A2D(0),1:jpkm1) + zprorcad(A2D(0),1:jpkm1) ) * zfact * tmask(A2D(0),1:jpkm1)
+ CALL iom_put( "TPP", zw3d )
+ CALL iom_put( "tintpp" , tpp * zfact ) ! global total integrated primary production molC/s
+ DEALLOCATE ( zw3d )
+ ENDIF
+ !
+ IF( l_dia_ppnew ) THEN
+ zfact = 1.e+3 * rfact2r ! conversion from mol/l/kt to mol/m3/s
+ ALLOCATE( zw3d(A2D(0),jpk) ) ; zw3d(A2D(0),jpk) = 0._wp
+ ! new primary production by nano
+ zw3d(A2D(0),1:jpkm1) = ( zprorcan(A2D(0),1:jpkm1) * xnanono3(A2D(0),1:jpkm1) &
+ & / ( xnanono3(A2D(0),1:jpkm1) + xnanonh4(A2D(0),1:jpkm1) + rtrn ) ) &
+ & * zfact * tmask(A2D(0),1:jpkm1)
+ CALL iom_put( "PPNEWN", zw3d )
+ ! new primary production by diatomes
+ zw3d(A2D(0),1:jpkm1) = ( zprorcad(A2D(0),1:jpkm1) * xdiatno3(A2D(0),1:jpkm1) &
+ & / ( xdiatno3(A2D(0),1:jpkm1) + xdiatnh4(A2D(0),1:jpkm1) + rtrn ) ) &
+ & * zfact * tmask(A2D(0),1:jpkm1)
+ CALL iom_put( "PPNEWD", zw3d )
+ ! total new production
+ zw3d(A2D(0),1:jpkm1) = ( ( zprorcan(A2D(0),1:jpkm1) * xnanono3(A2D(0),1:jpkm1) &
+ & / ( xnanono3(A2D(0),1:jpkm1) + xnanonh4(A2D(0),1:jpkm1) + rtrn ) ) &
+ & + ( zprorcad(A2D(0),1:jpkm1) * xdiatno3(A2D(0),1:jpkm1) &
+ & / ( xdiatno3(A2D(0),1:jpkm1) + xdiatnh4(A2D(0),1:jpkm1) + rtrn ) ) ) &
+ & * zfact * tmask(A2D(0),1:jpkm1)
+ CALL iom_put( "TPNEW", zw3d )
+ DEALLOCATE ( zw3d )
+ ENDIF
+ !
+ IF( l_dia_ppbsi ) THEN
+ zfact = 1.e+3 * rfact2r ! conversion from mol/l/kt to mol/m3/s
+ ALLOCATE( zw3d(A2D(0),jpk) ) ; zw3d(A2D(0),jpk) = 0._wp
+ ! biogenic silica production
+ zw3d(A2D(0),1:jpkm1) = zprorcad(A2D(0),1:jpkm1) * zysopt(A2D(0),1:jpkm1) * zfact * tmask(A2D(0),1:jpkm1)
+ CALL iom_put( "PBSi", zw3d )
+ DEALLOCATE ( zw3d )
+ ENDIF
+ !
+ IF( l_dia_ppbfe ) THEN
+ zfact = 1.e+3 * rfact2r ! conversion from mol/l/kt to mol/m3/s
+ ALLOCATE( zw3d(A2D(0),jpk) ) ; zw3d(A2D(0),jpk) = 0._wp
+ ! biogenic iron production by nanophyto
+ zw3d(A2D(0),1:jpkm1) = zprofen(A2D(0),1:jpkm1) * zfact * tmask(A2D(0),1:jpkm1)
+ CALL iom_put( "PFeN", zw3d )
+ ! biogenic iron production by diatomes
+ zw3d(A2D(0),1:jpkm1) = zprofed(A2D(0),1:jpkm1) * zfact * tmask(A2D(0),1:jpkm1)
+ CALL iom_put( "PFeD", zw3d )
+ ! total biogenic iron production
+ zw3d(A2D(0),1:jpkm1) = ( zprofen(A2D(0),1:jpkm1) + zprofed(A2D(0),1:jpkm1) ) * zfact * tmask(A2D(0),1:jpkm1)
+ CALL iom_put( "TPBFE", zw3d )
+ DEALLOCATE ( zw3d )
ENDIF
- CALL iom_put( "Mumax" , zprmaxn(:,:,:) * tmask(:,:,:) ) ! Maximum growth rate
- CALL iom_put( "MuN" , zprbio(:,:,:) * xlimphy(:,:,:) * tmask(:,:,:) ) ! Realized growth rate for nanophyto
- CALL iom_put( "MuD" , zprdia(:,:,:) * xlimdia(:,:,:) * tmask(:,:,:) ) ! Realized growth rate for diatoms
- CALL iom_put( "LNlight" , zprbio (:,:,:) / (zprmaxn(:,:,:) + rtrn) * tmask(:,:,:) ) ! light limitation term
- CALL iom_put( "LDlight" , zprdia (:,:,:) / (zprmaxd(:,:,:) + rtrn) * tmask(:,:,:) )
- CALL iom_put( "TPP" , ( zprorcan(:,:,:) + zprorcad(:,:,:) ) * zfact * tmask(:,:,:) ) ! total primary production
- CALL iom_put( "TPNEW" , ( zpronewn(:,:,:) + zpronewd(:,:,:) ) * zfact * tmask(:,:,:) ) ! total new production
- CALL iom_put( "TPBFE" , ( zprofen(:,:,:) + zprofed(:,:,:) ) * zfact * tmask(:,:,:) ) ! total biogenic iron production
- CALL iom_put( "tintpp" , tpp * zfact ) ! global total integrated primary production molC/s
+ !
+ IF( l_dia_mu ) THEN
+ zfact = 1.e+3 * rfact2r ! conversion from mol/l/kt to mol/m3/s
+ ALLOCATE( zw3d(A2D(0),jpk) ) ; zw3d(A2D(0),jpk) = 0._wp
+ zw3d(A2D(0),1:jpkm1) = zprmax(A2D(0),1:jpkm1) * tmask(A2D(0),1:jpkm1)
+ CALL iom_put( "Mumax", zw3d )
+ ! Realized growth rate for nanophyto
+ zw3d(A2D(0),1:jpkm1) = zprbio(A2D(0),1:jpkm1) * xlimphy(A2D(0),1:jpkm1) * tmask(A2D(0),1:jpkm1)
+ CALL iom_put( "MuN", zw3d )
+ ! Realized growth rate for diatoms
+ zw3d(A2D(0),1:jpkm1) = zprdia(A2D(0),1:jpkm1) * xlimdia(A2D(0),1:jpkm1) * tmask(A2D(0),1:jpkm1)
+ CALL iom_put( "MuD", zw3d )
+ DEALLOCATE ( zw3d )
+ ENDIF
+ !
+ IF( l_dia_light ) THEN
+ zfact = 1.e+3 * rfact2r ! conversion from mol/l/kt to mol/m3/s
+ ALLOCATE( zw3d(A2D(0),jpk) ) ; zw3d(A2D(0),jpk) = 0._wp
+ ! light limitation term for nano
+ zw3d(A2D(0),1:jpkm1) = zprbio(A2D(0),1:jpkm1) / ( zprmax(A2D(0),1:jpkm1) + rtrn ) * tmask(A2D(0),1:jpkm1)
+ CALL iom_put( "LNlight", zw3d )
+ ! light limitation term for diatomes
+ zw3d(A2D(0),1:jpkm1) = zprdia(A2D(0),1:jpkm1) / ( zprmax(A2D(0),1:jpkm1) + rtrn ) * tmask(A2D(0),1:jpkm1)
+ CALL iom_put( "LDlight", zw3d )
+ DEALLOCATE ( zw3d )
+ ENDIF
+ !
+ IF( l_dia_lprod ) THEN
+ zfact = 1.e+3 * rfact2r ! conversion from mol/l/kt to mol/m3/s
+ ALLOCATE( zw3d(A2D(0),jpk) ) ; zw3d(A2D(0),jpk) = 0._wp
+ zw3d(A2D(0),1:jpkm1) = ( excretd * zprorcad(A2D(0),1:jpkm1) + excretn * zprorcan(A2D(0),1:jpkm1) ) &
+ & * zfact * tmask(A2D(0),1:jpkm1)
+ CALL iom_put( "LPRODP" , zw3d * ldocp * 1e9 )
+ !
+ zw3d(A2D(0),1:jpkm1) = ( texcretn * zprofen(A2D(0),1:jpkm1) + texcretd * zprofed(A2D(0),1:jpkm1) ) &
+ & * plig(A2D(0),1:jpkm1) / ( rtrn + plig(A2D(0),1:jpkm1) + 75.0 * (1.0 - plig(A2D(0),1:jpkm1) ) ) &
+ & * zfact * tmask(A2D(0),1:jpkm1)
+ CALL iom_put( "LDETP" , zw3d * lthet * 1e9 )
+ DEALLOCATE ( zw3d )
+ ENDIF
+ !
ENDIF
IF(sn_cfctl%l_prttrc) THEN ! print mean trends (used for debugging)
@@ -475,12 +562,11 @@ CONTAINS
!
END SUBROUTINE p4z_prod_init
-
INTEGER FUNCTION p4z_prod_alloc()
!!----------------------------------------------------------------------
!! *** ROUTINE p4z_prod_alloc ***
!!----------------------------------------------------------------------
- ALLOCATE( quotan(jpi,jpj,jpk), quotad(jpi,jpj,jpk), STAT = p4z_prod_alloc )
+ ALLOCATE( quotan(A2D(0),jpk), quotad(A2D(0),jpk), STAT = p4z_prod_alloc )
!
IF( p4z_prod_alloc /= 0 ) CALL ctl_stop( 'STOP', 'p4z_prod_alloc : failed to allocate arrays.' )
!
diff --git a/src/TOP/PISCES/P4Z/p4zrem.F90 b/src/TOP/PISCES/P4Z/p4zrem.F90
index c63a6e63f59e3fd8d803181902ac7a046a6950e1..e63e5eec167f6d872b86ead61ae7568eaa21e87c 100644
--- a/src/TOP/PISCES/P4Z/p4zrem.F90
+++ b/src/TOP/PISCES/P4Z/p4zrem.F90
@@ -43,6 +43,7 @@ MODULE p4zrem
REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: denitr !: denitrification array
+ LOGICAL :: l_dia_remin, l_dia_febact, l_dia_bact, l_dia_denit
!! * Substitutions
# include "do_loop_substitute.h90"
# include "domzgr_substitute.h90"
@@ -73,28 +74,45 @@ CONTAINS
INTEGER :: ji, jj, jk
REAL(wp) :: zremik, zremikc, zremikn, zremikp, zsiremin, zfact
REAL(wp) :: zsatur, zsatur2, znusil, znusil2, zdep, zdepmin, zfactdep
- REAL(wp) :: zbactfer, zonitr, zrfact2
+ REAL(wp) :: zbactfer, zonitr
REAL(wp) :: zammonic, zoxyremc, zosil, ztem, zdenitnh4, zolimic
+ REAL(wp) :: zfacsi, zdepeff
CHARACTER (len=25) :: charout
- REAL(wp), DIMENSION(jpi,jpj,jpk) :: zdepbac, zolimi, zfacsi, zfacsib, zdepeff, zfebact
- REAL(wp), DIMENSION(jpi,jpj ) :: ztempbac
+ REAL(wp), DIMENSION(A2D(0),jpk) :: zdepbac, zfacsib
+ REAL(wp), DIMENSION(A2D(0) ) :: ztempbac
+ REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zw3d, zolimi, zfebact
!!---------------------------------------------------------------------
!
IF( ln_timing ) CALL timing_start('p4z_rem')
!
+ IF( kt == nittrc000 ) THEN
+ l_dia_remin = iom_use( "REMIN" )
+ l_dia_febact = iom_use( "FEBACT" )
+ l_dia_denit = iom_use( "DENIT" )
+ l_dia_bact = iom_use( "BACT" )
+ ENDIF
+ IF( l_dia_remin ) THEN
+ ALLOCATE( zolimi(A2D(0),jpk) ) ; zolimi(A2D(0),jpk) = 0._wp
+ DO_3D( 0, 0, 0, 0, 1, jpk)
+ zolimi(ji,jj,jk) = tr(ji,jj,jk,jpoxy,Krhs)
+ END_3D
+ ENDIF
+ IF( l_dia_febact ) THEN
+ ALLOCATE( zfebact(A2D(0),jpk) ) ; zfebact(A2D(0),jpk) = 0._wp
+ DO_3D( 0, 0, 0, 0, 1, jpk)
+ zfebact(ji,jj,jk) = tr(ji,jj,jk,jpfer,Krhs)
+ END_3D
+ ENDIF
! Initialisation of arrays
- zdepeff (:,:,:) = 0.3_wp
zfacsib(:,:,:) = xsilab / ( 1.0 - xsilab )
- zfebact(:,:,:) = 0._wp
- zfacsi(:,:,:) = xsilab
! Computation of the mean bacterial concentration
! this parameterization has been deduced from a model version
- ! that was modeling explicitely bacteria. This is a very old param
+ ! that was modeling explicitely bacteria. This is a very old parame
! that will be very soon updated based on results from a much more
! recent version of PISCES with bacteria.
! ----------------------------------------------------------------
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1)
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
zdep = MAX( hmld(ji,jj), heup_01(ji,jj) )
IF ( gdept(ji,jj,jk,Kmm) < zdep ) THEN
zdepbac(ji,jj,jk) = 0.6 * ( MAX(0.0, tr(ji,jj,jk,jpzoo,Kbb) + tr(ji,jj,jk,jpmes,Kbb) ) * 1.0E6 )**0.6 * 1.E-6
@@ -102,13 +120,11 @@ CONTAINS
! IF( gdept(ji,jj,jk,Kmm) >= zdep ) THEN
ELSE
zdepmin = MIN( 1., zdep / gdept(ji,jj,jk,Kmm) )
- zdepbac (ji,jj,jk) = zdepmin**0.683 * ztempbac(ji,jj)
-! zdepeff(ji,jj,jk) = zdepeff(ji,jj,jk) * zdepmin**0.3
- zdepeff(ji,jj,jk) = zdepeff(ji,jj,jk) * zdepmin**0.6
+ zdepbac(ji,jj,jk) = zdepmin**0.683 * ztempbac(ji,jj)
ENDIF
END_3D
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1)
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
! DOC ammonification. Depends on depth, phytoplankton biomass
! and a limitation term which is supposed to be a parameterization of the bacterial activity.
! --------------------------------------------------------------------------
@@ -119,7 +135,6 @@ CONTAINS
! -----------------------------------------------------
zolimic = zremikc * ( 1.- nitrfac(ji,jj,jk) ) * tr(ji,jj,jk,jpdoc,Kbb)
zolimic = MAX(0., MIN( ( tr(ji,jj,jk,jpoxy,Kbb) - rtrn ) / o2ut, zolimic ) )
- zolimi(ji,jj,jk) = zolimic
! Ammonification in suboxic waters with denitrification
! -----------------------------------------------------
@@ -152,7 +167,7 @@ CONTAINS
ENDIF
END_3D
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1)
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
! NH4 nitrification to NO3. Ceased for oxygen concentrations
! below 2 umol/L. Inhibited at strong light
! ----------------------------------------------------------
@@ -174,14 +189,22 @@ CONTAINS
CALL prt_ctl(tab4d_1=tr(:,:,:,:,Krhs), mask1=tmask, clinfo=ctrcnm)
ENDIF
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1)
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
+ zdep = MAX( hmld(ji,jj), heup_01(ji,jj) )
+ IF( gdept(ji,jj,jk,Kmm) >= zdep ) THEN
+ zdepmin = MIN( 1., zdep / gdept(ji,jj,jk,Kmm) )
+ zdepeff = 0.3_wp * zdepmin**0.6
+! zdepeff = 0.3_wp * zdepmin**0.3
+ ELSE
+ zdepeff = 0.3_wp
+ ENDIF
! Bacterial uptake of iron. No iron is available in DOC. So
! Bacteries are obliged to take up iron from the water. Some
! studies (especially at Papa) have shown this uptake to be significant
! ----------------------------------------------------------
zbactfer = feratb * 0.6_wp * xstep * tgfunc(ji,jj,jk) * xlimbacl(ji,jj,jk) * tr(ji,jj,jk,jpfer,Kbb) &
- & / ( xkferb + tr(ji,jj,jk,jpfer,Kbb) ) * zdepeff(ji,jj,jk) * zdepbac(ji,jj,jk)
+ & / ( xkferb + tr(ji,jj,jk,jpfer,Kbb) ) * zdepeff * zdepbac(ji,jj,jk)
! Only the transfer of iron from its dissolved form to particles
! is treated here. The GGE of bacteria supposed to be equal to
@@ -189,8 +212,7 @@ CONTAINS
tr(ji,jj,jk,jpfer,Krhs) = tr(ji,jj,jk,jpfer,Krhs) - zbactfer*0.1
tr(ji,jj,jk,jpsfe,Krhs) = tr(ji,jj,jk,jpsfe,Krhs) + zbactfer*0.08
tr(ji,jj,jk,jpbfe,Krhs) = tr(ji,jj,jk,jpbfe,Krhs) + zbactfer*0.02
- zfebact(ji,jj,jk) = zbactfer * 0.1
- blim(ji,jj,jk) = xlimbacl(ji,jj,jk) * zdepbac(ji,jj,jk) / 1.e-6
+ blim(ji,jj,jk) = xlimbacl(ji,jj,jk) * zdepbac(ji,jj,jk) / 1.e-6
END_3D
IF(sn_cfctl%l_prttrc) THEN ! print mean trends (used for debugging)
@@ -202,7 +224,7 @@ CONTAINS
! Initialization of the array which contains the labile fraction
! of bSi. Set to a constant in the upper ocean
! ---------------------------------------------------------------
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1)
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
! Remineralization rate of BSi dependent on T and saturation
! The parameterization is taken from Ridgwell et al. (2002)
! ---------------------------------------------------------
@@ -219,13 +241,14 @@ CONTAINS
! of bSi. This is computed assuming steady state.
! --------------------------------------------------------------
IF ( gdept(ji,jj,jk,Kmm) > zdep ) THEN
- zfacsib(ji,jj,jk) = zfacsib(ji,jj,jk-1) * EXP( -0.5 * ( xsiremlab - xsirem ) &
- & * znusil * e3t(ji,jj,jk,Kmm) / wsbio4(ji,jj,jk) )
- zfacsi(ji,jj,jk) = zfacsib(ji,jj,jk) / ( 1.0 + zfacsib(ji,jj,jk) )
- zfacsib(ji,jj,jk) = zfacsib(ji,jj,jk) * EXP( -0.5 * ( xsiremlab - xsirem ) &
- & * znusil * e3t(ji,jj,jk,Kmm) / wsbio4(ji,jj,jk) )
+ zfactdep = EXP( -0.5 * ( xsiremlab - xsirem ) * znusil * e3t(ji,jj,jk,Kmm) / wsbio4(ji,jj,jk) )
+ zfacsib(ji,jj,jk) = zfacsib(ji,jj,jk-1) * zfactdep
+ zfacsi = zfacsib(ji,jj,jk) / ( 1.0 + zfacsib(ji,jj,jk) )
+ zfacsib(ji,jj,jk) = zfacsib(ji,jj,jk) * zfactdep
+ ELSE
+ zfacsi = xsilab
ENDIF
- zsiremin = ( xsiremlab * zfacsi(ji,jj,jk) + xsirem * ( 1. - zfacsi(ji,jj,jk) ) ) * xstep * znusil
+ zsiremin = ( xsiremlab * zfacsi + xsirem * ( 1. - zfacsi ) ) * xstep * znusil
zosil = zsiremin * tr(ji,jj,jk,jpgsi,Kbb)
!
tr(ji,jj,jk,jpgsi,Krhs) = tr(ji,jj,jk,jpgsi,Krhs) - zosil
@@ -236,20 +259,46 @@ CONTAINS
WRITE(charout, FMT="('rem3')")
CALL prt_ctl_info( charout, cdcomp = 'top' )
CALL prt_ctl(tab4d_1=tr(:,:,:,:,Krhs), mask1=tmask, clinfo=ctrcnm)
- ENDIF
+ ENDIF
- IF( knt == nrdttrc ) THEN
- zrfact2 = 1.e+3 * rfact2r ! conversion from mol/l/kt to mol/m3/s
+ IF( lk_iomput .AND. knt == nrdttrc ) THEN
!
- IF( iom_use( "REMIN" ) ) THEN ! Remineralisation rate
- zolimi(:,:,jpk) = 0. ; CALL iom_put( "REMIN" , zolimi(:,:,:) * tmask(:,:,:) * zrfact2 )
+ IF( l_dia_febact ) THEN
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
+ zfebact(ji,jj,jk) = ( zfebact(ji,jj,jk) - tr(ji,jj,jk,jpfer,Krhs) ) &
+ & * 1e9 * rfact2r * tmask(ji,jj,jk) ! conversion in nmol/m2/s
+ END_3D
+ CALL iom_put( "FEBACT", zfebact )
+ DEALLOCATE( zfebact )
ENDIF
- CALL iom_put( "DENIT" , denitr(:,:,:) * rdenit * rno3 * tmask(:,:,:) * zrfact2 ) ! Denitrification
- IF( iom_use( "BACT" ) ) THEN ! Bacterial biomass
- zdepbac(:,:,jpk) = 0. ; CALL iom_put( "BACT", zdepbac(:,:,:) * 1.E6 * tmask(:,:,:) )
+ IF( l_dia_remin ) THEN ! Remineralisation rate
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
+ zolimi(ji,jj,jk) = ( zolimi(ji,jj,jk) - tr(ji,jj,jk,jpoxy,Krhs) ) / o2ut &
+ & * rfact2r * tmask(ji,jj,jk) !
+ END_3D
+ CALL iom_put( "REMIN", zolimi )
+ DEALLOCATE( zolimi )
ENDIF
- CALL iom_put( "FEBACT" , zfebact(:,:,:) * 1E9 * tmask(:,:,:) * zrfact2 )
- ENDIF
+ !
+ IF( l_dia_bact ) THEN ! Bacterial biomass
+ ALLOCATE( zw3d(A2D(0),jpk) ) ; zw3d(A2D(0),jpk) = 0._wp
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
+ zw3d(ji,jj,jk) = zdepbac(ji,jj,jk) * 1.E6 * tmask(ji,jj,jk)
+ END_3D
+ CALL iom_put( "BACT", zw3d )
+ DEALLOCATE( zw3d )
+ ENDIF
+ !
+ IF( l_dia_denit ) THEN ! Denitrification
+ ALLOCATE( zw3d(A2D(0),jpk) ) ; zw3d(A2D(0),jpk) = 0._wp
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
+ zw3d(ji,jj,jk) = denitr(ji,jj,jk) * 1E+3 * rfact2r * rno3 * tmask(ji,jj,jk)
+ END_3D
+ CALL iom_put( "DENIT", zw3d )
+ DEALLOCATE( zw3d )
+ ENDIF
+ !
+ ENDIF
!
IF( ln_timing ) CALL timing_stop('p4z_rem')
!
diff --git a/src/TOP/PISCES/P4Z/p4zsed.F90 b/src/TOP/PISCES/P4Z/p4zsed.F90
index ca6bdb281c10b0e6c24143440ce85618e10042f0..45d5dafba939d609e8ea8258c62e5aba83f4368a 100644
--- a/src/TOP/PISCES/P4Z/p4zsed.F90
+++ b/src/TOP/PISCES/P4Z/p4zsed.F90
@@ -15,6 +15,7 @@ MODULE p4zsed
USE sms_pisces ! PISCES Source Minus Sink variables
USE p4zlim ! Co-limitations of differents nutrients
USE p4zint ! interpolation and computation of various fields
+ USE p4zsink ! Sinking fluxes
USE sed ! Sediment module
USE iom ! I/O manager
USE prtctl ! print control for debugging
@@ -36,6 +37,8 @@ MODULE p4zsed
REAL(wp), SAVE :: r1_rday
REAL(wp), SAVE :: sedsilfrac, sedcalfrac
+ LOGICAL :: l_dia_sdenit, l_dia_nfix, l_dia_sed
+
!! * Substitutions
# include "do_loop_substitute.h90"
# include "domzgr_substitute.h90"
@@ -60,54 +63,41 @@ CONTAINS
INTEGER, INTENT(in) :: kt, knt ! ocean time step
INTEGER, INTENT(in) :: Kbb, Kmm, Krhs ! time level indices
INTEGER :: ji, jj, jk, ikt
- REAL(wp) :: zrivalk, zrivsil, zrivno3
+ REAL(wp) :: zbureff, zrivsil
REAL(wp) :: zlim, zfact, zfactcal
REAL(wp) :: zo2, zno3, zflx, zpdenit, z1pdenit, zolimit
- REAL(wp) :: zsiloss, zcaloss, zws3, zws4, zwsc, zdep
+ REAL(wp) :: zsiloss, zcaloss, zdep
REAL(wp) :: zwstpoc, zwstpon, zwstpop
REAL(wp) :: ztrfer, ztrpo4s, ztrdp, zwdust, zmudia, ztemp
+ REAL(wp) :: zsoufer, zlight, ztrpo4, ztrdop
REAL(wp) :: xdiano3, xdianh4
!
CHARACTER (len=25) :: charout
- REAL(wp), DIMENSION(jpi,jpj ) :: zdenit2d, zbureff, zwork
- REAL(wp), DIMENSION(jpi,jpj ) :: zwsbio3, zwsbio4
- REAL(wp), DIMENSION(jpi,jpj ) :: zsedcal, zsedsi, zsedc
- REAL(wp), DIMENSION(jpi,jpj,jpk) :: zsoufer, zlight
- REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: ztrpo4, ztrdop, zirondep, zpdep
+ REAL(wp), DIMENSION(A2D(0)) :: zdenit2d, zrivno3, zrivalk
+ REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zw3d
!!---------------------------------------------------------------------
!
IF( ln_timing ) CALL timing_start('p4z_sed')
!
+ IF( kt == nittrc000 ) THEN
+ l_dia_nfix = iom_use( "Nfix" )
+ l_dia_sdenit = iom_use( "Sdenit" )
+ l_dia_sed = .NOT.lk_sed .AND. ( iom_use( "SedC" ) .OR. iom_use( "SedCal" ) .OR. iom_use( "SedSi" ) )
+ ENDIF
- ! Allocate temporary workspace
- ALLOCATE( ztrpo4(jpi,jpj,jpk) )
- IF( ln_p5z ) ALLOCATE( ztrdop(jpi,jpj,jpk) )
-
+ !
zdenit2d(:,:) = 0.e0
- zbureff (:,:) = 0.e0
- zwork (:,:) = 0.e0
- zsedsi (:,:) = 0.e0
- zsedcal (:,:) = 0.e0
- zsedc (:,:) = 0.e0
-
- ! OA: Warning, the following part is necessary to avoid CFL problems above the sediments
- ! --------------------------------------------------------------------
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
- ikt = mbkt(ji,jj)
- zdep = e3t(ji,jj,ikt,Kmm) / xstep
- zwsbio4(ji,jj) = MIN( 0.99 * zdep, wsbio4(ji,jj,ikt) )
- zwsbio3(ji,jj) = MIN( 0.99 * zdep, wsbio3(ji,jj,ikt) )
- END_2D
-
+ zrivno3 (:,:) = 0.e0
+ zrivalk (:,:) = 0.e0
+ !
IF( .NOT.lk_sed ) THEN
! Computation of the sediment denitrification proportion: The metamodel from midlleburg (2006) is being used
! Computation of the fraction of organic matter that is permanently buried from Dunne's model
! -------------------------------------------------------
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
IF( tmask(ji,jj,1) == 1 ) THEN
ikt = mbkt(ji,jj)
- zflx = ( tr(ji,jj,ikt,jpgoc,Kbb) * zwsbio4(ji,jj) &
- & + tr(ji,jj,ikt,jppoc,Kbb) * zwsbio3(ji,jj) ) * 1E3 * 1E6 / 1E4
+ zflx = sinkpocb(ji,jj) / xstep * 1E3 * 1E6 / 1E4
zflx = LOG10( MAX( 1E-3, zflx ) )
zo2 = LOG10( MAX( 10. , tr(ji,jj,ikt,jpoxy,Kbb) * 1E6 ) )
zno3 = LOG10( MAX( 1. , tr(ji,jj,ikt,jpno3,Kbb) * 1E6 * rno3 ) )
@@ -116,9 +106,9 @@ CONTAINS
& + 0.4721 * zo2 - 0.0996 * zdep + 0.4256 * zflx * zo2
zdenit2d(ji,jj) = 10.0**( zdenit2d(ji,jj) )
!
- zflx = ( tr(ji,jj,ikt,jpgoc,Kbb) * zwsbio4(ji,jj) &
- & + tr(ji,jj,ikt,jppoc,Kbb) * zwsbio3(ji,jj) ) * 1E6
- zbureff(ji,jj) = 0.013 + 0.53 * zflx**2 / ( 7.0 + zflx )**2
+ zflx = sinkpocb(ji,jj) / xstep * 1E6
+ zbureff = 0.013 + 0.53 * zflx**2 / ( 7.0 + zflx )**2
+ zrivno3(ji,jj) = 1. - zbureff
ENDIF
END_2D
!
@@ -127,74 +117,33 @@ CONTAINS
! This loss is scaled at each bottom grid cell for equilibrating the total budget of silica in the ocean.
! Thus, the amount of silica lost in the sediments equal the supply at the surface (dust+rivers)
! ------------------------------------------------------
- IF( .NOT.lk_sed ) zrivsil = 1._wp - sedsilfrac
-
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
- ikt = mbkt(ji,jj)
- zdep = xstep / e3t(ji,jj,ikt,Kmm)
- zwsc = zwsbio4(ji,jj) * zdep
- zsiloss = tr(ji,jj,ikt,jpgsi,Kbb) * zwsc
- zcaloss = tr(ji,jj,ikt,jpcal,Kbb) * zwsc
- !
- tr(ji,jj,ikt,jpgsi,Krhs) = tr(ji,jj,ikt,jpgsi,Krhs) - zsiloss
- tr(ji,jj,ikt,jpcal,Krhs) = tr(ji,jj,ikt,jpcal,Krhs) - zcaloss
- END_2D
!
IF( .NOT.lk_sed ) THEN
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ zrivsil = 1._wp - sedsilfrac
+ DO_2D( 0, 0, 0, 0 )
ikt = mbkt(ji,jj)
- zdep = xstep / e3t(ji,jj,ikt,Kmm)
- zwsc = zwsbio4(ji,jj) * zdep
- zsiloss = tr(ji,jj,ikt,jpgsi,Kbb) * zwsc
- zcaloss = tr(ji,jj,ikt,jpcal,Kbb) * zwsc
+ zdep = 1._wp / e3t(ji,jj,ikt,Kmm)
+ zsiloss = sinksilb(ji,jj) * zdep
+ zcaloss = sinkcalb(ji,jj) * zdep
tr(ji,jj,ikt,jpsil,Krhs) = tr(ji,jj,ikt,jpsil,Krhs) + zsiloss * zrivsil
!
zfactcal = MAX(-0.1, MIN( excess(ji,jj,ikt), 0.2 ) )
zfactcal = 0.3 + 0.7 * MIN( 1., (0.1 + zfactcal) / ( 0.5 - zfactcal ) )
- zrivalk = sedcalfrac * zfactcal
- tr(ji,jj,ikt,jptal,Krhs) = tr(ji,jj,ikt,jptal,Krhs) + zcaloss * zrivalk * 2.0
- tr(ji,jj,ikt,jpdic,Krhs) = tr(ji,jj,ikt,jpdic,Krhs) + zcaloss * zrivalk
- zsedcal(ji,jj) = (1.0 - zrivalk) * zcaloss * e3t(ji,jj,ikt,Kmm)
- zsedsi (ji,jj) = (1.0 - zrivsil) * zsiloss * e3t(ji,jj,ikt,Kmm)
+ zrivalk(ji,jj) = sedcalfrac * zfactcal
+ tr(ji,jj,ikt,jptal,Krhs) = tr(ji,jj,ikt,jptal,Krhs) + zcaloss * zrivalk(ji,jj) * 2.0
+ tr(ji,jj,ikt,jpdic,Krhs) = tr(ji,jj,ikt,jpdic,Krhs) + zcaloss * zrivalk(ji,jj)
END_2D
ENDIF
!
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
- ikt = mbkt(ji,jj)
- zdep = xstep / e3t(ji,jj,ikt,Kmm)
- zws4 = zwsbio4(ji,jj) * zdep
- zws3 = zwsbio3(ji,jj) * zdep
- tr(ji,jj,ikt,jpgoc,Krhs) = tr(ji,jj,ikt,jpgoc,Krhs) - tr(ji,jj,ikt,jpgoc,Kbb) * zws4
- tr(ji,jj,ikt,jppoc,Krhs) = tr(ji,jj,ikt,jppoc,Krhs) - tr(ji,jj,ikt,jppoc,Kbb) * zws3
- tr(ji,jj,ikt,jpbfe,Krhs) = tr(ji,jj,ikt,jpbfe,Krhs) - tr(ji,jj,ikt,jpbfe,Kbb) * zws4
- tr(ji,jj,ikt,jpsfe,Krhs) = tr(ji,jj,ikt,jpsfe,Krhs) - tr(ji,jj,ikt,jpsfe,Kbb) * zws3
- END_2D
- !
- IF( ln_p5z ) THEN
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
- ikt = mbkt(ji,jj)
- zdep = xstep / e3t(ji,jj,ikt,Kmm)
- zws4 = zwsbio4(ji,jj) * zdep
- zws3 = zwsbio3(ji,jj) * zdep
- tr(ji,jj,ikt,jpgon,Krhs) = tr(ji,jj,ikt,jpgon,Krhs) - tr(ji,jj,ikt,jpgon,Kbb) * zws4
- tr(ji,jj,ikt,jppon,Krhs) = tr(ji,jj,ikt,jppon,Krhs) - tr(ji,jj,ikt,jppon,Kbb) * zws3
- tr(ji,jj,ikt,jpgop,Krhs) = tr(ji,jj,ikt,jpgop,Krhs) - tr(ji,jj,ikt,jpgop,Kbb) * zws4
- tr(ji,jj,ikt,jppop,Krhs) = tr(ji,jj,ikt,jppop,Krhs) - tr(ji,jj,ikt,jppop,Kbb) * zws3
- END_2D
- ENDIF
+ ! The 0.5 factor in zpdenit is to avoid negative NO3 concentration after
+ ! denitrification in the sediments. Not very clever, but simpliest option.
IF( .NOT.lk_sed ) THEN
- ! The 0.5 factor in zpdenit is to avoid negative NO3 concentration after
- ! denitrification in the sediments. Not very clever, but simpliest option.
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
ikt = mbkt(ji,jj)
- zdep = xstep / e3t(ji,jj,ikt,Kmm)
- zws4 = zwsbio4(ji,jj) * zdep
- zws3 = zwsbio3(ji,jj) * zdep
- zrivno3 = 1. - zbureff(ji,jj)
- zwstpoc = tr(ji,jj,ikt,jpgoc,Kbb) * zws4 + tr(ji,jj,ikt,jppoc,Kbb) * zws3
- zpdenit = MIN( 0.5 * ( tr(ji,jj,ikt,jpno3,Kbb) - rtrn ) / rdenit, zdenit2d(ji,jj) * zwstpoc * zrivno3 )
- z1pdenit = zwstpoc * zrivno3 - zpdenit
+ zwstpoc = sinkpocb(ji,jj) / e3t(ji,jj,ikt,Kmm)
+ zpdenit = MIN( 0.5 * ( tr(ji,jj,ikt,jpno3,Kbb) - rtrn ) / rdenit, zdenit2d(ji,jj) * zwstpoc * zrivno3(ji,jj) )
+ z1pdenit = zwstpoc * zrivno3(ji,jj) - zpdenit
zolimit = MIN( ( tr(ji,jj,ikt,jpoxy,Kbb) - rtrn ) / o2ut, z1pdenit * ( 1.- nitrfac(ji,jj,ikt) ) )
tr(ji,jj,ikt,jpdoc,Krhs) = tr(ji,jj,ikt,jpdoc,Krhs) + z1pdenit - zolimit
tr(ji,jj,ikt,jppo4,Krhs) = tr(ji,jj,ikt,jppo4,Krhs) + zpdenit + zolimit
@@ -204,27 +153,34 @@ CONTAINS
tr(ji,jj,ikt,jptal,Krhs) = tr(ji,jj,ikt,jptal,Krhs) + rno3 * (zolimit + (1.+rdenit) * zpdenit )
tr(ji,jj,ikt,jpdic,Krhs) = tr(ji,jj,ikt,jpdic,Krhs) + zpdenit + zolimit
sdenit(ji,jj) = rdenit * zpdenit * e3t(ji,jj,ikt,Kmm)
- zsedc(ji,jj) = (1. - zrivno3) * zwstpoc * e3t(ji,jj,ikt,Kmm)
- IF( ln_p5z ) THEN
- zwstpop = tr(ji,jj,ikt,jpgop,Kbb) * zws4 + tr(ji,jj,ikt,jppop,Kbb) * zws3
- zwstpon = tr(ji,jj,ikt,jpgon,Kbb) * zws4 + tr(ji,jj,ikt,jppon,Kbb) * zws3
+ END_2D
+ IF( ln_p5z ) THEN
+ DO_2D( 0, 0, 0, 0 )
+ ikt = mbkt(ji,jj)
+ zdep = 1._wp / e3t(ji,jj,ikt,Kmm)
+ zwstpoc = sinkpocb(ji,jj) * zdep
+ zwstpop = sinkpopb(ji,jj) * zdep
+ zwstpon = sinkponb(ji,jj) * zdep
+ zpdenit = MIN( 0.5 * ( tr(ji,jj,ikt,jpno3,Kbb) - rtrn ) / rdenit, zdenit2d(ji,jj) * zwstpoc * zrivno3(ji,jj) )
+ z1pdenit = zwstpoc * zrivno3(ji,jj) - zpdenit
+ zolimit = MIN( ( tr(ji,jj,ikt,jpoxy,Kbb) - rtrn ) / o2ut, z1pdenit * ( 1.- nitrfac(ji,jj,ikt) ) )
tr(ji,jj,ikt,jpdon,Krhs) = tr(ji,jj,ikt,jpdon,Krhs) + ( z1pdenit - zolimit ) * zwstpon / (zwstpoc + rtrn)
tr(ji,jj,ikt,jpdop,Krhs) = tr(ji,jj,ikt,jpdop,Krhs) + ( z1pdenit - zolimit ) * zwstpop / (zwstpoc + rtrn)
- ENDIF
- END_2D
+ END_2D
+ ENDIF
ENDIF
! Nitrogen fixation process
! Small source iron from particulate inorganic iron
!-----------------------------------
- DO jk = 1, jpkm1
- zlight (:,:,jk) = ( 1.- EXP( -etot_ndcy(:,:,jk) / diazolight ) ) * ( 1. - fr_i(:,:) )
- zsoufer(:,:,jk) = zlight(:,:,jk) * 2E-11 / ( 2E-11 + biron(:,:,jk) )
- ENDDO
+ !
IF( ln_p4z ) THEN
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1)
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
! ! Potential nitrogen fixation dependant on temperature and iron
+ zlight = ( 1.- EXP( -etot_ndcy(ji,jj,jk) / diazolight ) ) * ( 1. - fr_i(ji,jj) )
+ zsoufer = zlight * 2E-11 / ( 2E-11 + biron(ji,jj,jk) )
+ !
ztemp = ts(ji,jj,jk,jp_tem,Kmm)
zmudia = MAX( 0.,-0.001096*ztemp**2 + 0.057*ztemp -0.637 ) / rno3
! Potential nitrogen fixation dependant on temperature and iron
@@ -234,33 +190,11 @@ CONTAINS
IF( zlim <= 0.1 ) zlim = 0.01
zfact = zlim * rfact2
ztrfer = biron(ji,jj,jk) / ( concfediaz + biron(ji,jj,jk) )
- ztrpo4(ji,jj,jk) = tr(ji,jj,jk,jppo4,Kbb) / ( 1E-6 + tr(ji,jj,jk,jppo4,Kbb) )
- ztrdp = ztrpo4(ji,jj,jk)
- nitrpot(ji,jj,jk) = zmudia * r1_rday * zfact * MIN( ztrfer, ztrdp ) * zlight(ji,jj,jk)
- END_3D
- ELSE ! p5z
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1)
- ! ! Potential nitrogen fixation dependant on temperature and iron
- ztemp = ts(ji,jj,jk,jp_tem,Kmm)
- zmudia = MAX( 0.,-0.001096*ztemp**2 + 0.057*ztemp -0.637 ) * 7.625
- ! Potential nitrogen fixation dependant on temperature and iron
- xdianh4 = tr(ji,jj,jk,jpnh4,Kbb) / ( concnnh4 + tr(ji,jj,jk,jpnh4,Kbb) )
- xdiano3 = tr(ji,jj,jk,jpno3,Kbb) / ( concnno3 + tr(ji,jj,jk,jpno3,Kbb) ) * (1. - xdianh4)
- zlim = ( 1.- xdiano3 - xdianh4 )
- IF( zlim <= 0.1 ) zlim = 0.01
- zfact = zlim * rfact2
- ztrfer = biron(ji,jj,jk) / ( concfediaz + biron(ji,jj,jk) )
- ztrpo4(ji,jj,jk) = tr(ji,jj,jk,jppo4,Kbb) / ( 1E-6 + tr(ji,jj,jk,jppo4,Kbb) )
- ztrdop(ji,jj,jk) = tr(ji,jj,jk,jpdop,Kbb) / ( 1E-6 + tr(ji,jj,jk,jpdop,Kbb) ) * (1. - ztrpo4(ji,jj,jk))
- ztrdp = ztrpo4(ji,jj,jk) + ztrdop(ji,jj,jk)
- nitrpot(ji,jj,jk) = zmudia * r1_rday * zfact * MIN( ztrfer, ztrdp ) * zlight(ji,jj,jk)
- END_3D
- ENDIF
-
- ! Nitrogen change due to nitrogen fixation
- ! ----------------------------------------
- IF( ln_p4z ) THEN
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1)
+ ztrpo4 = tr(ji,jj,jk,jppo4,Kbb) / ( 1E-6 + tr(ji,jj,jk,jppo4,Kbb) )
+ nitrpot(ji,jj,jk) = zmudia * r1_rday * zfact * MIN( ztrfer, ztrpo4 ) * zlight
+ !
+ ! Nitrogen change due to nitrogen fixation
+ ! ----------------------------------------
zfact = nitrpot(ji,jj,jk) * nitrfix
tr(ji,jj,jk,jpnh4,Krhs) = tr(ji,jj,jk,jpnh4,Krhs) + zfact / 3.0
tr(ji,jj,jk,jptal,Krhs) = tr(ji,jj,jk,jptal,Krhs) + rno3 * zfact / 3.0
@@ -273,23 +207,41 @@ CONTAINS
tr(ji,jj,jk,jpfer,Krhs) = tr(ji,jj,jk,jpfer,Krhs) - 30E-6 * zfact * 1.0 / 3.0
tr(ji,jj,jk,jpsfe,Krhs) = tr(ji,jj,jk,jpsfe,Krhs) + 30E-6 * zfact * 1.0 / 3.0 * 2.0 / 3.0
tr(ji,jj,jk,jpbfe,Krhs) = tr(ji,jj,jk,jpbfe,Krhs) + 30E-6 * zfact * 1.0 / 3.0 * 1.0 / 3.0
- tr(ji,jj,jk,jpfer,Krhs) = tr(ji,jj,jk,jpfer,Krhs) + 0.002 * 4E-10 * zsoufer(ji,jj,jk) * rfact2 / rday
+ tr(ji,jj,jk,jpfer,Krhs) = tr(ji,jj,jk,jpfer,Krhs) + 0.002 * 4E-10 * zsoufer * rfact2 / rday
tr(ji,jj,jk,jppo4,Krhs) = tr(ji,jj,jk,jppo4,Krhs) + concdnh4 / ( concdnh4 + tr(ji,jj,jk,jppo4,Kbb) ) &
& * 0.001 * tr(ji,jj,jk,jpdoc,Kbb) * xstep
END_3D
- ELSE ! p5z
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1)
+ ELSE ! p5z
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
+ zlight = ( 1.- EXP( -etot_ndcy(ji,jj,jk) / diazolight ) ) * ( 1. - fr_i(ji,jj) )
+ zsoufer = zlight * 2E-11 / ( 2E-11 + biron(ji,jj,jk) )
+ !
+ ! ! Potential nitrogen fixation dependant on temperature and iron
+ ztemp = ts(ji,jj,jk,jp_tem,Kmm)
+ zmudia = MAX( 0.,-0.001096*ztemp**2 + 0.057*ztemp -0.637 ) * 7.625
+ ! Potential nitrogen fixation dependant on temperature and iron
+ xdianh4 = tr(ji,jj,jk,jpnh4,Kbb) / ( concnnh4 + tr(ji,jj,jk,jpnh4,Kbb) )
+ xdiano3 = tr(ji,jj,jk,jpno3,Kbb) / ( concnno3 + tr(ji,jj,jk,jpno3,Kbb) ) * (1. - xdianh4)
+ zlim = ( 1.- xdiano3 - xdianh4 )
+ IF( zlim <= 0.1 ) zlim = 0.01
+ zfact = zlim * rfact2
+ ztrfer = biron(ji,jj,jk) / ( concfediaz + biron(ji,jj,jk) )
+ ztrpo4 = tr(ji,jj,jk,jppo4,Kbb) / ( 1E-6 + tr(ji,jj,jk,jppo4,Kbb) )
+ ztrdop = tr(ji,jj,jk,jpdop,Kbb) / ( 1E-6 + tr(ji,jj,jk,jpdop,Kbb) ) * (1. - ztrpo4)
+ nitrpot(ji,jj,jk) = zmudia * r1_rday * zfact * MIN( ztrfer, ztrpo4 + ztrdop ) * zlight
+
+ ! Nitrogen change due to nitrogen fixation
+ ! ----------------------------------------
zfact = nitrpot(ji,jj,jk) * nitrfix
tr(ji,jj,jk,jpnh4,Krhs) = tr(ji,jj,jk,jpnh4,Krhs) + zfact / 3.0
tr(ji,jj,jk,jptal,Krhs) = tr(ji,jj,jk,jptal,Krhs) + rno3 * zfact / 3.0
tr(ji,jj,jk,jpdic,Krhs) = tr(ji,jj,jk,jpdic,Krhs) - zfact * 2.0 / 3.0
tr(ji,jj,jk,jppo4,Krhs) = tr(ji,jj,jk,jppo4,Krhs) - 16.0 / 46.0 * zfact * ( 1.0 - 1.0 / 3.0 ) &
- & * ztrpo4(ji,jj,jk) / (ztrpo4(ji,jj,jk) + ztrdop(ji,jj,jk) + rtrn)
+ & * ztrpo4 / (ztrpo4 + ztrdop + rtrn)
tr(ji,jj,jk,jpdon,Krhs) = tr(ji,jj,jk,jpdon,Krhs) + zfact * 1.0 / 3.0
tr(ji,jj,jk,jpdoc,Krhs) = tr(ji,jj,jk,jpdoc,Krhs) + zfact * 1.0 / 3.0
tr(ji,jj,jk,jpdop,Krhs) = tr(ji,jj,jk,jpdop,Krhs) + 16.0 / 46.0 * zfact / 3.0 &
- & - 16.0 / 46.0 * zfact * ztrdop(ji,jj,jk) &
- & / (ztrpo4(ji,jj,jk) + ztrdop(ji,jj,jk) + rtrn)
+ & - 16.0 / 46.0 * zfact * ztrdop / ( ztrpo4 + ztrdop + rtrn)
tr(ji,jj,jk,jppoc,Krhs) = tr(ji,jj,jk,jppoc,Krhs) + zfact * 1.0 / 3.0 * 2.0 / 3.0
tr(ji,jj,jk,jppon,Krhs) = tr(ji,jj,jk,jppon,Krhs) + zfact * 1.0 / 3.0 * 2.0 /3.0
tr(ji,jj,jk,jppop,Krhs) = tr(ji,jj,jk,jppop,Krhs) + 16.0 / 46.0 * zfact * 1.0 / 3.0 * 2.0 /3.0
@@ -300,18 +252,32 @@ CONTAINS
tr(ji,jj,jk,jpfer,Krhs) = tr(ji,jj,jk,jpfer,Krhs) - 30E-6 * zfact * 1.0 / 3.0
tr(ji,jj,jk,jpsfe,Krhs) = tr(ji,jj,jk,jpsfe,Krhs) + 30E-6 * zfact * 1.0 / 3.0 * 2.0 / 3.0
tr(ji,jj,jk,jpbfe,Krhs) = tr(ji,jj,jk,jpbfe,Krhs) + 30E-6 * zfact * 1.0 / 3.0 * 1.0 / 3.0
- tr(ji,jj,jk,jpfer,Krhs) = tr(ji,jj,jk,jpfer,Krhs) + 0.002 * 4E-10 * zsoufer(ji,jj,jk) * rfact2 / rday
+ tr(ji,jj,jk,jpfer,Krhs) = tr(ji,jj,jk,jpfer,Krhs) + 0.002 * 4E-10 * zsoufer * rfact2 / rday
END_3D
- !
ENDIF
IF( lk_iomput .AND. knt == nrdttrc ) THEN
- zfact = 1.e+3 * rfact2r ! conversion from molC/l/kt to molN/m3/s
- CALL iom_put( "Nfix", nitrpot(:,:,:) * nitrfix * rno3 * zfact * tmask(:,:,:) ) ! nitrogen fixation
- CALL iom_put( "SedCal", zsedcal(:,:) * zfact )
- CALL iom_put( "SedSi" , zsedsi (:,:) * zfact )
- CALL iom_put( "SedC" , zsedc (:,:) * zfact )
- CALL iom_put( "Sdenit", sdenit (:,:) * zfact * rno3 )
+ !
+ IF( l_dia_nfix ) THEN ! nitrogen fixation
+ zfact = rno3 * 1.e+3 * rfact2r ! conversion from molC/l/kt to molN/m3/s
+ ALLOCATE( zw3d(A2D(0),jpk) ) ; zw3d(A2D(0),jpk) = 0._wp
+ zw3d(A2D(0),1:jpkm1) = nitrpot(A2D(0),1:jpkm1) * nitrfix * zfact * tmask(A2D(0),1:jpkm1)
+ CALL iom_put( "Nfix", zw3d )
+ DEALLOCATE( zw3d )
+ ENDIF
+ !
+ IF( l_dia_sed ) THEN
+ zfact = 1.e+3 * rfact2r ! conversion from molC/l/kt to molC/m3/s
+ CALL iom_put( "SedCal", ( 1.0 - zrivalk(:,:) ) * sinkcalb(:,:) * zfact )
+ CALL iom_put( "SedSi" , ( 1.0 - zrivsil ) * sinksilb(:,:) * zfact )
+ CALL iom_put( "SedC" , ( 1.0 - zrivno3(:,:) ) * sinkpocb(:,:) * zfact )
+ ENDIF
+ !
+ IF( l_dia_sdenit ) THEN
+ zfact = rno3 * 1.e+3 * rfact2r ! conversion from molC/l/kt to molN/m3/s
+ CALL iom_put( "Sdenit", sdenit(:,:) * zfact )
+ ENDIF
+ !
ENDIF
!
IF(sn_cfctl%l_prttrc) THEN ! print mean trneds (USEd for debugging)
@@ -320,8 +286,6 @@ CONTAINS
CALL prt_ctl(tab4d_1=tr(:,:,:,:,Krhs), mask1=tmask, clinfo=ctrcnm)
ENDIF
!
- IF( ln_p5z ) DEALLOCATE( ztrpo4, ztrdop )
- !
IF( ln_timing ) CALL timing_stop('p4z_sed')
!
END SUBROUTINE p4z_sed
@@ -367,7 +331,7 @@ CONTAINS
!
lk_sed = ln_sediment .AND. ln_sed_2way
!
- nitrpot(:,:,jpk) = 0._wp ! define last level for iom_put
+! nitrpot(:,:,jpk) = 0._wp ! define last level for iom_put
!
END SUBROUTINE p4z_sed_init
@@ -375,7 +339,7 @@ CONTAINS
!!----------------------------------------------------------------------
!! *** ROUTINE p4z_sed_alloc ***
!!----------------------------------------------------------------------
- ALLOCATE( nitrpot(jpi,jpj,jpk), sdenit(jpi,jpj), STAT=p4z_sed_alloc )
+ ALLOCATE( nitrpot(A2D(0),jpk), sdenit(A2D(0)), STAT=p4z_sed_alloc )
!
IF( p4z_sed_alloc /= 0 ) CALL ctl_stop( 'STOP', 'p4z_sed_alloc: failed to allocate arrays' )
!
diff --git a/src/TOP/PISCES/P4Z/p4zsink.F90 b/src/TOP/PISCES/P4Z/p4zsink.F90
index 53db2671e02ac76bedea89eb4c7cfd259172fad5..e794e8a7d9dea887fd70324a228d821a42e44085 100644
--- a/src/TOP/PISCES/P4Z/p4zsink.F90
+++ b/src/TOP/PISCES/P4Z/p4zsink.F90
@@ -31,15 +31,15 @@ MODULE p4zsink
PUBLIC p4z_sink_init ! called in trcini_pisces.F90
PUBLIC p4z_sink_alloc ! called in trcini_pisces.F90
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: sinking, sinking2 !: POC sinking fluxes
- ! ! (different meanings depending on the parameterization)
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: sinkingn, sinking2n !: PON sinking fluxes
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: sinkingp, sinking2p !: POP sinking fluxes
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: sinkcal, sinksil !: CaCO3 and BSi sinking fluxes
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: sinkfer !: Small BFe sinking fluxes
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: sinkfer2 !: Big iron sinking fluxes
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sinkpocb !: POC sinking fluxes at bottom
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sinkcalb !: CaCO3 sinking fluxes at bottom
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sinksilb !: BSi sinking fluxes at bottom
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sinkponb !: POC sinking fluxes at bottom
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sinkpopb !: POC sinking fluxes at bottom
INTEGER :: ik100
+ REAL(wp) :: xfact
+ LOGICAL :: l_dia_sink, l_diag
!! * Substitutions
# include "do_loop_substitute.h90"
@@ -68,10 +68,22 @@ CONTAINS
INTEGER :: ji, jj, jk
CHARACTER (len=25) :: charout
REAL(wp) :: zmax, zfact
+ REAL(wp), DIMENSION(A2D(0),jpk) :: zsinking
+ REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zw3d
!!---------------------------------------------------------------------
!
IF( ln_timing ) CALL timing_start('p4z_sink')
+ IF( kt == nittrc000 ) THEN
+ l_dia_sink = iom_use( "EPC100" ) .OR. iom_use( "EPFE100" ) .OR. iom_use( "EPCAL100" ) .OR. iom_use( "EPSI100" ) &
+ & .OR. iom_use( "EXPC" ) .OR. iom_use( "EXPFE" ) .OR. iom_use( "EXPCAL" ) .OR. iom_use( "EXPSI" ) &
+ & .OR. iom_use( "tcexp" )
+ !
+ xfact = 1.e+3 * rfact2r ! conversion from mol/l/kt to mol/m3/s
+ ENDIF
+ l_diag = l_dia_sink .OR. ( ln_check_mass .AND. kt == nitend )
+ l_diag = l_diag .AND. knt == nrdttrc
+
! Initialization of some global variables
! ---------------------------------------
prodpoc(:,:,:) = 0.
@@ -86,7 +98,7 @@ CONTAINS
! CaCO3 and bSi are supposed to sink at the big particles speed
! due to their high density
! ---------------------------------------------------------------
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1)
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
zmax = MAX( heup_01(ji,jj), hmld(ji,jj) )
zfact = MAX( 0., gdepw(ji,jj,jk+1,Kmm) - zmax ) / wsbio2scale
wsbio4(ji,jj,jk) = wsbio2 + MAX(0., ( wsbio2max - wsbio2 )) * zfact
@@ -95,62 +107,92 @@ CONTAINS
! Sinking speed of the small particles is always constant
wsbio3(:,:,:) = wsbio
- ! Initialize to zero all the sinking arrays
- ! -----------------------------------------
- sinking (:,:,:) = 0.e0
- sinking2(:,:,:) = 0.e0
- sinkcal (:,:,:) = 0.e0
- sinkfer (:,:,:) = 0.e0
- sinksil (:,:,:) = 0.e0
- sinkfer2(:,:,:) = 0.e0
-
! Compute the sedimentation term using trc_sink for all the sinking particles
! ---------------------------------------------------------------------------
- CALL trc_sink( kt, Kbb, Kmm, wsbio3, sinking , jppoc, rfact2 )
- CALL trc_sink( kt, Kbb, Kmm, wsbio3, sinkfer , jpsfe, rfact2 )
- CALL trc_sink( kt, Kbb, Kmm, wsbio4, sinking2, jpgoc, rfact2 )
- CALL trc_sink( kt, Kbb, Kmm, wsbio4, sinkfer2, jpbfe, rfact2 )
- CALL trc_sink( kt, Kbb, Kmm, wsbio4, sinksil , jpgsi, rfact2 )
- CALL trc_sink( kt, Kbb, Kmm, wsbio4, sinkcal , jpcal, rfact2 )
-
+ zsinking(:,:,:) = 0.e0
+ !
+ CALL trc_sink( kt, Kbb, Kmm, wsbio3, zsinking , jppoc, rfact2 )
+ DO_2D( 0, 0, 0, 0 )
+ sinkpocb(ji,jj) = zsinking(ji,jj,mbkt(ji,jj)+1)
+ END_2D
+ IF( l_diag ) THEN
+ ALLOCATE( zw3d(A2D(0),jpk) ) ; zw3d(A2D(0),:) = 0._wp
+ zw3d(A2D(0),1:jpkm1) = zsinking(A2D(0),1:jpkm1) * xfact * tmask(A2D(0),1:jpkm1)
+ ENDIF
+ !
+ CALL trc_sink( kt, Kbb, Kmm, wsbio4, zsinking, jpgoc, rfact2 )
+ DO_2D( 0, 0, 0, 0 )
+ sinkpocb(ji,jj) = sinkpocb(ji,jj) + zsinking(ji,jj,mbkt(ji,jj)+1)
+ END_2D
+ IF( l_diag ) THEN
+ zw3d(A2D(0),1:jpkm1) = zw3d(A2D(0),1:jpkm1) + zsinking(A2D(0),1:jpkm1) * xfact * tmask(A2D(0),1:jpkm1)
+ t_oce_co2_exp = glob_sum( 'p4zsink', zw3d(A2D(0),ik100) * e1e2t(A2D(0)) * tmask(A2D(0),1) )
+ CALL iom_put( "EPC100", zw3d(:,:,ik100) ) ! Export of carbon at 100m
+ CALL iom_put( "EXPC" , zw3d ) ! Export of carbon in the water column
+ CALL iom_put( "tcexp", t_oce_co2_exp ) ! Total cabon exort
+ ENDIF
+ !
+ CALL trc_sink( kt, Kbb, Kmm, wsbio4, zsinking, jpgsi, rfact2 )
+ DO_2D( 0, 0, 0, 0 )
+ sinksilb(ji,jj) = zsinking(ji,jj,mbkt(ji,jj)+1)
+ END_2D
+ IF( l_diag ) THEN
+ zw3d(A2D(0),1:jpkm1) = zsinking(A2D(0),1:jpkm1) * xfact * tmask(A2D(0),1:jpkm1)
+ CALL iom_put( "EPSI100", zw3d(:,:,ik100) ) ! Export of Silicate at 100m
+ CALL iom_put( "EXPSI" , zw3d ) ! Export of Silicate in the water column
+ ENDIF
+ !
+ CALL trc_sink( kt, Kbb, Kmm, wsbio4, zsinking, jpcal, rfact2 )
+ DO_2D( 0, 0, 0, 0 )
+ sinkcalb(ji,jj) = zsinking(ji,jj,mbkt(ji,jj)+1)
+ END_2D
+ IF( l_diag ) THEN
+ zw3d(A2D(0),1:jpkm1) = zsinking(A2D(0),1:jpkm1) * xfact * tmask(A2D(0),1:jpkm1)
+ CALL iom_put( "EPCAL100", zw3d(:,:,ik100) ) ! Export of calcite at 100m
+ CALL iom_put( "EXPCAL" , zw3d ) ! Export of calcite in the water column
+ ENDIF
+ !
+ CALL trc_sink( kt, Kbb, Kmm, wsbio3, zsinking, jpsfe, rfact2 )
+ IF( l_diag ) THEN
+ zw3d(A2D(0),1:jpkm1) = zsinking(A2D(0),1:jpkm1) * xfact * tmask(A2D(0),1:jpkm1)
+ ENDIF
+ CALL trc_sink( kt, Kbb, Kmm, wsbio4, zsinking, jpbfe, rfact2 )
+ IF( l_diag ) THEN
+ zw3d(A2D(0),1:jpkm1) = zw3d(A2D(0),1:jpkm1) + zsinking(A2D(0),1:jpkm1) * xfact * tmask(A2D(0),1:jpkm1)
+ CALL iom_put( "EPFE100", zw3d(:,:,ik100) ) ! Export of iron at 100m
+ CALL iom_put( "EXPFE" , zw3d ) ! Export of iron in the water column
+ ENDIF
+ !
! PISCES-QUOTA part
IF( ln_p5z ) THEN
- sinkingn (:,:,:) = 0.e0
- sinking2n(:,:,:) = 0.e0
- sinkingp (:,:,:) = 0.e0
- sinking2p(:,:,:) = 0.e0
-
- ! Compute the sedimentation term using trc_sink for all the sinking particles
- ! ---------------------------------------------------------------------------
- CALL trc_sink( kt, Kbb, Kmm, wsbio3, sinkingn , jppon, rfact2 )
- CALL trc_sink( kt, Kbb, Kmm, wsbio3, sinkingp , jppop, rfact2 )
- CALL trc_sink( kt, Kbb, Kmm, wsbio4, sinking2n, jpgon, rfact2 )
- CALL trc_sink( kt, Kbb, Kmm, wsbio4, sinking2p, jpgop, rfact2 )
- ENDIF
-
- ! Total carbon export per year
- IF( iom_use( "tcexp" ) .OR. ( ln_check_mass .AND. kt == nitend .AND. knt == nrdttrc ) ) &
- & t_oce_co2_exp = glob_sum( 'p4zsink', ( sinking(:,:,ik100) + sinking2(:,:,ik100) ) * e1e2t(:,:) * tmask(:,:,1) )
- !
- IF( lk_iomput .AND. knt == nrdttrc ) THEN
- zfact = 1.e+3 * rfact2r ! conversion from mol/l/kt to mol/m3/s
- !
- CALL iom_put( "EPC100" , ( sinking(:,:,ik100) + sinking2(:,:,ik100) ) * zfact * tmask(:,:,1) ) ! Export of carbon at 100m
- CALL iom_put( "EPFE100" , ( sinkfer(:,:,ik100) + sinkfer2(:,:,ik100) ) * zfact * tmask(:,:,1) ) ! Export of iron at 100m
- CALL iom_put( "EPCAL100", sinkcal(:,:,ik100) * zfact * tmask(:,:,1) ) ! Export of calcite at 100m
- CALL iom_put( "EPSI100" , sinksil(:,:,ik100) * zfact * tmask(:,:,1) ) ! Export of bigenic silica at 100m
- CALL iom_put( "EXPC" , ( sinking(:,:,:) + sinking2(:,:,:) ) * zfact * tmask(:,:,:) ) ! Export of carbon in the water column
- CALL iom_put( "EXPFE" , ( sinkfer(:,:,:) + sinkfer2(:,:,:) ) * zfact * tmask(:,:,:) ) ! Export of iron
- CALL iom_put( "EXPCAL" , sinkcal(:,:,:) * zfact * tmask(:,:,:) ) ! Export of calcite
- CALL iom_put( "EXPSI" , sinksil(:,:,:) * zfact * tmask(:,:,:) ) ! Export of bigenic silica
- CALL iom_put( "tcexp" , t_oce_co2_exp * zfact ) ! molC/s
- !
+ !
+ CALL trc_sink( kt, Kbb, Kmm, wsbio3, zsinking, jppon, rfact2 )
+ DO_2D( 0, 0, 0, 0 )
+ sinkponb(ji,jj) = zsinking(ji,jj,mbkt(ji,jj)+1)
+ END_2D
+ !
+ CALL trc_sink( kt, Kbb, Kmm, wsbio4, zsinking, jpgon, rfact2 )
+ DO_2D( 0, 0, 0, 0 )
+ sinkponb(ji,jj) = sinkponb(ji,jj) + zsinking(ji,jj,mbkt(ji,jj)+1)
+ END_2D
+ !
+ CALL trc_sink( kt, Kbb, Kmm, wsbio3, zsinking, jppop, rfact2 )
+ DO_2D( 0, 0, 0, 0 )
+ sinkpopb(ji,jj) = zsinking(ji,jj,mbkt(ji,jj)+1)
+ END_2D
+ !
+ CALL trc_sink( kt, Kbb, Kmm, wsbio4, zsinking, jpgop, rfact2 )
+ DO_2D( 0, 0, 0, 0 )
+ sinkpopb(ji,jj) = sinkpopb(ji,jj) + zsinking(ji,jj,mbkt(ji,jj)+1)
+ END_2D
ENDIF
!
+ IF( l_diag ) DEALLOCATE( zw3d )
+ !
IF(sn_cfctl%l_prttrc) THEN ! print mean trends (used for debugging)
WRITE(charout, FMT="('sink')")
CALL prt_ctl_info( charout, cdcomp = 'top' )
- CALL prt_ctl(tab4d_1=tr(:,:,:,:,Krhs), mask1=tmask, clinfo=ctrcnm)
+ CALL prt_ctl(tab4d_1=tr(:,:,:,:,Kbb), mask1=tmask, clinfo=ctrcnm)
ENDIF
!
IF( ln_timing ) CALL timing_stop('p4z_sink')
@@ -179,8 +221,6 @@ CONTAINS
IF (lwp) WRITE(numout,*) ' Level corresponding to 100m depth ', ik100 + 1
IF (lwp) WRITE(numout,*)
!
- t_oce_co2_exp = 0._wp
- !
END SUBROUTINE p4z_sink_init
INTEGER FUNCTION p4z_sink_alloc()
@@ -192,13 +232,10 @@ CONTAINS
!
ierr(:) = 0
!
- ALLOCATE( sinking(jpi,jpj,jpk) , sinking2(jpi,jpj,jpk) , &
- & sinkcal(jpi,jpj,jpk) , sinksil (jpi,jpj,jpk) , &
- & sinkfer2(jpi,jpj,jpk) , &
- & sinkfer(jpi,jpj,jpk) , STAT=ierr(1) )
- !
- IF( ln_p5z ) ALLOCATE( sinkingn(jpi,jpj,jpk), sinking2n(jpi,jpj,jpk) , &
- & sinkingp(jpi,jpj,jpk), sinking2p(jpi,jpj,jpk) , STAT=ierr(2) )
+ ALLOCATE( sinkpocb(A2D(0)), sinkcalb(A2D(0)), sinksilb(A2D(0)), STAT=ierr(1) )
+ !
+ IF( ln_p5z ) ALLOCATE( sinkponb(A2D(0)), sinkpopb(A2D(0)), STAT=ierr(2) )
+
!
p4z_sink_alloc = MAXVAL( ierr )
IF( p4z_sink_alloc /= 0 ) CALL ctl_stop( 'STOP', 'p4z_sink_alloc : failed to allocate arrays.' )
diff --git a/src/TOP/PISCES/P4Z/p4zsms.F90 b/src/TOP/PISCES/P4Z/p4zsms.F90
index 32a3c6fbac65ca672e5782a096564e4f45633bd3..000eacc408197a5d3c3a17907d66e29a16a14380 100644
--- a/src/TOP/PISCES/P4Z/p4zsms.F90
+++ b/src/TOP/PISCES/P4Z/p4zsms.F90
@@ -116,8 +116,6 @@ CONTAINS
CALL p4z_che( Kbb, Kmm ) ! computation of chemical constants
CALL p4z_int( kt, Kbb, Kmm ) ! computation of various rates for biogeochemistry
!
- IF( nn_hls > 1 ) CALL lbc_lnk( 'p4zsms', hmld(:,:), 'T', 1._wp ) ! hmld defined only on first halo in zdfmxl
- !
DO jnt = 1, nrdttrc ! Potential time splitting if requested
!
CALL p4z_bio( kt, jnt, Kbb, Kmm, Krhs ) ! Biology
@@ -134,7 +132,7 @@ CONTAINS
! ------------------------------------------------------------------
xnegtr(:,:,:) = 1.e0
DO jn = jp_pcs0, jp_pcs1
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpk)
+ DO_3D( 0, 0, 0, 0, 1, jpk)
IF( ( tr(ji,jj,jk,jn,Kbb) + tr(ji,jj,jk,jn,Krhs) ) < 0.e0 ) THEN
ztra = ABS( tr(ji,jj,jk,jn,Kbb) ) / ( ABS( tr(ji,jj,jk,jn,Krhs) ) + rtrn )
xnegtr(ji,jj,jk) = MIN( xnegtr(ji,jj,jk), ztra )
@@ -151,45 +149,56 @@ CONTAINS
IF( iom_use( 'INTdtAlk' ) .OR. iom_use( 'INTdtDIC' ) .OR. iom_use( 'INTdtFer' ) .OR. &
& iom_use( 'INTdtDIN' ) .OR. iom_use( 'INTdtDIP' ) .OR. iom_use( 'INTdtSil' ) ) THEN
!
- ALLOCATE( zw3d(jpi,jpj,jpk), zw2d(jpi,jpj) )
- zw3d(:,:,jpk) = 0.
- DO jk = 1, jpkm1
- zw3d(:,:,jk) = xnegtr(:,:,jk) * xfact * e3t(:,:,jk,Kmm) * tmask(:,:,jk)
- ENDDO
+ ALLOCATE( zw3d(A2D(0),jpk), zw2d(A2D(0)) )
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
+ zw3d(ji,jj,jk) = xnegtr(ji,jj,jk) * xfact * e3t(ji,jj,jk,Kmm) * tmask(ji,jj,jk)
+ END_3D
!
zw2d(:,:) = 0.
DO jk = 1, jpkm1
- zw2d(:,:) = zw2d(:,:) + zw3d(:,:,jk) * tr(:,:,jk,jptal,Krhs)
+ DO_2D( 0, 0, 0, 0 )
+ zw2d(ji,jj) = zw2d(ji,jj) + zw3d(ji,jj,jk) * tr(ji,jj,jk,jptal,Krhs)
+ END_2D
ENDDO
CALL iom_put( 'INTdtAlk', zw2d )
!
zw2d(:,:) = 0.
DO jk = 1, jpkm1
- zw2d(:,:) = zw2d(:,:) + zw3d(:,:,jk) * tr(:,:,jk,jpdic,Krhs)
+ DO_2D( 0, 0, 0, 0 )
+ zw2d(ji,jj) = zw2d(ji,jj) + zw3d(ji,jj,jk) * tr(ji,jj,jk,jpdic,Krhs)
+ END_2D
ENDDO
CALL iom_put( 'INTdtDIC', zw2d )
!
zw2d(:,:) = 0.
DO jk = 1, jpkm1
- zw2d(:,:) = zw2d(:,:) + zw3d(:,:,jk) * rno3 * ( tr(:,:,jk,jpno3,Krhs) + tr(:,:,jk,jpnh4,Krhs) )
+ DO_2D( 0, 0, 0, 0 )
+ zw2d(ji,jj) = zw2d(ji,jj) + zw3d(ji,jj,jk) * rno3 * ( tr(ji,jj,jk,jpno3,Krhs) + tr(ji,jj,jk,jpnh4,Krhs) )
+ END_2D
ENDDO
CALL iom_put( 'INTdtDIN', zw2d )
!
zw2d(:,:) = 0.
DO jk = 1, jpkm1
- zw2d(:,:) = zw2d(:,:) + zw3d(:,:,jk) * po4r * tr(:,:,jk,jppo4,Krhs)
+ DO_2D( 0, 0, 0, 0 )
+ zw2d(ji,jj) = zw2d(ji,jj) + zw3d(ji,jj,jk) * po4r * tr(ji,jj,jk,jppo4,Krhs)
+ END_2D
ENDDO
CALL iom_put( 'INTdtDIP', zw2d )
!
zw2d(:,:) = 0.
DO jk = 1, jpkm1
- zw2d(:,:) = zw2d(:,:) + zw3d(:,:,jk) * tr(:,:,jk,jpfer,Krhs)
+ DO_2D( 0, 0, 0, 0 )
+ zw2d(ji,jj) = zw2d(ji,jj) + zw3d(ji,jj,jk) * tr(ji,jj,jk,jpfer,Krhs)
+ END_2D
ENDDO
CALL iom_put( 'INTdtFer', zw2d )
!
zw2d(:,:) = 0.
DO jk = 1, jpkm1
- zw2d(:,:) = zw2d(:,:) + zw3d(:,:,jk) * tr(:,:,jk,jpsil,Krhs)
+ DO_2D( 0, 0, 0, 0 )
+ zw2d(ji,jj) = zw2d(ji,jj) + zw3d(ji,jj,jk) * tr(ji,jj,jk,jpsil,Krhs)
+ END_2D
ENDDO
CALL iom_put( 'INTdtSil', zw2d )
!
@@ -516,8 +525,9 @@ CONTAINS
INTEGER, INTENT( in ) :: Kmm ! time level indices
REAL(wp) :: zrdenittot, zsdenittot, znitrpottot
CHARACTER(LEN=100) :: cltxt
- INTEGER :: jk
- REAL(wp), DIMENSION(jpi,jpj,jpk) :: zwork
+ INTEGER :: ji, jj, jk
+ REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zw3d
+ REAL(wp), ALLOCATABLE, DIMENSION(:,: ) :: zw2d
!!----------------------------------------------------------------------
!
IF( kt == nittrc000 ) THEN
@@ -536,82 +546,113 @@ CONTAINS
! Compute the budget of NO3
IF( iom_use( "pno3tot" ) .OR. ( ln_check_mass .AND. kt == nitend ) ) THEN
+ ALLOCATE( zw3d(A2D(0),jpk) ) ; zw3d(A2D(0),jpk) = 0._wp
IF( ln_p4z ) THEN
- zwork(:,:,:) = tr(:,:,:,jpno3,Kmm) + tr(:,:,:,jpnh4,Kmm) &
- & + tr(:,:,:,jpphy,Kmm) + tr(:,:,:,jpdia,Kmm) &
- & + tr(:,:,:,jppoc,Kmm) + tr(:,:,:,jpgoc,Kmm) + tr(:,:,:,jpdoc,Kmm) &
- & + tr(:,:,:,jpzoo,Kmm) + tr(:,:,:,jpmes,Kmm)
+ DO_3D( 0, 0, 0, 0, 1, jpk)
+ zw3d(ji,jj,jk) = ( tr(ji,jj,jk,jpno3,Kmm) + tr(ji,jj,jk,jpnh4,Kmm) &
+ & + tr(ji,jj,jk,jpphy,Kmm) + tr(ji,jj,jk,jpdia,Kmm) &
+ & + tr(ji,jj,jk,jppoc,Kmm) + tr(ji,jj,jk,jpgoc,Kmm) + tr(ji,jj,jk,jpdoc,Kmm) &
+ & + tr(ji,jj,jk,jpzoo,Kmm) + tr(ji,jj,jk,jpmes,Kmm) ) * cvol(ji,jj,jk)
+ END_3D
ELSE
- zwork(:,:,:) = tr(:,:,:,jpno3,Kmm) + tr(:,:,:,jpnh4,Kmm) + tr(:,:,:,jpnph,Kmm) &
- & + tr(:,:,:,jpndi,Kmm) + tr(:,:,:,jpnpi,Kmm) &
- & + tr(:,:,:,jppon,Kmm) + tr(:,:,:,jpgon,Kmm) + tr(:,:,:,jpdon,Kmm) &
- & + ( tr(:,:,:,jpzoo,Kmm) + tr(:,:,:,jpmes,Kmm) ) * no3rat3
+ DO_3D( 0, 0, 0, 0, 1, jpk)
+ zw3d(ji,jj,jk) = ( tr(ji,jj,jk,jpno3,Kmm) + tr(ji,jj,jk,jpnh4,Kmm) + tr(ji,jj,jk,jpnph,Kmm) &
+ & + tr(ji,jj,jk,jpndi,Kmm) + tr(ji,jj,jk,jpnpi,Kmm) &
+ & + tr(ji,jj,jk,jppon,Kmm) + tr(ji,jj,jk,jpgon,Kmm) + tr(ji,jj,jk,jpdon,Kmm) &
+ & + ( tr(ji,jj,jk,jpzoo,Kmm) + tr(ji,jj,jk,jpmes,Kmm) ) * no3rat3 ) * cvol(ji,jj,jk)
+ END_3D
ENDIF
!
- no3budget = glob_sum( 'p4zsms', zwork(:,:,:) * cvol(:,:,:) )
+ no3budget = glob_sum( 'p4zsms', zw3d(:,:,:) )
no3budget = no3budget / areatot
CALL iom_put( "pno3tot", no3budget )
+ DEALLOCATE( zw3d )
ENDIF
!
! Compute the budget of PO4
IF( iom_use( "ppo4tot" ) .OR. ( ln_check_mass .AND. kt == nitend ) ) THEN
+ ALLOCATE( zw3d(A2D(0),jpk) ) ; zw3d(A2D(0),jpk) = 0._wp
IF( ln_p4z ) THEN
- zwork(:,:,:) = tr(:,:,:,jppo4,Kmm) &
- & + tr(:,:,:,jpphy,Kmm) + tr(:,:,:,jpdia,Kmm) &
- & + tr(:,:,:,jppoc,Kmm) + tr(:,:,:,jpgoc,Kmm) + tr(:,:,:,jpdoc,Kmm) &
- & + tr(:,:,:,jpzoo,Kmm) + tr(:,:,:,jpmes,Kmm)
- ELSE
- zwork(:,:,:) = tr(:,:,:,jppo4,Kmm) + tr(:,:,:,jppph,Kmm) &
- & + tr(:,:,:,jppdi,Kmm) + tr(:,:,:,jpppi,Kmm) &
- & + tr(:,:,:,jppop,Kmm) + tr(:,:,:,jpgop,Kmm) + tr(:,:,:,jpdop,Kmm) &
- & + ( tr(:,:,:,jpzoo,Kmm) + tr(:,:,:,jpmes,Kmm) ) * po4rat3
+ DO_3D( 0, 0, 0, 0, 1, jpk)
+ zw3d(ji,jj,jk) = ( tr(ji,jj,jk,jppo4,Kmm) &
+ & + tr(ji,jj,jk,jpphy,Kmm) + tr(ji,jj,jk,jpdia,Kmm) &
+ & + tr(ji,jj,jk,jppoc,Kmm) + tr(ji,jj,jk,jpgoc,Kmm) + tr(ji,jj,jk,jpdoc,Kmm) &
+ & + tr(ji,jj,jk,jpzoo,Kmm) + tr(ji,jj,jk,jpmes,Kmm) ) * cvol(ji,jj,jk)
+ END_3D
+ ELSE
+ DO_3D( 0, 0, 0, 0, 1, jpk)
+ zw3d(ji,jj,jk) = ( tr(ji,jj,jk,jppo4,Kmm) + tr(ji,jj,jk,jppph,Kmm) &
+ & + tr(ji,jj,jk,jppdi,Kmm) + tr(ji,jj,jk,jpppi,Kmm) &
+ & + tr(ji,jj,jk,jppop,Kmm) + tr(ji,jj,jk,jpgop,Kmm) + tr(ji,jj,jk,jpdop,Kmm) &
+ & + ( tr(ji,jj,jk,jpzoo,Kmm) + tr(ji,jj,jk,jpmes,Kmm) ) * po4rat3 ) * cvol(ji,jj,jk)
+ END_3D
ENDIF
!
- po4budget = glob_sum( 'p4zsms', zwork(:,:,:) * cvol(:,:,:) )
+ po4budget = glob_sum( 'p4zsms', zw3d(:,:,:) )
po4budget = po4budget / areatot
CALL iom_put( "ppo4tot", po4budget )
+ DEALLOCATE( zw3d )
ENDIF
!
! Compute the budget of SiO3
IF( iom_use( "psiltot" ) .OR. ( ln_check_mass .AND. kt == nitend ) ) THEN
- zwork(:,:,:) = tr(:,:,:,jpsil,Kmm) + tr(:,:,:,jpgsi,Kmm) + tr(:,:,:,jpdsi,Kmm)
+ ALLOCATE( zw3d(A2D(0),jpk) ) ; zw3d(A2D(0),jpk) = 0._wp
+ DO_3D( 0, 0, 0, 0, 1, jpk)
+ zw3d(ji,jj,jk) = ( tr(ji,jj,jk,jpsil,Kmm) + tr(ji,jj,jk,jpgsi,Kmm) + tr(ji,jj,jk,jpdsi,Kmm) ) * cvol(ji,jj,jk)
+ END_3D
!
- silbudget = glob_sum( 'p4zsms', zwork(:,:,:) * cvol(:,:,:) )
+ silbudget = glob_sum( 'p4zsms', zw3d(:,:,:) )
silbudget = silbudget / areatot
CALL iom_put( "psiltot", silbudget )
+ DEALLOCATE( zw3d )
ENDIF
!
IF( iom_use( "palktot" ) .OR. ( ln_check_mass .AND. kt == nitend ) ) THEN
- zwork(:,:,:) = tr(:,:,:,jpno3,Kmm) * rno3 + tr(:,:,:,jptal,Kmm) + tr(:,:,:,jpcal,Kmm) * 2.
+ ALLOCATE( zw3d(A2D(0),jpk) ) ; zw3d(A2D(0),jpk) = 0._wp
+ DO_3D( 0, 0, 0, 0, 1, jpk)
+ zw3d(ji,jj,jk) = ( tr(ji,jj,jk,jpno3,Kmm) * rno3 + tr(ji,jj,jk,jptal,Kmm) + tr(ji,jj,jk,jpcal,Kmm) * 2. ) * cvol(ji,jj,jk)
+ END_3D
!
- alkbudget = glob_sum( 'p4zsms', zwork(:,:,:) * cvol(:,:,:) ) !
+ alkbudget = glob_sum( 'p4zsms', zw3d(:,:,:) ) !
alkbudget = alkbudget / areatot
CALL iom_put( "palktot", alkbudget )
+ DEALLOCATE( zw3d )
ENDIF
!
! Compute the budget of Iron
IF( iom_use( "pfertot" ) .OR. ( ln_check_mass .AND. kt == nitend ) ) THEN
- zwork(:,:,:) = tr(:,:,:,jpfer,Kmm) + tr(:,:,:,jpnfe,Kmm) + tr(:,:,:,jpdfe,Kmm) &
- & + tr(:,:,:,jpbfe,Kmm) + tr(:,:,:,jpsfe,Kmm) &
- & + ( tr(:,:,:,jpzoo,Kmm) * feratz + tr(:,:,:,jpmes,Kmm) ) * feratm
+ ALLOCATE( zw3d(A2D(0),jpk) ) ; zw3d(A2D(0),jpk) = 0._wp
+ DO_3D( 0, 0, 0, 0, 1, jpk)
+ zw3d(ji,jj,jk) = ( tr(ji,jj,jk,jpfer,Kmm) + tr(ji,jj,jk,jpnfe,Kmm) + tr(ji,jj,jk,jpdfe,Kmm) &
+ & + tr(ji,jj,jk,jpbfe,Kmm) + tr(ji,jj,jk,jpsfe,Kmm) &
+ & + tr(ji,jj,jk,jpzoo,Kmm) * feratz + tr(ji,jj,jk,jpmes,Kmm) * feratm ) * cvol(ji,jj,jk)
+ END_3D
!
- ferbudget = glob_sum( 'p4zsms', zwork(:,:,:) * cvol(:,:,:) )
+ ferbudget = glob_sum( 'p4zsms', zw3d(:,:,:) )
ferbudget = ferbudget / areatot
CALL iom_put( "pfertot", ferbudget )
+ DEALLOCATE( zw3d )
ENDIF
!
! Global budget of N SMS : denitrification in the water column and in the sediment
! nitrogen fixation by the diazotrophs
! --------------------------------------------------------------------------------
IF( iom_use( "tnfix" ) .OR. ( ln_check_mass .AND. kt == nitend ) ) THEN
- znitrpottot = glob_sum ( 'p4zsms', nitrpot(:,:,:) * nitrfix * cvol(:,:,:) )
+ ALLOCATE( zw3d(A2D(0),jpk) ) ; zw3d(:,:,jpk) = 0._wp
+ zw3d(:,:,1:jpkm1) = nitrpot(A2D(0),1:jpkm1) * nitrfix * cvol(A2D(0),1:jpkm1)
+ znitrpottot = glob_sum ( 'p4zsms', zw3d)
CALL iom_put( "tnfix" , znitrpottot * xfact3 ) ! Global nitrogen fixation molC/l to molN/m3
+ DEALLOCATE( zw3d )
ENDIF
!
IF( iom_use( "tdenit" ) .OR. ( ln_check_mass .AND. kt == nitend ) ) THEN
- zrdenittot = glob_sum ( 'p4zsms', denitr(:,:,:) * rdenit * xnegtr(:,:,:) * cvol(:,:,:) )
- zsdenittot = glob_sum ( 'p4zsms', sdenit(:,:) * e1e2t(:,:) * tmask(:,:,1) )
+ ALLOCATE( zw3d(A2D(0),jpk), zw2d(A2D(0)) ) ; zw3d(:,:,jpk) = 0._wp
+ zw3d(:,:,1:jpkm1) = denitr(A2D(0),1:jpkm1) * rdenit * xnegtr(A2D(0),1:jpkm1) * cvol(A2D(0),1:jpkm1)
+ zw2d(:,:) = sdenit(A2D(0)) * e1e2t(A2D(0)) * tmask(A2D(0),1)
+ zrdenittot = glob_sum ( 'p4zsms', zw3d )
+ zsdenittot = glob_sum ( 'p4zsms', Zw2d )
CALL iom_put( "tdenit" , ( zrdenittot + zsdenittot ) * xfact3 ) ! Total denitrification molC/l to molN/m3
+ DEALLOCATE( zw3d, zw2d )
ENDIF
!
IF( ln_check_mass .AND. kt == nitend ) THEN ! Compute the budget of NO3, ALK, Si, Fer
diff --git a/src/TOP/PISCES/P4Z/p5zlim.F90 b/src/TOP/PISCES/P4Z/p5zlim.F90
index 91e94183a3e6f79b83a9db8ac4c3129fc5be99be..dfaa8c68402e642de8d293c07391ecc60b4f3f41 100644
--- a/src/TOP/PISCES/P4Z/p5zlim.F90
+++ b/src/TOP/PISCES/P4Z/p5zlim.F90
@@ -94,6 +94,9 @@ MODULE p5zlim
REAL(wp) :: xcoef1 = 0.00167 / 55.85
REAL(wp) :: xcoef2 = 1.21E-5 * 14. / 55.85 / 7.625 * 0.5 * 1.5
REAL(wp) :: xcoef3 = 1.15E-4 * 14. / 55.85 / 7.625 * 0.5
+
+ LOGICAL :: l_dia_nut_lim, l_dia_iron_lim, l_dia_fracal
+ LOGICAL :: l_dia_size_lim, l_dia_size_pro
!! * Substitutions
# include "do_loop_substitute.h90"
!!----------------------------------------------------------------------
@@ -136,15 +139,23 @@ CONTAINS
REAL(wp) :: zfvn, zfvp, zfvf, zsizen, zsizep, zsized, znanochl, zpicochl, zdiatchl
REAL(wp) :: zqfemn, zqfemp, zqfemd, zbactno3, zbactnh4, zbiron
REAL(wp) :: znutlimtot, zlimno3, zlimnh4, zlim1f, zsizetmp
- REAL(wp), DIMENSION(jpi,jpj,jpk) :: zrassn, zrassp, zrassd
+ REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zw3d
!!---------------------------------------------------------------------
!
IF( ln_timing ) CALL timing_start('p5z_lim')
+
+ IF( kt == nittrc000 ) THEN
+ l_dia_nut_lim = iom_use( "LNnut" ) .OR. iom_use( "LDnut" ) .OR. iom_use( "LPnut" )
+ l_dia_iron_lim = iom_use( "LNFe" ) .OR. iom_use( "LDFe" ) .OR. iom_use( "LPFe" )
+ l_dia_size_lim = iom_use( "SIZEN" ) .OR. iom_use( "SIZED" ) .OR. iom_use( "SIZEP" )
+ l_dia_size_pro = iom_use( "RASSN" ) .OR. iom_use( "RASSP" ) .OR. iom_use( "RASSP" )
+ l_dia_fracal = iom_use( "xfracal" )
+ ENDIF
!
zratchl = 6.0
sizena(:,:,:) = 0.0 ; sizepa(:,:,:) = 0.0 ; sizeda(:,:,:) = 0.0
!
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1)
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
! Computation of the Chl/C ratio of each phytoplankton group
! -------------------------------------------------------
z1_trnphy = 1. / ( tr(ji,jj,jk,jpphy,Kbb) + rtrn )
@@ -407,7 +418,7 @@ CONTAINS
! nutrient uptake pool and assembly machinery. DNA is assumed to represent 1% of the dry mass of
! phytoplankton (see Daines et al., 2013).
! --------------------------------------------------------------------------------------------------
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1)
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
! Size estimation of nanophytoplankton based on total biomass
! Assumes that larger biomass implies addition of larger cells
! ------------------------------------------------------------
@@ -419,7 +430,6 @@ CONTAINS
! Computed from Inomura et al. (2020) using Pavlova Lutheri
zrpho = 11.55 * tr(ji,jj,jk,jpnch,Kbb) / ( tr(ji,jj,jk,jpphy,Kbb) * 12. + rtrn )
zrass = MAX(0.62/4., ( 1. - zrpho - zfuptk ) * xlimnpn(ji,jj,jk) )
- zrassn(ji,jj,jk) = zrass
xqpnmin(ji,jj,jk) = ( 0.0 + 0.0078 + 0.62/4. * 0.0783 ) * 16.
xqpnmax(ji,jj,jk) = ( zrpho * 0.0089 + zrass * 0.0783 ) * 16.
xqpnmax(ji,jj,jk) = xqpnmax(ji,jj,jk) + (0.033 + 0.0078 ) * 16.
@@ -437,7 +447,6 @@ CONTAINS
! Computed from Inomura et al. (2020) using a synechococcus
zrpho = 13.4 * tr(ji,jj,jk,jppch,Kbb) / ( tr(ji,jj,jk,jppic,Kbb) * 12. + rtrn )
zrass = MAX(0.4/4., ( 1. - zrpho - zfuptk ) * xlimnpp(ji,jj,jk) )
- zrassp(ji,jj,jk) = zrass
xqppmin(ji,jj,jk) = ( (0.0 + 0.0078 ) + 0.4/4. * 0.0517 ) * 16.
xqppmax(ji,jj,jk) = ( zrpho * 0.0076 + zrass * 0.0517 ) * 16.
xqppmax(ji,jj,jk) = xqppmax(ji,jj,jk) + (0.033 + 0.0078 ) * 16
@@ -454,7 +463,6 @@ CONTAINS
! Computed from Inomura et al. (2020) using a synechococcus
zrpho = 8.08 * tr(ji,jj,jk,jpdch,Kbb) / ( tr(ji,jj,jk,jpndi,Kbb) * 12. + rtrn )
zrass = MAX(0.66/4., ( 1. - zrpho - zfuptk ) * xlimnpd(ji,jj,jk) )
- zrassd(ji,jj,jk)=zrass
xqpdmin(ji,jj,jk) = ( ( 0.0 + 0.0078 ) + 0.66/4. * 0.0783 ) * 16.
xqpdmax(ji,jj,jk) = ( zrpho * 0.0135 + zrass * 0.0783 ) * 16.
xqpdmax(ji,jj,jk) = xqpdmax(ji,jj,jk) + ( 0.0078 + 0.033 ) * 16.
@@ -465,7 +473,7 @@ CONTAINS
! This is a purely adhoc formulation described in Aumont et al. (2015)
! This fraction depends on nutrient limitation, light, temperature
! --------------------------------------------------------------------
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1)
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
zlim1 = tr(ji,jj,jk,jpnh4,Kbb) / ( tr(ji,jj,jk,jpnh4,Kbb) + concnnh4 ) + tr(ji,jj,jk,jpno3,Kbb) &
& / ( tr(ji,jj,jk,jpno3,Kbb) + concnno3 ) * ( 1.0 - tr(ji,jj,jk,jpnh4,Kbb) &
& / ( tr(ji,jj,jk,jpnh4,Kbb) + concnnh4 ) )
@@ -482,7 +490,7 @@ CONTAINS
xfracal(ji,jj,jk) = MAX( 0.02, MIN( 0.8 , xfracal(ji,jj,jk) ) )
END_3D
!
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1)
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
! denitrification factor computed from O2 levels
nitrfac(ji,jj,jk) = MAX( 0.e0, 0.4 * ( 6.e-6 - tr(ji,jj,jk,jpoxy,Kbb) ) &
& / ( oxymin + tr(ji,jj,jk,jpoxy,Kbb) ) )
@@ -490,19 +498,70 @@ CONTAINS
END_3D
!
IF( lk_iomput .AND. knt == nrdttrc ) THEN ! save output diagnostics
- CALL iom_put( "xfracal", xfracal(:,:,:) * tmask(:,:,:) ) ! euphotic layer deptht
- CALL iom_put( "LNnut" , xlimphy(:,:,:) * tmask(:,:,:) ) ! Nutrient limitation term
- CALL iom_put( "LPnut" , xlimpic(:,:,:) * tmask(:,:,:) ) ! Nutrient limitation term
- CALL iom_put( "LDnut" , xlimdia(:,:,:) * tmask(:,:,:) ) ! Nutrient limitation term
- CALL iom_put( "LNFe" , xlimnfe(:,:,:) * tmask(:,:,:) ) ! Iron limitation term
- CALL iom_put( "LPFe" , xlimpfe(:,:,:) * tmask(:,:,:) ) ! Iron limitation term
- CALL iom_put( "LDFe" , xlimdfe(:,:,:) * tmask(:,:,:) ) ! Iron limitation term
- CALL iom_put( "SIZEN" , sizen (:,:,:) * tmask(:,:,:) ) ! Iron limitation term
- CALL iom_put( "SIZEP" , sizep (:,:,:) * tmask(:,:,:) ) ! Iron limitation term
- CALL iom_put( "SIZED" , sized (:,:,:) * tmask(:,:,:) ) ! Iron limitation term
- CALL iom_put( "RASSN" , zrassn (:,:,:) * tmask(:,:,:) ) ! Iron limitation term
- CALL iom_put( "RASSP" , zrassp (:,:,:) * tmask(:,:,:) ) ! Iron limitation term
- CALL iom_put( "RASSD" , zrassd (:,:,:) * tmask(:,:,:) ) ! Iron limitation term
+ !
+ IF( l_dia_fracal ) THEN ! fraction of calcifiers
+ ALLOCATE( zw3d(A2D(0),jpk) ) ; zw3d(A2D(0),jpk) = 0._wp
+ zw3d(A2D(0),1:jpkm1) = xfracal(A2D(0),1:jpkm1) * tmask(A2D(0),1:jpkm1)
+ CALL iom_put( "xfracal", zw3d)
+ DEALLOCATE( zw3d )
+ ENDIF
+ !
+ IF( l_dia_nut_lim ) THEN ! Nutrient limitation term
+ ALLOCATE( zw3d(A2D(0),jpk) ) ; zw3d(A2D(0),jpk) = 0._wp
+ zw3d(A2D(0),1:jpkm1) = xlimphy(A2D(0),1:jpkm1) * tmask(A2D(0),1:jpkm1)
+ CALL iom_put( "LNnut", zw3d)
+ zw3d(A2D(0),1:jpkm1) = xlimdia(A2D(0),1:jpkm1) * tmask(A2D(0),1:jpkm1)
+ CALL iom_put( "LDnut", zw3d)
+ zw3d(A2D(0),1:jpkm1) = xlimpic(A2D(0),1:jpkm1) * tmask(A2D(0),1:jpkm1)
+ CALL iom_put( "LPnut", zw3d)
+ DEALLOCATE( zw3d )
+ ENDIF
+ !
+ IF( l_dia_iron_lim ) THEN ! Iron limitation term
+ ALLOCATE( zw3d(A2D(0),jpk) ) ; zw3d(A2D(0),jpk) = 0._wp
+ zw3d(A2D(0),1:jpkm1) = xlimnfe(A2D(0),1:jpkm1) * tmask(A2D(0),1:jpkm1)
+ CALL iom_put( "LNFe", zw3d)
+ zw3d(A2D(0),1:jpkm1) = xlimdfe(A2D(0),1:jpkm1) * tmask(A2D(0),1:jpkm1)
+ CALL iom_put( "LDFe", zw3d)
+ zw3d(A2D(0),1:jpkm1) = xlimpfe(A2D(0),1:jpkm1) * tmask(A2D(0),1:jpkm1)
+ CALL iom_put( "LPFe", zw3d)
+ DEALLOCATE( zw3d )
+ ENDIF
+ !
+ IF( l_dia_size_lim ) THEN ! Size limitation term
+ ALLOCATE( zw3d(A2D(0),jpk) ) ; zw3d(A2D(0),jpk) = 0._wp
+ zw3d(A2D(0),1:jpkm1) = sizen(A2D(0),1:jpkm1) * tmask(A2D(0),1:jpkm1)
+ CALL iom_put( "SIZEN", zw3d)
+ zw3d(A2D(0),1:jpkm1) = sized(A2D(0),1:jpkm1) * tmask(A2D(0),1:jpkm1)
+ CALL iom_put( "SIZED", zw3d)
+ zw3d(A2D(0),1:jpkm1) = sizep(A2D(0),1:jpkm1) * tmask(A2D(0),1:jpkm1)
+ CALL iom_put( "SIZEP", zw3d)
+ DEALLOCATE( zw3d )
+ ENDIF
+ !
+ IF( l_dia_size_pro ) THEN ! Size of the protein machinery
+ ALLOCATE( zw3d(A2D(0),jpk) ) ; zw3d(A2D(0),jpk) = 0._wp
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
+ zfuptk = 0.2 + 0.12 / ( 3.0 * sizen(ji,jj,jk) + rtrn )
+ zrpho = 11.55 * tr(ji,jj,jk,jpnch,Kbb) / ( tr(ji,jj,jk,jpphy,Kbb) * 12. + rtrn )
+ zw3d(ji,jj,jk) = MAX(0.62/4., ( 1. - zrpho - zfuptk ) * xlimnpn(ji,jj,jk) ) * tmask(ji,jj,jk)
+ END_3D
+ CALL iom_put( "RASSN", zw3d)
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
+ zfuptk = 0.2 + 0.12 / ( 3.0 * sizep(ji,jj,jk) + rtrn )
+ zrpho = 11.55 * tr(ji,jj,jk,jppch,Kbb) / ( tr(ji,jj,jk,jppic,Kbb) * 12. + rtrn )
+ zw3d(ji,jj,jk) = MAX(0.62/4., ( 1. - zrpho - zfuptk ) * xlimnpp(ji,jj,jk) ) * tmask(ji,jj,jk)
+ END_3D
+ CALL iom_put( "RASSP", zw3d)
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
+ zfuptk = 0.2 + 0.12 / ( 3.0 * sized(ji,jj,jk) + rtrn )
+ zrpho = 11.55 * tr(ji,jj,jk,jpdch,Kbb) / ( tr(ji,jj,jk,jpndi,Kbb) * 12. + rtrn )
+ zw3d(ji,jj,jk) = MAX(0.62/4., ( 1. - zrpho - zfuptk ) * xlimnpd(ji,jj,jk) ) * tmask(ji,jj,jk)
+ END_3D
+ CALL iom_put( "RASSD", zw3d)
+ DEALLOCATE( zw3d )
+ ENDIF
+ !
ENDIF
!
IF( ln_timing ) CALL timing_stop('p5z_lim')
@@ -635,24 +694,24 @@ CONTAINS
ierr(:) = 0
!
!* Biological arrays for phytoplankton growth
- ALLOCATE( xpicono3(jpi,jpj,jpk), xpiconh4(jpi,jpj,jpk), &
- & xpicopo4(jpi,jpj,jpk), xpicodop(jpi,jpj,jpk), &
- & xnanodop(jpi,jpj,jpk), xdiatdop(jpi,jpj,jpk), &
- & xpicofer(jpi,jpj,jpk), xlimpfe (jpi,jpj,jpk), &
- & fvnuptk (jpi,jpj,jpk), fvduptk (jpi,jpj,jpk), &
- & xlimphys(jpi,jpj,jpk), xlimdias(jpi,jpj,jpk), &
- & xlimnpp (jpi,jpj,jpk), xlimnpn (jpi,jpj,jpk), &
- & xlimnpd (jpi,jpj,jpk), &
- & xlimpics(jpi,jpj,jpk), xqfuncfecp(jpi,jpj,jpk), &
- & fvpuptk (jpi,jpj,jpk), xlimpic (jpi,jpj,jpk), STAT=ierr(1) )
+ ALLOCATE( xpicono3(A2D(0),jpk), xpiconh4(A2D(0),jpk), &
+ & xpicopo4(A2D(0),jpk), xpicodop(A2D(0),jpk), &
+ & xnanodop(A2D(0),jpk), xdiatdop(A2D(0),jpk), &
+ & xpicofer(A2D(0),jpk), xlimpfe (A2D(0),jpk), &
+ & fvnuptk (A2D(0),jpk), fvduptk (A2D(0),jpk), &
+ & xlimphys(A2D(0),jpk), xlimdias(A2D(0),jpk), &
+ & xlimnpp (A2D(0),jpk), xlimnpn (A2D(0),jpk), &
+ & xlimnpd (A2D(0),jpk), &
+ & xlimpics(A2D(0),jpk), xqfuncfecp(A2D(0),jpk), &
+ & fvpuptk (A2D(0),jpk), xlimpic (A2D(0),jpk), STAT=ierr(1) )
!
!* Minimum/maximum quotas of phytoplankton
- ALLOCATE( xqnnmin (jpi,jpj,jpk), xqnnmax(jpi,jpj,jpk), &
- & xqpnmin (jpi,jpj,jpk), xqpnmax(jpi,jpj,jpk), &
- & xqnpmin (jpi,jpj,jpk), xqnpmax(jpi,jpj,jpk), &
- & xqppmin (jpi,jpj,jpk), xqppmax(jpi,jpj,jpk), &
- & xqndmin (jpi,jpj,jpk), xqndmax(jpi,jpj,jpk), &
- & xqpdmin (jpi,jpj,jpk), xqpdmax(jpi,jpj,jpk), STAT=ierr(2) )
+ ALLOCATE( xqnnmin (A2D(0),jpk), xqnnmax(A2D(0),jpk), &
+ & xqpnmin (A2D(0),jpk), xqpnmax(A2D(0),jpk), &
+ & xqnpmin (A2D(0),jpk), xqnpmax(A2D(0),jpk), &
+ & xqppmin (A2D(0),jpk), xqppmax(A2D(0),jpk), &
+ & xqndmin (A2D(0),jpk), xqndmax(A2D(0),jpk), &
+ & xqpdmin (A2D(0),jpk), xqpdmax(A2D(0),jpk), STAT=ierr(2) )
!
p5z_lim_alloc = MAXVAL( ierr )
!
diff --git a/src/TOP/PISCES/P4Z/p5zmeso.F90 b/src/TOP/PISCES/P4Z/p5zmeso.F90
index 24ca0260d8b5f0d17aebf1da57293231fb8eebf1..9e0bf8a6c21da3646a50fb312762cbc1a427db25 100644
--- a/src/TOP/PISCES/P4Z/p5zmeso.F90
+++ b/src/TOP/PISCES/P4Z/p5zmeso.F90
@@ -58,6 +58,7 @@ MODULE p5zmeso
REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: depmig !: DVM of mesozooplankton : migration depth
INTEGER , ALLOCATABLE, SAVE, DIMENSION(:,:) :: kmig !: Vertical indice of the the migration depth
+ LOGICAL :: l_dia_fezoo2, l_dia_graz2, l_dia_lprodz2
!! * Substitutions
# include "do_loop_substitute.h90"
# include "domzgr_substitute.h90"
@@ -103,21 +104,40 @@ CONTAINS
REAL(wp) :: zmigreltime, zrum, zcodel, zargu, zval, zmigthick
CHARACTER (len=25) :: charout
REAL(wp) :: zrfact2, zmetexcess, zsigma, zdiffdn
- REAL(wp), DIMENSION(jpi,jpj,jpk) :: zgrazing, zfezoo2
- REAL(wp), DIMENSION(jpi,jpj,jpk) :: zgrarem, zgraref, zgrapoc, zgrapof
- REAL(wp), DIMENSION(jpi,jpj,jpk) :: zgrarep, zgraren, zgrapon, zgrapop
- REAL(wp), DIMENSION(jpi,jpj,jpk) :: zgradoc, zgradon, zgradop
+ REAL(wp), DIMENSION(A2D(0),jpk) :: zgrarem, zgraref, zgrapoc, zgrapof
+ REAL(wp), DIMENSION(A2D(0),jpk) :: zgrarep, zgraren, zgrapon, zgrapop
+ REAL(wp), DIMENSION(A2D(0),jpk) :: zgradoc, zgradon, zgradop
REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zgramigrem, zgramigref, zgramigpoc, zgramigpof
REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zgramigrep, zgramigren, zgramigpop, zgramigpon
REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zgramigdoc, zgramigdop, zgramigdon
-
+ REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zgrazing2, zfezoo2, zzligprod2, zw3d
!!---------------------------------------------------------------------
!
IF( ln_timing ) CALL timing_start('p5z_meso')
!
+ IF( kt == nittrc000 ) THEN
+ l_dia_graz2 = iom_use( "GRAZ2" )
+ l_dia_fezoo2 = iom_use( "FEZOO2" )
+ l_dia_lprodz2 = ln_ligand .AND. iom_use( "LPRODZ2" )
+ ENDIF
+ IF( l_dia_lprodz2 ) THEN
+ ALLOCATE( zzligprod2(A2D(0),jpk) )
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
+ zzligprod2(ji,jj,jk) = tr(ji,jj,jk,jplgw,Krhs)
+ END_3D
+ ENDIF
+ IF( l_dia_fezoo2 ) THEN
+ ALLOCATE( zfezoo2(A2D(0),jpk) )
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
+ zfezoo2(ji,jj,jk) = tr(ji,jj,jk,jpfer,Krhs)
+ END_3D
+ ENDIF
+ IF( l_dia_graz2 ) THEN
+ ALLOCATE( zgrazing2(A2D(0),jpk) )
+ ENDIF
+
! Initialization of local arrays
- zgrazing(:,:,:) = 0._wp ; zfezoo2(:,:,:) = 0._wp
zgrarem (:,:,:) = 0._wp ; zgraren(:,:,:) = 0._wp
zgrarep (:,:,:) = 0._wp ; zgraref(:,:,:) = 0._wp
zgrapoc (:,:,:) = 0._wp ; zgrapon(:,:,:) = 0._wp
@@ -136,7 +156,7 @@ CONTAINS
zmetexcess = 0.0
IF ( bmetexc2 ) zmetexcess = 1.0
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1)
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
zcompam = MAX( ( tr(ji,jj,jk,jpmes,Kbb) - 1.e-9 ), 0.e0 )
zfact = xstep * tgfunc2(ji,jj,jk) * zcompam
@@ -284,7 +304,7 @@ CONTAINS
& + zgrazffpp + zgrazffpg
! Total grazing ( grazing by microzoo is already computed in p5zmicro )
- zgrazing(ji,jj,jk) = zgraztotc
+ IF( l_dia_graz2 ) zgrazing2(ji,jj,jk) = zgraztotc
! Stoichiometruc ratios of the food ingested by zooplanton
! --------------------------------------------------------
@@ -427,7 +447,7 @@ CONTAINS
! This fraction is sumed over the euphotic zone and is removed from
! the fluxes driven by mesozooplankton in the euphotic zone.
! --------------------------------------------------------------------
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1)
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
zmigreltime = (1. - strn(ji,jj))
IF( gdept(ji,jj,jk,Kmm) <= heup(ji,jj) ) THEN
zmigthick = e3t(ji,jj,jk,Kmm) * tmask(ji,jj,jk) * ( 1. - zmigreltime )
@@ -460,7 +480,7 @@ CONTAINS
! The inorganic and organic fluxes induced by migrating organisms are added at the
! the migration depth (corresponding indice is set by kmig)
! --------------------------------------------------------------------------------
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
IF( tmask(ji,jj,1) == 1. ) THEN
jkt = kmig(ji,jj)
zdep = 1. / e3t(ji,jj,jkt,Kmm)
@@ -490,7 +510,7 @@ CONTAINS
! This only concerns the variables which are affected by DVM (inorganic
! nutrients, DOC agands, and particulate organic carbon).
! ---------------------------------------------------------------------
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1)
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
tr(ji,jj,jk,jppo4,Krhs) = tr(ji,jj,jk,jppo4,Krhs) + zgrarep(ji,jj,jk)
tr(ji,jj,jk,jpnh4,Krhs) = tr(ji,jj,jk,jpnh4,Krhs) + zgraren(ji,jj,jk)
tr(ji,jj,jk,jpdoc,Krhs) = tr(ji,jj,jk,jpdoc,Krhs) + zgradoc(ji,jj,jk)
@@ -512,12 +532,47 @@ CONTAINS
tr(ji,jj,jk,jpbfe,Krhs) = tr(ji,jj,jk,jpbfe,Krhs) + zgrapof(ji,jj,jk)
END_3D
!
+ ! Write the output
IF( lk_iomput .AND. knt == nrdttrc ) THEN
- CALL iom_put( "PCAL" , prodcal(:,:,:) * 1.e+3 * rfact2r * tmask(:,:,:) ) ! Calcite production
- CALL iom_put( "GRAZ2" , zgrazing(:,:,:) * 1.e+3 * rfact2r * tmask(:,:,:) ) ! Total grazing of phyto by zoo
- CALL iom_put( "FEZOO2", zfezoo2(:,:,:) * 1e9 * 1.e+3 * rfact2r * tmask(:,:,:) )
- IF( ln_ligand ) &
- & CALL iom_put( "LPRODZ2", zgradoc(:,:,:) * ldocz * 1e9 * 1.e+3 * rfact2r * tmask(:,:,:) )
+ !
+ IF( iom_use ( "PCAL" ) ) THEN ! Calcite production
+ ALLOCATE( zw3d(A2D(0),jpk) ) ; zw3d(A2D(0),jpk) = 0._wp
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
+ zw3d(ji,jj,jk) = prodcal(ji,jj,jk) * 1.e+3 * rfact2r * tmask(ji,jj,jk)
+ END_3D
+ CALL iom_put( "PCAL", zw3d )
+ DEALLOCATE( zw3d )
+ ENDIF
+ !
+ IF( l_dia_graz2 ) THEN ! Total grazing of phyto by zooplankton
+ zgrazing2(A2D(0),jpk) = 0._wp
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
+ zgrazing2(ji,jj,jk) = zgrazing2(ji,jj,jk) * 1.e+3 * rfact2r * tmask(ji,jj,jk) ! conversion in mol/m2/s
+ END_3D
+ CALL iom_put( "GRAZ2" , zgrazing2 )
+ DEALLOCATE( zgrazing2 )
+ ENDIF
+ !
+ IF( l_dia_fezoo2 ) THEN
+ zfezoo2(A2D(0),jpk) = 0._wp
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
+ zfezoo2(ji,jj,jk) = ( tr(ji,jj,jk,jpfer,Krhs) - zfezoo2(ji,jj,jk) ) &
+ & * 1e9 * 1.e+3 * rfact2r * tmask(ji,jj,jk) ! conversion in nmol/m2/s
+ END_3D
+ CALL iom_put( "FEZOO2", zfezoo2 )
+ DEALLOCATE( zfezoo2 )
+ ENDIF
+ !
+ IF( l_dia_lprodz2 ) THEN
+ zzligprod2(A2D(0),jpk) = 0._wp
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
+ zzligprod2(ji,jj,jk) = ( tr(ji,jj,jk,jplgw,Krhs) - zzligprod2(ji,jj,jk) ) &
+ & * 1e9 * 1.e+3 * rfact2r * tmask(ji,jj,jk) ! conversion in nmol/m2/s
+ END_3D
+ CALL iom_put( "LPRODZ2", zzligprod2 )
+ DEALLOCATE( zzligprod2 )
+ ENDIF
+ !
ENDIF
!
IF(sn_cfctl%l_prttrc) THEN ! print mean trends (used for debugging)
@@ -626,7 +681,7 @@ CONTAINS
! Compute the averaged values of oxygen, temperature over the domain
! 150m to 500 m depth.
! ------------------------------------------------------------------
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpk )
+ DO_3D( 0, 0, 0, 0, 1, jpk )
IF( tmask(ji,jj,jk) == 1.) THEN
IF( gdept(ji,jj,jk,Kmm) >= 150. .AND. gdept(ji,jj,jk,kmm) <= 500.) THEN
oxymoy(ji,jj) = oxymoy(ji,jj) + tr(ji,jj,jk,jpoxy,Kbb) * 1E6 * e3t(ji,jj,jk,Kmm)
@@ -639,7 +694,7 @@ CONTAINS
! Compute the difference between surface values and the mean values in the mesopelagic
! domain
! ------------------------------------------------------------------------------------
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
z1dep = 1. / ( zdepmoy(ji,jj) + rtrn )
oxymoy(ji,jj) = tr(ji,jj,1,jpoxy,Kbb) * 1E6 - oxymoy(ji,jj) * z1dep
tempmoy(ji,jj) = ts(ji,jj,1,jp_tem,Kmm) - tempmoy(ji,jj) * z1dep
@@ -648,7 +703,7 @@ CONTAINS
! Computation of the migration depth based on the parameterization of
! Bianchi et al. (2013)
! -------------------------------------------------------------------
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
IF( tmask(ji,jj,1) == 1. ) THEN
ztotchl = ( tr(ji,jj,1,jppch,Kbb) + tr(ji,jj,1,jpnch,Kbb) + tr(ji,jj,1,jpdch,Kbb) ) * 1E6
depmig(ji,jj) = 398. - 0.56 * oxymoy(ji,jj) -115. * log10(ztotchl) + 0.36 * hmld(ji,jj) -2.4 * tempmoy(ji,jj)
@@ -657,7 +712,7 @@ CONTAINS
! Computation of the corresponding jk indice
! ------------------------------------------
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
IF( depmig(ji,jj) >= gdepw(ji,jj,jk,Kmm) .AND. depmig(ji,jj) < gdepw(ji,jj,jk+1,Kmm) ) THEN
kmig(ji,jj) = jk
ENDIF
@@ -669,7 +724,7 @@ CONTAINS
! to 0. Thus, to avoid that problem, the migration depth is adjusted so
! that it falls above the OMZ
! -----------------------------------------------------------------------
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
IF( tr(ji,jj,kmig(ji,jj),jpoxy,Kbb) < 5E-6 ) THEN
DO jk = kmig(ji,jj),1,-1
IF( tr(ji,jj,jk,jpoxy,Kbb) >= 5E-6 .AND. tr(ji,jj,jk+1,jpoxy,Kbb) < 5E-6) THEN
@@ -689,7 +744,7 @@ CONTAINS
!! *** ROUTINE p5z_meso_alloc ***
!!----------------------------------------------------------------------
!
- ALLOCATE( depmig(jpi,jpj), kmig(jpi,jpj), STAT= p5z_meso_alloc )
+ ALLOCATE( depmig(A2D(0)), kmig(A2D(0)), STAT= p5z_meso_alloc )
!
IF( p5z_meso_alloc /= 0 ) CALL ctl_stop( 'STOP', 'p5z_meso_alloc : failed to allocate arrays.' )
!
diff --git a/src/TOP/PISCES/P4Z/p5zmicro.F90 b/src/TOP/PISCES/P4Z/p5zmicro.F90
index 6edfde55e504a8916bb3098a293078c1da86c3c0..d70b3ff467e7968481b132ff606cb50cee82daa0 100644
--- a/src/TOP/PISCES/P4Z/p5zmicro.F90
+++ b/src/TOP/PISCES/P4Z/p5zmicro.F90
@@ -53,6 +53,8 @@ MODULE p5zmicro
REAL(wp), PUBLIC :: xsigmadel !: Maximum additional width of the grazing window at low food density
LOGICAL, PUBLIC :: bmetexc !: Use of excess carbon for respiration
+ LOGICAL :: l_dia_fezoo, l_dia_graz1, l_dia_lprodz
+
!! * Substitutions
# include "do_loop_substitute.h90"
!!----------------------------------------------------------------------
@@ -88,18 +90,39 @@ CONTAINS
REAL(wp) :: zgraznc, zgraznn, zgraznp, zgrazpoc, zgrazpon, zgrazpop, zgrazpof
REAL(wp) :: zgrazdc, zgrazdn, zgrazdp, zgrazdf, zgraznf, zgrazz
REAL(wp) :: zgrazpc, zgrazpn, zgrazpp, zgrazpf, zbeta, zrfact2, zmetexcess
- REAL(wp), DIMENSION(jpi,jpj,jpk) :: zgrazing, zfezoo, zzligprod
REAL(wp) :: zsigma, zdiffdn, zdiffpn, zdiffdp, zproport, zproport2
+ REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zgrazing, zfezoo, zzligprod, zw3d
CHARACTER (len=25) :: charout
!!---------------------------------------------------------------------
!
IF( ln_timing ) CALL timing_start('p5z_micro')
!
+ IF( kt == nittrc000 ) THEN
+ l_dia_graz1 = iom_use( "GRAZ1" )
+ l_dia_fezoo = iom_use( "FEZOO" )
+ l_dia_lprodz = ln_ligand .AND. iom_use( "LPRODZ" )
+ ENDIF
+ IF( l_dia_lprodz ) THEN
+ ALLOCATE( zzligprod(A2D(0),jpk) )
+ DO_3D( 0, 0, 0, 0, 1, jpk)
+ zzligprod(ji,jj,jk) = tr(ji,jj,jk,jplgw,Krhs)
+ END_3D
+ ENDIF
+ IF( l_dia_fezoo ) THEN
+ ALLOCATE( zfezoo(A2D(0),jpk) )
+ DO_3D( 0, 0, 0, 0, 1, jpk)
+ zfezoo(ji,jj,jk) = tr(ji,jj,jk,jpfer,Krhs)
+ END_3D
+ ENDIF
+ IF( l_dia_graz1 ) THEN
+ ALLOCATE( zgrazing(A2D(0),jpk) )
+ ENDIF
+
! Use of excess carbon for metabolism
zmetexcess = 0.0
IF ( bmetexc ) zmetexcess = 1.0
!
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1)
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
zcompaz = MAX( ( tr(ji,jj,jk,jpzoo,Kbb) - 1.e-9 ), 0.e0 )
zfact = xstep * tgfunc2(ji,jj,jk) * zcompaz
! Proportion of nano and diatoms that are within the size range
@@ -207,14 +230,13 @@ CONTAINS
zgrazdf = zgrazdc * tr(ji,jj,jk,jpdfe,Kbb) / (tr(ji,jj,jk,jpdia,Kbb) + rtrn)
!
! Total ingestion rates in C, P, Fe, N
- zgraztotc = zgraznc + zgrazpoc + zgrazdc + zgrazz + zgrazpc
+ zgraztotc = zgraznc + zgrazpoc + zgrazdc + zgrazz + zgrazpc ! Grazing by microzooplankton
+ IF( l_dia_graz1 ) zgrazing(ji,jj,jk) = zgraztotc
+
zgraztotn = zgraznn + zgrazpn + zgrazpon + zgrazdn + zgrazz * no3rat3
zgraztotp = zgraznp + zgrazpp + zgrazpop + zgrazdp + zgrazz * po4rat3
zgraztotf = zgraznf + zgrazpf + zgrazpof + zgrazdf + zgrazz * feratz
!
- ! Grazing by microzooplankton
- zgrazing(ji,jj,jk) = zgraztotc
-
! Stoichiometruc ratios of the food ingested by zooplanton
! --------------------------------------------------------
zgrasratf = (zgraztotf + rtrn) / ( zgraztotc + rtrn )
@@ -298,14 +320,12 @@ CONTAINS
!
IF( ln_ligand ) THEN
tr(ji,jj,jk,jplgw,Krhs) = tr(ji,jj,jk,jplgw,Krhs) + zgradoc * ldocz
- zzligprod(ji,jj,jk) = zgradoc * ldocz
ENDIF
!
tr(ji,jj,jk,jpdon,Krhs) = tr(ji,jj,jk,jpdon,Krhs) + zgradon
tr(ji,jj,jk,jpdop,Krhs) = tr(ji,jj,jk,jpdop,Krhs) + zgradop
tr(ji,jj,jk,jpoxy,Krhs) = tr(ji,jj,jk,jpoxy,Krhs) - o2ut * zgrarem
tr(ji,jj,jk,jpfer,Krhs) = tr(ji,jj,jk,jpfer,Krhs) + zgraref
- zfezoo(ji,jj,jk) = zgraref
tr(ji,jj,jk,jpzoo,Krhs) = tr(ji,jj,jk,jpzoo,Krhs) + zepsherv * zgraztotc - zrespirc - ztortz - zgrazz
tr(ji,jj,jk,jpphy,Krhs) = tr(ji,jj,jk,jpphy,Krhs) - zgraznc
tr(ji,jj,jk,jpnph,Krhs) = tr(ji,jj,jk,jpnph,Krhs) - zgraznn
@@ -342,15 +362,36 @@ CONTAINS
END_3D
!
IF( lk_iomput .AND. knt == nrdttrc ) THEN
- IF( iom_use("GRAZ1") ) THEN ! Total grazing of phyto by zooplankton
- zgrazing(:,:,jpk) = 0._wp ; CALL iom_put( "GRAZ1" , zgrazing(:,:,:) * 1.e+3 * rfact2r * tmask(:,:,:) )
- ENDIF
- IF( iom_use("FEZOO") ) THEN
- zfezoo (:,:,jpk) = 0._wp ; CALL iom_put( "FEZOO" , zfezoo(:,:,:) * 1e9 * 1.e+3 * rfact2r * tmask(:,:,:) )
- ENDIF
- IF( ln_ligand ) THEN
- zzligprod(:,:,jpk) = 0._wp ; CALL iom_put( "LPRODZ", zzligprod(:,:,:) * 1e9 * 1.e+3 * rfact2r * tmask(:,:,:))
- ENDIF
+ !
+ IF( l_dia_graz1 ) THEN ! Total grazing of phyto by zooplankton
+ zgrazing(A2D(0),jpk) = 0._wp
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
+ zgrazing(ji,jj,jk) = zgrazing(ji,jj,jk) * 1.e+3 * rfact2r * tmask(ji,jj,jk) ! conversion in mol/m2/s
+ END_3D
+ CALL iom_put( "GRAZ1" , zgrazing )
+ DEALLOCATE( zgrazing )
+ ENDIF
+ !
+ IF( l_dia_fezoo ) THEN
+ zfezoo(A2D(0),jpk) = 0._wp
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
+ zfezoo(ji,jj,jk) = ( tr(ji,jj,jk,jpfer,Krhs) - zfezoo(ji,jj,jk) ) &
+ & * 1e9 * 1.e+3 * rfact2r * tmask(ji,jj,jk) ! conversion in nmol/m2/s
+ END_3D
+ CALL iom_put( "FEZOO", zfezoo )
+ DEALLOCATE( zfezoo )
+ ENDIF
+ !
+ IF( l_dia_lprodz ) THEN
+ zzligprod(A2D(0),jpk) = 0._wp
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
+ zzligprod(ji,jj,jk) = ( tr(ji,jj,jk,jplgw,Krhs) - zzligprod(ji,jj,jk) ) &
+ & * 1e9 * 1.e+3 * rfact2r * tmask(ji,jj,jk) ! conversion in nmol/m2/s
+ END_3D
+ CALL iom_put( "LPRODZ", zzligprod )
+ DEALLOCATE( zzligprod )
+ ENDIF
+ !
ENDIF
!
IF(sn_cfctl%l_prttrc) THEN ! print mean trends (used for debugging)
diff --git a/src/TOP/PISCES/P4Z/p5zmort.F90 b/src/TOP/PISCES/P4Z/p5zmort.F90
index 396be16f7db0f854fd3b3e4ba46fe6bf2fab4c45..4fb33dac3f590cf33e27a9ab99ab84683dcc35a5 100644
--- a/src/TOP/PISCES/P4Z/p5zmort.F90
+++ b/src/TOP/PISCES/P4Z/p5zmort.F90
@@ -80,7 +80,7 @@ CONTAINS
IF( ln_timing ) CALL timing_start('p5z_mort_nano')
!
prodcal(:,:,:) = 0. !: calcite production variable set to zero
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1)
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
zcompaph = MAX( ( tr(ji,jj,jk,jpphy,Kbb) - 1e-9 ), 0.e0 )
! Quadratic mortality of nano due to aggregation during
@@ -151,7 +151,7 @@ CONTAINS
!
IF( ln_timing ) CALL timing_start('p5z_mort_pico')
!
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1)
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
zcompaph = MAX( ( tr(ji,jj,jk,jppic,Kbb) - 1e-9 ), 0.e0 )
! Quadratic mortality of pico due to aggregation during
@@ -215,7 +215,7 @@ CONTAINS
IF( ln_timing ) CALL timing_start('p5z_mort_diat')
!
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1)
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
zcompadi = MAX( ( tr(ji,jj,jk,jpdia,Kbb) - 1E-9), 0. )
diff --git a/src/TOP/PISCES/P4Z/p5zprod.F90 b/src/TOP/PISCES/P4Z/p5zprod.F90
index 848f8550539968bc10d6efcfcfc6ae007fc215d2..0888dfc072dcef329d69404c2cdd60ac5909f09a 100644
--- a/src/TOP/PISCES/P4Z/p5zprod.F90
+++ b/src/TOP/PISCES/P4Z/p5zprod.F90
@@ -26,7 +26,6 @@ MODULE p5zprod
PUBLIC p5z_prod ! called in p5zbio.F90
PUBLIC p5z_prod_init ! called in trcsms_pisces.F90
- PUBLIC p5z_prod_alloc
!! * Shared module variables
REAL(wp), PUBLIC :: pislopen !: P-I slope of nanophytoplankton
@@ -43,12 +42,16 @@ MODULE p5zprod
REAL(wp), PUBLIC :: chlcmin !: Minimum Chl/C ratio of phytoplankton
REAL(wp), PUBLIC :: grosip !: Mean Si/C ratio of diatoms
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: zdaylen ! day length
-
- REAL(wp) :: r1_rday !: 1 / rday
- REAL(wp) :: texcretn !: 1 - excretn
- REAL(wp) :: texcretp !: 1 - excretp
- REAL(wp) :: texcretd !: 1 - excretd
+ REAL(wp) :: r1_rday !: 1 / rday
+ REAL(wp) :: texcretn !: 1 - excretn
+ REAL(wp) :: texcretp !: 1 - excretp
+ REAL(wp) :: texcretd !: 1 - excretd
+ REAL(wp) :: xq10_n !: q10 coef for nano = 1. + xpsino3 * qnnmax
+ REAL(wp) :: xq10_p !: q10 coef for pico = 1. + xpsino3 * qnpmax
+ REAL(wp) :: xq10_d !: q10 coef for diat = 1. + xpsino3 * qndmax
+
+ LOGICAL :: l_dia_ppphy, l_dia_ppnew, l_dia_ppbfe, l_dia_ppbsi
+ LOGICAL :: l_dia_mu, l_dia_light, l_dia_lprod
!! * Substitutions
# include "do_loop_substitute.h90"
@@ -76,51 +79,60 @@ CONTAINS
INTEGER :: ji, jj, jk
REAL(wp) :: zsilfac, znanotot, zpicotot, zdiattot, zconctemp, zconctemp2
REAL(wp) :: zration, zratiop, zratiof, zmax, ztn, zadap
- REAL(wp) :: zpronmax, zpropmax, zprofmax, zratio
+ REAL(wp) :: zprofmax, zratio
+ REAL(wp) :: zpronewn, zpronewp, zpronewd
+ REAL(wp) :: zproregn, zproregp, zproregd
+ REAL(wp) :: zpropo4n, zpropo4p, zpropo4d
+ REAL(wp) :: zprodopn, zprodopp, zprodopd
REAL(wp) :: zlim, zsilfac2, zsiborn, zprod, zprontot, zproptot, zprodtot
REAL(wp) :: zproddoc, zproddon, zproddop, zprodsil, zprodfer, zprodlig, zresptot
REAL(wp) :: zprnutmax, zprochln, zprochld, zprochlp
REAL(wp) :: zpislopen, zpislopep, zpisloped
REAL(wp) :: zval, zpptot, zpnewtot, zpregtot
+ REAL(wp) :: zmxl_chl, zmxl_fac
REAL(wp) :: zqfpmax, zqfnmax, zqfdmax
REAL(wp) :: zfact, zrfact2, zmaxsi, zratiosi, zsizetmp, zlimfac, zsilim
CHARACTER (len=25) :: charout
- REAL(wp), DIMENSION(jpi,jpj ) :: zmixnano, zmixpico, zmixdiat
- REAL(wp), DIMENSION(jpi,jpj,jpk) :: zpislopeadn, zpislopeadp, zpislopeadd
- REAL(wp), DIMENSION(jpi,jpj,jpk) :: zprnut, zprmaxp, zprmaxn, zprmaxd
- REAL(wp), DIMENSION(jpi,jpj,jpk) :: zprbio, zprpic, zprdia, zysopt
- REAL(wp), DIMENSION(jpi,jpj,jpk) :: zprchln, zprchlp, zprchld
- REAL(wp), DIMENSION(jpi,jpj,jpk) :: zprorcan, zprorcap, zprorcad
- REAL(wp), DIMENSION(jpi,jpj,jpk) :: zprofed, zprofep, zprofen
- REAL(wp), DIMENSION(jpi,jpj,jpk) :: zpronewn, zpronewp, zpronewd
- REAL(wp), DIMENSION(jpi,jpj,jpk) :: zproregn, zproregp, zproregd
- REAL(wp), DIMENSION(jpi,jpj,jpk) :: zpropo4n, zpropo4p, zpropo4d
- REAL(wp), DIMENSION(jpi,jpj,jpk) :: zprodopn, zprodopp, zprodopd
- REAL(wp), DIMENSION(jpi,jpj,jpk) :: zrespn, zrespp, zrespd
- REAL(wp), DIMENSION(jpi,jpj,jpk) :: zmxl_fac, zmxl_chl
- REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zpligprod
+ REAL(wp), DIMENSION(A2D(0),jpk) :: zprorcan, zprorcap, zprorcad
+ REAL(wp), DIMENSION(A2D(0),jpk) :: zpislopeadn, zpislopeadp, zpislopeadd
+ REAL(wp), DIMENSION(A2D(0),jpk) :: zprnut, zprbio, zprpic, zprdia, zysopt
+ REAL(wp), DIMENSION(A2D(0),jpk) :: zprchln, zprchlp, zprchld
+ REAL(wp), DIMENSION(A2D(0),jpk) :: zprofed, zprofep, zprofen
+ REAL(wp), DIMENSION(A2D(0),jpk) :: zpronmaxn, zpronmaxp,zpronmaxd
+ REAL(wp), DIMENSION(A2D(0),jpk) :: zpropmaxn, zpropmaxp,zpropmaxd
+! REAL(wp), DIMENSION(A2D(0),jpk) :: zrespn, zrespp, zrespd
+ REAL(wp), DIMENSION(A2D(0),jpk) :: zprmaxn, zprmaxd, zprmaxp, zmxl
+ REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zw3d
!!---------------------------------------------------------------------
!
IF( ln_timing ) CALL timing_start('p5z_prod')
+ !
+ IF( kt == nittrc000 ) THEN
+ l_dia_ppphy = iom_use( "PPPHYN" ) .OR. iom_use( "PPPHYD" ) .OR. iom_use( "PPPHYP" ) .OR. iom_use( "TPP" )
+ l_dia_ppnew = iom_use( "PPNEWN" ) .OR. iom_use( "PPNEWD" ) .OR. iom_use( "PPNEWP" ) .OR. iom_use( "TPNEW")
+ l_dia_ppbfe = iom_use( "PFeN" ) .OR. iom_use( "PFeD" ) .OR. iom_use( "PFeP" ) .OR. iom_use( "TPBFE")
+ l_dia_ppbsi = iom_use( "PBSi" )
+ l_dia_mu = iom_use( "Mumax" ) .OR. iom_use( "MuN" ) .OR. iom_use( "MuD") .OR. iom_use( "MuP")
+ l_dia_light = iom_use( "LNlight") .OR. iom_use( "LDlight") .OR. iom_use( "LPlight")
+ l_dia_lprod = ln_ligand .AND. ( iom_use( "LPRODP") .OR. iom_use( "LDETP") )
+ ENDIF
! Initialize the local arrays
- zprorcan(:,:,:) = 0._wp ; zprorcap(:,:,:) = 0._wp ; zprorcad(:,:,:) = 0._wp
- zprofed (:,:,:) = 0._wp ; zprofep (:,:,:) = 0._wp ; zprofen (:,:,:) = 0._wp
- zpronewn(:,:,:) = 0._wp ; zpronewp(:,:,:) = 0._wp ; zpronewd(:,:,:) = 0._wp
- zproregn(:,:,:) = 0._wp ; zproregp(:,:,:) = 0._wp ; zproregd(:,:,:) = 0._wp
- zpropo4n(:,:,:) = 0._wp ; zpropo4p(:,:,:) = 0._wp ; zpropo4d(:,:,:) = 0._wp
- zprdia (:,:,:) = 0._wp ; zprpic (:,:,:) = 0._wp ; zprbio (:,:,:) = 0._wp
- zprodopn(:,:,:) = 0._wp ; zprodopp(:,:,:) = 0._wp ; zprodopd(:,:,:) = 0._wp
- zysopt (:,:,:) = 0._wp
- zrespn (:,:,:) = 0._wp ; zrespp (:,:,:) = 0._wp ; zrespd (:,:,:) = 0._wp
- zmxl_fac(:,:,:) = 0._wp ; zmxl_chl(:,:,:) = 0._wp
+ zprorcan (:,:,:) = 0._wp ; zprorcap (:,:,:) = 0._wp ; zprorcad (:,:,:) = 0._wp
+ zprofen (:,:,:) = 0._wp ; zprofep (:,:,:) = 0._wp ; zprofed (:,:,:) = 0._wp
+ zprbio (:,:,:) = 0._wp ; zprpic (:,:,:) = 0._wp ; zprdia (:,:,:) = 0._wp
+ zpronmaxn(:,:,:) = 0._wp ; zpronmaxp(:,:,:) = 0._wp ; zpronmaxd(:,:,:) = 0._wp
+ zpropmaxn(:,:,:) = 0._wp ; zpropmaxp(:,:,:) = 0._wp ; zpropmaxd(:,:,:) = 0._wp
+ zmxl (:,:,:) = 0._wp ; zysopt (:,:,:) = 0._wp
+
+! zrespn (:,:,:) = 0._wp ; zrespp (:,:,:) = 0._wp ; zrespd (:,:,:) = 0._wp
! Computation of the optimal production rates and nutrient uptake
! rates. Based on a Q10 description of the thermal dependency.
- zprnut (:,:,:) = 0.8_wp * r1_rday * tgfunc(:,:,:)
- zprmaxn(:,:,:) = 0.8_wp * (1. + xpsino3 * qnnmax ) * r1_rday * tgfunc(:,:,:)
- zprmaxd(:,:,:) = 0.8_wp * (1. + xpsino3 * qndmax ) * r1_rday * tgfunc(:,:,:)
- zprmaxp(:,:,:) = 0.6_wp * (1. + xpsino3 * qnpmax ) * r1_rday * tgfunc(:,:,:)
+ zprnut (:,:,:) = 0.8_wp * r1_rday * tgfunc(:,:,:)
+ zprmaxn(:,:,:) = 0.8_wp * xq10_n * r1_rday * tgfunc(:,:,:)
+ zprmaxd(:,:,:) = 0.8_wp * xq10_d * r1_rday * tgfunc(:,:,:)
+ zprmaxp(:,:,:) = 0.6_wp * xq10_p * r1_rday * tgfunc(:,:,:)
! Impact of the day duration and light intermittency on phytoplankton growth
! Intermittency is supposed to have a similar effect on production as
@@ -131,42 +143,39 @@ CONTAINS
! -------------------------------------------------------------------------
IF ( ln_p4z_dcyc ) THEN ! Diurnal cycle in PISCES
-
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1)
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
IF( etot_ndcy(ji,jj,jk) > 1.E-3 ) THEN
IF( gdepw(ji,jj,jk+1,Kmm) <= hmld(ji,jj) ) THEN
zval = MIN(1., heup_01(ji,jj) / ( hmld(ji,jj) + rtrn ))
ENDIF
- zmxl_chl(ji,jj,jk) = zval / 24.
- zmxl_fac(ji,jj,jk) = 1.0 - exp( -0.26 * zval )
+ zmxl(ji,jj,jk) = zval
ENDIF
END_3D
-
ELSE ! No diurnal cycle in PISCES
-
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1)
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
IF( etot_ndcy(ji,jj,jk) > 1.E-3 ) THEN
zval = MAX( 1., strn(ji,jj) )
IF( gdepw(ji,jj,jk+1,Kmm) <= hmld(ji,jj) ) THEN
zval = zval * MIN(1., heup_01(ji,jj) / ( hmld(ji,jj) + rtrn ))
ENDIF
- zmxl_chl(ji,jj,jk) = zval / 24.
- zmxl_fac(ji,jj,jk) = 1.0 - exp( -0.26 * zval )
+ zmxl(ji,jj,jk) = zval
ENDIF
END_3D
ENDIF
- zprbio(:,:,:) = zprmaxn(:,:,:) * zmxl_fac(:,:,:)
- zprdia(:,:,:) = zprmaxd(:,:,:) * zmxl_fac(:,:,:)
- zprpic(:,:,:) = zprmaxp(:,:,:) * zmxl_fac(:,:,:)
-
- ! Maximum light intensity
- zdaylen(:,:) = MAX(1., strn(:,:)) / 24.
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
+ IF( etot_ndcy(ji,jj,jk) > 1.E-3 ) THEN
+ zmxl_fac = 1.0 - EXP( -0.26 * zmxl(ji,jj,jk) )
+ zprbio(ji,jj,jk) = zprmaxn(ji,jj,jk) * zmxl_fac
+ zprdia(ji,jj,jk) = zprmaxd(ji,jj,jk) * zmxl_fac
+ zprpic(ji,jj,jk) = zprmaxp(ji,jj,jk) * zmxl_fac
+ ENDIF
+ END_3D
! Computation of the P-I slope for nanos, picos and diatoms
! The formulation proposed by Geider et al. (1997) has been used.
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1)
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
IF( etot_ndcy(ji,jj,jk) > 1.E-3 ) THEN
! Computation of the P-I slope for nanos and diatoms
ztn = MAX( 0., ts(ji,jj,jk,jp_tem,Kmm) - 15. )
@@ -191,26 +200,31 @@ CONTAINS
! Computation of production function for Carbon
! Actual light levels are used here
! ---------------------------------------------
- zprbio(ji,jj,jk) = zprbio(ji,jj,jk) * ( 1.- EXP( -zpislopen * enano(ji,jj,jk) / zmxl_fac(ji,jj,jk) ) )
- zprpic(ji,jj,jk) = zprpic(ji,jj,jk) * ( 1.- EXP( -zpislopep * epico(ji,jj,jk) / zmxl_fac(ji,jj,jk) ) )
- zprdia(ji,jj,jk) = zprdia(ji,jj,jk) * ( 1.- EXP( -zpisloped * ediat(ji,jj,jk) / zmxl_fac(ji,jj,jk) ) )
+ zmxl_fac = 1.0 - EXP( -0.26 * zmxl(ji,jj,jk) )
+ zmxl_chl = zmxl(ji,jj,jk) / 24.
+ !
+ zprbio(ji,jj,jk) = zprbio(ji,jj,jk) * ( 1.- EXP( -zpislopen * enano(ji,jj,jk) / zmxl_fac ) )
+ zprpic(ji,jj,jk) = zprpic(ji,jj,jk) * ( 1.- EXP( -zpislopep * epico(ji,jj,jk) / zmxl_fac ) )
+ zprdia(ji,jj,jk) = zprdia(ji,jj,jk) * ( 1.- EXP( -zpisloped * ediat(ji,jj,jk) / zmxl_fac ) )
! Computation of production function for Chlorophyll
! Mean light level in the mixed layer (when appropriate)
! is used here (acclimation is in general slower than
! the characteristic time scales of vertical mixing)
! ------------------------------------------------------
- zpislopen = zpislopen * zmxl_fac(ji,jj,jk) / ( zmxl_chl(ji,jj,jk) + rtrn )
- zpisloped = zpisloped * zmxl_fac(ji,jj,jk) / ( zmxl_chl(ji,jj,jk) + rtrn )
- zpislopep = zpislopep * zmxl_fac(ji,jj,jk) / ( zmxl_chl(ji,jj,jk) + rtrn )
+ zpislopen = zpislopen * zmxl_fac / ( zmxl_chl + rtrn )
+ zpisloped = zpisloped * zmxl_fac / ( zmxl_chl + rtrn )
+ zpislopep = zpislopep * zmxl_fac / ( zmxl_chl + rtrn )
+ !
zprchln(ji,jj,jk) = zprmaxn(ji,jj,jk) * ( 1.- EXP( -zpislopen * enanom(ji,jj,jk) ) )
zprchlp(ji,jj,jk) = zprmaxp(ji,jj,jk) * ( 1.- EXP( -zpislopep * epicom(ji,jj,jk) ) )
zprchld(ji,jj,jk) = zprmaxd(ji,jj,jk) * ( 1.- EXP( -zpisloped * ediatm(ji,jj,jk) ) )
ENDIF
END_3D
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1)
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
IF( etot_ndcy(ji,jj,jk) > 1.E-3 ) THEN
+ !
! Si/C of diatoms
! ------------------------
! Si/C increases with iron stress and silicate availability (zsilfac)
@@ -242,7 +256,7 @@ CONTAINS
! Sea-ice effect on production
! No production is assumed below sea ice
! --------------------------------------
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1)
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
zprbio(ji,jj,jk) = zprbio(ji,jj,jk) * ( 1. - fr_i(ji,jj) )
zprpic(ji,jj,jk) = zprpic(ji,jj,jk) * ( 1. - fr_i(ji,jj) )
zprdia(ji,jj,jk) = zprdia(ji,jj,jk) * ( 1. - fr_i(ji,jj) )
@@ -256,7 +270,7 @@ CONTAINS
! quota, uptake is downregulated according to a sigmoidal function
! (power 2), as proposed by Flynn (2003)
! ---------------------------------------------------------------------------
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1)
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
IF( etot_ndcy(ji,jj,jk) > 1.E-3 ) THEN
! production terms for nanophyto.
zprorcan(ji,jj,jk) = zprbio(ji,jj,jk) * xlimphy(ji,jj,jk) * tr(ji,jj,jk,jpphy,Kbb) * rfact2
@@ -278,17 +292,13 @@ CONTAINS
! Uptake of nitrogen
zratio = 1.0 - MIN( 1., zration / (xqnnmax(ji,jj,jk) + rtrn) )
zmax = MAX(0., MIN(1., zratio**2 / (0.05**2 + zratio**2) ) )
- zpronmax = zprnutmax * zmax * MAX(0., MIN(1., ( zratiop - xqpnmin(ji,jj,jk) ) &
+ zpronmaxn(ji,jj,jk) = zprnutmax * zmax * MAX(0., MIN(1., ( zratiop - xqpnmin(ji,jj,jk) ) &
& / ( xqpnmax(ji,jj,jk) - xqpnmin(ji,jj,jk) + rtrn ), xlimnfe(ji,jj,jk) ) )
- zpronmax = zpronmax * xqnnmin(ji,jj,jk) / qnnmin
- zpronewn(ji,jj,jk) = zpronmax * xnanono3(ji,jj,jk)
- zproregn(ji,jj,jk) = zpronmax * xnanonh4(ji,jj,jk)
+ zpronmaxn(ji,jj,jk) = zpronmaxn(ji,jj,jk) * xqnnmin(ji,jj,jk) / qnnmin
! Uptake of phosphorus and DOP
zratio = 1.0 - MIN( 1., zratiop / (xqpnmax(ji,jj,jk) + rtrn) )
zmax = MAX(0., MIN(1., zratio**2 / (0.05**2 + zratio**2) ) )
- zpropmax = zprnutmax * zmax * xlimnfe(ji,jj,jk)
- zpropo4n(ji,jj,jk) = zpropmax * xnanopo4(ji,jj,jk)
- zprodopn(ji,jj,jk) = zpropmax * xnanodop(ji,jj,jk)
+ zpropmaxn(ji,jj,jk) = zprnutmax * zmax * xlimnfe(ji,jj,jk)
! Uptake of iron
zqfnmax = xqfuncfecn(ji,jj,jk) + ( qfnmax - xqfuncfecn(ji,jj,jk) ) * xlimnpn(ji,jj,jk)
zratio = 1.0 - MIN( 1., zratiof / zqfnmax )
@@ -307,8 +317,9 @@ CONTAINS
! quota, uptake is downregulated according to a sigmoidal function
! (power 2), as proposed by Flynn (2003)
! ---------------------------------------------------------------------------
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1)
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
IF( etot_ndcy(ji,jj,jk) > 1.E-3 ) THEN
+ !
! production terms for picophyto.
zprorcap(ji,jj,jk) = zprpic(ji,jj,jk) * xlimpic(ji,jj,jk) * tr(ji,jj,jk,jppic,Kbb) * rfact2
! Size computation
@@ -328,17 +339,13 @@ CONTAINS
! Uptake of nitrogen
zratio = 1.0 - MIN( 1., zration / (xqnpmax(ji,jj,jk) + rtrn) )
zmax = MAX(0., MIN(1., zratio**2/ (0.05**2 + zratio**2) ) )
- zpronmax = zprnutmax * zmax * MAX(0., MIN(1., ( zratiop - xqppmin(ji,jj,jk) ) &
+ zpronmaxp(ji,jj,jk) = zprnutmax * zmax * MAX(0., MIN(1., ( zratiop - xqppmin(ji,jj,jk) ) &
& / ( xqppmax(ji,jj,jk) - xqppmin(ji,jj,jk) + rtrn ), xlimpfe(ji,jj,jk) ) )
- zpronmax = zpronmax * xqnpmin(ji,jj,jk) / qnnmin
- zpronewp(ji,jj,jk) = zpronmax * xpicono3(ji,jj,jk)
- zproregp(ji,jj,jk) = zpronmax * xpiconh4(ji,jj,jk)
+ zpronmaxp(ji,jj,jk) = zpronmaxp(ji,jj,jk) * xqnpmin(ji,jj,jk) / qnnmin
! Uptake of phosphorus
zratio = 1.0 - MIN( 1., zratiop / (xqppmax(ji,jj,jk) + rtrn) )
zmax = MAX(0., MIN(1., zratio**2 / (0.05**2 + zratio**2) ) )
- zpropmax = zprnutmax * zmax * xlimpfe(ji,jj,jk)
- zpropo4p(ji,jj,jk) = zpropmax * xpicopo4(ji,jj,jk)
- zprodopp(ji,jj,jk) = zpropmax * xpicodop(ji,jj,jk)
+ zpropmaxp(ji,jj,jk) = zprnutmax * zmax * xlimpfe(ji,jj,jk)
! Uptake of iron
zqfpmax = xqfuncfecp(ji,jj,jk) + ( qfpmax - xqfuncfecp(ji,jj,jk) ) * xlimnpp(ji,jj,jk)
zratio = 1.0 - MIN( 1., zratiof / zqfpmax )
@@ -357,8 +364,9 @@ CONTAINS
! quota, uptake is downregulated according to a sigmoidal function
! (power 2), as proposed by Flynn (2003)
! ---------------------------------------------------------------------------
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1)
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
IF( etot_ndcy(ji,jj,jk) > 1.E-3 ) THEN
+ !
! production terms for diatomees
zprorcad(ji,jj,jk) = zprdia(ji,jj,jk) * xlimdia(ji,jj,jk) * tr(ji,jj,jk,jpdia,Kbb) * rfact2
! Size computation
@@ -378,17 +386,13 @@ CONTAINS
! Uptake of nitrogen
zratio = 1.0 - MIN( 1., zration / (xqndmax(ji,jj,jk) + rtrn) )
zmax = MAX(0., MIN(1., zratio**2 / (0.05**2 + zratio**2) ) )
- zpronmax = zprnutmax * zmax * MAX(0., MIN(1., ( zratiop - xqpdmin(ji,jj,jk) ) &
+ zpronmaxd(ji,jj,jk) = zprnutmax * zmax * MAX(0., MIN(1., ( zratiop - xqpdmin(ji,jj,jk) ) &
& / ( xqpdmax(ji,jj,jk) - xqpdmin(ji,jj,jk) + rtrn ), xlimdfe(ji,jj,jk) ) )
- zpronmax = zpronmax * xqndmin(ji,jj,jk) / qnnmin
- zpronewd(ji,jj,jk) = zpronmax * xdiatno3(ji,jj,jk)
- zproregd(ji,jj,jk) = zpronmax * xdiatnh4(ji,jj,jk)
+ zpronmaxd(ji,jj,jk) = zpronmaxd(ji,jj,jk) * xqndmin(ji,jj,jk) / qnnmin
! Uptake of phosphorus
zratio = 1.0 - MIN( 1., zratiop / (xqpdmax(ji,jj,jk) + rtrn) )
zmax = MAX(0., MIN(1., zratio**2/ (0.05**2 + zratio**2) ) )
- zpropmax = zprnutmax * zmax * xlimdfe(ji,jj,jk)
- zpropo4d(ji,jj,jk) = zpropmax * xdiatpo4(ji,jj,jk)
- zprodopd(ji,jj,jk) = zpropmax * xdiatdop(ji,jj,jk)
+ zpropmaxd(ji,jj,jk) = zprnutmax * zmax * xlimdfe(ji,jj,jk)
! Uptake of iron
zqfdmax = xqfuncfecd(ji,jj,jk) + ( qfdmax - xqfuncfecd(ji,jj,jk) ) * xlimnpd(ji,jj,jk)
zratio = 1.0 - MIN( 1., zratiof / zqfdmax )
@@ -403,21 +407,28 @@ CONTAINS
! Production of Chlorophyll. The formulation proposed by Geider et al.
! is adopted here.
! --------------------------------------------------------------------
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1)
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
IF( etot_ndcy(ji,jj,jk) > 1.E-3 ) THEN
- ! production terms for nanophyto. ( chlorophyll )
- znanotot = enanom(ji,jj,jk) / ( zmxl_chl(ji,jj,jk) + rtrn )
- zprod = rday * (zpronewn(ji,jj,jk) + zproregn(ji,jj,jk)) * zprchln(ji,jj,jk) * xlimphy(ji,jj,jk)
+ zmxl_chl = zmxl(ji,jj,jk) / 24.
+ ! production terms for nanophyto. ( chlorophyll )
+ zpronewn = zpronmaxn(ji,jj,jk) * xnanono3(ji,jj,jk)
+ zproregn = zpronmaxn(ji,jj,jk) * xnanonh4(ji,jj,jk)
+ znanotot = enanom(ji,jj,jk) / ( zmxl_chl + rtrn )
+ zprod = rday * (zpronewn + zproregn) * zprchln(ji,jj,jk) * xlimphy(ji,jj,jk)
zprochln = thetannm * zprod / ( zpislopeadn(ji,jj,jk) * znanotot + rtrn )
zprochln = MAX(zprochln, chlcmin * 12. * zprorcan (ji,jj,jk) )
- ! production terms for picophyto. ( chlorophyll )
- zpicotot = epicom(ji,jj,jk) / ( zmxl_chl(ji,jj,jk) + rtrn )
- zprod = rday * (zpronewp(ji,jj,jk) + zproregp(ji,jj,jk)) * zprchlp(ji,jj,jk) * xlimpic(ji,jj,jk)
+ ! production terms for picophyto. ( chlorophyll )
+ zpronewp = zpronmaxp(ji,jj,jk) * xpicono3(ji,jj,jk)
+ zproregp = zpronmaxp(ji,jj,jk) * xpiconh4(ji,jj,jk)
+ zpicotot = epicom(ji,jj,jk) / ( zmxl_chl + rtrn )
+ zprod = rday * (zpronewp + zproregp) * zprchlp(ji,jj,jk) * xlimpic(ji,jj,jk)
zprochlp = thetanpm * zprod / ( zpislopeadp(ji,jj,jk) * zpicotot + rtrn )
zprochlp = MAX(zprochlp, chlcmin * 12. * zprorcap(ji,jj,jk) )
! production terms for diatoms ( chlorophyll )
- zdiattot = ediatm(ji,jj,jk) / ( zmxl_chl(ji,jj,jk) + rtrn )
- zprod = rday * (zpronewd(ji,jj,jk) + zproregd(ji,jj,jk)) * zprchld(ji,jj,jk) * xlimdia(ji,jj,jk)
+ zpronewd = zpronmaxd(ji,jj,jk) * xdiatno3(ji,jj,jk)
+ zproregd = zpronmaxd(ji,jj,jk) * xdiatnh4(ji,jj,jk)
+ zdiattot = ediatm(ji,jj,jk) / ( zmxl_chl + rtrn )
+ zprod = rday * (zpronewd + zproregd) * zprchld(ji,jj,jk) * xlimdia(ji,jj,jk)
zprochld = thetandm * zprod / ( zpislopeadd(ji,jj,jk) * zdiattot + rtrn )
zprochld = MAX(zprochld, chlcmin * 12. * zprorcad(ji,jj,jk) )
! Update the arrays TRA which contain the Chla sources and sinks
@@ -428,83 +439,104 @@ CONTAINS
END_3D
! Update the arrays TRA which contain the biological sources and sinks
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1)
- zpptot = zpropo4n(ji,jj,jk) + zpropo4d(ji,jj,jk) + zpropo4p(ji,jj,jk)
- zpnewtot = zpronewn(ji,jj,jk) + zpronewd(ji,jj,jk) + zpronewp(ji,jj,jk)
- zpregtot = zproregn(ji,jj,jk) + zproregd(ji,jj,jk) + zproregp(ji,jj,jk)
-
- zprontot = zpronewn(ji,jj,jk) + zproregn(ji,jj,jk)
- zproptot = zpronewp(ji,jj,jk) + zproregp(ji,jj,jk)
- zprodtot = zpronewd(ji,jj,jk) + zproregd(ji,jj,jk)
- !
- zproddoc = excretd * zprorcad(ji,jj,jk) &
- & + excretn * zprorcan(ji,jj,jk) &
- & + excretp * zprorcap(ji,jj,jk)
- !
- zproddop = excretd * zpropo4d(ji,jj,jk) - texcretd * zprodopd(ji,jj,jk) &
- & + excretn * zpropo4n(ji,jj,jk) - texcretn * zprodopn(ji,jj,jk) &
- & + excretp * zpropo4p(ji,jj,jk) - texcretp * zprodopp(ji,jj,jk)
-
- zproddon = excretd * zprodtot + excretn * zprontot + excretp * zproptot
-
- zprodfer = texcretn * zprofen(ji,jj,jk) + texcretd * zprofed(ji,jj,jk) + texcretp * zprofep(ji,jj,jk)
- zresptot = zrespn(ji,jj,jk) + zrespp(ji,jj,jk) + zrespd(ji,jj,jk)
- !
- tr(ji,jj,jk,jppo4,Krhs) = tr(ji,jj,jk,jppo4,Krhs) - zpptot
- tr(ji,jj,jk,jpno3,Krhs) = tr(ji,jj,jk,jpno3,Krhs) - zpnewtot
- tr(ji,jj,jk,jpnh4,Krhs) = tr(ji,jj,jk,jpnh4,Krhs) - zpregtot
- !
- tr(ji,jj,jk,jpphy,Krhs) = tr(ji,jj,jk,jpphy,Krhs) &
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
+ zpronewn = zpronmaxn(ji,jj,jk) * xnanono3(ji,jj,jk)
+ zpronewp = zpronmaxp(ji,jj,jk) * xpicono3(ji,jj,jk)
+ zpronewd = zpronmaxd(ji,jj,jk) * xdiatno3(ji,jj,jk)
+ !
+ zproregn = zpronmaxn(ji,jj,jk) * xnanonh4(ji,jj,jk)
+ zproregp = zpronmaxp(ji,jj,jk) * xpiconh4(ji,jj,jk)
+ zproregd = zpronmaxd(ji,jj,jk) * xdiatnh4(ji,jj,jk)
+ !
+ zpropo4n = zpropmaxn(ji,jj,jk) * xnanopo4(ji,jj,jk)
+ zpropo4p = zpropmaxp(ji,jj,jk) * xpicopo4(ji,jj,jk)
+ zpropo4d = zpropmaxd(ji,jj,jk) * xdiatpo4(ji,jj,jk)
+ !
+ zprodopn = zpropmaxn(ji,jj,jk) * xnanodop(ji,jj,jk)
+ zprodopp = zpropmaxp(ji,jj,jk) * xpicodop(ji,jj,jk)
+ zprodopd = zpropmaxd(ji,jj,jk) * xdiatdop(ji,jj,jk)
+ !
+ zpptot = zpropo4n + zpropo4d + zpropo4p
+ zpnewtot = zpronewn + zpronewd + zpronewp
+ zpregtot = zproregn + zproregd + zproregp
+
+ zprontot = zpronewn + zproregn
+ zproptot = zpronewp + zproregp
+ zprodtot = zpronewd + zproregd
+ !
+ zproddoc = excretd * zprorcad(ji,jj,jk) &
+ & + excretn * zprorcan(ji,jj,jk) &
+ & + excretp * zprorcap(ji,jj,jk)
+ !
+ zproddop = excretd * zpropo4d - texcretd * zprodopd &
+ & + excretn * zpropo4n - texcretn * zprodopn &
+ & + excretp * zpropo4p - texcretp * zprodopp
+
+ zproddon = excretd * zprodtot + excretn * zprontot + excretp * zproptot
+
+ zprodfer = texcretn * zprofen(ji,jj,jk) + texcretd * zprofed(ji,jj,jk) + texcretp * zprofep(ji,jj,jk)
+! CE : zrespn/d/p ????
+! zresptot = zrespn(ji,jj,jk) + zrespp(ji,jj,jk) + zrespd(ji,jj,jk)
+ zresptot = 0._wp
+ !
+ tr(ji,jj,jk,jppo4,Krhs) = tr(ji,jj,jk,jppo4,Krhs) - zpptot
+ tr(ji,jj,jk,jpno3,Krhs) = tr(ji,jj,jk,jpno3,Krhs) - zpnewtot
+ tr(ji,jj,jk,jpnh4,Krhs) = tr(ji,jj,jk,jpnh4,Krhs) - zpregtot
+ !
+ tr(ji,jj,jk,jpphy,Krhs) = tr(ji,jj,jk,jpphy,Krhs) &
& + zprorcan(ji,jj,jk) * texcretn &
- & - xpsino3 * zpronewn(ji,jj,jk) &
- & - xpsinh4 * zproregn(ji,jj,jk) &
- & - zrespn(ji,jj,jk)
-
- tr(ji,jj,jk,jpnph,Krhs) = tr(ji,jj,jk,jpnph,Krhs) + zprontot * texcretn
- tr(ji,jj,jk,jppph,Krhs) = tr(ji,jj,jk,jppph,Krhs) + ( zpropo4n(ji,jj,jk) + zprodopn(ji,jj,jk) ) * texcretn
- tr(ji,jj,jk,jpnfe,Krhs) = tr(ji,jj,jk,jpnfe,Krhs) + zprofen(ji,jj,jk) * texcretn
-
- !
- tr(ji,jj,jk,jppic,Krhs) = tr(ji,jj,jk,jppic,Krhs) &
- & + zprorcap(ji,jj,jk) * texcretp &
- & - xpsino3 * zpronewp(ji,jj,jk) &
- & - xpsinh4 * zproregp(ji,jj,jk) &
- & - zrespp(ji,jj,jk)
-
- tr(ji,jj,jk,jpnpi,Krhs) = tr(ji,jj,jk,jpnpi,Krhs) + zproptot * texcretp
- tr(ji,jj,jk,jpppi,Krhs) = tr(ji,jj,jk,jpppi,Krhs) + ( zpropo4p(ji,jj,jk) + zprodopp(ji,jj,jk) ) * texcretp
- tr(ji,jj,jk,jppfe,Krhs) = tr(ji,jj,jk,jppfe,Krhs) + zprofep(ji,jj,jk) * texcretp
-
- !
- tr(ji,jj,jk,jpdia,Krhs) = tr(ji,jj,jk,jpdia,Krhs) &
- & + zprorcad(ji,jj,jk) * texcretd &
- & - xpsino3 * zpronewd(ji,jj,jk) &
- & - xpsinh4 * zproregd(ji,jj,jk) &
- & - zrespd(ji,jj,jk)
-
- tr(ji,jj,jk,jpndi,Krhs) = tr(ji,jj,jk,jpndi,Krhs) + zprodtot * texcretd
- tr(ji,jj,jk,jppdi,Krhs) = tr(ji,jj,jk,jppdi,Krhs) + ( zpropo4d(ji,jj,jk) + zprodopd(ji,jj,jk) ) * texcretd
- tr(ji,jj,jk,jpdfe,Krhs) = tr(ji,jj,jk,jpdfe,Krhs) + zprofed(ji,jj,jk) * texcretd
- tr(ji,jj,jk,jpdsi,Krhs) = tr(ji,jj,jk,jpdsi,Krhs) + zprmaxd(ji,jj,jk) * zysopt(ji,jj,jk) * rfact2 * tr(ji,jj,jk,jpdia,Kbb)
- tr(ji,jj,jk,jpdoc,Krhs) = tr(ji,jj,jk,jpdoc,Krhs) + zproddoc
- tr(ji,jj,jk,jpdon,Krhs) = tr(ji,jj,jk,jpdon,Krhs) + zproddon
- tr(ji,jj,jk,jpdop,Krhs) = tr(ji,jj,jk,jpdop,Krhs) + zproddop
+ & - xpsino3 * zpronewn &
+ & - xpsinh4 * zproregn
+! & - zrespn(ji,jj,jk)
+
+ tr(ji,jj,jk,jpnph,Krhs) = tr(ji,jj,jk,jpnph,Krhs) + zprontot * texcretn
+ tr(ji,jj,jk,jppph,Krhs) = tr(ji,jj,jk,jppph,Krhs) + ( zpropo4n + zprodopn ) * texcretn
+ tr(ji,jj,jk,jpnfe,Krhs) = tr(ji,jj,jk,jpnfe,Krhs) + zprofen(ji,jj,jk) * texcretn
+
+ !
+ tr(ji,jj,jk,jppic,Krhs) = tr(ji,jj,jk,jppic,Krhs) &
+ & + zprorcap(ji,jj,jk) * texcretp &
+ & - xpsino3 * zpronewp &
+ & - xpsinh4 * zproregp
+! & - zrespp(ji,jj,jk)
+
+ tr(ji,jj,jk,jpnpi,Krhs) = tr(ji,jj,jk,jpnpi,Krhs) + zproptot * texcretp
+ tr(ji,jj,jk,jpppi,Krhs) = tr(ji,jj,jk,jpppi,Krhs) + ( zpropo4p + zprodopp ) * texcretp
+ tr(ji,jj,jk,jppfe,Krhs) = tr(ji,jj,jk,jppfe,Krhs) + zprofep(ji,jj,jk) * texcretp
+
+ !
+ tr(ji,jj,jk,jpdia,Krhs) = tr(ji,jj,jk,jpdia,Krhs) &
+ & + zprorcad(ji,jj,jk) * texcretd &
+ & - xpsino3 * zpronewd &
+ & - xpsinh4 * zproregd
+! & - zrespd(ji,jj,jk)
+
+ !
+ zprodsil = zprmaxd(ji,jj,jk) * zysopt(ji,jj,jk) * rfact2 * tr(ji,jj,jk,jpdia,Kbb)
+ !
+ tr(ji,jj,jk,jpndi,Krhs) = tr(ji,jj,jk,jpndi,Krhs) + zprodtot * texcretd
+ tr(ji,jj,jk,jppdi,Krhs) = tr(ji,jj,jk,jppdi,Krhs) + ( zpropo4d + zprodopd ) * texcretd
+ tr(ji,jj,jk,jpdfe,Krhs) = tr(ji,jj,jk,jpdfe,Krhs) + zprofed(ji,jj,jk) * texcretd
+ tr(ji,jj,jk,jpdsi,Krhs) = tr(ji,jj,jk,jpdsi,Krhs) + zprodsil
+ tr(ji,jj,jk,jpdoc,Krhs) = tr(ji,jj,jk,jpdoc,Krhs) + zproddoc
+ tr(ji,jj,jk,jpdon,Krhs) = tr(ji,jj,jk,jpdon,Krhs) + zproddon
+ tr(ji,jj,jk,jpdop,Krhs) = tr(ji,jj,jk,jpdop,Krhs) + zproddop
- tr(ji,jj,jk,jpoxy,Krhs) = tr(ji,jj,jk,jpoxy,Krhs) &
+ tr(ji,jj,jk,jpoxy,Krhs) = tr(ji,jj,jk,jpoxy,Krhs) &
& + o2ut * zpregtot + ( o2ut + o2nit ) * zpnewtot - o2ut * zresptot
- tr(ji,jj,jk,jpfer,Krhs) = tr(ji,jj,jk,jpfer,Krhs) - zprodfer
- consfe3(ji,jj,jk) = zprodfer * 75.0 / ( rtrn + ( plig(ji,jj,jk) + 75.0 * (1.0 - plig(ji,jj,jk) ) ) &
- & * tr(ji,jj,jk,jpfer,Kbb) ) / rfact2
- tr(ji,jj,jk,jpsil,Krhs) = tr(ji,jj,jk,jpsil,Krhs) - zprmaxd(ji,jj,jk) * zysopt(ji,jj,jk) * rfact2 * tr(ji,jj,jk,jpdia,Kbb)
+ tr(ji,jj,jk,jpfer,Krhs) = tr(ji,jj,jk,jpfer,Krhs) - zprodfer
+ consfe3(ji,jj,jk) = zprodfer * 75.0 / ( rtrn + ( plig(ji,jj,jk) + 75.0 * (1.0 - plig(ji,jj,jk) ) ) &
+ & * tr(ji,jj,jk,jpfer,Kbb) ) / rfact2
+ tr(ji,jj,jk,jpsil,Krhs) = tr(ji,jj,jk,jpsil,Krhs) - zprodsil
- tr(ji,jj,jk,jpdic,Krhs) = tr(ji,jj,jk,jpdic,Krhs) - zpptot &
- & + xpsino3 * zpronewn(ji,jj,jk) + xpsinh4 * zproregn(ji,jj,jk) &
- & + xpsino3 * zpronewp(ji,jj,jk) + xpsinh4 * zproregp(ji,jj,jk) &
- & + xpsino3 * zpronewd(ji,jj,jk) + xpsinh4 * zproregd(ji,jj,jk)
+ tr(ji,jj,jk,jpdic,Krhs) = tr(ji,jj,jk,jpdic,Krhs) - zpptot &
+ & + xpsino3 * zpronewn + xpsinh4 * zproregn &
+ & + xpsino3 * zpronewp + xpsinh4 * zproregp &
+ & + xpsino3 * zpronewd + xpsinh4 * zproregd
- tr(ji,jj,jk,jptal,Krhs) = tr(ji,jj,jk,jptal,Krhs) + rno3 * ( zpnewtot - zpregtot )
- !
+ tr(ji,jj,jk,jptal,Krhs) = tr(ji,jj,jk,jptal,Krhs) + rno3 * ( zpnewtot - zpregtot )
+ !
END_3D
! Production and uptake of ligands by phytoplankton. This part is activated
@@ -513,7 +545,7 @@ CONTAINS
! Shaked and Lis (2012)
! -------------------------------------------------------------------------
IF( ln_ligand ) THEN
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1)
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
zproddoc = excretd * zprorcad(ji,jj,jk) + excretn * zprorcan(ji,jj,jk) + excretp * zprorcap(ji,jj,jk)
zprodfer = texcretn * zprofen(ji,jj,jk) + texcretd * zprofed(ji,jj,jk) + texcretp * zprofep(ji,jj,jk)
zprodlig = plig(ji,jj,jk) / ( rtrn + plig(ji,jj,jk) + 75.0 * (1.0 - plig(ji,jj,jk) ) ) * lthet
@@ -522,47 +554,141 @@ CONTAINS
END_3D
ENDIF
+ ! Output of the diagnostics
! Total primary production per year
- IF( iom_use( "tintpp" ) .OR. ( ln_check_mass .AND. kt == nitend .AND. knt == nrdttrc ) ) &
- & tpp = glob_sum( 'p5zprod', ( zprorcan(:,:,:) + zprorcad(:,:,:) + zprorcap(:,:,:) ) * cvol(:,:,:) )
+ IF( l_dia_ppphy .OR. ( ln_check_mass .AND. kt == nitend .AND. knt == nrdttrc ) ) THEN
+ ALLOCATE( zw3d(A2D(0),jpk) ) ; zw3d(A2D(0),jpk) = 0._wp
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
+ zw3d(ji,jj,jk) = ( zprorcan(ji,jj,jk) + zprorcad(ji,jj,jk) + zprorcap(ji,jj,jk) ) * cvol(ji,jj,jk)
+ END_3D
+ tpp = glob_sum( 'p5zprod', zw3d )
+ DEALLOCATE ( zw3d )
+ ENDIF
IF( lk_iomput .AND. knt == nrdttrc ) THEN
- zfact = 1.e+3 * rfact2r ! conversion from mol/l/kt to mol/m3/s
!
- CALL iom_put( "PPPHYP" , zprorcap(:,:,:) * zfact * tmask(:,:,:) ) ! primary production by picophyto
- CALL iom_put( "PPPHYN" , zprorcan(:,:,:) * zfact * tmask(:,:,:) ) ! primary production by nanophyto
- CALL iom_put( "PPPHYD" , zprorcad(:,:,:) * zfact * tmask(:,:,:) ) ! primary production by diatomes
- CALL iom_put( "PPNEWN" , zpronewp(:,:,:) * zfact * tmask(:,:,:) ) ! new primary production by picophyto
- CALL iom_put( "PPNEWN" , zpronewn(:,:,:) * zfact * tmask(:,:,:) ) ! new primary production by nanophyto
- CALL iom_put( "PPNEWD" , zpronewd(:,:,:) * zfact * tmask(:,:,:) ) ! new primary production by diatomes
- CALL iom_put( "PBSi" , zprmaxd (:,:,:) * zfact * tmask(:,:,:) * zysopt(:,:,:) ) ! biogenic silica production
- CALL iom_put( "PFeP" , zprofep (:,:,:) * zfact * tmask(:,:,:) ) ! biogenic iron production by picophyto
- CALL iom_put( "PFeN" , zprofen(:,:,:) * zfact * tmask(:,:,:) ) ! biogenic iron production by nanophyto
- CALL iom_put( "PFeD" , zprofed(:,:,:) * zfact * tmask(:,:,:) ) ! biogenic iron production by diatomes
- IF( ln_ligand .AND. ( iom_use( "LPRODP" ) .OR. iom_use( "LDETP" ) ) ) THEN
- ALLOCATE( zpligprod(jpi,jpj,jpk) )
- zpligprod(:,:,:) = excretd * zprorcad(:,:,:) + excretn * zprorcan(:,:,:) + excretp * zprorcap(:,:,:)
- CALL iom_put( "LPRODP" , zpligprod(:,:,:) * ldocp * 1e9 * zfact * tmask(:,:,:) )
- !
- zpligprod(:,:,:) = ( texcretn * zprofen(:,:,:) + texcretd * zprofed(:,:,:) + texcretp * zprofep(:,:,:) ) &
- & * plig(:,:,:) / ( rtrn + plig(:,:,:) + 75.0 * (1.0 - plig(:,:,:) ) )
- CALL iom_put( "LDETP" , zpligprod(:,:,:) * lthet * 1e9 * zfact * tmask(:,:,:) )
- DEALLOCATE( zpligprod )
+ IF( l_dia_ppphy ) THEN
+ zfact = 1.e+3 * rfact2r ! conversion from mol/l/kt to mol/m3/s
+ ALLOCATE( zw3d(A2D(0),jpk) ) ; zw3d(A2D(0),jpk) = 0._wp
+ ! primary production by nanophyto
+ zw3d(A2D(0),1:jpkm1) = zprorcan(A2D(0),1:jpkm1) * zfact * tmask(A2D(0),1:jpkm1)
+ CALL iom_put( "PPPHYN", zw3d )
+ ! primary production by diatomes
+ zw3d(A2D(0),1:jpkm1) = zprorcad(A2D(0),1:jpkm1) * zfact * tmask(A2D(0),1:jpkm1)
+ CALL iom_put( "PPPHYD", zw3d )
+ ! primary production by pico
+ zw3d(A2D(0),1:jpkm1) = zprorcap(A2D(0),1:jpkm1) * zfact * tmask(A2D(0),1:jpkm1)
+ CALL iom_put( "PPPHYP", zw3d )
+ ! total primary production
+ zw3d(A2D(0),1:jpkm1) = ( zprorcan(A2D(0),1:jpkm1) + zprorcad(A2D(0),1:jpkm1) + zprorcap(A2D(0),1:jpkm1) ) &
+ & * zfact * tmask(A2D(0),1:jpkm1)
+ CALL iom_put( "TPP", zw3d )
+ CALL iom_put( "tintpp" , tpp * zfact ) ! global total integrated primary production molC/s
+ DEALLOCATE ( zw3d )
+ ENDIF
+ !
+ IF( l_dia_ppnew ) THEN
+ zfact = 1.e+3 * rfact2r ! conversion from mol/l/kt to mol/m3/s
+ ALLOCATE( zw3d(A2D(0),jpk) ) ; zw3d(A2D(0),jpk) = 0._wp
+ ! new primary production by nano
+ zw3d(A2D(0),1:jpkm1) = zpronmaxn(A2D(0),1:jpkm1) * xnanono3(A2D(0),1:jpkm1) * zfact * tmask(A2D(0),1:jpkm1)
+ CALL iom_put( "PPNEWN", zw3d )
+ ! new primary production by diatomes
+ zw3d(A2D(0),1:jpkm1) = zpronmaxd(A2D(0),1:jpkm1) * xdiatno3(A2D(0),1:jpkm1) * zfact * tmask(A2D(0),1:jpkm1)
+ CALL iom_put( "PPNEWD", zw3d )
+ ! new primary production by pico
+ zw3d(A2D(0),1:jpkm1) = zpronmaxp(A2D(0),1:jpkm1) * xpicono3(A2D(0),1:jpkm1) * zfact * tmask(A2D(0),1:jpkm1)
+ CALL iom_put( "PPNEWP", zw3d )
+ ! total new production
+ zw3d(A2D(0),1:jpkm1) = ( zpronmaxn(A2D(0),1:jpkm1) * xnanono3(A2D(0),1:jpkm1) + &
+ & zpronmaxd(A2D(0),1:jpkm1) * xdiatno3(A2D(0),1:jpkm1) + &
+ & zpronmaxp(A2D(0),1:jpkm1) * xpicono3(A2D(0),1:jpkm1) ) &
+ & * zfact * tmask(A2D(0),1:jpkm1)
+ CALL iom_put( "TPNEW", zw3d )
+ DEALLOCATE ( zw3d )
ENDIF
- CALL iom_put( "Mumax" , zprmaxn(:,:,:) * tmask(:,:,:) ) ! Maximum growth rate
- CALL iom_put( "MuP" , zprpic(:,:,:) * xlimpic(:,:,:) * tmask(:,:,:) ) ! Realized growth rate for picophyto
- CALL iom_put( "MuN" , zprbio(:,:,:) * xlimphy(:,:,:) * tmask(:,:,:) ) ! Realized growth rate for nanophyto
- CALL iom_put( "MuD" , zprdia(:,:,:) * xlimdia(:,:,:) * tmask(:,:,:) ) ! Realized growth rate for diatoms
- CALL iom_put( "LPlight" , zprpic(:,:,:) / (zprmaxp(:,:,:) + rtrn) * tmask(:,:,:) ) ! light limitation term
- CALL iom_put( "LNlight" , zprbio(:,:,:) / (zprmaxn(:,:,:) + rtrn) * tmask(:,:,:) ) ! light limitation term
- CALL iom_put( "LDlight" , zprdia(:,:,:) / (zprmaxd(:,:,:) + rtrn) * tmask(:,:,:) )
- CALL iom_put( "MunetP" , ( tr(:,:,:,jppic,Krhs)/rfact2/(tr(:,:,:,jppic,Kbb)+ rtrn ) * tmask(:,:,:)) ) ! Realized growth rate for picophyto
- CALL iom_put( "MunetN" , ( tr(:,:,:,jpphy,Krhs)/rfact2/(tr(:,:,:,jpphy,Kbb)+ rtrn ) * tmask(:,:,:)) ) ! Realized growth rate for picophyto
- CALL iom_put( "MunetD" , ( tr(:,:,:,jpdia,Krhs)/rfact2/(tr(:,:,:,jpdia,Kbb)+ rtrn ) * tmask(:,:,:)) ) ! Realized growth rate for picophyto
- CALL iom_put( "TPP" , ( zprorcap(:,:,:) + zprorcan(:,:,:) + zprorcad(:,:,:) ) * zfact * tmask(:,:,:) ) ! total primary production
- CALL iom_put( "TPNEW" , ( zpronewp(:,:,:) + zpronewn(:,:,:) + zpronewd(:,:,:) ) * zfact * tmask(:,:,:) ) ! total new production
- CALL iom_put( "TPBFE" , ( zprofep (:,:,:) + zprofen (:,:,:) + zprofed (:,:,:) ) * zfact * tmask(:,:,:) ) ! total biogenic iron production
- CALL iom_put( "tintpp" , tpp * zfact ) ! global total integrated primary production molC/s
+ !
+ IF( l_dia_ppbsi ) THEN
+ zfact = 1.e+3 * rfact2r ! conversion from mol/l/kt to mol/m3/s
+ ALLOCATE( zw3d(A2D(0),jpk) ) ; zw3d(A2D(0),jpk) = 0._wp
+ ! biogenic silica production
+ zw3d(A2D(0),1:jpkm1) = zprmaxd(A2D(0),1:jpkm1) * zysopt(A2D(0),1:jpkm1) &
+ & * zfact * tmask(A2D(0),1:jpkm1)
+ CALL iom_put( "PBSi", zw3d )
+ DEALLOCATE ( zw3d )
+ ENDIF
+ !
+ !
+ IF( l_dia_ppbfe ) THEN
+ zfact = 1.e+3 * rfact2r ! conversion from mol/l/kt to mol/m3/s
+ ALLOCATE( zw3d(A2D(0),jpk) ) ; zw3d(A2D(0),jpk) = 0._wp
+ ! biogenic iron production by nanophyto
+ zw3d(A2D(0),1:jpkm1) = zprofen(A2D(0),1:jpkm1) * zfact * tmask(A2D(0),1:jpkm1)
+ CALL iom_put( "PFeN", zw3d )
+ ! biogenic iron production by diatomes
+ zw3d(A2D(0),1:jpkm1) = zprofed(A2D(0),1:jpkm1) * zfact * tmask(A2D(0),1:jpkm1)
+ CALL iom_put( "PFeD", zw3d )
+ ! biogenic iron production by pico
+ zw3d(A2D(0),1:jpkm1) = zprofep(A2D(0),1:jpkm1) * zfact * tmask(A2D(0),1:jpkm1)
+ CALL iom_put( "PFeP", zw3d )
+ ! total biogenic iron production
+ zw3d(A2D(0),1:jpkm1) = ( zprofen(A2D(0),1:jpkm1) + zprofed(A2D(0),1:jpkm1) + zprofep(A2D(0),1:jpkm1) ) &
+ & * zfact * tmask(A2D(0),1:jpkm1)
+ CALL iom_put( "TPBFE", zw3d )
+ DEALLOCATE ( zw3d )
+ ENDIF
+ !
+ IF( l_dia_mu ) THEN
+ zfact = 1.e+3 * rfact2r ! conversion from mol/l/kt to mol/m3/s
+ ALLOCATE( zw3d(A2D(0),jpk) ) ; zw3d(A2D(0),jpk) = 0._wp
+ zw3d(A2D(0),1:jpkm1) = zprmaxn(A2D(0),1:jpkm1) * tmask(A2D(0),1:jpkm1)
+ CALL iom_put( "Mumax", zw3d )
+ ! Realized growth rate for nanophyto
+ zw3d(A2D(0),1:jpkm1) = zprbio(A2D(0),1:jpkm1) * xlimphy(A2D(0),1:jpkm1) * tmask(A2D(0),1:jpkm1)
+ CALL iom_put( "MuN", zw3d )
+ ! Realized growth rate for diatoms
+ zw3d(A2D(0),1:jpkm1) = zprdia(A2D(0),1:jpkm1) * xlimdia(A2D(0),1:jpkm1) * tmask(A2D(0),1:jpkm1)
+ CALL iom_put( "MuD", zw3d )
+ ! Realized growth rate for pico
+ zw3d(A2D(0),1:jpkm1) = zprpic(A2D(0),1:jpkm1) * xlimpic(A2D(0),1:jpkm1) * tmask(A2D(0),1:jpkm1)
+ CALL iom_put( "MuP", zw3d )
+ DEALLOCATE ( zw3d )
+ ENDIF
+ !
+ !
+ IF( l_dia_light ) THEN
+ zfact = 1.e+3 * rfact2r ! conversion from mol/l/kt to mol/m3/s
+ ALLOCATE( zw3d(A2D(0),jpk) ) ; zw3d(A2D(0),jpk) = 0._wp
+ ! light limitation term for nano
+ zw3d(A2D(0),1:jpkm1) = zprbio(A2D(0),1:jpkm1) / (zprmaxn(A2D(0),1:jpkm1)+rtrn) &
+ & * tmask(A2D(0),1:jpkm1)
+ CALL iom_put( "LNlight", zw3d )
+ ! light limitation term for diatomes
+ zw3d(A2D(0),1:jpkm1) = zprdia(A2D(0),1:jpkm1) / (zprmaxd(A2D(0),1:jpkm1)+rtrn) &
+ & * tmask(A2D(0),1:jpkm1)
+ CALL iom_put( "LDlight", zw3d )
+ ! light limitation term for pico
+ zw3d(A2D(0),1:jpkm1) = zprpic(A2D(0),1:jpkm1) / (zprmaxp(A2D(0),1:jpkm1)+rtrn) &
+ & * tmask(A2D(0),1:jpkm1)
+ CALL iom_put( "LPlight", zw3d )
+ DEALLOCATE ( zw3d )
+ ENDIF
+ !
+ IF( l_dia_lprod ) THEN
+ zfact = 1.e+3 * rfact2r ! conversion from mol/l/kt to mol/m3/s
+ ALLOCATE( zw3d(A2D(0),jpk) ) ; zw3d(A2D(0),jpk) = 0._wp
+ zw3d(A2D(0),1:jpkm1) = ( excretd * zprorcad(A2D(0),1:jpkm1) + excretn * zprorcan(A2D(0),1:jpkm1) + &
+ & excretp * zprorcap(A2D(0),1:jpkm1) ) * zfact * tmask(A2D(0),1:jpkm1)
+ CALL iom_put( "LPRODP" , zw3d * ldocp * 1e9 )
+ !
+ zw3d(A2D(0),1:jpkm1) = ( texcretn * zprofen(A2D(0),1:jpkm1) + texcretd * zprofed(A2D(0),1:jpkm1) + &
+ & texcretp * zprofep(A2D(0),1:jpkm1) ) * plig(A2D(0),1:jpkm1) &
+ & / ( rtrn + plig(A2D(0),1:jpkm1) + 75.0 * (1.0 - plig(A2D(0),1:jpkm1) ) ) &
+ & * zfact * tmask(A2D(0),1:jpkm1)
+ CALL iom_put( "LDETP" , zw3d * lthet * 1e9 )
+ DEALLOCATE ( zw3d )
+ ENDIF
+ !
ENDIF
IF(sn_cfctl%l_prttrc) THEN ! print mean trends (used for debugging)
@@ -625,17 +751,11 @@ CONTAINS
texcretd = 1._wp - excretd
tpp = 0._wp
!
+ xq10_n = 1. + xpsino3 * qnnmax
+ xq10_d = 1. + xpsino3 * qndmax
+ xq10_p = 1. + xpsino3 * qnpmax
+ !
END SUBROUTINE p5z_prod_init
-
- INTEGER FUNCTION p5z_prod_alloc()
- !!----------------------------------------------------------------------
- !! *** ROUTINE p5z_prod_alloc ***
- !!----------------------------------------------------------------------
- ALLOCATE( zdaylen(jpi,jpj), STAT = p5z_prod_alloc )
- !
- IF( p5z_prod_alloc /= 0 ) CALL ctl_stop( 'STOP', 'p5z_prod_alloc : failed to allocate arrays.' )
- !
- END FUNCTION p5z_prod_alloc
!!======================================================================
END MODULE p5zprod
diff --git a/src/TOP/PISCES/SED/oce_sed.F90 b/src/TOP/PISCES/SED/oce_sed.F90
index 00b3385f25078b3d45c757bf137063b27605e8c5..71754971c1ab944b1b6d358e6dbda46a85221993 100644
--- a/src/TOP/PISCES/SED/oce_sed.F90
+++ b/src/TOP/PISCES/SED/oce_sed.F90
@@ -14,12 +14,15 @@ MODULE oce_sed
USE dom_oce , ONLY : glamt => glamt !: longitude of t-point (degre)
USE dom_oce , ONLY : gphit => gphit !: latitude of t-point (degre)
-#if defined key_qco || defined key_linssh
-#else
- USE dom_oce , ONLY : e3t => e3t !: latitude of t-point (degre)
-#endif
USE dom_oce , ONLY : e3t_1d => e3t_1d !: reference depth of t-points (m)
- USE dom_oce , ONLY : gdepw_0 => gdepw_0 !: reference depth of t-points (m)
+ USE dom_oce , ONLY : gdepw_1d => gdepw_1d !: reference depth of t-points (m)
+
+#if defined key_vco_1d3d || defined key_vco_3d
+ USE dom_oce , ONLY : e3t_3d => e3t_3d !: reference depth of t-points (m)
+# if defined key_vco_3d
+ USE dom_oce , ONLY : gdepw_3d => gdepw_3d !: reference depth of t-points (m)
+# endif
+#endif
USE dom_oce , ONLY : mbkt => mbkt !: vertical index of the bottom last T- ocean level
USE dom_oce , ONLY : tmask => tmask !: land/ocean mask at t-points
USE dom_oce , ONLY : rn_Dt => rn_Dt !: time step for the dynamics
diff --git a/src/TOP/PISCES/SED/sedchem.F90 b/src/TOP/PISCES/SED/sedchem.F90
index afdc80a1c67aab714f5fa287713a32a89e0d549b..8c5d9e50f5489955f9c67460925dc769507c1c58 100644
--- a/src/TOP/PISCES/SED/sedchem.F90
+++ b/src/TOP/PISCES/SED/sedchem.F90
@@ -138,7 +138,7 @@ CONTAINS
IF (ln_sediment_offline) THEN
CALL sed_chem_cst
ELSE
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
ikt = mbkt(ji,jj)
IF ( tmask(ji,jj,ikt) == 1 ) THEN
zchem_data(ji,jj,1) = ak13 (ji,jj,ikt)
diff --git a/src/TOP/PISCES/SED/sedini.F90 b/src/TOP/PISCES/SED/sedini.F90
index 329503ae33a2bffddcbf7be18d0e636da7ed4f49..fae7793c9bf64a8f41e80c6dd33fbf68515ffd1e 100644
--- a/src/TOP/PISCES/SED/sedini.F90
+++ b/src/TOP/PISCES/SED/sedini.F90
@@ -81,6 +81,7 @@ MODULE sedini
!! * Substitutions
# include "do_loop_substitute.h90"
+# include "domzgr_substitute.h90"
!! $Id: sedini.F90 15450 2021-10-27 14:32:08Z cetlod $
CONTAINS
diff --git a/src/TOP/PISCES/SED/sedsfc.F90 b/src/TOP/PISCES/SED/sedsfc.F90
index 460d760d94900d1ae159b9ec11b90db666977c74..9e36c0727122b19e610eb26dd9429fe8a4c0391e 100644
--- a/src/TOP/PISCES/SED/sedsfc.F90
+++ b/src/TOP/PISCES/SED/sedsfc.F90
@@ -49,7 +49,7 @@ CONTAINS
CALL unpack_arr ( jpoce, trc_data(1:jpi,1:jpj,8), iarroce(1:jpoce), pwcp(1:jpoce,1,jwfe2) )
CALL unpack_arr ( jpoce, trc_data(1:jpi,1:jpj,9), iarroce(1:jpoce), pwcp(1:jpoce,1,jwlgw) )
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
ikt = mbkt(ji,jj)
IF ( tmask(ji,jj,ikt) == 1 ) THEN
tr(ji,jj,ikt,jptal,Kbb) = trc_data(ji,jj,1)
diff --git a/src/TOP/PISCES/SED/trcdmp_sed.F90 b/src/TOP/PISCES/SED/trcdmp_sed.F90
index 190206e5482ee8c689af5e05cc59dba609a27c6b..b17ee20af3b24bf6bd9470d3d90afaf16df726e9 100644
--- a/src/TOP/PISCES/SED/trcdmp_sed.F90
+++ b/src/TOP/PISCES/SED/trcdmp_sed.F90
@@ -92,7 +92,7 @@ CONTAINS
jl = n_trc_index(jn)
CALL trc_dta( kt, jl, ztrcdta ) ! read tracer data at nit000
!
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
ikt = mbkt(ji,jj)
tr(ji,jj,ikt,jn,Kbb) = ztrcdta(ji,jj,ikt) + ( tr(ji,jj,ikt,jn,Kbb) - ztrcdta(ji,jj,ikt) ) &
& * exp( -restosed(ji,jj,ikt) * dtsed )
diff --git a/src/TOP/PISCES/sms_pisces.F90 b/src/TOP/PISCES/sms_pisces.F90
index ba890a006293caee267e405e6f29a9ed15445d83..e4862e94983ae2c3e7157d98e0bf86a5fc69529b 100644
--- a/src/TOP/PISCES/sms_pisces.F90
+++ b/src/TOP/PISCES/sms_pisces.F90
@@ -124,6 +124,8 @@ MODULE sms_pisces
LOGICAL, SAVE :: lk_sed
+ !! * Substitutions
+# include "do_loop_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/TOP 4.0 , NEMO Consortium (2018)
!! $Id: sms_pisces.F90 15459 2021-10-29 08:19:18Z cetlod $
@@ -140,52 +142,52 @@ CONTAINS
!!----------------------------------------------------------------------
ierr(:) = 0
!* Biological fluxes for light : shared variables for pisces & lobster
- ALLOCATE( xksi(jpi,jpj), strn(jpi,jpj), STAT=ierr(1) )
+ ALLOCATE( xksi(A2D(0)), strn(A2D(0)), STAT=ierr(1) )
IF( ln_p4z .OR. ln_p5z ) THEN
!* Optics
- ALLOCATE( enano(jpi,jpj,jpk) , ediat(jpi,jpj,jpk) , &
- & enanom(jpi,jpj,jpk), ediatm(jpi,jpj,jpk), &
- & emoy(jpi,jpj,jpk) , etotm(jpi,jpj,jpk), STAT=ierr(2) )
+ ALLOCATE( enano(A2D(0),jpk) , ediat(A2D(0),jpk) , &
+ & enanom(A2D(0),jpk), ediatm(A2D(0),jpk), &
+ & emoy(A2D(0),jpk) , etotm(A2D(0),jpk), STAT=ierr(2) )
!* Biological SMS
- ALLOCATE( xksimax(jpi,jpj) , biron(jpi,jpj,jpk) , STAT=ierr(3) )
+ ALLOCATE( xksimax(A2D(0)) , biron(A2D(0),jpk) , STAT=ierr(3) )
! Biological SMS
- ALLOCATE( xfracal (jpi,jpj,jpk), orem (jpi,jpj,jpk), &
- & nitrfac (jpi,jpj,jpk), nitrfac2(jpi,jpj,jpk), &
- & prodcal (jpi,jpj,jpk), xdiss (jpi,jpj,jpk), &
- & prodpoc (jpi,jpj,jpk), conspoc (jpi,jpj,jpk), &
- & prodgoc (jpi,jpj,jpk), consgoc (jpi,jpj,jpk), &
- & blim (jpi,jpj,jpk), consfe3 (jpi,jpj,jpk), &
- & xfecolagg(jpi,jpj,jpk), xcoagfe (jpi,jpj,jpk), STAT=ierr(4) )
+ ALLOCATE( xfracal (A2D(0),jpk), orem (A2D(0),jpk), &
+ & nitrfac (A2D(0),jpk), nitrfac2(A2D(0),jpk), &
+ & prodcal (A2D(0),jpk), xdiss (A2D(0),jpk), &
+ & prodpoc (A2D(0),jpk), conspoc (A2D(0),jpk), &
+ & prodgoc (A2D(0),jpk), consgoc (A2D(0),jpk), &
+ & blim (A2D(0),jpk), consfe3 (A2D(0),jpk), &
+ & xfecolagg(A2D(0),jpk), xcoagfe (A2D(0),jpk), STAT=ierr(4) )
!* Carbonate chemistry
- ALLOCATE( ak13 (jpi,jpj,jpk) , &
- & ak23(jpi,jpj,jpk) , aksp (jpi,jpj,jpk) , &
- & hi (jpi,jpj,jpk) , excess(jpi,jpj,jpk) , &
- & aphscale(jpi,jpj,jpk), STAT=ierr(5) )
+ ALLOCATE( ak13(A2D(0),jpk), &
+ & ak23(A2D(0),jpk), aksp (A2D(0),jpk) , &
+ & hi (A2D(0),jpk), excess(A2D(0),jpk) , &
+ & aphscale(A2D(0),jpk), STAT=ierr(5) )
!
!* Temperature dependency of SMS terms
- ALLOCATE( tgfunc (jpi,jpj,jpk) , tgfunc2(jpi,jpj,jpk), STAT=ierr(6) )
+ ALLOCATE( tgfunc (A2D(0),jpk) , tgfunc2(A2D(0),jpk), STAT=ierr(6) )
!
!* Sinking speed
- ALLOCATE( wsbio3 (jpi,jpj,jpk) , wsbio4 (jpi,jpj,jpk), STAT=ierr(7) )
+ ALLOCATE( wsbio3 (A2D(0),jpk) , wsbio4 (A2D(0),jpk), STAT=ierr(7) )
!* Size of phytoplankton cells
- ALLOCATE( sizen (jpi,jpj,jpk), sized (jpi,jpj,jpk), &
- & sizena(jpi,jpj,jpk), sizeda(jpi,jpj,jpk), STAT=ierr(8) )
+ ALLOCATE( sizen (A2D(0),jpk), sized (A2D(0),jpk), &
+ & sizena(A2D(0),jpk), sizeda(A2D(0),jpk), STAT=ierr(8) )
!
- ALLOCATE( plig(jpi,jpj,jpk) , STAT=ierr(9) )
+ ALLOCATE( plig(A2D(0),jpk) , STAT=ierr(9) )
ENDIF
!
IF( ln_p5z ) THEN
! PISCES-QUOTA specific part
- ALLOCATE( epico(jpi,jpj,jpk) , epicom(jpi,jpj,jpk) , STAT=ierr(10) )
+ ALLOCATE( epico(A2D(0),jpk) , epicom(A2D(0),jpk) , STAT=ierr(10) )
!* Size of phytoplankton cells
- ALLOCATE( sizep(jpi,jpj,jpk), sizepa(jpi,jpj,jpk), STAT=ierr(11) )
+ ALLOCATE( sizep(A2D(0),jpk), sizepa(A2D(0),jpk), STAT=ierr(11) )
ENDIF
!
sms_pisces_alloc = MAXVAL( ierr )
diff --git a/src/TOP/PISCES/trcice_pisces.F90 b/src/TOP/PISCES/trcice_pisces.F90
index 8ce76bc76b9740e84bcd3bac29fea74ad22daae7..06e458a54852ae81a83dc6da4f26c0d7d9c97b60 100644
--- a/src/TOP/PISCES/trcice_pisces.F90
+++ b/src/TOP/PISCES/trcice_pisces.F90
@@ -19,6 +19,8 @@ MODULE trcice_pisces
PUBLIC trc_ice_ini_pisces ! called by trcini.F90 module
+ !! * Substitutions
+# include "do_loop_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/TOP 4.0 , NEMO Consortium (2018)
!! $Id: trcice_pisces.F90 10794 2019-03-22 09:25:28Z cetlod $
@@ -283,15 +285,15 @@ CONTAINS
ENDIF
!
DO jn = jp_pcs0, jp_pcs1
- IF( cn_trc_o(jn) == 'GL ' ) trc_o(:,:,jn) = zpisc(jn,1) ! Global case
+ IF( cn_trc_o(jn) == 'GL ' ) trc_o(A2D(0),jn) = zpisc(jn,1) ! Global case
IF( cn_trc_o(jn) == 'AA ' ) THEN
- WHERE( gphit(:,:) >= 0._wp ) ; trc_o(:,:,jn) = zpisc(jn,2) ; END WHERE ! Arctic
- WHERE( gphit(:,:) < 0._wp ) ; trc_o(:,:,jn) = zpisc(jn,3) ; END WHERE ! Antarctic
+ WHERE( gphit(A2D(0)) >= 0._wp ) ; trc_o(A2D(0),jn) = zpisc(jn,2) ; END WHERE ! Arctic
+ WHERE( gphit(A2D(0)) < 0._wp ) ; trc_o(A2D(0),jn) = zpisc(jn,3) ; END WHERE ! Antarctic
ENDIF
IF( cn_cfg == "orca" .OR. cn_cfg == "ORCA" ) THEN ! Baltic Sea particular case for ORCA configurations
- WHERE( 14._wp <= glamt(:,:) .AND. glamt(:,:) <= 32._wp .AND. &
- 54._wp <= gphit(:,:) .AND. gphit(:,:) <= 66._wp )
- trc_o(:,:,jn) = zpisc(jn,4)
+ WHERE( 14._wp <= glamt(A2D(0)) .AND. glamt(A2D(0)) <= 32._wp .AND. &
+ 54._wp <= gphit(A2D(0)) .AND. gphit(A2D(0)) <= 66._wp )
+ trc_o(A2D(0),jn) = zpisc(jn,4)
END WHERE
ENDIF
ENDDO
@@ -321,16 +323,16 @@ CONTAINS
DO jn = jp_pcs0, jp_pcs1
!-- Everywhere but in the Baltic
IF ( trc_ice_ratio(jn) >= -1._wp ) THEN ! no prescribed conc. ; typically everything but iron)
- trc_i(:,:,jn) = zratio(jn,1) * trc_o(:,:,jn)
+ trc_i(A2D(0),jn) = zratio(jn,1) * trc_o(A2D(0),jn)
ELSE ! prescribed concentration
- trc_i(:,:,jn) = trc_ice_prescr(jn)
+ trc_i(A2D(0),jn) = trc_ice_prescr(jn)
ENDIF
!-- Baltic
IF( cn_cfg == "orca" .OR. cn_cfg == "ORCA" ) THEN
IF ( trc_ice_ratio(jn) >= - 1._wp ) THEN ! no prescribed conc. ; typically everything but iron)
- WHERE( 14._wp <= glamt(:,:) .AND. glamt(:,:) <= 32._wp .AND. &
- 54._wp <= gphit(:,:) .AND. gphit(:,:) <= 66._wp )
- trc_i(:,:,jn) = zratio(jn,2) * trc_o(:,:,jn)
+ WHERE( 14._wp <= glamt(A2D(0)) .AND. glamt(A2D(0)) <= 32._wp .AND. &
+ 54._wp <= gphit(A2D(0)) .AND. gphit(A2D(0)) <= 66._wp )
+ trc_i(A2D(0),jn) = zratio(jn,2) * trc_o(A2D(0),jn)
END WHERE
ENDIF
ENDIF
diff --git a/src/TOP/PISCES/trcini_pisces.F90 b/src/TOP/PISCES/trcini_pisces.F90
index f47975faa06b9538176c67fb49955384f18f274d..eaaac7e2cd486fab3aad2498f24796ce0256ae64 100644
--- a/src/TOP/PISCES/trcini_pisces.F90
+++ b/src/TOP/PISCES/trcini_pisces.F90
@@ -123,7 +123,6 @@ CONTAINS
ELSE
! PISCES-QUOTA part
ierr = ierr + p5z_lim_alloc()
- ierr = ierr + p5z_prod_alloc()
ierr = ierr + p5z_meso_alloc()
ENDIF
ierr = ierr + p4z_rem_alloc()
diff --git a/src/TOP/PISCES/trcwri_pisces.F90 b/src/TOP/PISCES/trcwri_pisces.F90
index e5cce04d5a93d31375531ac4d92fb9e5e00a2520..d44b7b11eaa800b2cb374084b3cd80f5dae4fb93 100644
--- a/src/TOP/PISCES/trcwri_pisces.F90
+++ b/src/TOP/PISCES/trcwri_pisces.F90
@@ -38,7 +38,7 @@ CONTAINS
CHARACTER (len=20) :: cltra
REAL(wp) :: zfact
INTEGER :: ji, jj, jk, jn
- REAL(wp), DIMENSION(jpi,jpj) :: zdic, zo2min, zdepo2min
+ REAL(wp), DIMENSION(A2D(0)) :: zdic, zo2min, zdepo2min
!!---------------------------------------------------------------------
! write the tracer concentrations in the file
@@ -60,15 +60,19 @@ CONTAINS
IF( iom_use( "INTDIC" ) ) THEN ! DIC content in kg/m2
zdic(:,:) = 0.
DO jk = 1, jpkm1
- zdic(:,:) = zdic(:,:) + tr(:,:,jk,jpdic,Kmm) * e3t(:,:,jk,Kmm) * tmask(:,:,jk) * 12.
+ DO_2D( 0, 0, 0, 0 )
+ zdic(ji,jj) = zdic(ji,jj) + tr(ji,jj,jk,jpdic,Kmm) * e3t(ji,jj,jk,Kmm) * tmask(ji,jj,jk) * 12.
+ END_2D
ENDDO
- CALL iom_put( 'INTDIC', zdic )
+ CALL iom_put( 'INTDIC', zdic )
ENDIF
!
- IF( iom_use( "O2MIN" ) .OR. iom_use ( "ZO2MIN" ) ) THEN ! Oxygen minimum concentration and depth
- zo2min (:,:) = tr(:,:,1,jpoxy,Kmm) * tmask(:,:,1)
- zdepo2min(:,:) = gdepw(:,:,1,Kmm) * tmask(:,:,1)
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 2, jpkm1 )
+ IF( iom_use( "O2MIN" ) .OR. iom_use ( "ZO2MIN" ) ) THEN ! Oxygen minimum concentration and depth
+ DO_2D( 0, 0, 0, 0 )
+ zo2min (ji,jj) = tr(ji,jj,1,jpoxy,Kmm) * tmask(ji,jj,1)
+ zdepo2min(ji,jj) = gdepw(ji,jj,1,Kmm) * tmask(ji,jj,1)
+ END_2D
+ DO_3D( 0, 0, 0, 0, 2, jpkm1 )
IF( tmask(ji,jj,jk) == 1 ) then
IF( tr(ji,jj,jk,jpoxy,Kmm) < zo2min(ji,jj) ) then
zo2min (ji,jj) = tr(ji,jj,jk,jpoxy,Kmm)
diff --git a/src/TOP/TRP/trcadv.F90 b/src/TOP/TRP/trcadv.F90
index 92bee0044c27efbfacf9fc15ad7301e19bb607b0..243624840a6a0de2b037fc075ae868c8e5b5ff78 100644
--- a/src/TOP/TRP/trcadv.F90
+++ b/src/TOP/TRP/trcadv.F90
@@ -8,6 +8,7 @@ MODULE trcadv
!! 3.7 ! 2014-05 (G. Madec, C. Ethe) Add 2nd/4th order cases for CEN and FCT schemes
!! 4.0 ! 2017-09 (G. Madec) remove vertical time-splitting option
!! 4.5 ! 2021-08 (G. Madec, S. Techene) add advective velocities as optional arguments
+ !! - ! 2022-06 (S. Techene, G, Madec) refactorization to reduce local memory usage
!!----------------------------------------------------------------------
#if defined key_top
!!----------------------------------------------------------------------
@@ -123,26 +124,19 @@ CONTAINS
!
IF( ln_wave .AND. ln_sdw ) THEN
DO_3D( nn_hls, nn_hls-1, nn_hls, nn_hls-1, 1, jpkm1 ) ! eulerian transport + Stokes Drift
- zuu(ji,jj,jk) = e2u (ji,jj) * e3u(ji,jj,jk,Kmm) * ( zptu(ji,jj,jk) + usd(ji,jj,jk) )
- zvv(ji,jj,jk) = e1v (ji,jj) * e3v(ji,jj,jk,Kmm) * ( zptv(ji,jj,jk) + vsd(ji,jj,jk) )
+ zuu(ji,jj,jk) = e2u(ji,jj) * e3u(ji,jj,jk,Kmm) * ( zptu(ji,jj,jk) + usd(ji,jj,jk) )
+ zvv(ji,jj,jk) = e1v(ji,jj) * e3v(ji,jj,jk,Kmm) * ( zptv(ji,jj,jk) + vsd(ji,jj,jk) )
END_3D
DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpkm1 )
- zww(ji,jj,jk) = e1e2t(ji,jj) * ( zptw(ji,jj,jk) + wsd(ji,jj,jk) )
+ zww(ji,jj,jk) = e1e2t(ji,jj) * ( zptw(ji,jj,jk) + wsd(ji,jj,jk) )
END_3D
ELSE
DO_3D( nn_hls, nn_hls-1, nn_hls, nn_hls-1, 1, jpkm1 )
- zuu(ji,jj,jk) = e2u (ji,jj) * e3u(ji,jj,jk,Kmm) * zptu(ji,jj,jk) ! eulerian transport
- zvv(ji,jj,jk) = e1v (ji,jj) * e3v(ji,jj,jk,Kmm) * zptv(ji,jj,jk)
+ zuu(ji,jj,jk) = e2u(ji,jj) * e3u(ji,jj,jk,Kmm) * zptu(ji,jj,jk) ! eulerian transport
+ zvv(ji,jj,jk) = e1v(ji,jj) * e3v(ji,jj,jk,Kmm) * zptv(ji,jj,jk)
END_3D
DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpkm1 )
- zww(ji,jj,jk) = e1e2t(ji,jj) * zptw(ji,jj,jk)
- END_3D
- ENDIF
- !
- IF( ln_vvl_ztilde .OR. ln_vvl_layer ) THEN ! add z-tilde and/or vvl corrections
- DO_3D( nn_hls, nn_hls-1, nn_hls, nn_hls-1, 1, jpkm1 )
- zuu(ji,jj,jk) = zuu(ji,jj,jk) + un_td(ji,jj,jk)
- zvv(ji,jj,jk) = zvv(ji,jj,jk) + vn_td(ji,jj,jk)
+ zww(ji,jj,jk) = e1e2t(ji,jj) * zptw(ji,jj,jk)
END_3D
ENDIF
!
@@ -156,15 +150,15 @@ CONTAINS
SELECT CASE ( nadv ) !== compute advection trend and add it to general trend ==!
!
CASE ( np_CEN ) ! Centered : 2nd / 4th order
- CALL tra_adv_cen ( kt, nittrc000,'TRC', zuu, zvv, zww, Kmm, ptr, jptra, Krhs, nn_cen_h, nn_cen_v )
+ CALL tra_adv_cen( kt, nittrc000,'TRC', zuu, zvv, zww, Kmm, ptr, jptra, Krhs, nn_cen_h, nn_cen_v )
CASE ( np_FCT ) ! FCT : 2nd / 4th order
- CALL tra_adv_fct( kt, nittrc000,'TRC', rDt_trc, zuu, zvv, zww, Kbb, Kmm, Kaa, ptr, jptra, Krhs, nn_fct_h, nn_fct_v )
+ CALL tra_adv_fct( kt, nittrc000,'TRC', rDt_trc, zuu, zvv, zww, Kbb, Kmm, Kaa, ptr, jptra, Krhs, nn_fct_h, nn_fct_v )
CASE ( np_MUS ) ! MUSCL
- CALL tra_adv_mus( kt, nittrc000,'TRC', rDt_trc, zuu, zvv, zww, Kbb, Kmm, ptr, jptra, Krhs, ln_mus_ups )
+ CALL tra_adv_mus( kt, nittrc000,'TRC', rDt_trc, zuu, zvv, zww, Kbb, Kmm, ptr, jptra, Krhs, ln_mus_ups )
CASE ( np_UBS ) ! UBS
- CALL tra_adv_ubs ( kt, nittrc000,'TRC', rDt_trc, zuu, zvv, zww, Kbb, Kmm, ptr, jptra, Krhs, nn_ubs_v )
+ CALL tra_adv_ubs( kt, nittrc000,'TRC', rDt_trc, zuu, zvv, zww, Kbb, Kmm, ptr, jptra, Krhs, nn_ubs_v )
CASE ( np_QCK ) ! QUICKEST
- CALL tra_adv_qck ( kt, nittrc000,'TRC', rDt_trc, zuu, zvv, zww, Kbb, Kmm, ptr, jptra, Krhs )
+ CALL tra_adv_qck( kt, nittrc000,'TRC', rDt_trc, zuu, zvv, zww, Kbb, Kmm, ptr, jptra, Krhs )
!
END SELECT
!
diff --git a/src/TOP/TRP/trcatf.F90 b/src/TOP/TRP/trcatf.F90
index 9a2f4e2ed9b169e71e86e0092b57d9ac5e9678db..5f13e2908c7c3d9457e3cdae21f9d613857e88b2 100644
--- a/src/TOP/TRP/trcatf.F90
+++ b/src/TOP/TRP/trcatf.F90
@@ -19,6 +19,7 @@ MODULE trcatf
!! 3.1 ! 2009-02 (G. Madec, R. Benshila) re-introduce the vvl option
!! 3.3 ! 2010-06 (C. Ethe, G. Madec) Merge TRA-TRC
!! 4.1 ! 2019-08 (A. Coward, D. Storkey) rename trcnxt.F90 -> trcatf.F90. Now only does time filtering.
+ !! 4.x ! 2022-12 (S. Techene, G.Madec) remove vvl use qco exclusively
!!----------------------------------------------------------------------
#if defined key_top && ! defined key_RK3
!!----------------------------------------------------------------------
@@ -33,8 +34,6 @@ MODULE trcatf
USE trdtra
# if defined key_qco || defined key_linssh
USE traatf_qco ! tracer : Asselin filter (qco)
-# else
- USE traatf ! tracer : Asselin filter (vvl)
# endif
USE bdy_oce , ONLY: ln_bdy
USE trcbdy ! BDY open boundaries
@@ -156,13 +155,8 @@ CONTAINS
!
ELSE
IF( .NOT. l_offline ) THEN ! Leap-Frog + Asselin filter time stepping
-# if defined key_qco || defined key_linssh
IF( ln_linssh ) THEN ; CALL tra_atf_fix_lf( kt, Kbb, Kmm, Kaa, nittrc000, 'TRC', ptr, jptra ) ! linear ssh
ELSE ; CALL tra_atf_qco_lf( kt, Kbb, Kmm, Kaa, nittrc000, rn_Dt, 'TRC', ptr, sbc_trc, sbc_trc_b, jptra ) ! non-linear ssh
-# else
- IF( ln_linssh ) THEN ; CALL tra_atf_fix( kt, Kbb, Kmm, Kaa, nittrc000, 'TRC', ptr, jptra ) ! linear ssh
- ELSE ; CALL tra_atf_vvl( kt, Kbb, Kmm, Kaa, nittrc000, rn_Dt, 'TRC', ptr, sbc_trc, sbc_trc_b, jptra ) ! non-linear ssh
-# endif
ENDIF
ELSE
CALL trc_atf_off( kt, Kbb, Kmm, Kaa, ptr ) ! offline
diff --git a/src/TOP/TRP/trcdmp.F90 b/src/TOP/TRP/trcdmp.F90
index 8b2be2d95e3d0f78ff0435d8868636662bf465f0..03535a63c1c18465e26e74e732db305253e7a7dc 100644
--- a/src/TOP/TRP/trcdmp.F90
+++ b/src/TOP/TRP/trcdmp.F90
@@ -57,7 +57,7 @@ CONTAINS
!!----------------------------------------------------------------------
!! *** ROUTINE trc_dmp_alloc ***
!!----------------------------------------------------------------------
- ALLOCATE( restotr(jpi,jpj,jpk) , STAT=trc_dmp_alloc )
+ ALLOCATE( restotr(A2D(0),jpk) , STAT=trc_dmp_alloc )
!
IF( trc_dmp_alloc /= 0 ) CALL ctl_warn('trc_dmp_alloc: failed to allocate array')
!
@@ -329,11 +329,11 @@ CONTAINS
! convert the position in local domain indices
! --------------------------------------------
DO jc = 1, npncts
- nctsi1(jc) = mi0( nctsi1(jc) )
- nctsj1(jc) = mj0( nctsj1(jc) )
+ nctsi1(jc) = mi0( nctsi1(jc), nn_hls )
+ nctsj1(jc) = mj0( nctsj1(jc), nn_hls )
!
- nctsi2(jc) = mi1( nctsi2(jc) )
- nctsj2(jc) = mj1( nctsj2(jc) )
+ nctsi2(jc) = mi1( nctsi2(jc), nn_hls )
+ nctsj2(jc) = mj1( nctsj2(jc), nn_hls )
END DO
!
ENDIF
diff --git a/src/TOP/TRP/trcldf.F90 b/src/TOP/TRP/trcldf.F90
index b3344d094ce49d801acf495d31ad07c8c5647277..97a1d4163e78f5413ab9a9308ed45c2e262b5d17 100644
--- a/src/TOP/TRP/trcldf.F90
+++ b/src/TOP/TRP/trcldf.F90
@@ -19,7 +19,8 @@ MODULE trcldf
USE oce_trc ! ocean dynamics and active tracers
USE ldftra ! lateral diffusion: eddy diffusivity & EIV coeff.
USE ldfslp ! Lateral diffusion: slopes of neutral surfaces
- USE traldf_lap_blp ! lateral diffusion: lap/bilaplacian iso-level operator (tra_ldf_lap/_blp routine)
+ USE traldf_lev ! lateral diffusion: laplacian iso-level operator (traldf_lap/_blp routines)
+!!st USE traldf_lap_blp ! lateral diffusion: lap/bilaplacian iso-level operator (tra_ldf_lap/_blp routine)
USE traldf_iso ! lateral diffusion: laplacian iso-neutral standard operator (tra_ldf_iso routine)
USE traldf_triad ! lateral diffusion: laplacian iso-neutral triad operator (tra_ldf_ triad routine)
USE trd_oce ! trends: ocean variables
@@ -90,19 +91,23 @@ CONTAINS
END_3D
!
SELECT CASE ( nldf_trc ) !* compute lateral mixing trend and add it to the general trend
- !
- CASE ( np_lap ) ! iso-level laplacian
- CALL tra_ldf_lap ( kt, Kmm, nittrc000,'TRC', zahu, zahv, gtru, gtrv, gtrui, gtrvi, &
- & ptr(:,:,:,:,Kbb), ptr(:,:,:,:,Krhs), jptra, 1 )
- CASE ( np_lap_i ) ! laplacian : standard iso-neutral operator (Madec)
- CALL tra_ldf_iso ( kt, Kmm, nittrc000,'TRC', zahu, zahv, gtru, gtrv, gtrui, gtrvi, &
- & ptr(:,:,:,:,Kbb), ptr(:,:,:,:,Kbb), ptr(:,:,:,:,Krhs), jptra, 1 )
- CASE ( np_lap_it ) ! laplacian : triad iso-neutral operator (griffies)
- CALL tra_ldf_triad( kt, Kmm, nittrc000,'TRC', zahu, zahv, gtru, gtrv, gtrui, gtrvi, &
- & ptr(:,:,:,:,Kbb), ptr(:,:,:,:,Kbb), ptr(:,:,:,:,Krhs), jptra, 1 )
- CASE ( np_blp , np_blp_i , np_blp_it ) ! bilaplacian: all operator (iso-level, -neutral)
- CALL tra_ldf_blp ( kt, Kmm, nittrc000,'TRC', zahu, zahv, gtru, gtrv, gtrui, gtrvi, &
- & ptr(:,:,:,:,Kbb) , ptr(:,:,:,:,Krhs), jptra, nldf_trc )
+ ! !- laplacian - !
+ CASE ( np_lap ) ! level operator
+ CALL traldf_lev_lap ( kt, Kbb, Kmm, ptr, Krhs )
+ CASE ( np_lap_i ) ! standard iso-neutral operator
+ CALL traldf_iso_lap ( kt, Kbb, Kmm, ptr, Krhs )
+ CASE ( np_lap_it ) ! laplacian: triad iso-neutral operator
+ CALL traldf_triad_lap( kt, Kmm, nittrc000,'TRC', zahu, zahv, &
+ & ptr(:,:,:,:,Kbb), ptr(:,:,:,:,Kbb), ptr(:,:,:,:,Krhs), jptra, 1 )
+ ! !- bilaplacian - !
+ CASE ( np_blp ) ! iso-level operators
+ CALL traldf_lev_blp ( kt, Kbb, Kmm, ptr, Krhs )
+ CASE ( np_blp_i ) ! standard iso-neutral operator
+ CALL traldf_iso_blp ( kt, Kbb, Kmm, ptr, Krhs )
+ CASE ( np_blp_it ) ! bilaplacian: iso-level & iso-neutral operators
+ CALL traldf_triad_blp( kt, Kmm, nittrc000,'TRC', zahu, zahv, &
+ & ptr(:,:,:,:,Kbb), ptr(:,:,:,:,Krhs), jptra )
+ !
END SELECT
!
IF( l_trdtrc ) THEN ! send the trends for further diagnostics
diff --git a/src/TOP/TRP/trcsbc.F90 b/src/TOP/TRP/trcsbc.F90
index f817b677b011d92edd8a7515e009f0f22f2a0272..42efe65bc125d0611295e7bfc0fdbec7ea05d174 100644
--- a/src/TOP/TRP/trcsbc.F90
+++ b/src/TOP/TRP/trcsbc.F90
@@ -51,12 +51,12 @@ CONTAINS
!! * concentration/dilution effect:
!! The surface freshwater flux modify the ocean volume
!! and thus the concentration of a tracer as :
- !! tr(Krhs) = tr(Krhs) + emp * tr(Kmm) / e3t_ + fmmflx * tri / e3t for k=1
+ !! tr(Krhs) = tr(Krhs) + emp * tr(Kmm) / e3t_ + fwfice * tri / e3t for k=1
!! - tr(Kmm) , the concentration of tracer in the ocean
!! - tri, the concentration of tracer in the sea-ice
- !! - emp, the surface freshwater budget (evaporation minus precipitation + fmmflx)
+ !! - emp, the surface freshwater budget (evaporation minus precipitation + fwfice)
!! given in kg/m2/s is divided by 1035 kg/m3 (density of ocean water) to obtain m/s.
- !! - fmmflx, the flux asscociated to freezing-melting of sea-ice
+ !! - fwfice, the flux asscociated to freezing-melting of sea-ice
!! In linear free surface case (ln_linssh=T), the volume of the
!! ocean does not change with the water exchanges at the (air+ice)-sea
!!
@@ -115,14 +115,14 @@ CONTAINS
CASE ( -1 ) ! ! No tracers in sea ice ( trc_i = 0 )
!
DO jn = 1, jptra
- DO_2D( 0, 0, 0, 1 )
+ DO_2D( 0, 0, 0, 0 )
sbc_trc(ji,jj,jn) = 0._wp
END_2D
END DO
!
IF( ln_linssh ) THEN !* linear free surface
DO jn = 1, jptra
- DO_2D( 0, 0, 0, 1 )
+ DO_2D( 0, 0, 0, 0 )
sbc_trc(ji,jj,jn) = sbc_trc(ji,jj,jn) + r1_rho0 * emp(ji,jj) * ptr(ji,jj,1,jn,Kmm) !==>> add concentration/dilution effect due to constant volume cell
END_2D
END DO
@@ -131,14 +131,14 @@ CONTAINS
CASE ( 0 ) ! Same concentration in sea ice and in the ocean ( trc_i = ptr(...,Kmm) )
!
DO jn = 1, jptra
- DO_2D( 0, 0, 0, 1 )
- sbc_trc(ji,jj,jn) = - fmmflx(ji,jj) * r1_rho0 * ptr(ji,jj,1,jn,Kmm)
+ DO_2D( 0, 0, 0, 0 )
+ sbc_trc(ji,jj,jn) = fwfice(ji,jj) * r1_rho0 * ptr(ji,jj,1,jn,Kmm)
END_2D
END DO
!
IF( ln_linssh ) THEN !* linear free surface
DO jn = 1, jptra
- DO_2D( 0, 0, 0, 1 )
+ DO_2D( 0, 0, 0, 0 )
sbc_trc(ji,jj,jn) = sbc_trc(ji,jj,jn) + r1_rho0 * emp(ji,jj) * ptr(ji,jj,1,jn,Kmm) !==>> add concentration/dilution effect due to constant volume cell
END_2D
END DO
@@ -147,21 +147,21 @@ CONTAINS
CASE ( 1 ) ! Specific treatment of sea ice fluxes with an imposed concentration in sea ice
!
DO jn = 1, jptra
- DO_2D( 0, 0, 0, 1 )
- sbc_trc(ji,jj,jn) = - fmmflx(ji,jj) * r1_rho0 * trc_i(ji,jj,jn)
+ DO_2D( 0, 0, 0, 0 )
+ sbc_trc(ji,jj,jn) = fwfice(ji,jj) * r1_rho0 * trc_i(ji,jj,jn)
END_2D
END DO
!
IF( ln_linssh ) THEN !* linear free surface
DO jn = 1, jptra
- DO_2D( 0, 0, 0, 1 )
+ DO_2D( 0, 0, 0, 0 )
sbc_trc(ji,jj,jn) = sbc_trc(ji,jj,jn) + r1_rho0 * emp(ji,jj) * ptr(ji,jj,1,jn,Kmm) !==>> add concentration/dilution effect due to constant volume cell
END_2D
END DO
ENDIF
!
DO jn = 1, jptra
- DO_2D( 0, 0, 0, 1 )
+ DO_2D( 0, 0, 0, 0 )
zse3t = rDt_trc / e3t(ji,jj,1,Kmm)
zdtra = ptr(ji,jj,1,jn,Kmm) + sbc_trc(ji,jj,jn) * zse3t
IF( zdtra < 0. ) sbc_trc(ji,jj,jn) = MAX( zdtra, -ptr(ji,jj,1,jn,Kmm) / zse3t ) ! avoid negative concentration that can occurs if trc_i > ptr
@@ -176,7 +176,7 @@ CONTAINS
!
IF( l_trdtrc ) ztrtrd(:,:,:) = ptr(:,:,:,jn,Krhs) ! save trends
!
- DO_2D( 0, 0, 0, 1 )
+ DO_2D( 0, 0, 0, 0 )
zse3t = zfact / e3t(ji,jj,1,Kmm)
ptr(ji,jj,1,jn,Krhs) = ptr(ji,jj,1,jn,Krhs) + ( sbc_trc_b(ji,jj,jn) + sbc_trc(ji,jj,jn) ) * zse3t
END_2D
@@ -259,7 +259,7 @@ CONTAINS
!
IF( .NOT.ln_linssh ) THEN !* only passive tracer fluxes associated with mass fluxes
! ! no passive tracer concentration modification due to ssh variation
-!!st emp includes fmm see iceupdate.F90
+!!st emp includes fwfice see iceupdate.F90
!!not sure about trc_i case... (1)
DO jn = 1, jptra
DO_2D( 0, 0, 0, 0 ) !!st WHY 1 : exterior here ?
@@ -292,12 +292,12 @@ CONTAINS
END_2D
END DO
!
- CASE ( 0 ) ! Same concentration in sea ice and in the ocean fmm contribution to concentration/dilution effect has to be removed
+ CASE ( 0 ) ! Same concentration in sea ice and in the ocean fwfice contribution to concentration/dilution effect has to be removed
!
DO jn = 1, jptra
- DO_2D( 0, 0, 0, 1 )
+ DO_2D( 0, 0, 0, 0 )
z1_rho0_e3t = r1_rho0 / e3t(ji,jj,1,Kmm)
- ptr(ji,jj,1,jn,Krhs) = ptr(ji,jj,1,jn,Krhs) + ( emp(ji,jj) - fmmflx(ji,jj) ) * r1_rho0 * ptr(ji,jj,1,jn,Kmm)
+ ptr(ji,jj,1,jn,Krhs) = ptr(ji,jj,1,jn,Krhs) + ( emp(ji,jj) + fwfice(ji,jj) ) * r1_rho0 * ptr(ji,jj,1,jn,Kmm)
END_2D
END DO
!
@@ -307,13 +307,13 @@ CONTAINS
DO_2D( 0, 0, 0, 0 )
z1_rho0_e3t = r1_rho0 / e3t(ji,jj,1,Kmm)
! tracer flux at the ice/ocean interface (tracer/m2/s)
- zftra = - trc_i(ji,jj,jn) * fmmflx(ji,jj) ! uptake of tracer in the sea ice
- ! ! only used in the levitating sea ice case
+ zftra = trc_i(ji,jj,jn) * fwfice(ji,jj) ! uptake of tracer in the sea ice
+ ! ! only used in the levitating sea ice case
! tracer flux only : add concentration dilution term in net tracer flux, no F-M in volume flux
! tracer and mass fluxes : no concentration dilution term in net tracer flux, F-M term in volume flux
ztfx = zftra ! net tracer flux
!
- zdtra = r1_rho0 * ( ztfx + ( emp(ji,jj) - fmmflx(ji,jj) ) * ptr(ji,jj,1,jn,Kmm) )
+ zdtra = r1_rho0 * ( ztfx + ( emp(ji,jj) + fwfice(ji,jj) ) * ptr(ji,jj,1,jn,Kmm) )
IF ( zdtra < 0. ) THEN
zdtra = MAX(zdtra, -ptr(ji,jj,1,jn,Kmm) * e3t(ji,jj,1,Kmm) / rDt_trc ) ! avoid negative concentrations to arise
ENDIF
@@ -331,9 +331,9 @@ CONTAINS
CASE ( 0 ) ! Same concentration in sea ice and in the ocean : correct concentration/dilution effect due to "freezing - melting"
!
DO jn = 1, jptra
- DO_2D( 0, 0, 0, 1 )
+ DO_2D( 0, 0, 0, 0 )
z1_rho0_e3t = r1_rho0 / e3t(ji,jj,1,Kmm)
- ptr(ji,jj,1,jn,Krhs) = ptr(ji,jj,1,jn,Krhs) - fmmflx(ji,jj) * r1_rho0 * ptr(ji,jj,1,jn,Kmm)
+ ptr(ji,jj,1,jn,Krhs) = ptr(ji,jj,1,jn,Krhs) + fwfice(ji,jj) * r1_rho0 * ptr(ji,jj,1,jn,Kmm)
END_2D
END DO
!
@@ -342,13 +342,13 @@ CONTAINS
DO jn = 1, jptra
DO_2D( 0, 0, 0, 0 )
! tracer flux at the ice/ocean interface (tracer/m2/s)
- zftra = - trc_i(ji,jj,jn) * fmmflx(ji,jj) ! uptake of tracer in the sea ice
- ! ! only used in the levitating sea ice case
+ zftra = trc_i(ji,jj,jn) * fwfice(ji,jj) ! uptake of tracer in the sea ice
+ ! ! only used in the levitating sea ice case
! tracer flux only : add concentration dilution term in net tracer flux, no F-M in volume flux
! tracer and mass fluxes : no concentration dilution term in net tracer flux, F-M term in volume flux
ztfx = zftra ! net tracer flux
!
- zdtra = r1_rho0 * ( ztfx - fmmflx(ji,jj) * ptr(ji,jj,1,jn,Kmm) )
+ zdtra = r1_rho0 * ( ztfx + fwfice(ji,jj) * ptr(ji,jj,1,jn,Kmm) )
IF ( zdtra < 0. ) THEN
zdtra = MAX(zdtra, -ptr(ji,jj,1,jn,Kmm) * e3t(ji,jj,1,Kmm) / rDt_trc ) ! avoid negative concentrations to arise
ENDIF
diff --git a/src/TOP/TRP/trcsink.F90 b/src/TOP/TRP/trcsink.F90
index 5cee9b0ba920b1b15b43de995caa6d163d883685..d7735a8e182e7a3839c3cc0b3c1ac898ad250b95 100644
--- a/src/TOP/TRP/trcsink.F90
+++ b/src/TOP/TRP/trcsink.F90
@@ -50,12 +50,12 @@ CONTAINS
INTEGER , INTENT(in) :: Kbb, Kmm
INTEGER , INTENT(in) :: jp_tra ! tracer index index
REAL(wp), INTENT(in) :: rsfact ! time step duration
- REAL(wp), INTENT(in) , DIMENSION(jpi,jpj,jpk) :: pwsink
- REAL(wp), INTENT(inout), DIMENSION(jpi,jpj,jpk) :: psinkflx
+ REAL(wp), INTENT(in) , DIMENSION(A2D(0),jpk) :: pwsink
+ REAL(wp), INTENT(inout), DIMENSION(A2D(0),jpk) :: psinkflx
INTEGER :: ji, jj, jk
- INTEGER, DIMENSION(jpi, jpj) :: iiter
+ INTEGER, DIMENSION(A2D(0)) :: iiter
REAL(wp) :: zfact, zwsmax, zmax
- REAL(wp), DIMENSION(jpi,jpj,jpk) :: zwsink
+ REAL(wp), DIMENSION(A2D(0),jpk) :: zwsink
!!---------------------------------------------------------------------
!
IF( ln_timing ) CALL timing_start('trc_sink')
@@ -73,7 +73,7 @@ CONTAINS
IF( nitermax == 1 ) THEN
iiter(:,:) = 1
ELSE
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
iiter(ji,jj) = 1
DO jk = 1, jpkm1
IF( tmask(ji,jj,jk) == 1.0 ) THEN
@@ -85,14 +85,9 @@ CONTAINS
iiter(:,:) = MIN( iiter(:,:), nitermax )
ENDIF
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 )
- IF( tmask(ji,jj,jk) == 1.0 ) THEN
- zwsmax = 0.5 * e3t(ji,jj,jk,Kmm) * rday / rsfact
- zwsink(ji,jj,jk) = MIN( pwsink(ji,jj,jk), zwsmax * REAL( iiter(ji,jj), wp ) )
- ELSE
- ! provide a default value so there is no use of undefinite value in trc_sink2 for zwsink2 initialization
- zwsink(ji,jj,jk) = 0.
- ENDIF
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
+ zwsmax = 0.5 * e3t(ji,jj,jk,Kmm) * rday / rsfact
+ zwsink(ji,jj,jk+1) = -MIN( pwsink(ji,jj,jk), zwsmax * REAL( iiter(ji,jj), wp ) ) / rday
END_3D
! Initializa to zero all the sinking arrays
@@ -121,23 +116,18 @@ CONTAINS
INTEGER, INTENT(in ) :: Kbb, Kmm ! time level indices
INTEGER, INTENT(in ) :: jp_tra ! tracer index index
REAL(wp), INTENT(in ) :: rsfact ! duration of time step
- INTEGER, INTENT(in ), DIMENSION(jpi,jpj) :: kiter ! number of iterations for time-splitting
- REAL(wp), INTENT(in ), DIMENSION(jpi,jpj,jpk) :: pwsink ! sinking speed
- REAL(wp), INTENT(inout), DIMENSION(jpi,jpj,jpk) :: psinkflx ! sinking fluxe
+ INTEGER, INTENT(in ), DIMENSION(A2D(0)) :: kiter ! number of iterations for time-splitting
+ REAL(wp), INTENT(in ), DIMENSION(A2D(0),jpk) :: pwsink ! sinking speed
+ REAL(wp), INTENT(inout), DIMENSION(A2D(0),jpk) :: psinkflx ! sinking fluxe
!
INTEGER :: ji, jj, jk, jn, jt
- REAL(wp) :: zigma,zew,zign, zflx, zstep
- REAL(wp), DIMENSION(jpi,jpj,jpk) :: ztraz, zakz, zwsink2, ztrb, psinking
+ REAL(wp) :: zigma,z0w,zign, zflx, zstep, zzwx, zzwy, zalpha
+ REAL(wp), DIMENSION(A2D(0),jpk) :: ztraz, zakz, ztrb, zsinking
!!---------------------------------------------------------------------
!
IF( ln_timing ) CALL timing_start('trc_sink2')
!
- DO jk = 1, jpkm1
- zwsink2(:,:,jk+1) = -pwsink(:,:,jk) / rday * tmask(:,:,jk+1)
- END DO
- zwsink2(:,:,1) = 0.e0
-
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
! Vertical advective flux
zstep = rsfact / REAL( kiter(ji,jj), wp ) / 2.
DO jt = 1, kiter(ji,jj)
@@ -166,27 +156,28 @@ CONTAINS
! vertical advective flux
DO jk = 1, jpkm1
- zigma = zwsink2(ji,jj,jk+1) * zstep / e3w(ji,jj,jk+1,Kmm)
- zew = zwsink2(ji,jj,jk+1)
- psinking(ji,jj,jk+1) = -zew * ( tr(ji,jj,jk,jp_tra,Kbb) - 0.5 * ( 1 + zigma ) * zakz(ji,jj,jk) ) * zstep
+ z0w = SIGN( 0.5_wp, pwsink(ji,jj,jk+1) )
+ zalpha = 0.5 + z0w
+ zigma = z0w - 0.5 * pwsink(ji,jj,jk+1) * zstep / e3w(ji,jj,jk+1,Kmm)
+ zzwx = tr(ji,jj,jk+1,jp_tra,Kbb) + zigma * zakz(ji,jj,jk+1)
+ zzwy = tr(ji,jj,jk,jp_tra,Kbb) + zigma * zakz(ji,jj,jk)
+ zsinking(ji,jj,jk+1) = -pwsink(ji,jj,jk+1) * ( zalpha * zzwx + (1.0 - zalpha) * zzwy ) * zstep
END DO
!
! Boundary conditions
- psinking(ji,jj,1 ) = 0.e0
- psinking(ji,jj,jpk) = 0.e0
-
+ zsinking(ji,jj,1 ) = 0.e0
DO jk = 1, jpkm1
- zflx = ( psinking(ji,jj,jk) - psinking(ji,jj,jk+1) ) / e3t(ji,jj,jk,Kmm)
- tr(ji,jj,jk,jp_tra,Kbb) = tr(ji,jj,jk,jp_tra,Kbb) + zflx
+ zflx = ( zsinking(ji,jj,jk) - zsinking(ji,jj,jk+1) ) / e3t(ji,jj,jk,Kmm)
+ tr(ji,jj,jk,jp_tra,Kbb) = tr(ji,jj,jk,jp_tra,Kbb) + zflx * tmask(ji,jj,jk)
END DO
END DO
DO jk = 1, jpkm1
- zflx = ( psinking(ji,jj,jk) - psinking(ji,jj,jk+1) ) / e3t(ji,jj,jk,Kmm)
- ztrb(ji,jj,jk) = ztrb(ji,jj,jk) + 2. * zflx
+ zflx = ( zsinking(ji,jj,jk) - zsinking(ji,jj,jk+1) ) / e3t(ji,jj,jk,Kmm)
+ ztrb(ji,jj,jk) = ztrb(ji,jj,jk) + 2. * zflx * tmask(ji,jj,jk)
END DO
tr(ji,jj,:,jp_tra,Kbb) = ztrb(ji,jj,:)
- psinkflx(ji,jj,:) = psinkflx(ji,jj,:) + 2. * psinking(ji,jj,:)
+ psinkflx(ji,jj,:) = psinkflx(ji,jj,:) + 2. * zsinking(ji,jj,:)
END DO
END_2D
!
diff --git a/src/TOP/TRP/trctrp.F90 b/src/TOP/TRP/trctrp.F90
index 6996ccaa072713721aeccb16d92ff28c307d200d..c14f052f52b4f35be93cefac123d0ec9df97a3a8 100644
--- a/src/TOP/TRP/trctrp.F90
+++ b/src/TOP/TRP/trctrp.F90
@@ -26,7 +26,6 @@ MODULE trctrp
USE trcsbc ! surface boundary condition (trc_sbc routine)
USE trcbc ! Tracers boundary condtions ( trc_bc routine)
USE trcais ! Antarctic Ice Sheet tracers (trc_ais routine)
- USE zpshde ! partial step: hor. derivative (zps_hde routine)
USE bdy_oce , ONLY: ln_bdy
USE trcbdy ! BDY open boundaries
USE in_out_manager
@@ -68,13 +67,6 @@ CONTAINS
!
IF( .NOT. ln_c1d ) THEN
!
- ! ! Partial top/bottom cell: GRADh( trb )
- IF( ln_zps ) THEN
- IF( ln_isfcav ) THEN ; CALL zps_hde_isf( kt, jptra, tr(:,:,:,:,Kbb), pgtu=gtru, pgtv=gtrv, pgtui=gtrui, pgtvi=gtrvi ) ! both top & bottom
- ELSE ; CALL zps_hde ( kt, jptra, tr(:,:,:,:,Kbb), gtru, gtrv ) ! only bottom
- ENDIF
- ENDIF
- !
#if ! defined key_RK3
CALL trc_sbc ( kt, Kmm, tr, Krhs ) ! surface boundary condition
#endif
diff --git a/src/TOP/TRP/trczdf.F90 b/src/TOP/TRP/trczdf.F90
index 2f0b5a8f2dbebb0ba09b1467a6b1b7831777b741..b5a9dd4ccd34296c7f3ba759cc8830496b836d95 100644
--- a/src/TOP/TRP/trczdf.F90
+++ b/src/TOP/TRP/trczdf.F90
@@ -53,7 +53,7 @@ CONTAINS
!
IF( l_trdtrc ) ztrtrd(:,:,:,:) = ptr(:,:,:,:,Krhs)
!
- CALL tra_zdf_imp( kt, nittrc000, 'TRC', rDt_trc, Kbb, Kmm, Krhs, ptr, Kaa, jptra ) ! implicit scheme
+ CALL tra_zdf_imp( 'TRC', Kbb, Kmm, Krhs, ptr, Kaa, jptra ) ! implicit scheme
!
IF( l_trdtrc ) THEN ! save the vertical diffusive trends for further diagnostics
DO jn = 1, jptra
diff --git a/src/TOP/TRP/trdmxl_trc.F90 b/src/TOP/TRP/trdmxl_trc.F90
index 1525d1d72618af2c559c1f126a17fac215c45ebd..1d13a2e85c82820a74218d60de645400a3a02f6f 100644
--- a/src/TOP/TRP/trdmxl_trc.F90
+++ b/src/TOP/TRP/trdmxl_trc.F90
@@ -112,7 +112,13 @@ CONTAINS
SELECT CASE ( nn_ctls_trc ) ! choice of the control surface
CASE ( -2 ) ; CALL ctl_stop( 'STOP', 'trdmxl_trc : not ready ' ) ! -> isopycnal surface (see ???)
CASE ( -1 ) ; nmld_trc(:,:) = neln(:,:) ! -> euphotic layer with light criterion
- CASE ( 0 ) ; nmld_trc(:,:) = nmln(:,:) ! -> ML with density criterion (see zdfmxl)
+ CASE ( 0 )
+ ! nmln calculation in zdfmxl is only on internal points
+ DO_2D( 0, 0, 0, 0 )
+ zvlmsk(ji,jj) = REAL( nmln(ji,jj), wp )
+ END_2D
+ CALL lbc_lnk( 'trdmxl_trc', zvlmsk, 'T', 1.0_wp, kfillmode=jpfillcopy ) ! No 0 over closed boundaries
+ nmld_trc(:,:) = NINT( zvlmsk(:,:) ) ! -> ML with density criterion (see zdfmxl)
CASE ( 1 ) ; nmld_trc(:,:) = nbol_trc(:,:) ! -> read index from file
CASE ( 2: ) ; nn_ctls_trc = MIN( nn_ctls_trc, jpktrd_trc - 1 )
nmld_trc(:,:) = nn_ctls_trc + 1 ! -> model level
@@ -258,7 +264,7 @@ CONTAINS
IF( ln_trcldf_iso ) THEN
!
DO jn = 1, jptra
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) ! description ???
+ DO_2D( 0, 0, 0, 0 ) ! description ???
ik = nmld_trc(ji,jj)
IF( ln_trdtrc(jn) ) &
tmltrd_trc(ji,jj,jpmxl_trc_zdf,jn) = - avs(ji,jj,ik) / e3w(ji,jj,ik,Kmm) * tmask(ji,jj,ik) &
diff --git a/src/TOP/oce_trc.F90 b/src/TOP/oce_trc.F90
index 7745fc71328e0e950e428bd4c4491ec121b266ff..f7c3b5503a08d3919530e6537fc5274ec6cc794c 100644
--- a/src/TOP/oce_trc.F90
+++ b/src/TOP/oce_trc.F90
@@ -33,10 +33,6 @@ MODULE oce_trc
USE dom_oce !* model domain *
- USE domvvl, ONLY : un_td, vn_td !: thickness diffusion transport
- USE domvvl, ONLY : ln_vvl_ztilde !: ztilde vertical coordinate
- USE domvvl, ONLY : ln_vvl_layer !: level vertical coordinate
-
!* ocean fields: here now and after fields *
USE oce , ONLY : uu => uu !: i-horizontal velocity (m s-1)
USE oce , ONLY : vv => vv !: j-horizontal velocity (m s-1)
@@ -54,7 +50,7 @@ MODULE oce_trc
USE sbc_oce , ONLY : qsr => qsr !: penetrative solar radiation (w m-2)
USE sbc_oce , ONLY : emp => emp !: freshwater budget: volume flux [Kg/m2/s]
USE sbc_oce , ONLY : emp_b => emp_b !: freshwater budget: volume flux [Kg/m2/s]
- USE sbc_oce , ONLY : fmmflx => fmmflx !: freshwater budget: volume flux [Kg/m2/s]
+ USE sbc_oce , ONLY : fwfice => fwfice !: freshwater budget: volume flux [Kg/m2/s]
USE sbc_oce , ONLY : rnf => rnf !: river runoff [Kg/m2/s]
USE sbc_oce , ONLY : rnf_b => rnf_b !: river runoff at previus step [Kg/m2/s]
USE sbc_oce , ONLY : ln_dm2dc => ln_dm2dc !: Diurnal Cycle
@@ -96,7 +92,6 @@ MODULE oce_trc
USE zdfmxl , ONLY : nmln => nmln !: number of level in the mixed layer
USE zdfmxl , ONLY : hmld => hmld !: mixing layer depth (turbocline)
USE zdfmxl , ONLY : hmlp => hmlp !: mixed layer depth (rho=rho0+zdcrit) (m)
- USE zdfmxl , ONLY : hmlpt => hmlpt !: mixed layer depth at t-points (m)
USE zdfmxl , ONLY : avt_c => avt_c !: Kz criterion for the turbocline depth
END MODULE oce_trc
diff --git a/src/TOP/trc.F90 b/src/TOP/trc.F90
index d5b85e041f9f4a1a60f4dfe167cb6bba7b329b68..4836efb7e2ff7ac1923e05e1bee94743ce36aa42 100644
--- a/src/TOP/trc.F90
+++ b/src/TOP/trc.F90
@@ -158,19 +158,19 @@ CONTAINS
!!-------------------------------------------------------------------
ierr(:) = 0
!
- ALLOCATE( tr(jpi,jpj,jpk,jptra,jpt) , &
- & trc_i(jpi,jpj,jptra) , trc_o(jpi,jpj,jptra) , &
- & gtru (jpi,jpj,jptra) , gtrv (jpi,jpj,jptra) , &
- & gtrui(jpi,jpj,jptra) , gtrvi(jpi,jpj,jptra) , &
- & trc_ice_ratio(jptra) , trc_ice_prescr(jptra) , cn_trc_o(jptra) , &
- & neln(jpi,jpj) , heup(jpi,jpj) , heup_01(jpi,jpj) , &
- & etot(jpi,jpj,jpk) , etot_ndcy(jpi,jpj,jpk) , &
- & sbc_trc_b(jpi,jpj,jptra), sbc_trc(jpi,jpj,jptra) , &
- & cvol(jpi,jpj,jpk) , trai(jptra) , &
- & ctrcnm(jptra) , ctrcln(jptra) , ctrcun(jptra) , &
- & ln_trc_ini(jptra) , &
- & ln_trc_sbc(jptra) , ln_trc_cbc(jptra) , ln_trc_obc(jptra) , &
- & ln_trc_ais(jptra) , &
+ ALLOCATE( tr(jpi,jpj,jpk,jptra,jpt) , &
+ & gtru (jpi,jpj,jptra) , gtrv (jpi,jpj,jptra) , &
+ & gtrui(jpi,jpj,jptra) , gtrvi(jpi,jpj,jptra) , &
+ & trc_i(A2D(0),jptra) , trc_o(A2D(0),jptra) , &
+ & trc_ice_ratio(jptra) , trc_ice_prescr(jptra) , cn_trc_o(jptra) , &
+ & neln(A2D(0)) , heup(A2D(0)) , heup_01(A2D(0)) , &
+ & etot(A2D(0),jpk) , etot_ndcy(A2D(0),jpk) , &
+ & sbc_trc_b(A2D(0),jptra), sbc_trc(A2D(0),jptra) , &
+ & cvol(jpi,jpj,jpk) , trai(jptra) , &
+ & ctrcnm(jptra) , ctrcln(jptra) , ctrcun(jptra) , &
+ & ln_trc_ini(jptra) , &
+ & ln_trc_sbc(jptra) , ln_trc_cbc(jptra) , ln_trc_obc(jptra) , &
+ & ln_trc_ais(jptra) , &
& STAT = ierr(1) )
!
IF( ln_bdy ) ALLOCATE( trcdta_bdy(jptra, jp_bdy) , STAT = ierr(2) )
diff --git a/src/TOP/trcais.F90 b/src/TOP/trcais.F90
index 5bd051387df35ca4faedfea9a07b47dc5b06be27..010e9fce1e2f7550977e3d2dce6abcfec2fc2b4e 100644
--- a/src/TOP/trcais.F90
+++ b/src/TOP/trcais.F90
@@ -169,7 +169,7 @@ CONTAINS
DO jn = 1, jptra
IF( ln_trc_ais(jn) ) THEN
jl = n_trc_indais(jn)
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
zfact = 1. / e3t(ji,jj,1,Kmm)
ptr(ji,jj,jk,jn,Krhs) = ptr(ji,jj,1,jn,Krhs) + fwficb(ji,jj) * r1_rho0 * ptr(ji,jj,1,jn,Kmm) * zfact
END_2D
@@ -181,7 +181,7 @@ CONTAINS
DO jn = 1, jptra
IF( ln_trc_ais(jn) ) THEN
jl = n_trc_indais(jn)
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
IF( ln_isfpar_mlt ) THEN
zcalv = fwfisf_par(ji,jj) * r1_rho0 / rhisf_tbl_par(ji,jj)
ikt = misfkt_par(ji,jj)
@@ -213,7 +213,7 @@ CONTAINS
DO jn = 1, jptra
IF( ln_trc_ais(jn) ) THEN
jl = n_trc_indais(jn)
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
DO jk = 1, icblev
zcalv = fwficb(ji,jj) * r1_rho0
ptr(ji,jj,jk,jn,Krhs) = ptr(ji,jj,jk,jn,Krhs) + rf_trafac(jl) * zcalv / gdepw(ji,jj,icblev+1,Kmm)
@@ -228,7 +228,7 @@ CONTAINS
DO jn = 1, jptra
IF( ln_trc_ais(jn) ) THEN
jl = n_trc_indais(jn)
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ DO_2D( 0, 0, 0, 0 )
IF( ln_isfpar_mlt ) THEN
zcalv = - fwfisf_par(ji,jj) * r1_rho0 / rhisf_tbl_par(ji,jj)
ikt = misfkt_par(ji,jj)
diff --git a/src/TOP/trcbc.F90 b/src/TOP/trcbc.F90
index fc829d8db5b806c8ad2e6edffc680a788ae91800..141ecf03c6db857d1a90b0e03d7def0c8745592b 100644
--- a/src/TOP/trcbc.F90
+++ b/src/TOP/trcbc.F90
@@ -414,7 +414,7 @@ CONTAINS
!
! Remove river dilution for tracers with absent river load
IF( ln_rnf_ctl .AND. .NOT.ln_trc_cbc(jn) ) THEN
- DO_2D( 0, 0, 0, 1 )
+ DO_2D( 0, 0, 0, 0 )
DO jk = 1, nk_rnf(ji,jj)
#if defined key_RK3
zrnf = rnf(ji,jj) * r1_rho0 / h_rnf(ji,jj)
@@ -432,7 +432,7 @@ CONTAINS
IF( ln_trc_sbc(jn) ) THEN
jl = n_trc_indsbc(jn)
sf_trcsbc(jl)%fnow(:,:,1) = MAX( rtrn, sf_trcsbc(jl)%fnow(:,:,1) ) ! avoid nedgative value due to interpolation
- DO_2D( 0, 0, 0, 1 )
+ DO_2D( 0, 0, 0, 0 )
zfact = 1. / ( e3t(ji,jj,1,Kmm) * rn_sbc_time )
ptr(ji,jj,1,jn,Krhs) = ptr(ji,jj,1,jn,Krhs) + rf_trsfac(jl) * sf_trcsbc(jl)%fnow(ji,jj,1) * zfact
END_2D
@@ -443,7 +443,7 @@ CONTAINS
IF( l_offline ) rn_rfact = 1._wp
jl = n_trc_indcbc(jn)
sf_trccbc(jl)%fnow(:,:,1) = MAX( rtrn, sf_trccbc(jl)%fnow(:,:,1) ) ! avoid nedgative value due to interpolation
- DO_2D( 0, 0, 0, 1 )
+ DO_2D( 0, 0, 0, 0 )
DO jk = 1, nk_rnf(ji,jj)
zfact = rn_rfact / ( e1e2t(ji,jj) * h_rnf(ji,jj) * rn_cbc_time )
ptr(ji,jj,jk,jn,Krhs) = ptr(ji,jj,jk,jn,Krhs) + rf_trcfac(jl) * sf_trccbc(jl)%fnow(ji,jj,1) * zfact
diff --git a/src/TOP/trcdta.F90 b/src/TOP/trcdta.F90
index ec3a47d238d280e62d0b65dd1c173e2505b15566..7a95df42aecbf58ec19ed1b700834e58d074f4f5 100644
--- a/src/TOP/trcdta.F90
+++ b/src/TOP/trcdta.F90
@@ -189,7 +189,7 @@ CONTAINS
ptrcdta(:,:,:) = sf_trcdta(kjl)%fnow(:,:,:) * tmask(:,:,:)
!
#if ! defined key_sed_off
- IF( ln_sco ) THEN !== s- or mixed s-zps-coordinate ==!
+ IF( l_sco ) THEN !== s- or mixed s-zps-coordinate ==!
!
IF( kt == nit000 .AND. lwp )THEN
WRITE(numout,*)
@@ -217,23 +217,6 @@ CONTAINS
ptrcdta(ji,jj,jpk) = 0._wp
END_2D
!
- ELSE !== z- or zps- coordinate ==!
- ! zps-coordinate (partial steps) interpolation at the last ocean level
- IF( ln_zps ) THEN
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
- ik = mbkt(ji,jj)
- IF( ik > 1 .AND. gdept_0(ji,jj,ik) < gdept_1d(ik) ) THEN
- zl = ( gdept_1d(ik) - gdept_0(ji,jj,ik) ) / ( gdept_1d(ik) - gdept_1d(ik-1) )
- ptrcdta(ji,jj,ik) = (1.-zl) * ptrcdta(ji,jj,ik) + zl * ptrcdta(ji,jj,ik-1)
- ENDIF
- ik = mikt(ji,jj)
- IF( ik > 1 ) THEN
- zl = ( gdept_0(ji,jj,ik) - gdept_1d(ik) ) / ( gdept_1d(ik+1) - gdept_1d(ik) )
- ptrcdta(ji,jj,ik) = (1.-zl) * ptrcdta(ji,jj,ik) + zl * ptrcdta(ji,jj,ik+1)
- ENDIF
- END_2D
- ENDIF
- !
ENDIF
#endif
! Scale by multiplicative factor
diff --git a/src/TOP/trcini.F90 b/src/TOP/trcini.F90
index 394f1cd16b77cf421edafa76afb8f4bc25316cb7..f5275ead3833d971aec8e6e656e2d0609e362bb5 100644
--- a/src/TOP/trcini.F90
+++ b/src/TOP/trcini.F90
@@ -32,6 +32,8 @@ MODULE trcini
PUBLIC trc_init ! called by opa
+ !! * Substitutions
+# include "do_loop_substitute.h90"
# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/TOP 4.0 , NEMO Consortium (2018)
@@ -93,9 +95,8 @@ CONTAINS
!! ** Purpose : passive tracers inventories at initialsation phase
!!----------------------------------------------------------------------
INTEGER, INTENT(in) :: Kmm ! time level index
- INTEGER :: jk, jn ! dummy loop indices
+ INTEGER :: ji, jj, jk, jn ! dummy loop indices
CHARACTER (len=25) :: charout
- REAL(wp), DIMENSION(jpi,jpj,jpk,jptra) :: zzmsk
!!----------------------------------------------------------------------
!
IF(lwp) WRITE(numout,*)
diff --git a/src/TOP/trcnam.F90 b/src/TOP/trcnam.F90
index cacbe617105a4851b262e05392c3fdea4b542782..80a181e055938ffbb7c1649e105369158c6def10 100644
--- a/src/TOP/trcnam.F90
+++ b/src/TOP/trcnam.F90
@@ -254,7 +254,12 @@ CONTAINS
WRITE(numout,*) ' Namelist : namtrc_dcy '
WRITE(numout,*) ' Diurnal cycle for TOP ln_trcdc2dm = ', ln_trcdc2dm
ENDIF
-
+ ! ! Define logical parameter ton control dirunal cycle in TOP
+ l_trcdm2dc = ( ln_trcdc2dm .AND. .NOT. ln_dm2dc )
+ !
+ IF( l_trcdm2dc .AND. lwp ) CALL ctl_warn( 'Coupling with passive tracers and used of diurnal cycle.', &
+ & 'Computation of a daily mean shortwave for some biogeochemical models ' )
+ !
END SUBROUTINE trc_nam_dcy
SUBROUTINE trc_nam_trd
diff --git a/src/TOP/trcopt.F90 b/src/TOP/trcopt.F90
index 7620a4c0017f2abfc7dc8e86b3be9f6a0aa5b0cd..c7a013167fff63a3f4f5e71ee078d1197a2acf14 100644
--- a/src/TOP/trcopt.F90
+++ b/src/TOP/trcopt.F90
@@ -58,12 +58,14 @@ CONTAINS
INTEGER, INTENT(in) :: kt, knt ! ocean time step
INTEGER, INTENT(in) :: Kbb, Kmm ! time level indices
REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in) :: zchl ! chlorophyll field
- REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(out) :: ze1, ze2, ze3 ! PAR for individual wavelength
+ REAL(wp), DIMENSION(A2D(0),jpk), INTENT(out) :: ze1, ze2, ze3 ! PAR for individual wavelength
!
INTEGER :: ji, jj, jk, irgb
REAL(wp) :: ztmp
- REAL(wp), DIMENSION(jpi,jpj ) :: parsw, zqsr100, zqsr_corr
- REAL(wp), DIMENSION(jpi,jpj,jpk) :: ze0
+ REAL(wp), DIMENSION(A2D(0) ) :: parsw, zqsr100, zqsr_corr
+ REAL(wp), DIMENSION(A2D(0),jpk) :: ze0
+ REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zw3d
+ REAL(wp), ALLOCATABLE, DIMENSION(:,: ) :: zw2d
!!---------------------------------------------------------------------
!
IF( ln_timing ) CALL timing_start('trc_opt')
@@ -85,7 +87,7 @@ CONTAINS
! Attenuation coef. function of Chlorophyll and wavelength (RGB)
! --------------------------------------------------------------
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 1, jpkm1)
ztmp = ( zchl(ji,jj,jk) + rtrn ) * 1.e6
ztmp = MIN( 10. , MAX( 0.05, ztmp ) )
irgb = NINT( 41 + 20.* LOG10( ztmp ) + rtrn )
@@ -99,54 +101,63 @@ CONTAINS
! -----------------------------------------------
IF( ln_qsr_bio ) THEN
!
- zqsr_corr(:,:) = parsw(:,:) * qsr(:,:)
+ DO_2D( 0, 0, 0, 0 )
+ zqsr_corr(ji,jj) = parsw(ji,jj) * qsr(ji,jj)
+ END_2D
!
- ze0(:,:,1) = (1._wp - 3._wp * parsw(:,:)) * qsr(:,:) ! ( 1 - 3 * alpha ) * q
+ DO_2D( 0, 0, 0, 0 )
+ ze0(ji,jj,1) = (1._wp - 3._wp * parsw(ji,jj)) * qsr(ji,jj) ! ( 1 - 3 * alpha ) * q
+ END_2D
ze1(:,:,1) = zqsr_corr(:,:)
ze2(:,:,1) = zqsr_corr(:,:)
ze3(:,:,1) = zqsr_corr(:,:)
!
- DO jk = 2, nksrp + 1
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
- ze0(ji,jj,jk) = ze0(ji,jj,jk-1) * EXP( -e3t(ji,jj,jk-1,Kmm) * (1. / rn_si0) )
- ze1(ji,jj,jk) = ze1(ji,jj,jk-1) * EXP( -ekb (ji,jj,jk-1 ) )
- ze2(ji,jj,jk) = ze2(ji,jj,jk-1) * EXP( -ekg (ji,jj,jk-1 ) )
- ze3(ji,jj,jk) = ze3(ji,jj,jk-1) * EXP( -ekr (ji,jj,jk-1 ) )
- END_2D
- END DO
+ DO_3D( 0, 0, 0, 0, 2, nksrp + 1 )
+ ze0(ji,jj,jk) = ze0(ji,jj,jk-1) * EXP( -e3t(ji,jj,jk-1,Kmm) * (1. / rn_si0) )
+ ze1(ji,jj,jk) = ze1(ji,jj,jk-1) * EXP( -ekb (ji,jj,jk-1 ) )
+ ze2(ji,jj,jk) = ze2(ji,jj,jk-1) * EXP( -ekg (ji,jj,jk-1 ) )
+ ze3(ji,jj,jk) = ze3(ji,jj,jk-1) * EXP( -ekr (ji,jj,jk-1 ) )
+ END_3D
!
- etot3(:,:,1) = qsr(:,:) * tmask(:,:,1)
- DO jk = 2, nksrp + 1
- etot3(:,:,jk) = ( ze0(:,:,jk) + ze1(:,:,jk) + ze2(:,:,jk) + ze3(:,:,jk) ) * tmask(:,:,jk)
- END DO
+ DO_2D( 0, 0, 0, 0 )
+ etot3(ji,jj,1) = qsr(ji,jj) * tmask(ji,jj,1)
+ END_2D
+ DO_3D( 0, 0, 0, 0, 2, nksrp+1 )
+ etot3(ji,jj,jk) = ( ze0(ji,jj,jk) + ze1(ji,jj,jk) + ze2(ji,jj,jk) + ze3(ji,jj,jk) ) * tmask(ji,jj,jk)
+ END_3D
! ! ------------------------
ENDIF
! Photosynthetically Available Radiation (PAR)
! --------------------------------------------
- zqsr_corr(:,:) = parsw(:,:) * qsr(:,:) / ( 1.-fr_i(:,:) + rtrn )
+ DO_2D( 0, 0, 0, 0 )
+ zqsr_corr(ji,jj) = parsw(ji,jj) * qsr(ji,jj) / ( 1.-fr_i(ji,jj) + rtrn )
+ END_2D
!
CALL trc_opt_par( kt, zqsr_corr, ze1, ze2, ze3 )
!
- DO jk = 1, nksrp
- etot (:,:,jk) = ze1(:,:,jk) + ze2(:,:,jk) + ze3(:,:,jk)
- ENDDO
+ DO_3D( 0, 0, 0, 0, 1, nksr )
+ etot(ji,jj,jk) = ze1(ji,jj,jk) + ze2(ji,jj,jk) + ze3(ji,jj,jk)
+ END_3D
! No Diurnal cycle PAR
IF( l_trcdm2dc ) THEN
- zqsr_corr(:,:) = parsw(:,:) * qsr_mean(:,:) / ( 1.-fr_i(:,:) + rtrn )
+ DO_2D( 0, 0, 0, 0 )
+ zqsr_corr(ji,jj) = parsw(ji,jj) * qsr_mean(ji,jj) / ( 1.-fr_i(ji,jj) + rtrn )
+ END_2D
!
CALL trc_opt_par( kt, zqsr_corr, ze1, ze2, ze3 )
- DO jk = 1, nksrp
- etot_ndcy(:,:,jk) = ze1(:,:,jk) + ze2(:,:,jk) + ze3(:,:,jk)
- END DO
+ !
+ DO_3D( 0, 0, 0, 0, 1, nksr )
+ etot_ndcy(ji,jj,jk) = ze1(ji,jj,jk) + ze2(ji,jj,jk) + ze3(ji,jj,jk)
+ END_3D
ELSE
etot_ndcy(:,:,:) = etot(:,:,:)
ENDIF
! Weighted broadband attenuation coefficient
! ------------------------------------------
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 )
+ DO_3D( 0, 0, 0, 0, 1, jpkm1 )
ztmp = ze1(ji,jj,jk)* ekb(ji,jj,jk) + ze2(ji,jj,jk) * ekg(ji,jj,jk) + ze3(ji,jj,jk) * ekr(ji,jj,jk)
zeps(ji,jj,jk) = ztmp / e3t(ji,jj,jk,Kmm) / (etot(ji,jj,jk) + rtrn)
END_3D
@@ -154,26 +165,24 @@ CONTAINS
! Light at the euphotic depth
! ---------------------------
- zqsr100 = 0.01 * 3. * zqsr_corr(:,:)
+ zqsr100(:,:) = 0.01 * 3. * zqsr_corr(:,:)
! Euphotic depth and level
! ------------------------
- neln (:,:) = 1
- heup (:,:) = gdepw(:,:,2,Kmm)
- heup_01(:,:) = gdepw(:,:,2,Kmm)
- !
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 2, nksrp )
+ DO_2D( 0, 0, 0, 0 )
+ neln (ji,jj) = 1
+ heup (ji,jj) = gdepw(ji,jj,2,Kmm)
+ heup_01(ji,jj) = gdepw(ji,jj,2,Kmm)
+ END_2D
+
+ DO_3D( 0, 0, 0, 0, 2, nksr)
IF( etot_ndcy(ji,jj,jk) * tmask(ji,jj,jk) >= zqsr100(ji,jj) ) THEN
- ! Euphotic level (1st T-level strictly below Euphotic layer)
- ! NOTE: ensure compatibility with nmld_trc definition in trdmxl_trc
- neln(ji,jj) = jk+1
- !
- ! Euphotic layer depth
- heup(ji,jj) = gdepw(ji,jj,jk+1,Kmm)
+ neln(ji,jj) = jk+1 ! Euphotic level : 1rst T-level strictly below Euphotic layer
+ ! ! nb: ensure the compatibility with nmld_trc definition in trd_mld_trc_zint
+ heup(ji,jj) = gdepw(ji,jj,jk+1,Kmm) ! Euphotic layer depth
ENDIF
- ! Euphotic layer depth (light level definition)
- IF( etot_ndcy(ji,jj,jk) * tmask(ji,jj,jk) >= 0.50 ) THEN
- heup_01(ji,jj) = gdepw(ji,jj,jk+1,Kmm)
+ IF( etot_ndcy(ji,jj,jk) * tmask(ji,jj,jk) >= 0.10 ) THEN
+ heup_01(ji,jj) = gdepw(ji,jj,jk+1,Kmm) ! Euphotic layer depth (light level definition)
ENDIF
END_3D
!
@@ -181,8 +190,18 @@ CONTAINS
heup_01(:,:) = MIN( 300., heup_01(:,:) )
!
IF( lk_iomput ) THEN
- CALL iom_put( "xbla" , zeps(:,:,:) * tmask(:,:,:) )
- CALL iom_put( "Heup" , heup(:,: ) * tmask(:,:,1) )
+ IF( iom_use( "Heup" ) ) THEN
+ ALLOCATE( zw2d(A2D(0)) )
+ zw2d(A2D(0)) = heup(A2D(0)) * tmask(A2D(0),1)
+ CALL iom_put( "Heup", zw2d ) ! Euphotic layer depth
+ DEALLOCATE( zw2d )
+ ENDIF
+ IF( iom_use( "xbla" ) ) THEN
+ ALLOCATE( zw3d(A2D(0),jpk)) ; zw3d(A2D(0),jpk) = 0._wp
+ zw3d(A2D(0),1:jpkm1) = zeps(A2D(0),1:jpkm1) * tmask(A2D(0),1:jpkm1)
+ CALL iom_put( "xbla", zw3d ) ! Euphotic layer depth
+ DEALLOCATE( zw3d )
+ ENDIF
ENDIF
!
IF( ln_timing ) CALL timing_stop('trc_opt')
@@ -199,11 +218,11 @@ CONTAINS
!!
!!----------------------------------------------------------------------
INTEGER , INTENT(in) :: kt ! ocean time-step
- REAL(wp), DIMENSION(jpi,jpj) , INTENT(in) :: zqsr ! real shortwave
- REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(out) :: pe1 , pe2 , pe3 ! PAR (R-G-B)
+ REAL(wp), DIMENSION(A2D(0)) , INTENT(in) :: zqsr ! real shortwave
+ REAL(wp), DIMENSION(A2D(0),jpk), INTENT(out) :: pe1 , pe2 , pe3 ! PAR (R-G-B)
!
INTEGER :: ji, jj, jk ! dummy loop indices
- REAL(wp), DIMENSION(jpi,jpj) :: we1, we2, we3 ! PAR (R-G-B) at w-level
+ REAL(wp), DIMENSION(A2D(0)) :: we1, we2, we3 ! PAR (R-G-B) at w-level
!!----------------------------------------------------------------------
pe1(:,:,:) = 0. ; pe2(:,:,:) = 0. ; pe3(:,:,:) = 0.
!
@@ -213,7 +232,7 @@ CONTAINS
pe2(:,:,1) = zqsr(:,:) * EXP( -0.5 * ekg(:,:,1) )
pe3(:,:,1) = zqsr(:,:) * EXP( -0.5 * ekr(:,:,1) )
!
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 2, nksrp )
+ DO_3D( 0, 0, 0, 0, 2, nksrp )
pe1(ji,jj,jk) = pe1(ji,jj,jk-1) * EXP( -0.5 * ( ekb(ji,jj,jk-1) + ekb(ji,jj,jk) ) )
pe2(ji,jj,jk) = pe2(ji,jj,jk-1) * EXP( -0.5 * ( ekg(ji,jj,jk-1) + ekg(ji,jj,jk) ) )
pe3(ji,jj,jk) = pe3(ji,jj,jk-1) * EXP( -0.5 * ( ekr(ji,jj,jk-1) + ekr(ji,jj,jk) ) )
@@ -225,7 +244,7 @@ CONTAINS
we2(:,:) = zqsr(:,:)
we3(:,:) = zqsr(:,:)
!
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, nksrp )
+ DO_3D( 0, 0, 0, 0, 1, nksrp )
! integrate PAR over current t-level
pe1(ji,jj,jk) = we1(ji,jj) / (ekb(ji,jj,jk) + rtrn) * (1. - EXP( -ekb(ji,jj,jk) ))
pe2(ji,jj,jk) = we2(ji,jj) / (ekg(ji,jj,jk) + rtrn) * (1. - EXP( -ekg(ji,jj,jk) ))
@@ -266,7 +285,9 @@ CONTAINS
IF( ln_varpar ) THEN
IF( kt == nittrc000 .OR. ( kt /= nittrc000 .AND. ntimes_par > 1 ) ) THEN
CALL fld_read( kt, 1, sf_par )
- par_varsw(:,:) = ( sf_par(1)%fnow(:,:,1) ) / 3.0
+ DO_2D( 0, 0, 0, 0 )
+ par_varsw(ji,jj) = ( sf_par(1)%fnow(ji,jj,1) ) / 3.0
+ END_2D
ENDIF
ENDIF
!
@@ -348,8 +369,8 @@ CONTAINS
!! *** ROUTINE trc_opt_alloc ***
!!----------------------------------------------------------------------
!
- ALLOCATE( ekb(jpi,jpj,jpk), ekr(jpi,jpj,jpk), &
- ekg(jpi,jpj,jpk),zeps(jpi,jpj,jpk), STAT= trc_opt_alloc )
+ ALLOCATE( ekb(A2D(0),jpk),ekr(A2D(0),jpk), &
+ ekg(A2D(0),jpk),zeps(A2D(0),jpk), STAT= trc_opt_alloc )
!
IF( trc_opt_alloc /= 0 ) CALL ctl_stop( 'STOP', 'trc_opt_alloc : failed to allocate arrays.' )
!
diff --git a/src/TOP/trcstp.F90 b/src/TOP/trcstp.F90
index e016e27c21a29717d244b5d8d76cd13036a74989..5e98d3c38fbfd41dbbb9a9dcedfc588e14622f03 100644
--- a/src/TOP/trcstp.F90
+++ b/src/TOP/trcstp.F90
@@ -37,6 +37,8 @@ MODULE trcstp
REAL(wp) :: rsecfst, rseclast ! ???
REAL(wp), DIMENSION(:,:,:), SAVE, ALLOCATABLE :: qsr_arr ! save qsr during TOP time-step
+ !! * Substitutions
+# include "do_loop_substitute.h90"
# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/TOP 4.0 , NEMO Consortium (2018)
@@ -74,17 +76,13 @@ CONTAINS
ll_trcstat = ( sn_cfctl%l_trcstat ) .AND. &
& ( ( MOD( kt, sn_cfctl%ptimincr ) == 0 ) .OR. ( kt == nitend ) )
- IF( kt == nittrc000 ) CALL trc_stp_ctl ! control
IF( kt == nittrc000 .AND. lk_trdmxl_trc ) CALL trd_mxl_trc_init ! trends: Mixed-layer
!
IF( .NOT.ln_linssh ) THEN ! update ocean volume due to ssh temporal evolution
DO jk = 1, jpk
cvol(:,:,jk) = e1e2t(:,:) * e3t(:,:,jk,Kmm) * tmask(:,:,jk)
END DO
- IF ( ll_trcstat .OR. kt == nitrst .OR. ( ln_check_mass .AND. kt == nitend ) &
- & .OR. iom_use( "pno3tot" ) .OR. iom_use( "ppo4tot" ) .OR. iom_use( "psiltot" ) &
- & .OR. iom_use( "palktot" ) .OR. iom_use( "pfertot" ) ) &
- & areatot = glob_sum( 'trcstp', cvol(:,:,:) )
+ IF ( ll_trcstat .OR. kt == nitrst ) areatot = glob_sum( 'trcstp', cvol(:,:,:) )
ENDIF
!
IF( l_trcdm2dc ) CALL trc_mean_qsr( kt )
@@ -142,20 +140,6 @@ CONTAINS
END SUBROUTINE trc_stp
- SUBROUTINE trc_stp_ctl
- !!----------------------------------------------------------------------
- !! *** ROUTINE trc_stp_ctl ***
- !!----------------------------------------------------------------------
- !
- ! Define logical parameter ton control dirunal cycle in TOP
- l_trcdm2dc = ( ln_trcdc2dm .AND. .NOT. ln_dm2dc )
- !
- IF( l_trcdm2dc .AND. lwp ) CALL ctl_warn( 'Coupling with passive tracers and used of diurnal cycle.', &
- & 'Computation of a daily mean shortwave for some biogeochemical models ' )
- !
- END SUBROUTINE trc_stp_ctl
-
-
SUBROUTINE trc_mean_qsr( kt )
!!----------------------------------------------------------------------
!! *** ROUTINE trc_mean_qsr ***
@@ -170,7 +154,7 @@ CONTAINS
!!----------------------------------------------------------------------
INTEGER, INTENT( in ) :: kt ! ocean time-step index
!
- INTEGER :: jn ! dummy loop indices
+ INTEGER :: ji,jj,jn ! dummy loop indices
REAL(wp) :: zkt, zrec ! local scalars
CHARACTER(len=1) :: cl1 ! 1 character
CHARACTER(len=2) :: cl2 ! 2 characters
@@ -189,7 +173,7 @@ CONTAINS
WRITE(numout,*)
ENDIF
!
- ALLOCATE( qsr_arr(jpi,jpj,nb_rec_per_day ) )
+ ALLOCATE( qsr_arr(A2D(0),nb_rec_per_day ) )
!
! !* Restart: read in restart file
IF( ln_rsttr .AND. nn_rsttr /= 0 .AND. iom_varid( numrtr, 'qsr_mean' , ldstop = .FALSE. ) > 0 &
@@ -220,7 +204,9 @@ CONTAINS
IF(lwp) WRITE(numout,*) 'trc_qsr_mean: qsr_mean set to nit000 values'
rsecfst = kt * rn_Dt
!
- qsr_mean(:,:) = qsr(:,:)
+ DO_2D( 0, 0, 0, 0 )
+ qsr_mean(ji,jj) = qsr(ji,jj)
+ END_2D
DO jn = 1, nb_rec_per_day
qsr_arr(:,:,jn) = qsr_mean(:,:)
END DO
@@ -240,7 +226,7 @@ CONTAINS
qsr_arr(:,:,jn) = qsr_arr(:,:,jn+1)
ENDDO
qsr_arr (:,:,nb_rec_per_day) = qsr(:,:)
- qsr_mean(:,: ) = SUM( qsr_arr(:,:,:), 3 ) / nb_rec_per_day
+ qsr_mean(:,:) = SUM( qsr_arr(:,:,:), 3 ) / nb_rec_per_day
ENDIF
!
IF( lrst_trc ) THEN !* Write the mean of qsr in restart file
diff --git a/src/TOP/trcstp_rk3.F90 b/src/TOP/trcstp_rk3.F90
index 450d4b5ed1adbb667939f233d34bf36796931c35..e42148d86257807a3b0265df257876a76315648f 100644
--- a/src/TOP/trcstp_rk3.F90
+++ b/src/TOP/trcstp_rk3.F90
@@ -41,6 +41,8 @@ MODULE trcstp_rk3
REAL(wp) :: rsecfst, rseclast ! ???
REAL(wp), DIMENSION(:,:,:), SAVE, ALLOCATABLE :: qsr_arr ! save qsr during TOP time-step
+ !! * Substitutions
+# include "do_loop_substitute.h90"
# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/TOP 4.0 , NEMO Consortium (2018)
@@ -71,15 +73,14 @@ CONTAINS
l_trcstat = ( sn_cfctl%l_trcstat ) .AND. &
& ( ( MOD( kt, sn_cfctl%ptimincr ) == 0 ) .OR. ( kt == nitend ) )
!
- IF( kt == nittrc000 ) CALL trc_stp_ctl ! control
+ IF( kt == nittrc000 ) CALL trc_stpsctl ! control
IF( kt == nittrc000 .AND. lk_trdmxl_trc ) CALL trd_mxl_trc_init ! trends: Mixed-layer
!
IF( .NOT.ln_linssh ) THEN ! update ocean volume due to ssh temporal evolution
DO jk = 1, jpk
cvol(:,:,jk) = e1e2t(:,:) * e3t(:,:,jk,Kmm) * tmask(:,:,jk)
END DO
- IF( l_trcstat .OR. kt == nitrst .OR. ( ln_check_mass .AND. kt == nitend ) ) &
- & areatot = glob_sum( 'trcstp', cvol(:,:,:) )
+ IF( l_trcstat .OR. kt == nitrst ) areatot = glob_sum( 'trcstp', cvol(:,:,:) )
ENDIF
!
IF( l_trcdm2dc ) CALL trc_mean_qsr( kt )
@@ -146,22 +147,6 @@ CONTAINS
END SUBROUTINE trc_stp_end
- SUBROUTINE trc_stp_ctl
- !!----------------------------------------------------------------------
- !! *** ROUTINE trc_stp_ctl ***
- !! ** Purpose : Control + ocean volume
- !!----------------------------------------------------------------------
- !
- ! Define logical parameter ton control dirunal cycle in TOP
- l_trcdm2dc = ln_dm2dc .OR. ( ln_cpl .AND. ncpl_qsr_freq /= 1 .AND. ncpl_qsr_freq /= 0 )
- l_trcdm2dc = l_trcdm2dc .AND. .NOT. l_offline
- !
- IF( l_trcdm2dc .AND. lwp ) CALL ctl_warn( 'Coupling with passive tracers and used of diurnal cycle.', &
- & 'Computation of a daily mean shortwave for some biogeochemical models ' )
- !
- END SUBROUTINE trc_stp_ctl
-
-
SUBROUTINE trc_mean_qsr( kt )
!!----------------------------------------------------------------------
!! *** ROUTINE trc_mean_qsr ***
@@ -176,7 +161,7 @@ CONTAINS
!!----------------------------------------------------------------------
INTEGER, INTENT( in ) :: kt ! ocean time-step index
!
- INTEGER :: jn ! dummy loop indices
+ INTEGER :: ji,jj,jn ! dummy loop indices
REAL(wp) :: zkt, zrec ! local scalars
CHARACTER(len=1) :: cl1 ! 1 character
CHARACTER(len=2) :: cl2 ! 2 characters
@@ -185,13 +170,9 @@ CONTAINS
IF( ln_timing ) CALL timing_start('trc_mean_qsr')
!
IF( kt == nittrc000 ) THEN
- IF( ln_cpl ) THEN
- rdt_sampl = rday / ncpl_qsr_freq
- nb_rec_per_day = ncpl_qsr_freq
- ELSE
- rdt_sampl = MAX( 3600., rn_Dt )
- nb_rec_per_day = INT( rday / rdt_sampl )
- ENDIF
+ !
+ rdt_sampl = REAL( ncpl_qsr_freq )
+ nb_rec_per_day = INT( rday / ncpl_qsr_freq )
!
IF(lwp) THEN
WRITE(numout,*)
@@ -199,7 +180,7 @@ CONTAINS
WRITE(numout,*)
ENDIF
!
- ALLOCATE( qsr_arr(jpi,jpj,nb_rec_per_day ) )
+ ALLOCATE( qsr_arr(A2D(0),nb_rec_per_day ) )
!
! !* Restart: read in restart file
IF( ln_rsttr .AND. nn_rsttr /= 0 .AND. iom_varid( numrtr, 'qsr_mean' , ldstop = .FALSE. ) > 0 &
@@ -230,7 +211,9 @@ CONTAINS
IF(lwp) WRITE(numout,*) 'trc_qsr_mean: qsr_mean set to nit000 values'
rsecfst = kt * rn_Dt
!
- qsr_mean(:,:) = qsr(:,:)
+ DO_2D( 0, 0, 0, 0 )
+ qsr_mean(ji,jj) = qsr(ji,jj)
+ END_2D
DO jn = 1, nb_rec_per_day
qsr_arr(:,:,jn) = qsr_mean(:,:)
END DO
@@ -250,7 +233,7 @@ CONTAINS
qsr_arr(:,:,jn) = qsr_arr(:,:,jn+1)
END DO
qsr_arr (:,:,nb_rec_per_day) = qsr(:,:)
- qsr_mean(:,: ) = SUM( qsr_arr(:,:,:), 3 ) / nb_rec_per_day
+ qsr_mean(:,:) = SUM( qsr_arr(:,:,:), 3 ) / nb_rec_per_day
ENDIF
!
IF( lrst_trc ) THEN !* Write the mean of qsr in restart file
diff --git a/src/TOP/trcwri.F90 b/src/TOP/trcwri.F90
index 39e3123fecd095832a58f8a49d793f0590b88467..bdfc35124d9bd74aa74a4065970a3333d2ccd7c7 100644
--- a/src/TOP/trcwri.F90
+++ b/src/TOP/trcwri.F90
@@ -42,12 +42,12 @@ CONTAINS
INTEGER, INTENT( in ) :: kt
INTEGER, INTENT( in ) :: Kmm ! time level indices
!
- INTEGER :: jk, jn
+ INTEGER :: ji,jj,jk,jn
CHARACTER (len=20) :: cltra
CHARACTER (len=40) :: clhstnam
INTEGER :: inum = 11 ! temporary logical unit
- REAL(wp), DIMENSION(jpi,jpj,jpk) :: z3d ! 3D workspace
- !!---------------------------------------------------------------------
+ REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: z3d, z3d0 ! 3D workspace
+ !!----------------------------------------------------------------------
!
IF( ln_timing ) CALL timing_start('trc_wri')
!
@@ -59,32 +59,55 @@ CONTAINS
CLOSE(inum)
ENDIF
+ ALLOCATE( z3d(jpi,jpj,jpk) ) ; z3d(:,:,:) = 0._wp
+ ALLOCATE( z3d0(A2D(0),jpk) ) ; z3d0(:,:,:) = 0._wp
+
! Output of initial vertical scale factor
- CALL iom_put( "e3t_0", e3t_0(:,:,:) )
- CALL iom_put( "e3u_0", e3u_0(:,:,:) )
- CALL iom_put( "e3v_0", e3v_0(:,:,:) )
+ IF( lk_vco_1d ) THEN
+ DO_3D( 0, 0, 0, 0, 1, jpk )
+ z3d(ji,jj,jk) = e3t_0(ji,jj,jk)
+ END_3D
+ CALL iom_put( "e3t_0", z3d )
+ !
+ DO_3D( 0, 0, 0, 0, 1, jpk )
+ z3d(ji,jj,jk) = e3u_0(ji,jj,jk)
+ END_3D
+ CALL iom_put( "e3u_0", z3d )
+ !
+ DO_3D( 0, 0, 0, 0, 1, jpk )
+ z3d(ji,jj,jk) = e3v_0(ji,jj,jk)
+ END_3D
+ CALL iom_put( "e3v_0", z3d )
+ ELSE
+ CALL iom_put( "e3t_0", e3t_0(:,:,:) )
+ CALL iom_put( "e3u_0", e3u_0(:,:,:) )
+ CALL iom_put( "e3v_0", e3v_0(:,:,:) )
+ ENDIF
!
IF( .NOT.ln_linssh ) CALL iom_put( "ssh" , ssh(:,:,Kmm) ) ! sea surface height
!
- IF ( iom_use("e3t") ) THEN ! time-varying e3t
- DO jk = 1, jpk
- z3d(:,:,jk) = e3t(:,:,jk,Kmm)
- END DO
- CALL iom_put( "e3t", z3d(:,:,:) )
+ ! --- vertical scale factors --- !
+ IF( iom_use("e3t") ) THEN ! time-varying e3t
+ DO_3D( 0, 0, 0, 0, 1, jpk )
+ z3d0(ji,jj,jk) = e3t(ji,jj,jk,Kmm)
+ END_3D
+ CALL iom_put( "e3t", z3d0 )
ENDIF
IF ( iom_use("e3u") ) THEN ! time-varying e3u
- DO jk = 1, jpk
- z3d(:,:,jk) = e3u(:,:,jk,Kmm)
- END DO
- CALL iom_put( "e3u", z3d(:,:,:) )
+ DO_3D( 0, 0, 0, 0, 1, jpk )
+ z3d0(ji,jj,jk) = e3u(ji,jj,jk,Kmm)
+ END_3D
+ CALL iom_put( "e3u" , z3d0 )
ENDIF
IF ( iom_use("e3v") ) THEN ! time-varying e3v
- DO jk = 1, jpk
- z3d(:,:,jk) = e3v(:,:,jk,Kmm)
- END DO
- CALL iom_put( "e3v", z3d(:,:,:) )
+ DO_3D( 0, 0, 0, 0, 1, jpk )
+ z3d0(ji,jj,jk) = e3v(ji,jj,jk,Kmm)
+ END_3D
+ CALL iom_put( "e3v" , z3d0 )
ENDIF
!
+ DEALLOCATE( z3d )
+ DEALLOCATE( z3d0 )
ENDIF
!
! write the tracer concentrations in the file
diff --git a/tests/ADIAB_WAVE/MY_SRC/sbcwave.F90 b/tests/ADIAB_WAVE/MY_SRC/sbcwave.F90
index 070d04706dc0d7909ea39283425645813b6eeafc..7d54953254123cb0638dec6a2d1354cc2cdfe2a7 100644
--- a/tests/ADIAB_WAVE/MY_SRC/sbcwave.F90
+++ b/tests/ADIAB_WAVE/MY_SRC/sbcwave.F90
@@ -245,11 +245,11 @@ CONTAINS
! !== vertical Stokes Drift 3D velocity ==!
!
DO_3D( 0, 1, 0, 1, 1, jpkm1 ) ! Horizontal e3*divergence
- ze3divh(ji,jj,jk) = ( e2u(ji ,jj) * e3u(ji ,jj,jk,Kmm) * usd(ji ,jj,jk) &
- & - e2u(ji-1,jj) * e3u(ji-1,jj,jk,Kmm) * usd(ji-1,jj,jk) &
- & + e1v(ji,jj ) * e3v(ji,jj ,jk,Kmm) * vsd(ji,jj ,jk) &
- & - e1v(ji,jj-1) * e3v(ji,jj-1,jk,Kmm) * vsd(ji,jj-1,jk) ) &
- & * r1_e1e2t(ji,jj)
+ ze3divh(ji,jj,jk) = ( ( e2u(ji ,jj) * e3u(ji ,jj,jk,Kmm) * usd(ji ,jj,jk) & ! add () for NP repro
+ & - e2u(ji-1,jj) * e3u(ji-1,jj,jk,Kmm) * usd(ji-1,jj,jk) ) &
+ & + ( e1v(ji,jj ) * e3v(ji,jj ,jk,Kmm) * vsd(ji,jj ,jk) &
+ & - e1v(ji,jj-1) * e3v(ji,jj-1,jk,Kmm) * vsd(ji,jj-1,jk) ) &
+ & ) * r1_e1e2t(ji,jj)
END_3D
!
CALL lbc_lnk( 'sbcwave', ze3divh, 'T', 1.0_wp )
diff --git a/tests/ADIAB_WAVE/MY_SRC/usrdef_hgr.F90 b/tests/ADIAB_WAVE/MY_SRC/usrdef_hgr.F90
index 12f778f5cac9148c6245b17c272b77ba0488d440..ac53839aaac33728fe5dbe9fee5b3f8b2a4399bb 100644
--- a/tests/ADIAB_WAVE/MY_SRC/usrdef_hgr.F90
+++ b/tests/ADIAB_WAVE/MY_SRC/usrdef_hgr.F90
@@ -80,14 +80,14 @@ CONTAINS
DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
! DO_2D( 1, 1, 1, 1 )
! ! longitude
- plamt(ji,jj) = zfact * ( REAL( mig0(ji)-1 , wp ) )
- plamu(ji,jj) = zfact * ( 0.5 + REAL( mig0(ji)-1 , wp ) )
+ plamt(ji,jj) = zfact * ( REAL( mig(ji,0)-1 , wp ) )
+ plamu(ji,jj) = zfact * ( 0.5 + REAL( mig(ji,0)-1 , wp ) )
plamv(ji,jj) = plamt(ji,jj)
plamf(ji,jj) = plamu(ji,jj)
! ! latitude
- pphit(ji,jj) = zfact2 * ( REAL( mjg0(jj)-1 , wp ) )
+ pphit(ji,jj) = zfact2 * ( REAL( mjg(jj,0)-1 , wp ) )
pphiu(ji,jj) = pphit(ji,jj)
- pphiv(ji,jj) = zfact2 * ( 0.5 + REAL( mjg0(jj)-1 , wp ) )
+ pphiv(ji,jj) = zfact2 * ( 0.5 + REAL( mjg(jj,0)-1 , wp ) )
pphif(ji,jj) = pphiv(ji,jj)
END_2D
!
diff --git a/tests/ADIAB_WAVE/MY_SRC/usrdef_zgr.F90 b/tests/ADIAB_WAVE/MY_SRC/usrdef_zgr.F90
index 5c7fac8382fe52b9c044774838d5f5641b28c06a..ed83f79c1c1020b8f309e0a2631672caf02665d1 100644
--- a/tests/ADIAB_WAVE/MY_SRC/usrdef_zgr.F90
+++ b/tests/ADIAB_WAVE/MY_SRC/usrdef_zgr.F90
@@ -14,8 +14,7 @@ MODULE usrdef_zgr
!! zgr_z1d : reference 1D z-coordinate
!!---------------------------------------------------------------------
USE oce ! ocean variables
- USE dom_oce , ONLY: mi0, mi1 ! ocean space and time domain
- USE dom_oce , ONLY: glamt ! ocean space and time domain
+ USE dom_oce ! ocean space and time domain
USE usrdef_nam ! User defined : namelist variables
!
USE in_out_manager ! I/O manager
@@ -105,10 +104,10 @@ CONTAINS
END_2D
CALL lbc_lnk( 'usrdef_zgr', zhu, 'U', 1. ) ! boundary condition: this mask the surrouding grid-points
! ! ==>>> set by hand non-zero value on first/last columns & rows
- DO ji = mi0(1), mi1(1) ! first row of global domain only
+ DO ji = mi0(1,nn_hls), mi1(1,nn_hls) ! first row of global domain only
zhu(ji,2) = zht(ji,2)
END DO
- DO ji = mi0(jpiglo), mi1(jpiglo) ! last row of global domain only
+ DO ji = mi0(jpiglo,nn_hls), mi1(jpiglo,nn_hls) ! last row of global domain only
zhu(ji,2) = zht(ji,2)
END DO
zhu(:,1) = zhu(:,2)
diff --git a/tests/BENCH/MY_SRC/usrdef_hgr.F90 b/tests/BENCH/MY_SRC/usrdef_hgr.F90
index bc6b282ce81d4af6d1e7f0934780ffc7a91fd758..ec715f295a75705b5965706dd715e121b075e307 100644
--- a/tests/BENCH/MY_SRC/usrdef_hgr.F90
+++ b/tests/BENCH/MY_SRC/usrdef_hgr.F90
@@ -75,15 +75,15 @@ CONTAINS
! define unique value on each point of the inner global domain. z2d ranging from 0.05 to -0.05
!
DO_2D( 0, 0, 0, 0 ) ! +/- 0.5
- z2d(ji,jj) = 0.5 - REAL( mig0(ji) + (mjg0(jj)-1) * Ni0glo, wp ) / REAL( Ni0glo * Nj0glo, wp )
+ z2d(ji,jj) = 0.5 - REAL( mig(ji,0) + (mjg(jj,0)-1) * Ni0glo, wp ) / REAL( Ni0glo * Nj0glo, wp )
END_2D
!
! Position coordinates (in grid points)
! ==========
DO_2D( 0, 0, 0, 0 )
- zti = REAL( mig0(ji), wp ) - 0.5_wp ! start at i=0.5 in the global grid without halos
- ztj = REAL( mjg0(jj), wp ) - 0.5_wp ! start at j=0.5 in the global grid without halos
+ zti = REAL( mig(ji,0), wp ) - 0.5_wp ! start at i=0.5 in the global grid without halos
+ ztj = REAL( mjg(jj,0), wp ) - 0.5_wp ! start at j=0.5 in the global grid without halos
plamt(ji,jj) = zti * (1. + 1.0e-5 * z2d(ji,jj) )
plamu(ji,jj) = ( zti + 0.5_wp ) * (1. + 2.0e-5 * z2d(ji,jj) )
diff --git a/tests/BENCH/MY_SRC/usrdef_istate.F90 b/tests/BENCH/MY_SRC/usrdef_istate.F90
index 69da90f1b8425eec665b26e6d8b8c2fc29628abe..bb35d7849422e2cc9f34673f677d4a8d5cc22af5 100644
--- a/tests/BENCH/MY_SRC/usrdef_istate.F90
+++ b/tests/BENCH/MY_SRC/usrdef_istate.F90
@@ -65,7 +65,7 @@ CONTAINS
! define unique value on each point of the inner global domain. z2d ranging from 0.05 to -0.05
!
DO_2D( 0, 0, 0, 0 ) ! +/- 0.05
- z2d(ji,jj) = 0.1 * ( 0.5 - REAL( mig0(ji) + (mjg0(jj)-1) * Ni0glo, wp ) / REAL( Ni0glo * Nj0glo, wp ) )
+ z2d(ji,jj) = 0.1 * ( 0.5 - REAL( mig(ji,0) + (mjg(jj,0)-1) * Ni0glo, wp ) / REAL( Ni0glo * Nj0glo, wp ) )
END_2D
!
DO_3D( 0, 0, 0, 0, 1, jpkm1 )
@@ -108,7 +108,7 @@ CONTAINS
IF(lwp) WRITE(numout,*) 'usr_def_istate_ssh : BENCH configuration, analytical definition of initial ssh'
!
DO_2D( 0, 0, 0, 0 ) ! sea level: +/- 0.05 m
- pssh(ji,jj) = 0.1 * ( 0.5 - REAL( mig0(ji) + (mjg0(jj)-1) * Ni0glo, wp ) / REAL( Ni0glo * Nj0glo, wp ) )
+ pssh(ji,jj) = 0.1 * ( 0.5 - REAL( mig(ji,0) + (mjg(jj,0)-1) * Ni0glo, wp ) / REAL( Ni0glo * Nj0glo, wp ) )
END_2D
!
CALL lbc_lnk('usrdef_istate', pssh, 'T', 1. ) ! apply boundary conditions
diff --git a/tests/BENCH/MY_SRC/usrdef_sbc.F90 b/tests/BENCH/MY_SRC/usrdef_sbc.F90
index e9ac757b669a92d58a27241281a7abf2db635ba8..fb690fe8e436f550a69bf82751ca49db6a1ef512 100644
--- a/tests/BENCH/MY_SRC/usrdef_sbc.F90
+++ b/tests/BENCH/MY_SRC/usrdef_sbc.F90
@@ -104,12 +104,19 @@ CONTAINS
! define unique value on each point. z2d ranging from 0.05 to -0.05
!
DO_2D( 0, 0, 0, 0 )
- zztmp = 0.1 * ( 0.5 - REAL( mig0(ji) + (mjg0(jj)-1) * Ni0glo, wp ) / REAL( Ni0glo * Nj0glo, wp ) )
+ zztmp = 0.1 * ( 0.5 - REAL( mig(ji,0) + (mjg(jj,0)-1) * Ni0glo, wp ) / REAL( Ni0glo * Nj0glo, wp ) )
utau_ice(ji,jj) = 0.1_wp + zztmp
vtau_ice(ji,jj) = 0.1_wp + zztmp
END_2D
- CALL lbc_lnk( 'usrdef_sbc', utau_ice, 'U', -1., vtau_ice, 'V', -1. )
+ IF( l_NFold .AND. c_NFtype == 'T' ) THEN ! force 0 at the folding points
+ utau_ice(mi0(jpiglo/2+1,nn_hls):mi1(jpiglo/2+1,nn_hls),mj0(jpjglo-nn_hls,nn_hls):mj1(jpjglo-nn_hls,nn_hls)) = 0._wp
+ vtau_ice(mi0(jpiglo/2+1,nn_hls):mi1(jpiglo/2+1,nn_hls),mj0(jpjglo-nn_hls,nn_hls):mj1(jpjglo-nn_hls,nn_hls)) = 0._wp
+ utau_ice(mi0( nn_hls+1,nn_hls):mi1( nn_hls+1,nn_hls),mj0(jpjglo-nn_hls,nn_hls):mj1(jpjglo-nn_hls,nn_hls)) = 0._wp
+ vtau_ice(mi0( nn_hls+1,nn_hls):mi1( nn_hls+1,nn_hls),mj0(jpjglo-nn_hls,nn_hls):mj1(jpjglo-nn_hls,nn_hls)) = 0._wp
+ ENDIF
+
+ CALL lbc_lnk( 'usrdef_sbc', utau_ice, 'T', -1., vtau_ice, 'T', -1., ldfull = .TRUE. )
#endif
!
END SUBROUTINE usrdef_sbc_ice_tau
@@ -125,7 +132,7 @@ CONTAINS
REAL(wp), DIMENSION(:,:,:), INTENT(in) :: phs ! snow thickness
REAL(wp), DIMENSION(:,:,:), INTENT(in) :: phi ! ice thickness
!!
- REAL(wp), DIMENSION(jpi,jpj) :: zsnw ! snw distribution after wind blowing
+ REAL(wp), DIMENSION(A2D(0)) :: zsnw ! snw distribution after wind blowing
!!---------------------------------------------------------------------
#if defined key_si3
!
@@ -150,9 +157,9 @@ CONTAINS
emp_ice (:,:) = SUM( a_i_b(:,:,:) * evap_ice(:,:,:), dim=3 ) - sprecip(:,:) * zsnw(:,:)
emp_oce (:,:) = emp_oce(:,:) - sprecip(:,:) * (1._wp - zsnw(:,:) )
qevap_ice(:,:,:) = 0._wp
- qprec_ice(:,:) = rhos * ( sst_m(:,:) * rcpi - rLfus ) * tmask(:,:,1) ! in J/m3
- qemp_oce (:,:) = - emp_oce(:,:) * sst_m(:,:) * rcp
- qemp_ice (:,:) = sprecip(:,:) * zsnw * ( sst_m(:,:) * rcpi - rLfus ) * tmask(:,:,1) ! solid precip (only)
+ qprec_ice(:,:) = rhos * ( sst_m(A2D(0)) * rcpi - rLfus ) * smask0(:,:) ! in J/m3
+ qemp_oce (:,:) = - emp_oce(:,:) * sst_m(A2D(0)) * rcp
+ qemp_ice (:,:) = sprecip(:,:) * zsnw * ( sst_m(A2D(0)) * rcpi - rLfus ) * smask0(:,:) ! solid precip (only)
! total fluxes
emp_tot (:,:) = emp_ice + emp_oce
diff --git a/tests/BENCH/MY_SRC/usrdef_zgr.F90 b/tests/BENCH/MY_SRC/usrdef_zgr.F90
index b547480010867bebbfec44f979d95ebe0c66470c..1f601c214d86d2567e4e3cf840c54463f6c64764 100644
--- a/tests/BENCH/MY_SRC/usrdef_zgr.F90
+++ b/tests/BENCH/MY_SRC/usrdef_zgr.F90
@@ -37,11 +37,11 @@ MODULE usrdef_zgr
CONTAINS
SUBROUTINE usr_def_zgr( ld_zco , ld_zps , ld_sco , ld_isfcav, & ! type of vertical coordinate
+ & k_top , k_bot , & ! top & bottom ocean level
& pdept_1d, pdepw_1d, pe3t_1d , pe3w_1d , & ! 1D reference vertical coordinate
- & pdept , pdepw , & ! 3D t & w-points depth
& pe3t , pe3u , pe3v , pe3f , & ! vertical scale factors
- & pe3w , pe3uw , pe3vw , & ! - - -
- & k_top , k_bot ) ! top & bottom ocean level
+ & pdept , pdepw , & ! 3D t & w-points depth
+ & pe3w , pe3uw , pe3vw ) ! vertical scale factors
!!---------------------------------------------------------------------
!! *** ROUTINE usr_def_zgr ***
!!
@@ -50,16 +50,12 @@ CONTAINS
!!----------------------------------------------------------------------
LOGICAL , INTENT(out) :: ld_zco, ld_zps, ld_sco ! vertical coordinate flags
LOGICAL , INTENT(out) :: ld_isfcav ! under iceshelf cavity flag
+ INTEGER , DIMENSION(:,:) , INTENT(out) :: k_top, k_bot ! first & last ocean level
REAL(wp), DIMENSION(:) , INTENT(out) :: pdept_1d, pdepw_1d ! 1D grid-point depth [m]
REAL(wp), DIMENSION(:) , INTENT(out) :: pe3t_1d , pe3w_1d ! 1D grid-point depth [m]
- REAL(wp), DIMENSION(:,:,:), INTENT(out) :: pdept, pdepw ! grid-point depth [m]
- REAL(wp), DIMENSION(:,:,:), INTENT(out) :: pe3t , pe3u , pe3v , pe3f ! vertical scale factors [m]
- REAL(wp), DIMENSION(:,:,:), INTENT(out) :: pe3w , pe3uw, pe3vw ! i-scale factors
- INTEGER , DIMENSION(:,:) , INTENT(out) :: k_top, k_bot ! first & last ocean level
- !
- INTEGER :: inum ! local logical unit
- REAL(WP) :: z_zco, z_zps, z_sco, z_cav
- REAL(wp), DIMENSION(jpi,jpj) :: z2d ! 2D workspace
+ REAL(wp), DIMENSION(:,:,:), OPTIONAL, INTENT(out) :: pdept, pdepw ! grid-point depth [m]
+ REAL(wp), DIMENSION(:,:,:), OPTIONAL, INTENT(out) :: pe3t , pe3u , pe3v , pe3f ! vertical scale factors [m]
+ REAL(wp), DIMENSION(:,:,:), OPTIONAL, INTENT(out) :: pe3w , pe3uw, pe3vw ! i-scale factors
!!----------------------------------------------------------------------
!
IF(lwp) WRITE(numout,*)
@@ -81,15 +77,16 @@ CONTAINS
!
CALL zgr_msk_top_bot( k_top , k_bot ) ! masked top and bottom ocean t-level indices
!
- ! ! z-coordinate (3D arrays) from the 1D z-coord.
- CALL zgr_zco( pdept_1d, pdepw_1d, pe3t_1d, pe3w_1d, & ! in : 1D reference vertical coordinate
- & pdept , pdepw , & ! out : 3D t & w-points depth
- & pe3t , pe3u , pe3v , pe3f , & ! vertical scale factors
- & pe3w , pe3uw , pe3vw ) ! - - -
+ IF( PRESENT( pe3t ) ) THEN ! z-coordinate (3D arrays) from the 1D z-coord.
+ CALL zgr_zco( pdept_1d, pdepw_1d, pe3t_1d, pe3w_1d, & ! in : 1D reference vertical coordinate
+ & pdept , pdepw , & ! out : 3D t & w-points depth
+ & pe3t , pe3u , pe3v , pe3f , & ! vertical scale factors
+ & pe3w , pe3uw , pe3vw ) ! - - -
+ ENDIF
!
END SUBROUTINE usr_def_zgr
-
+
SUBROUTINE zgr_z( pdept_1d, pdepw_1d, pe3t_1d , pe3w_1d ) ! 1D reference vertical coordinate
!!----------------------------------------------------------------------
!! *** ROUTINE zgr_z ***
@@ -197,15 +194,15 @@ CONTAINS
!
!!$ IF( c_NFtype == 'T' ) THEN ! add a small island in the upper corners to avoid model instabilities...
-!!$ z2d(mi0( nn_hls):mi1( nn_hls+2 ),mj0(jpjglo-nn_hls-1):mj1(jpjglo-nn_hls+1)) = 0._wp
-!!$ z2d(mi0(jpiglo-nn_hls):mi1(MIN(jpiglo,jpiglo-nn_hls+2)),mj0(jpjglo-nn_hls-1):mj1(jpjglo-nn_hls+1)) = 0._wp
-!!$ z2d(mi0(jpiglo/2 ):mi1( jpiglo/2 +2 ),mj0(jpjglo-nn_hls-1):mj1(jpjglo-nn_hls+1)) = 0._wp
+!!$ z2d(mi0( nn_hls,nn_hls):mi1( nn_hls+2 ,nn_hls),mj0(jpjglo-nn_hls-1,nn_hls):mj1(jpjglo-nn_hls+1,nn_hls)) = 0._wp
+!!$ z2d(mi0(jpiglo-nn_hls,nn_hls):mi1(MIN(jpiglo,jpiglo-nn_hls+2),nn_hls),mj0(jpjglo-nn_hls-1,nn_hls):mj1(jpjglo-nn_hls+1,nn_hls)) = 0._wp
+!!$ z2d(mi0(jpiglo/2 ,nn_hls):mi1( jpiglo/2 +2 ,nn_hls),mj0(jpjglo-nn_hls-1,nn_hls):mj1(jpjglo-nn_hls+1,nn_hls)) = 0._wp
!!$ ENDIF
!!$ !
- IF( c_NFtype == 'F' ) THEN ! Must mask the 2 pivot-points
- z2d(mi0(nn_hls+1):mi1(nn_hls+1),mj0(jpjglo-nn_hls):mj1(jpjglo-nn_hls)) = 0._wp
- z2d(mi0(jpiglo/2):mi1(jpiglo/2),mj0(jpjglo-nn_hls):mj1(jpjglo-nn_hls)) = 0._wp
- ENDIF
+!!$ IF( c_NFtype == 'F' ) THEN ! Must mask the 2 pivot-points
+!!$ z2d(mi0(nn_hls+1,nn_hls):mi1(nn_hls+1,nn_hls),mj0(jpjglo-nn_hls,nn_hls):mj1(jpjglo-nn_hls,nn_hls)) = 0._wp
+!!$ z2d(mi0(jpiglo/2,nn_hls):mi1(jpiglo/2,nn_hls),mj0(jpjglo-nn_hls,nn_hls):mj1(jpjglo-nn_hls,nn_hls)) = 0._wp
+!!$ ENDIF
!
CALL lbc_lnk( 'usrdef_zgr', z2d, 'T', 1._wp ) ! set surrounding land to zero (closed boundaries)
!
diff --git a/tests/BENCH/cpp_BENCH.fcm b/tests/BENCH/cpp_BENCH.fcm
index cd3173f56a174f47e14a09544d8e32a9e8cea146..c09e39ca5dae427c36d535b7517232af3243a3fb 100644
--- a/tests/BENCH/cpp_BENCH.fcm
+++ b/tests/BENCH/cpp_BENCH.fcm
@@ -1 +1 @@
- bld::tool::fppkeys key_si3 key_top key_qco
+ bld::tool::fppkeys key_si3 key_top key_qco key_vco_1d
diff --git a/tests/C1D_ASICS/MY_SRC/usrdef_nam.F90 b/tests/C1D_ASICS/MY_SRC/usrdef_nam.F90
index 538d753ce1ee95a7c140b11ece2e8e2abe58822c..c1d0b976524ec0e85b9bc2ea9354feff39231098 100644
--- a/tests/C1D_ASICS/MY_SRC/usrdef_nam.F90
+++ b/tests/C1D_ASICS/MY_SRC/usrdef_nam.F90
@@ -13,7 +13,6 @@ MODULE usrdef_nam
!! usr_def_nam : read user defined namelist and set global domain size
!! usr_def_hgr : initialize the horizontal mesh
!!----------------------------------------------------------------------
- USE dom_oce , ONLY: nimpp, njmpp ! ocean space and time domain
USE dom_oce , ONLY: ln_zco, ln_zps, ln_sco ! flag of type of coordinate
USE par_oce ! ocean space and time domain
USE phycst ! physical constants
diff --git a/tests/CANAL/EXPREF/file_def_nemo-oce.xml b/tests/CANAL/EXPREF/file_def_nemo-oce.xml
index 689b95dd6d9b1e960650cd83922b4ed7448d8ae5..45712ad6d87398fee622f6ab7574d39787508da4 100644
--- a/tests/CANAL/EXPREF/file_def_nemo-oce.xml
+++ b/tests/CANAL/EXPREF/file_def_nemo-oce.xml
@@ -20,15 +20,15 @@
<field field_ref="ssrelpotvor" />
<field field_ref="saltc" />
<field field_ref="salt2c" />
+ <field field_ref="utau" />
+ <field field_ref="vtau" />
</file>
<file id="file3" name_suffix="_grid_U" description="ocean U grid variables" >
- <field field_ref="utau" />
<field field_ref="uoce" />
</file>
<file id="file4" name_suffix="_grid_V" description="ocean V grid variables" >
- <field field_ref="vtau" />
<field field_ref="voce" />
</file>
diff --git a/tests/CANAL/MY_SRC/usrdef_hgr.F90 b/tests/CANAL/MY_SRC/usrdef_hgr.F90
index 8cb9d5bdd63f60707f5eb141312df90075034e2d..c7b469cf89c039d7887ae1c14dc6e149d082dc02 100644
--- a/tests/CANAL/MY_SRC/usrdef_hgr.F90
+++ b/tests/CANAL/MY_SRC/usrdef_hgr.F90
@@ -88,8 +88,8 @@ CONTAINS
#endif
DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
- zti = REAL( mig0(ji)-ii0, wp ) ! =0 at i=ii0 in the global grid without halos
- ztj = REAL( mjg0(jj)-ij0, wp ) ! =0 at i=ij0 in the global grid without halos
+ zti = REAL( mig(ji,0)-ii0, wp ) ! =0 at i=ii0 in the global grid without halos
+ ztj = REAL( mjg(jj,0)-ij0, wp ) ! =0 at i=ij0 in the global grid without halos
plamt(ji,jj) = rn_dx * zti
plamu(ji,jj) = rn_dx * ( zti + 0.5_wp )
diff --git a/tests/CANAL/MY_SRC/usrdef_zgr.F90 b/tests/CANAL/MY_SRC/usrdef_zgr.F90
index 1f9da256991333df8dbc50228df7dfddcdd00f62..e6438852a9db61a58dc973a7a369fe7dd4663979 100644
--- a/tests/CANAL/MY_SRC/usrdef_zgr.F90
+++ b/tests/CANAL/MY_SRC/usrdef_zgr.F90
@@ -38,11 +38,11 @@ MODULE usrdef_zgr
CONTAINS
SUBROUTINE usr_def_zgr( ld_zco , ld_zps , ld_sco , ld_isfcav, & ! type of vertical coordinate
+ & k_top , k_bot , & ! top & bottom ocean level
& pdept_1d, pdepw_1d, pe3t_1d , pe3w_1d , & ! 1D reference vertical coordinate
- & pdept , pdepw , & ! 3D t & w-points depth
& pe3t , pe3u , pe3v , pe3f , & ! vertical scale factors
- & pe3w , pe3uw , pe3vw , & ! - - -
- & k_top , k_bot ) ! top & bottom ocean level
+ & pdept , pdepw , & ! 3D t & w-points depth
+ & pe3w , pe3uw , pe3vw ) ! vertical scale factors
!!---------------------------------------------------------------------
!! *** ROUTINE usr_def_zgr ***
!!
@@ -51,16 +51,12 @@ CONTAINS
!!----------------------------------------------------------------------
LOGICAL , INTENT(out) :: ld_zco, ld_zps, ld_sco ! vertical coordinate flags
LOGICAL , INTENT(out) :: ld_isfcav ! under iceshelf cavity flag
+ INTEGER , DIMENSION(:,:) , INTENT(out) :: k_top, k_bot ! first & last ocean level
REAL(wp), DIMENSION(:) , INTENT(out) :: pdept_1d, pdepw_1d ! 1D grid-point depth [m]
REAL(wp), DIMENSION(:) , INTENT(out) :: pe3t_1d , pe3w_1d ! 1D grid-point depth [m]
- REAL(wp), DIMENSION(:,:,:), INTENT(out) :: pdept, pdepw ! grid-point depth [m]
- REAL(wp), DIMENSION(:,:,:), INTENT(out) :: pe3t , pe3u , pe3v , pe3f ! vertical scale factors [m]
- REAL(wp), DIMENSION(:,:,:), INTENT(out) :: pe3w , pe3uw, pe3vw ! i-scale factors
- INTEGER , DIMENSION(:,:) , INTENT(out) :: k_top, k_bot ! first & last ocean level
- !
- INTEGER :: inum ! local logical unit
- REAL(WP) :: z_zco, z_zps, z_sco, z_cav
- REAL(wp), DIMENSION(jpi,jpj) :: z2d ! 2D workspace
+ REAL(wp), DIMENSION(:,:,:), OPTIONAL, INTENT(out) :: pdept, pdepw ! grid-point depth [m]
+ REAL(wp), DIMENSION(:,:,:), OPTIONAL, INTENT(out) :: pe3t , pe3u , pe3v , pe3f ! vertical scale factors [m]
+ REAL(wp), DIMENSION(:,:,:), OPTIONAL, INTENT(out) :: pe3w , pe3uw, pe3vw ! i-scale factors
!!----------------------------------------------------------------------
!
IF(lwp) WRITE(numout,*)
@@ -82,11 +78,13 @@ CONTAINS
!
CALL zgr_msk_top_bot( k_top , k_bot ) ! masked top and bottom ocean t-level indices
!
- ! ! z-coordinate (3D arrays) from the 1D z-coord.
- CALL zgr_zco( pdept_1d, pdepw_1d, pe3t_1d, pe3w_1d, & ! in : 1D reference vertical coordinate
- & pdept , pdepw , & ! out : 3D t & w-points depth
- & pe3t , pe3u , pe3v , pe3f , & ! vertical scale factors
- & pe3w , pe3uw , pe3vw ) ! - - -
+ !
+ IF( PRESENT( pe3t ) ) THEN ! z-coordinate (3D arrays) from the 1D z-coord.
+ CALL zgr_zco( pdept_1d, pdepw_1d, pe3t_1d, pe3w_1d, & ! in : 1D reference vertical coordinate
+ & pdept , pdepw , & ! out : 3D t & w-points depth
+ & pe3t , pe3u , pe3v , pe3f , & ! vertical scale factors
+ & pe3w , pe3uw , pe3vw ) ! - - -
+ ENDIF
!
END SUBROUTINE usr_def_zgr
diff --git a/tests/CANAL/cpp_CANAL.fcm b/tests/CANAL/cpp_CANAL.fcm
index 49e75303359f07b5071c2eb02f3188d207210d54..65263b4e637bdfdc6da04ebd34447212ff046168 100644
--- a/tests/CANAL/cpp_CANAL.fcm
+++ b/tests/CANAL/cpp_CANAL.fcm
@@ -1 +1 @@
- bld::tool::fppkeys key_xios key_qco
+ bld::tool::fppkeys key_xios key_qco key_vco_1d
diff --git a/tests/DIA_GPU/EXPREF/file_def_nemo-oce.xml b/tests/DIA_GPU/EXPREF/file_def_nemo-oce.xml
index c043f56fe5e9ae6fc252ae34d78b6c2660381ec9..04590b55f29789842576a1dff286ad9ec572d172 100644
--- a/tests/DIA_GPU/EXPREF/file_def_nemo-oce.xml
+++ b/tests/DIA_GPU/EXPREF/file_def_nemo-oce.xml
@@ -34,6 +34,8 @@
<field field_ref="qt_oce" name="qt_oce" />
<field field_ref="saltflx" name="sfx" />
<field field_ref="taum" name="taum" />
+ <field field_ref="utau" name="tauuo" />
+ <field field_ref="vtau" name="tauvo" />
<field field_ref="wspd" name="windsp" />
<field field_ref="precip" name="precip" />
<!-- ice and snow -->
@@ -44,7 +46,6 @@
<field field_ref="e3u" />
<field field_ref="ssu" name="uos" />
<field field_ref="uoce" name="uo" operation="instant" freq_op="5d" > @uoce_e3u / @e3u </field>
- <field field_ref="utau" name="tauuo" />
<field field_ref="uocetr_eff" name="uocetr_eff" />
<!-- available with diaar5 -->
<field field_ref="u_masstr" name="vozomatr" />
@@ -56,7 +57,6 @@
<field field_ref="e3v" />
<field field_ref="ssv" name="vos" />
<field field_ref="voce" name="vo" operation="instant" freq_op="5d" > @voce_e3v / @e3v </field>
- <field field_ref="vtau" name="tauvo" />
<field field_ref="vocetr_eff" name="vocetr_eff" />
<!-- available with diaar5 -->
<field field_ref="v_masstr" name="vomematr" />
diff --git a/tests/DIA_GPU/MY_SRC/stpctl.F90 b/tests/DIA_GPU/MY_SRC/stpctl.F90
index acf186402f013f39829f4d01a3dd39a21d1b8879..cf7cd09c9e6fc5d66a50d7bdce3543d96060af0f 100644
--- a/tests/DIA_GPU/MY_SRC/stpctl.F90
+++ b/tests/DIA_GPU/MY_SRC/stpctl.F90
@@ -232,7 +232,7 @@ CONTAINS
iloc(1:3,3) = MINLOC( ts(:,:,:,jp_sal,Kmm) , mask = llmsk(:,:,:) )
iloc(1:3,4) = MAXLOC( ts(:,:,:,jp_sal,Kmm) , mask = llmsk(:,:,:) )
DO ji = 1, jptst ! local domain indices ==> global domain indices, excluding halos
- iloc(1:2,ji) = (/ mig0(iloc(1,ji)), mjg0(iloc(2,ji)) /)
+ iloc(1:2,ji) = (/ mig(iloc(1,ji),0), mjg(iloc(2,ji),0) /)
END DO
iareamin(:) = narea ; iareamax(:) = narea ; iareasum(:) = 1 ! this is local information
ENDIF
diff --git a/tests/DOME/MY_SRC/usrdef_hgr.F90 b/tests/DOME/MY_SRC/usrdef_hgr.F90
index e135d867ad01c3effe1b5eda4ffb79775321b596..3717ef1cc0e7b7cac05812f497c814c2bbe57a56 100644
--- a/tests/DOME/MY_SRC/usrdef_hgr.F90
+++ b/tests/DOME/MY_SRC/usrdef_hgr.F90
@@ -93,8 +93,8 @@ CONTAINS
#endif
DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
- zti = REAL( mig0(ji) - 1, wp ) ! start at i=0 in the global grid without halos
- ztj = REAL( mjg0(jj) - 1, wp ) ! start at j=0 in the global grid without halos
+ zti = REAL( mig(ji,0) - 1, wp ) ! start at i=0 in the global grid without halos
+ ztj = REAL( mjg(jj,0) - 1, wp ) ! start at j=0 in the global grid without halos
plamt(ji,jj) = roffsetx + rn_dx * 1.e-3 * ( zti - 0.5_wp )
plamu(ji,jj) = roffsetx + rn_dx * 1.e-3 * zti
diff --git a/tests/DOME/MY_SRC/usrdef_istate.F90 b/tests/DOME/MY_SRC/usrdef_istate.F90
index e41bad22dc51d56f3ad634693a06281e573014d1..782e164e35250f7a9bc3af7ed437ca9211632f7c 100644
--- a/tests/DOME/MY_SRC/usrdef_istate.F90
+++ b/tests/DOME/MY_SRC/usrdef_istate.F90
@@ -105,10 +105,10 @@ CONTAINS
! ztd = 15._wp*gdepw_0(ji,jj,jk+1)-0.5*rho0*zn2/(rn_a0*grav)*gdepw_0(ji,jj,jk+1)**2
! ztu = 15._wp*gdepw_0(ji,jj,jk )-0.5*rho0*zn2/(rn_a0*grav)*gdepw_0(ji,jj,jk )**2
! pts(ji,jj,jk,jp_tem) = (ztd - ztu)/e3t_0(ji,jj,jk) * ptmask(ji,jj,jk)
- IF (Agrif_root().AND.( mjg0(jj) == Nj0glo-2 ) ) THEN
+ IF (Agrif_root().AND.( mjg(jj,0) == Nj0glo-2 ) ) THEN
pv(ji,jj,jk) = -sqrt(zdb*zh0)*exp(-zxw/zro)*(1._wp-zf) * ptmask(ji,jj,jk)
ENDIF
- IF (Agrif_root().AND.( mjg0(jj) == Nj0glo-1 ) ) THEN
+ IF (Agrif_root().AND.( mjg(jj,0) == Nj0glo-1 ) ) THEN
pts(ji,jj,jk,jp_tem) = MIN(pts(ji,jj,jk,jp_tem), 15._wp - zdb*rho0/grav/rn_a0*(1._wp-zf)) * ptmask(ji,jj,jk)
pts(ji,jj,jk,jp_sal) = 1._wp * ptmask(ji,jj,jk)
ENDIF
diff --git a/tests/DOME/MY_SRC/usrdef_zgr.F90 b/tests/DOME/MY_SRC/usrdef_zgr.F90
index 797006a772fd6df5b35684cf7bc4f997fe1dc69c..0fb7ecd0cfb333f9ec198dfd3e0f833f8bab3350 100644
--- a/tests/DOME/MY_SRC/usrdef_zgr.F90
+++ b/tests/DOME/MY_SRC/usrdef_zgr.F90
@@ -14,8 +14,7 @@ MODULE usrdef_zgr
!! zgr_z1d : reference 1D z-coordinate
!!---------------------------------------------------------------------
USE oce ! ocean variables
- USE dom_oce , ONLY: mi0, mi1 ! ocean space and time domain
- USE dom_oce , ONLY: glamt, gphit ! ocean space and time domain
+ USE dom_oce ! ocean space and time domain
USE usrdef_nam ! User defined : namelist variables
!
USE in_out_manager ! I/O manager
diff --git a/tests/DONUT/EXPREF/file_def_nemo-oce.xml b/tests/DONUT/EXPREF/file_def_nemo-oce.xml
index 40a640ffbc616de642a88e5a7976cb0633b3a40d..0f5dc0b4e0ca47c227f1ed46d96122ad66f4481e 100644
--- a/tests/DONUT/EXPREF/file_def_nemo-oce.xml
+++ b/tests/DONUT/EXPREF/file_def_nemo-oce.xml
@@ -28,6 +28,8 @@
<field field_ref="qt_oce" name="qt_oce" />
<field field_ref="saltflx" name="sfx" />
<field field_ref="taum" name="taum" />
+ <field field_ref="utau" name="tauuo" />
+ <field field_ref="vtau" name="tauvo" />
<field field_ref="wspd" name="windsp" />
<field field_ref="precip" name="precip" />
</file>
@@ -36,14 +38,12 @@
<field field_ref="e3u" />
<field field_ref="ssu" name="uos" />
<field field_ref="uoce" name="uo" operation="instant" freq_op="1d" > @uoce_e3u / @e3u </field>
- <field field_ref="utau" name="tauuo" />
</file>
<file id="file13" name_suffix="_grid_V" description="ocean V grid variables" >
<field field_ref="e3v" />
<field field_ref="ssv" name="vos" />
<field field_ref="voce" name="vo" operation="instant" freq_op="1d" > @voce_e3v / @e3v </field>
- <field field_ref="vtau" name="tauvo" />
</file>
</file_group>
diff --git a/tests/DONUT/cpp_DONUT.fcm b/tests/DONUT/cpp_DONUT.fcm
index b2a45480f8748e5d7a0cb34792b132ebdd4e35f4..647c4d5f591339110d6c9bf1de8efb89a605f8cd 100644
--- a/tests/DONUT/cpp_DONUT.fcm
+++ b/tests/DONUT/cpp_DONUT.fcm
@@ -1 +1 @@
- bld::tool::fppkeys key_si3 key_qco key_xios
+ bld::tool::fppkeys key_si3 key_qco key_xios key_zco
diff --git a/tests/ICB/MY_SRC/usrdef_nam.F90 b/tests/ICB/MY_SRC/usrdef_nam.F90
index e850ce892fc8898e80374eedac0d0268a6b2f4fa..a9e5401091b47826a38c8c471a967d73fde11195 100644
--- a/tests/ICB/MY_SRC/usrdef_nam.F90
+++ b/tests/ICB/MY_SRC/usrdef_nam.F90
@@ -14,7 +14,6 @@ MODULE usrdef_nam
!! usr_def_nam : read user defined namelist and set global domain size
!! usr_def_hgr : initialize the horizontal mesh
!!----------------------------------------------------------------------
- USE dom_oce , ONLY: nimpp , njmpp ! i- & j-indices of the local domain
USE dom_oce , ONLY: ln_zco, ln_zps, ln_sco ! flag of type of coordinate
USE par_oce ! ocean space and time domain
USE phycst ! physical constants
diff --git a/tests/ICE_ADV1D/EXPREF/file_def_nemo-ice.xml b/tests/ICE_ADV1D/EXPREF/file_def_nemo-ice.xml
index 712929ba9dafed4a8e0465203df44be460936813..7c5c6d538a4ea34a318d306d9d6f2ae6fd4a032f 100644
--- a/tests/ICE_ADV1D/EXPREF/file_def_nemo-ice.xml
+++ b/tests/ICE_ADV1D/EXPREF/file_def_nemo-ice.xml
@@ -22,8 +22,6 @@
<field field_ref="icethic" name="sithic" />
<field field_ref="icethic" name="sithic_max" operation="maximum" />
<field field_ref="icethic" name="sithic_min" operation="minimum" />
- <field field_ref="iceneg_pres" name="sineg_pres" />
- <field field_ref="iceneg_volu" name="sineg_volu" />
<field field_ref="fasticepres" name="fasticepres" />
<field field_ref="icevolu" name="sivolu" />
<field field_ref="iceconc" name="siconc" />
diff --git a/tests/ICE_ADV1D/MY_SRC/usrdef_hgr.F90 b/tests/ICE_ADV1D/MY_SRC/usrdef_hgr.F90
index 507212b66c157e048e60fbd7e31b79faedc5a880..92abf49f0240c8c9b9f60eb547ad8dbb47fac0e8 100644
--- a/tests/ICE_ADV1D/MY_SRC/usrdef_hgr.F90
+++ b/tests/ICE_ADV1D/MY_SRC/usrdef_hgr.F90
@@ -78,8 +78,8 @@ CONTAINS
zphi0 = -REAL(Nj0glo, wp) * 0.5 * 1.e-3 * rn_dy
DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
- zti = REAL( mig0(ji), wp ) - 0.5_wp ! start at i=0.5 in the global grid without halos
- ztj = REAL( mjg0(jj), wp ) - 0.5_wp ! start at j=0.5 in the global grid without halos
+ zti = REAL( mig(ji,0), wp ) - 0.5_wp ! start at i=0.5 in the global grid without halos
+ ztj = REAL( mjg(jj,0), wp ) - 0.5_wp ! start at j=0.5 in the global grid without halos
plamt(ji,jj) = zlam0 + rn_dx * 1.e-3 * zti
plamu(ji,jj) = zlam0 + rn_dx * 1.e-3 * ( zti + 0.5_wp )
diff --git a/tests/ICE_ADV1D/MY_SRC/usrdef_sbc.F90 b/tests/ICE_ADV1D/MY_SRC/usrdef_sbc.F90
index 6b65db2750185b4c2258d2821c635967810b972f..f242e5a3ca7a82eb83234df445f0a15ae5c6f237 100644
--- a/tests/ICE_ADV1D/MY_SRC/usrdef_sbc.F90
+++ b/tests/ICE_ADV1D/MY_SRC/usrdef_sbc.F90
@@ -16,17 +16,15 @@ MODULE usrdef_sbc
USE dom_oce ! ocean space and time domain
USE sbc_oce ! Surface boundary condition: ocean fields
USE sbc_ice ! Surface boundary condition: ice fields
+ USE sbc_phy, ONLY : pp_cldf
USE phycst ! physical constants
- USE ice, ONLY : at_i_b, a_i_b
- USE icethd_dh ! for CALL ice_thd_snwblow
- USE sbc_phy, ONLY : pp_cldf
+ USE ice, ONLY : jpl, at_i_b, a_i_b
!
USE in_out_manager ! I/O manager
USE lib_mpp ! distribued memory computing library
USE lbclnk ! ocean lateral boundary conditions (or mpp link)
USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined)
-
IMPLICIT NONE
PRIVATE
@@ -34,6 +32,8 @@ MODULE usrdef_sbc
PUBLIC usrdef_sbc_ice_tau ! routine called by icestp.F90 for ice dynamics
PUBLIC usrdef_sbc_ice_flx ! routine called by icestp.F90 for ice thermo
+ !! * Substitutions
+# include "do_loop_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
!! $Id: usrdef_sbc.F90 10074 2018-08-28 16:15:49Z nicolasmartin $
@@ -105,13 +105,13 @@ CONTAINS
!! ** Purpose : provide the surface boundary (flux) condition over sea-ice
!!---------------------------------------------------------------------
INTEGER, INTENT(in) :: kt ! ocean time step
- REAL(wp), DIMENSION(:,:,:), INTENT(in) :: phs ! snow thickness
- REAL(wp), DIMENSION(:,:,:), INTENT(in) :: phi ! ice thickness
+ REAL(wp), DIMENSION(:,:,:), INTENT(in) :: phs ! snow thickness
+ REAL(wp), DIMENSION(:,:,:), INTENT(in) :: phi ! ice thickness
!!
INTEGER :: jl
- REAL(wp) :: zfr1, zfr2 ! local variables
- REAL(wp), DIMENSION(jpi,jpj) :: zsnw ! snw distribution after wind blowing
- REAL(wp), DIMENSION(jpi,jpj) :: ztri
+ REAL(wp) :: zfr1, zfr2 ! local variables
+ REAL(wp), DIMENSION(A2D(0)) :: zsnw ! snw distribution after wind blowing
+ REAL(wp), DIMENSION(A2D(0)) :: ztri
!!---------------------------------------------------------------------
!
IF( kt==nit000 .AND. lwp) WRITE(numout,*)' usrdef_sbc_ice : ICE_ADV1D case: NO flux forcing'
@@ -135,9 +135,9 @@ CONTAINS
emp_ice (:,:) = SUM( a_i_b(:,:,:) * evap_ice(:,:,:), dim=3 ) - sprecip(:,:) * zsnw(:,:)
emp_oce (:,:) = emp_oce(:,:) - sprecip(:,:) * (1._wp - zsnw(:,:) )
qevap_ice(:,:,:) = 0._wp
- qprec_ice(:,:) = rhos * ( sst_m(:,:) * rcpi - rLfus ) * tmask(:,:,1) ! in J/m3
- qemp_oce (:,:) = - emp_oce(:,:) * sst_m(:,:) * rcp
- qemp_ice (:,:) = sprecip(:,:) * zsnw * ( sst_m(:,:) * rcpi - rLfus ) * tmask(:,:,1) ! solid precip (only)
+ qprec_ice(:,:) = rhos * ( sst_m(A2D(0)) * rcpi - rLfus ) * smask0(:,:) ! in J/m3
+ qemp_oce (:,:) = - emp_oce(:,:) * sst_m(A2D(0)) * rcp
+ qemp_ice (:,:) = sprecip(:,:) * zsnw * ( sst_m(A2D(0)) * rcpi - rLfus ) * smask0(:,:) ! solid precip (only)
! total fluxes
emp_tot (:,:) = emp_ice + emp_oce
@@ -149,9 +149,9 @@ CONTAINS
ztri(:,:) = 0.18 * ( 1.0 - cloud_fra(:,:) ) + 0.35 * cloud_fra(:,:) ! surface transmission when hi>10cm
!
DO jl = 1, jpl
- WHERE ( phs(:,:,jl) <= 0._wp .AND. phi(:,:,jl) < 0.1_wp ) ! linear decrease from hi=0 to 10cm
- qtr_ice_top(:,:,jl) = qsr_ice(:,:,jl) * ( ztri(:,:) + ( 1._wp - ztri(:,:) ) * ( 1._wp - phi(:,:,jl) * 10._wp ) )
- ELSEWHERE( phs(:,:,jl) <= 0._wp .AND. phi(:,:,jl) >= 0.1_wp ) ! constant (ztri) when hi>10cm
+ WHERE ( phs(A2D(0),jl) <= 0._wp .AND. phi(A2D(0),jl) < 0.1_wp ) ! linear decrease from hi=0 to 10cm
+ qtr_ice_top(:,:,jl) = qsr_ice(:,:,jl) * ( ztri(:,:) + ( 1._wp - ztri(:,:) ) * ( 1._wp - phi(A2D(0),jl) * 10._wp ) )
+ ELSEWHERE( phs(A2D(0),jl) <= 0._wp .AND. phi(A2D(0),jl) >= 0.1_wp ) ! constant (ztri) when hi>10cm
qtr_ice_top(:,:,jl) = qsr_ice(:,:,jl) * ztri(:,:)
ELSEWHERE ! zero when hs>0
qtr_ice_top(:,:,jl) = 0._wp
diff --git a/tests/ICE_ADV1D/MY_SRC/usrdef_zgr.F90 b/tests/ICE_ADV1D/MY_SRC/usrdef_zgr.F90
index 5e2735f7cf5bd9295fdc23b974e9413f8b7fb03d..e9e25e4a25eee8e1fd25706ca646e6ae40d41ec0 100644
--- a/tests/ICE_ADV1D/MY_SRC/usrdef_zgr.F90
+++ b/tests/ICE_ADV1D/MY_SRC/usrdef_zgr.F90
@@ -88,7 +88,7 @@ CONTAINS
!
! !== z-coordinate ==! (step-like topography)
! !* bottom ocean compute from the depth of grid-points
- jpkm1 = jpk
+ !!jpkm1 = jpk
k_bot(:,:) = 1 ! here use k_top as a land mask
! !* horizontally uniform coordinate (reference z-co everywhere)
DO jk = 1, jpk
diff --git a/tests/ICE_ADV2D/EXPREF/file_def_nemo-ice.xml b/tests/ICE_ADV2D/EXPREF/file_def_nemo-ice.xml
index 1213d19492c9e9e13b5821fde93aa998ee0cdfa4..7b1acad6badfb30b9132be84adf095cd8ecc48af 100644
--- a/tests/ICE_ADV2D/EXPREF/file_def_nemo-ice.xml
+++ b/tests/ICE_ADV2D/EXPREF/file_def_nemo-ice.xml
@@ -22,8 +22,6 @@
<field field_ref="icethic" name="sithic" />
<field field_ref="icethic" name="sithic_max" operation="maximum" />
<field field_ref="icethic" name="sithic_min" operation="minimum" />
- <field field_ref="iceneg_pres" name="sineg_pres" />
- <field field_ref="iceneg_volu" name="sineg_volu" />
<field field_ref="fasticepres" name="fasticepres" />
<field field_ref="icevolu" name="sivolu" />
<field field_ref="iceconc" name="siconc" />
diff --git a/tests/ICE_ADV2D/MY_SRC/usrdef_hgr.F90 b/tests/ICE_ADV2D/MY_SRC/usrdef_hgr.F90
index b2b645b8bef5d3e4e6e5bb2dbee77bfe5e14ed3b..0c554f80d531e4db2cb8bf57b27b4dd6fd9dac49 100644
--- a/tests/ICE_ADV2D/MY_SRC/usrdef_hgr.F90
+++ b/tests/ICE_ADV2D/MY_SRC/usrdef_hgr.F90
@@ -90,8 +90,8 @@ CONTAINS
#endif
DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
- zti = REAL( mig0(ji), wp ) - 0.5_wp ! start at i=0.5 in the global grid without halos
- ztj = REAL( mjg0(jj), wp ) - 0.5_wp ! start at j=0.5 in the global grid without halos
+ zti = REAL( mig(ji,0), wp ) - 0.5_wp ! start at i=0.5 in the global grid without halos
+ ztj = REAL( mjg(jj,0), wp ) - 0.5_wp ! start at j=0.5 in the global grid without halos
plamt(ji,jj) = zlam0 + rn_dx * 1.e-3 * zti
plamu(ji,jj) = zlam0 + rn_dx * 1.e-3 * ( zti + 0.5_wp )
@@ -110,19 +110,19 @@ CONTAINS
!! clem: This can be used with a 1proc simulation but I think it breaks repro when >1procs are used
!! DO jj = 1, jpj
!! DO ji = 1, jpi
-!! !!pe1t(ji,jj) = rn_dx * EXP( -0.8/REAL(jpiglo**2) * (mi0(ji)-REAL(jpiglo+1)*0.5)**2 ) ! gaussian shape
-!! !!pe2t(ji,jj) = rn_dy * EXP( -0.8/REAL(jpjglo**2) * (mj0(jj)-REAL(jpjglo+1)*0.5)**2 ) ! gaussian shape
-!! pe1t(ji,jj) = rn_dx * ( 1. -0.1 * ABS(REAL(mi0(ji))-REAL(jpiglo+1)*0.5) / (1.-REAL(jpiglo+1)*0.5) ) ! linear shape
-!! pe2t(ji,jj) = rn_dy * ( 1. -0.1 * ABS(REAL(mj0(jj))-REAL(jpjglo+1)*0.5) / (1.-REAL(jpjglo+1)*0.5) ) ! linear shape
+!! !!pe1t(ji,jj) = rn_dx * EXP( -0.8/REAL(jpiglo**2) * (mi0(ji,nn_hls)-REAL(jpiglo+1)*0.5)**2 ) ! gaussian shape
+!! !!pe2t(ji,jj) = rn_dy * EXP( -0.8/REAL(jpjglo**2) * (mj0(jj,nn_hls)-REAL(jpjglo+1)*0.5)**2 ) ! gaussian shape
+!! pe1t(ji,jj) = rn_dx * ( 1. -0.1 * ABS(REAL(mi0(ji,nn_hls))-REAL(jpiglo+1)*0.5) / (1.-REAL(jpiglo+1)*0.5) ) ! linear shape
+!! pe2t(ji,jj) = rn_dy * ( 1. -0.1 * ABS(REAL(mj0(jj,nn_hls))-REAL(jpjglo+1)*0.5) / (1.-REAL(jpjglo+1)*0.5) ) ! linear shape
!! END DO
!! END DO
!!#if defined key_agrif
!! IF( .NOT. Agrif_Root() ) THEN ! only works if the zoom is positioned at the center of the parent grid
!! DO jj = 1, jpj
!! DO ji = 1, jpi
-!! pe1t(ji,jj) = rn_dx * ( 1. -0.1 * ABS(REAL(mi0(ji))-REAL(jpiglo+1)*0.5) / (1.-REAL(jpiglo+1)*0.5) &
+!! pe1t(ji,jj) = rn_dx * ( 1. -0.1 * ABS(REAL(mi0(ji,nn_hls))-REAL(jpiglo+1)*0.5) / (1.-REAL(jpiglo+1)*0.5) &
!! & * REAL(jpiglo) / REAL(Agrif_Parent(jpiglo) * Agrif_Rhox()) ) ! factor to match parent grid
-!! pe2t(ji,jj) = rn_dy * ( 1. -0.1 * ABS(REAL(mj0(jj))-REAL(jpjglo+1)*0.5) / (1.-REAL(jpjglo+1)*0.5) &
+!! pe2t(ji,jj) = rn_dy * ( 1. -0.1 * ABS(REAL(mj0(jj,nn_hls))-REAL(jpjglo+1)*0.5) / (1.-REAL(jpjglo+1)*0.5) &
!! & * REAL(jpjglo) / REAL(Agrif_Parent(jpjglo) * Agrif_Rhoy()) ) ! factor to match parent grid
!! END DO
!! END DO
diff --git a/tests/ICE_ADV2D/MY_SRC/usrdef_sbc.F90 b/tests/ICE_ADV2D/MY_SRC/usrdef_sbc.F90
index 32df85c4ed8614aa7cffe0721c8ec3e7a990c168..508e0eb4b852730f042845d3e9eaf3819fcc3563 100644
--- a/tests/ICE_ADV2D/MY_SRC/usrdef_sbc.F90
+++ b/tests/ICE_ADV2D/MY_SRC/usrdef_sbc.F90
@@ -16,9 +16,9 @@ MODULE usrdef_sbc
USE dom_oce ! ocean space and time domain
USE sbc_oce ! Surface boundary condition: ocean fields
USE sbc_ice ! Surface boundary condition: ice fields
+ USE sbc_phy, ONLY : pp_cldf
USE phycst ! physical constants
USE ice, ONLY : jpl, at_i_b, a_i_b
- USE icethd_dh ! for CALL ice_thd_snwblow
!
USE in_out_manager ! I/O manager
USE lib_mpp ! distribued memory computing library
@@ -32,6 +32,8 @@ MODULE usrdef_sbc
PUBLIC usrdef_sbc_ice_tau ! routine called by icestp.F90 for ice dynamics
PUBLIC usrdef_sbc_ice_flx ! routine called by icestp.F90 for ice thermo
+ !! * Substitutions
+# include "do_loop_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
!! $Id: usrdef_sbc.F90 10074 2018-08-28 16:15:49Z nicolasmartin $
@@ -107,9 +109,9 @@ CONTAINS
REAL(wp), DIMENSION(:,:,:), INTENT(in) :: phi ! ice thickness
!!
INTEGER :: jl
- REAL(wp) :: zfr1, zfr2 ! local variables
- REAL(wp), DIMENSION(jpi,jpj) :: zsnw ! snw distribution after wind blowing
- REAL(wp), DIMENSION(jpi,jpj) :: ztri
+ REAL(wp) :: zfr1, zfr2 ! local variables
+ REAL(wp), DIMENSION(A2D(0)) :: zsnw ! snw distribution after wind blowing
+ REAL(wp), DIMENSION(A2D(0)) :: ztri
!!---------------------------------------------------------------------
!
IF( kt==nit000 .AND. lwp) WRITE(numout,*)' usrdef_sbc_ice : ICE_ADV2D case: NO flux forcing'
@@ -133,9 +135,9 @@ CONTAINS
emp_ice (:,:) = SUM( a_i_b(:,:,:) * evap_ice(:,:,:), dim=3 ) - sprecip(:,:) * zsnw(:,:)
emp_oce (:,:) = emp_oce(:,:) - sprecip(:,:) * (1._wp - zsnw(:,:) )
qevap_ice(:,:,:) = 0._wp
- qprec_ice(:,:) = rhos * ( sst_m(:,:) * rcpi - rLfus ) * tmask(:,:,1) ! in J/m3
- qemp_oce (:,:) = - emp_oce(:,:) * sst_m(:,:) * rcp
- qemp_ice (:,:) = sprecip(:,:) * zsnw * ( sst_m(:,:) * rcpi - rLfus ) * tmask(:,:,1) ! solid precip (only)
+ qprec_ice(:,:) = rhos * ( sst_m(A2D(0)) * rcpi - rLfus ) * smask0(:,:) ! in J/m3
+ qemp_oce (:,:) = - emp_oce(:,:) * sst_m(A2D(0)) * rcp
+ qemp_ice (:,:) = sprecip(:,:) * zsnw * ( sst_m(A2D(0)) * rcpi - rLfus ) * smask0(:,:) ! solid precip (only)
! total fluxes
emp_tot (:,:) = emp_ice + emp_oce
@@ -147,9 +149,9 @@ CONTAINS
ztri(:,:) = 0.18 * ( 1.0 - cloud_fra(:,:) ) + 0.35 * cloud_fra(:,:) ! surface transmission when hi>10cm
!
DO jl = 1, jpl
- WHERE ( phs(:,:,jl) <= 0._wp .AND. phi(:,:,jl) < 0.1_wp ) ! linear decrease from hi=0 to 10cm
- qtr_ice_top(:,:,jl) = qsr_ice(:,:,jl) * ( ztri(:,:) + ( 1._wp - ztri(:,:) ) * ( 1._wp - phi(:,:,jl) * 10._wp ) )
- ELSEWHERE( phs(:,:,jl) <= 0._wp .AND. phi(:,:,jl) >= 0.1_wp ) ! constant (ztri) when hi>10cm
+ WHERE ( phs(A2D(0),jl) <= 0._wp .AND. phi(A2D(0),jl) < 0.1_wp ) ! linear decrease from hi=0 to 10cm
+ qtr_ice_top(:,:,jl) = qsr_ice(:,:,jl) * ( ztri(:,:) + ( 1._wp - ztri(:,:) ) * ( 1._wp - phi(A2D(0),jl) * 10._wp ) )
+ ELSEWHERE( phs(A2D(0),jl) <= 0._wp .AND. phi(A2D(0),jl) >= 0.1_wp ) ! constant (ztri) when hi>10cm
qtr_ice_top(:,:,jl) = qsr_ice(:,:,jl) * ztri(:,:)
ELSEWHERE ! zero when hs>0
qtr_ice_top(:,:,jl) = 0._wp
diff --git a/tests/ICE_ADV2D/MY_SRC/usrdef_zgr.F90 b/tests/ICE_ADV2D/MY_SRC/usrdef_zgr.F90
index 38db0bd1ee8cf12d2fbc6784ca76dcc5cdc9c76e..a4ce102ab18fff2faf845ece0bc214d18b40effc 100644
--- a/tests/ICE_ADV2D/MY_SRC/usrdef_zgr.F90
+++ b/tests/ICE_ADV2D/MY_SRC/usrdef_zgr.F90
@@ -88,7 +88,7 @@ CONTAINS
!
! !== z-coordinate ==! (step-like topography)
! !* bottom ocean compute from the depth of grid-points
- jpkm1 = jpk
+ !!clem jpkm1 = jpk
k_bot(:,:) = 1 ! here use k_top as a land mask
! !* horizontally uniform coordinate (reference z-co everywhere)
DO jk = 1, jpk
diff --git a/tests/ICE_AGRIF/MY_SRC/usrdef_hgr.F90 b/tests/ICE_AGRIF/MY_SRC/usrdef_hgr.F90
index 9ac18267bd01a0fbc24a3469adb0eaf483d2cc95..c087ceeb08f4aa717bb5becfaee406ad0e5aee82 100644
--- a/tests/ICE_AGRIF/MY_SRC/usrdef_hgr.F90
+++ b/tests/ICE_AGRIF/MY_SRC/usrdef_hgr.F90
@@ -96,8 +96,8 @@ CONTAINS
ENDIF
#endif
DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
- zti = REAL( mig0(ji)-1, wp ) ! start at i=0 in the global grid without halos
- ztj = REAL( mjg0(jj)-1, wp ) ! start at j=0 in the global grid without halos
+ zti = REAL( mig(ji,0)-1, wp ) ! start at i=0 in the global grid without halos
+ ztj = REAL( mjg(jj,0)-1, wp ) ! start at j=0 in the global grid without halos
plamt(ji,jj) = roffsetx + rn_dx * 1.e-3 * ( zti - 0.5_wp )
plamu(ji,jj) = roffsetx + rn_dx * 1.e-3 * zti
@@ -116,19 +116,19 @@ CONTAINS
!! clem: This can be used with a 1proc simulation but I think it breaks repro when >1procs are used
!! DO jj = 1, jpj
!! DO ji = 1, jpi
-!! !!pe1t(ji,jj) = rn_dx * EXP( -0.8/REAL(jpiglo**2) * (mi0(ji)-REAL(jpiglo+1)*0.5)**2 ) ! gaussian shape
-!! !!pe2t(ji,jj) = rn_dy * EXP( -0.8/REAL(jpjglo**2) * (mj0(jj)-REAL(jpjglo+1)*0.5)**2 ) ! gaussian shape
-!! pe1t(ji,jj) = rn_dx * ( 1. -0.1 * ABS(REAL(mi0(ji))-REAL(jpiglo+1)*0.5) / (1.-REAL(jpiglo+1)*0.5) ) ! linear shape
-!! pe2t(ji,jj) = rn_dy * ( 1. -0.1 * ABS(REAL(mj0(jj))-REAL(jpjglo+1)*0.5) / (1.-REAL(jpjglo+1)*0.5) ) ! linear shape
+!! !!pe1t(ji,jj) = rn_dx * EXP( -0.8/REAL(jpiglo**2) * (mi0(ji,nn_hls)-REAL(jpiglo+1)*0.5)**2 ) ! gaussian shape
+!! !!pe2t(ji,jj) = rn_dy * EXP( -0.8/REAL(jpjglo**2) * (mj0(jj,nn_hls)-REAL(jpjglo+1)*0.5)**2 ) ! gaussian shape
+!! pe1t(ji,jj) = rn_dx * ( 1. -0.1 * ABS(REAL(mi0(ji,nn_hls))-REAL(jpiglo+1)*0.5) / (1.-REAL(jpiglo+1)*0.5) ) ! linear shape
+!! pe2t(ji,jj) = rn_dy * ( 1. -0.1 * ABS(REAL(mj0(jj,nn_hls))-REAL(jpjglo+1)*0.5) / (1.-REAL(jpjglo+1)*0.5) ) ! linear shape
!! END DO
!! END DO
!!#if defined key_agrif
!! IF( .NOT. Agrif_Root() ) THEN ! only works if the zoom is positioned at the center of the parent grid
!! DO jj = 1, jpj
!! DO ji = 1, jpi
-!! pe1t(ji,jj) = rn_dx * ( 1. -0.1 * ABS(REAL(mi0(ji))-REAL(jpiglo+1)*0.5) / (1.-REAL(jpiglo+1)*0.5) &
+!! pe1t(ji,jj) = rn_dx * ( 1. -0.1 * ABS(REAL(mi0(ji,nn_hls))-REAL(jpiglo+1)*0.5) / (1.-REAL(jpiglo+1)*0.5) &
!! & * REAL(jpiglo) / REAL(Agrif_Parent(jpiglo) * Agrif_Rhox()) ) ! factor to match parent grid
-!! pe2t(ji,jj) = rn_dy * ( 1. -0.1 * ABS(REAL(mj0(jj))-REAL(jpjglo+1)*0.5) / (1.-REAL(jpjglo+1)*0.5) &
+!! pe2t(ji,jj) = rn_dy * ( 1. -0.1 * ABS(REAL(mj0(jj,nn_hls))-REAL(jpjglo+1)*0.5) / (1.-REAL(jpjglo+1)*0.5) &
!! & * REAL(jpjglo) / REAL(Agrif_Parent(jpjglo) * Agrif_Rhoy()) ) ! factor to match parent grid
!! END DO
!! END DO
diff --git a/tests/ICE_AGRIF/MY_SRC/usrdef_sbc.F90 b/tests/ICE_AGRIF/MY_SRC/usrdef_sbc.F90
index 6e7c527bf6b2f0361b64717e4c46ca4acd491f2a..5ba2758fdf833f73adb137067238e6437b98bc15 100644
--- a/tests/ICE_AGRIF/MY_SRC/usrdef_sbc.F90
+++ b/tests/ICE_AGRIF/MY_SRC/usrdef_sbc.F90
@@ -18,7 +18,7 @@ MODULE usrdef_sbc
USE sbc_ice ! Surface boundary condition: ice fields
USE phycst ! physical constants
USE ice, ONLY : at_i_b, a_i_b
- USE icethd_dh ! for CALL ice_thd_snwblow
+!! USE icethd_dh ! for CALL ice_thd_snwblow
USE sbc_phy, ONLY : pp_cldf
!
USE in_out_manager ! I/O manager
@@ -33,6 +33,8 @@ MODULE usrdef_sbc
PUBLIC usrdef_sbc_ice_tau ! routine called by icestp.F90 for ice dynamics
PUBLIC usrdef_sbc_ice_flx ! routine called by icestp.F90 for ice thermo
+ !! * Substitutions
+# include "do_loop_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
!! $Id: usrdef_sbc.F90 14273 2021-01-06 10:57:45Z smasson $
@@ -109,8 +111,8 @@ CONTAINS
!!
INTEGER :: jl
REAL(wp) :: zfr1, zfr2 ! local variables
- REAL(wp), DIMENSION(jpi,jpj) :: zsnw ! snw distribution after wind blowing
- REAL(wp), DIMENSION(jpi,jpj) :: ztri
+ REAL(wp), DIMENSION(A2D(0)) :: zsnw ! snw distribution after wind blowing
+ REAL(wp), DIMENSION(A2D(0)) :: ztri
!!---------------------------------------------------------------------
!
IF( kt==nit000 .AND. lwp) WRITE(numout,*)' usrdef_sbc_ice : ICE_AGRIF case: NO flux forcing'
@@ -134,9 +136,9 @@ CONTAINS
emp_ice (:,:) = SUM( a_i_b(:,:,:) * evap_ice(:,:,:), dim=3 ) - sprecip(:,:) * zsnw(:,:)
emp_oce (:,:) = emp_oce(:,:) - sprecip(:,:) * (1._wp - zsnw(:,:) )
qevap_ice(:,:,:) = 0._wp
- qprec_ice(:,:) = rhos * ( sst_m(:,:) * rcpi - rLfus ) * tmask(:,:,1) ! in J/m3
- qemp_oce (:,:) = - emp_oce(:,:) * sst_m(:,:) * rcp
- qemp_ice (:,:) = sprecip(:,:) * zsnw * ( sst_m(:,:) * rcpi - rLfus ) * tmask(:,:,1) ! solid precip (only)
+ qprec_ice(:,:) = rhos * ( sst_m(A2D(0)) * rcpi - rLfus ) * smask0(:,:) ! in J/m3
+ qemp_oce (:,:) = - emp_oce(:,:) * sst_m(A2D(0)) * rcp
+ qemp_ice (:,:) = sprecip(:,:) * zsnw * ( sst_m(A2D(0)) * rcpi - rLfus ) * smask0(:,:) ! solid precip (only)
! total fluxes
emp_tot (:,:) = emp_ice + emp_oce
@@ -148,11 +150,11 @@ CONTAINS
ztri(:,:) = 0.18 * ( 1.0 - cloud_fra(:,:) ) + 0.35 * cloud_fra(:,:) ! surface transmission when hi>10cm
!
DO jl = 1, jpl
- WHERE ( phs(:,:,jl) <= 0._wp .AND. phi(:,:,jl) < 0.1_wp ) ! linear decrease from hi=0 to 10cm
- qtr_ice_top(:,:,jl) = qsr_ice(:,:,jl) * ( ztri(:,:) + ( 1._wp - ztri(:,:) ) * ( 1._wp - phi(:,:,jl) * 10._wp ) )
- ELSEWHERE( phs(:,:,jl) <= 0._wp .AND. phi(:,:,jl) >= 0.1_wp ) ! constant (ztri) when hi>10cm
+ WHERE ( phs(A2D(0),jl) <= 0._wp .AND. phi(A2D(0),jl) < 0.1_wp ) ! linear decrease from hi=0 to 10cm
+ qtr_ice_top(:,:,jl) = qsr_ice(:,:,jl) * ( ztri(:,:) + ( 1._wp - ztri(:,:) ) * ( 1._wp - phi(A2D(0),jl) * 10._wp ) )
+ ELSEWHERE( phs(A2D(0),jl) <= 0._wp .AND. phi(A2D(0),jl) >= 0.1_wp ) ! constant (ztri) when hi>10cm
qtr_ice_top(:,:,jl) = qsr_ice(:,:,jl) * ztri(:,:)
- ELSEWHERE ! zero when hs>0
+ ELSEWHERE ! zero when hs>0
qtr_ice_top(:,:,jl) = 0._wp
END WHERE
ENDDO
diff --git a/tests/ICE_AGRIF/MY_SRC/usrdef_zgr.F90 b/tests/ICE_AGRIF/MY_SRC/usrdef_zgr.F90
index 1ae48cb5660cdf3553df782d2fa55f273c8b5e63..770cc8b82c0a860de36c122a0a47ddfc826628cd 100644
--- a/tests/ICE_AGRIF/MY_SRC/usrdef_zgr.F90
+++ b/tests/ICE_AGRIF/MY_SRC/usrdef_zgr.F90
@@ -13,6 +13,7 @@ MODULE usrdef_zgr
!! usr_def_zgr : user defined vertical coordinate system (required)
!!---------------------------------------------------------------------
USE oce ! ocean variables
+ USE dom_oce ! lk_vco_.
USE usrdef_nam ! User defined : namelist variables
!
USE in_out_manager ! I/O manager
@@ -32,11 +33,11 @@ MODULE usrdef_zgr
CONTAINS
SUBROUTINE usr_def_zgr( ld_zco , ld_zps , ld_sco , ld_isfcav, & ! type of vertical coordinate
+ & k_top , k_bot , & ! top & bottom ocean level
& pdept_1d, pdepw_1d, pe3t_1d , pe3w_1d , & ! 1D reference vertical coordinate
+ & pe3t , pe3u , pe3v , pe3f , & ! vertical scale factors
& pdept , pdepw , & ! 3D t & w-points depth
- & pe3t , pe3u , pe3v , pe3f , & ! vertical scale factors
- & pe3w , pe3uw , pe3vw, & ! - - -
- & k_top , k_bot ) ! top & bottom ocean level
+ & pe3w , pe3uw , pe3vw ) ! vertical scale factors
!!---------------------------------------------------------------------
!! *** ROUTINE usr_def_zgr ***
!!
@@ -45,12 +46,12 @@ CONTAINS
!!----------------------------------------------------------------------
LOGICAL , INTENT(out) :: ld_zco, ld_zps, ld_sco ! vertical coordinate flags
LOGICAL , INTENT(out) :: ld_isfcav ! under iceshelf cavity flag
+ INTEGER , DIMENSION(:,:) , INTENT(out) :: k_top, k_bot ! first & last ocean level
REAL(wp), DIMENSION(:) , INTENT(out) :: pdept_1d, pdepw_1d ! 1D grid-point depth [m]
REAL(wp), DIMENSION(:) , INTENT(out) :: pe3t_1d , pe3w_1d ! 1D grid-point depth [m]
- REAL(wp), DIMENSION(:,:,:), INTENT(out) :: pdept, pdepw ! grid-point depth [m]
- REAL(wp), DIMENSION(:,:,:), INTENT(out) :: pe3t , pe3u , pe3v , pe3f ! vertical scale factors [m]
- REAL(wp), DIMENSION(:,:,:), INTENT(out) :: pe3w , pe3uw, pe3vw ! i-scale factors
- INTEGER , DIMENSION(:,:) , INTENT(out) :: k_top, k_bot ! first & last ocean level
+ REAL(wp), DIMENSION(:,:,:), OPTIONAL, INTENT(out) :: pdept, pdepw ! grid-point depth [m]
+ REAL(wp), DIMENSION(:,:,:), OPTIONAL, INTENT(out) :: pe3t , pe3u , pe3v , pe3f ! vertical scale factors [m]
+ REAL(wp), DIMENSION(:,:,:), OPTIONAL, INTENT(out) :: pe3w , pe3uw, pe3vw ! i-scale factors
!
INTEGER :: jk, k_dz ! dummy indices
!!----------------------------------------------------------------------
@@ -90,18 +91,19 @@ CONTAINS
! !* bottom ocean compute from the depth of grid-points
jpkm1 = jpk-1
k_bot(:,:) = 1 ! here use k_top as a land mask
- ! !* horizontally uniform coordinate (reference z-co everywhere)
- DO jk = 1, jpk
- pdept(:,:,jk) = pdept_1d(jk)
- pdepw(:,:,jk) = pdepw_1d(jk)
- pe3t (:,:,jk) = pe3t_1d (jk)
- pe3u (:,:,jk) = pe3t_1d (jk)
- pe3v (:,:,jk) = pe3t_1d (jk)
- pe3f (:,:,jk) = pe3t_1d (jk)
- pe3w (:,:,jk) = pe3w_1d (jk)
- pe3uw(:,:,jk) = pe3w_1d (jk)
- pe3vw(:,:,jk) = pe3w_1d (jk)
- END DO
+ IF( lk_vco_3d ) THEN !* horizontally uniform coordinate (reference z-co everywhere)
+ DO jk = 1, jpk
+ pdept(:,:,jk) = pdept_1d(jk)
+ pdepw(:,:,jk) = pdepw_1d(jk)
+ pe3t (:,:,jk) = pe3t_1d (jk)
+ pe3u (:,:,jk) = pe3t_1d (jk)
+ pe3v (:,:,jk) = pe3t_1d (jk)
+ pe3f (:,:,jk) = pe3t_1d (jk)
+ pe3w (:,:,jk) = pe3w_1d (jk)
+ pe3uw(:,:,jk) = pe3w_1d (jk)
+ pe3vw(:,:,jk) = pe3w_1d (jk)
+ END DO
+ ENDIF
!
END SUBROUTINE usr_def_zgr
diff --git a/tests/ICE_AGRIF/cpp_ICE_AGRIF.fcm b/tests/ICE_AGRIF/cpp_ICE_AGRIF.fcm
index 8262d471b894b3f1add4e5dbfb99ecc2112eaaa3..30ded8825ac8787a0f8ead5a20d30eabdd318fbc 100644
--- a/tests/ICE_AGRIF/cpp_ICE_AGRIF.fcm
+++ b/tests/ICE_AGRIF/cpp_ICE_AGRIF.fcm
@@ -1 +1 @@
-bld::tool::fppkeys key_agrif key_si3 key_linssh key_xios
+bld::tool::fppkeys key_agrif key_si3 key_linssh key_vco_1d key_xios
diff --git a/tests/ICE_RHEO/EXPREF/file_def_nemo-oce.xml b/tests/ICE_RHEO/EXPREF/file_def_nemo-oce.xml
index 0dbbd2144297dcf224fc26e69fcf0c10ee7978bc..b307458f5d70ec49c7634a845887c617d487c101 100644
--- a/tests/ICE_RHEO/EXPREF/file_def_nemo-oce.xml
+++ b/tests/ICE_RHEO/EXPREF/file_def_nemo-oce.xml
@@ -13,14 +13,17 @@
<file_group id="1ts" output_freq="1ts" output_level="10" enabled=".TRUE."/> <!-- 1 time step files -->
<file_group id="1h" output_freq="1h" output_level="10" enabled=".TRUE."> <!-- 1h files -->
+ <file id="file1" name_suffix="_grid_T" description="ocean T grid variables" >
+ <field field_ref="utau" name="sozotaux" />
+ <field field_ref="vtau" name="sometauy" />
+ </file>
+
<file id="file2" name_suffix="_grid_U" description="ocean U grid variables" >
<field field_ref="uoce" name="vozocrtx" />
- <field field_ref="utau" name="sozotaux" />
</file>
<file id="file3" name_suffix="_grid_V" description="ocean V grid variables" >
<field field_ref="voce" name="vomecrty" />
- <field field_ref="vtau" name="sometauy" />
</file>
</file_group>
diff --git a/tests/ICE_RHEO/MY_SRC/icedyn_rhg_eap.F90 b/tests/ICE_RHEO/MY_SRC/icedyn_rhg_eap.F90
index 2c5e43487d05e15c63bc35b4cd3ceecd7629d9c6..6db0b1114dfb9565eaf1f47c2a1139f591b99f71 100644
--- a/tests/ICE_RHEO/MY_SRC/icedyn_rhg_eap.F90
+++ b/tests/ICE_RHEO/MY_SRC/icedyn_rhg_eap.F90
@@ -573,7 +573,7 @@ CONTAINS
& ) * zmsk00y(ji,jj)
ENDIF
!extra code for test case boundary conditions
- IF (mjg(jj)<25 .or. mjg(jj)>975 .or. mig(ji)<25 .or. mig(ji)>975) THEN
+ IF (mjg(jj,nn_hls)<25 .or. mjg(jj,nn_hls)>975 .or. mig(ji,nn_hls)<25 .or. mig(ji,nn_hls)>975) THEN
v_ice(ji,jj) = zinvw*(ztauy_ai(ji,jj) + zCorV(ji,jj) + zspgV(ji,jj) + ztauy_oi(ji,jj))
END IF
@@ -630,7 +630,7 @@ CONTAINS
& ) * zmsk00x(ji,jj)
ENDIF
!extra code for test case boundary conditions
- IF (mjg(jj)<25 .or. mjg(jj)>975 .or. mig(ji)<25 .or. mig(ji)>975) THEN
+ IF (mjg(jj,nn_hls)<25 .or. mjg(jj,nn_hls)>975 .or. mig(ji,nn_hls)<25 .or. mig(ji,nn_hls)>975) THEN
u_ice(ji,jj) = zinvw*(ztaux_ai(ji,jj) + zCorU(ji,jj) + zspgU(ji,jj) + ztaux_oi(ji,jj))
END IF
@@ -689,7 +689,7 @@ CONTAINS
& ) * zmsk00x(ji,jj)
ENDIF
!extra code for test case boundary conditions
- IF (mjg(jj)<25 .or. mjg(jj)>975 .or. mig(ji)<25 .or. mig(ji)>975) THEN
+ IF (mjg(jj,nn_hls)<25 .or. mjg(jj,nn_hls)>975 .or. mig(ji,nn_hls)<25 .or. mig(ji,nn_hls)>975) THEN
u_ice(ji,jj) = zinvw*(ztaux_ai(ji,jj) + zCorU(ji,jj) + zspgU(ji,jj) + ztaux_oi(ji,jj))
END IF
END_2D
@@ -745,7 +745,7 @@ CONTAINS
& ) * zmsk00y(ji,jj)
ENDIF
!extra code for test case boundary conditions
- IF (mjg(jj)<25 .or. mjg(jj)>975 .or. mig(ji)<25 .or. mig(ji)>975) THEN
+ IF (mjg(jj,nn_hls)<25 .or. mjg(jj,nn_hls)>975 .or. mig(ji,nn_hls)<25 .or. mig(ji,nn_hls)>975) THEN
v_ice(ji,jj) = zinvw*(ztauy_ai(ji,jj) + zCorV(ji,jj) + zspgV(ji,jj) + ztauy_oi(ji,jj))
END IF
END_2D
@@ -1048,7 +1048,7 @@ CONTAINS
zresm = 0._wp
DO_2D( 0, 0, 0, 0 )
! cut of the boundary of the box (forced velocities)
- IF (mjg0(jj)>30 .AND. mjg0(jj)<=970 .AND. mig0(ji)>30 .AND. mig0(ji)<=970) THEN
+ IF (mjg(jj,0)>30 .AND. mjg(jj,0)<=970 .AND. mig(ji,0)>30 .AND. mig(ji,0)<=970) THEN
zresm = MAX( zresm, MAX( ABS( pu(ji,jj) - pub(ji,jj) ) * umask(ji,jj,1), &
& ABS( pv(ji,jj) - pvb(ji,jj) ) * vmask(ji,jj,1) ) * pmsk15(ji,jj) )
ENDIF
diff --git a/tests/ICE_RHEO/MY_SRC/icedyn_rhg_evp.F90 b/tests/ICE_RHEO/MY_SRC/icedyn_rhg_evp.F90
index e2df97c76b330d0d855e9d4521260c2dc3a93bdd..8f691d6ca3f18e403d45fd70a5d7655295c8ca10 100644
--- a/tests/ICE_RHEO/MY_SRC/icedyn_rhg_evp.F90
+++ b/tests/ICE_RHEO/MY_SRC/icedyn_rhg_evp.F90
@@ -525,7 +525,7 @@ CONTAINS
& ) * zmsk00y(ji,jj)
ENDIF
!extra code for test case boundary conditions
- IF (mjg(jj)<25 .or. mjg(jj)>975 .or. mig(ji)<25 .or. mig(ji)>975) THEN
+ IF (mjg(jj,nn_hls)<25 .or. mjg(jj,nn_hls)>975 .or. mig(ji,nn_hls)<25 .or. mig(ji,nn_hls)>975) THEN
v_ice(ji,jj) = zinvw*(ztauy_ai(ji,jj) + zCorV(ji,jj) + zspgV(ji,jj) + ztauy_oi(ji,jj))
END IF
END_2D
@@ -581,7 +581,7 @@ CONTAINS
& ) * zmsk00x(ji,jj)
ENDIF
!extra code for test case boundary conditions
- IF (mjg(jj)<25 .or. mjg(jj)>975 .or. mig(ji)<25 .or. mig(ji)>975) THEN
+ IF (mjg(jj,nn_hls)<25 .or. mjg(jj,nn_hls)>975 .or. mig(ji,nn_hls)<25 .or. mig(ji,nn_hls)>975) THEN
u_ice(ji,jj) = zinvw*(ztaux_ai(ji,jj) + zCorU(ji,jj) + zspgU(ji,jj) + ztaux_oi(ji,jj))
END IF
END_2D
@@ -639,7 +639,7 @@ CONTAINS
& ) * zmsk00x(ji,jj)
ENDIF
!extra code for test case boundary conditions
- IF (mjg(jj)<25 .or. mjg(jj)>975 .or. mig(ji)<25 .or. mig(ji)>975) THEN
+ IF (mjg(jj,nn_hls)<25 .or. mjg(jj,nn_hls)>975 .or. mig(ji,nn_hls)<25 .or. mig(ji,nn_hls)>975) THEN
u_ice(ji,jj) = zinvw*(ztaux_ai(ji,jj) + zCorU(ji,jj) + zspgU(ji,jj) + ztaux_oi(ji,jj))
END IF
END_2D
@@ -695,7 +695,7 @@ CONTAINS
& ) * zmsk00y(ji,jj)
ENDIF
!extra code for test case boundary conditions
- IF (mjg(jj)<25 .or. mjg(jj)>975 .or. mig(ji)<25 .or. mig(ji)>975) THEN
+ IF (mjg(jj,nn_hls)<25 .or. mjg(jj,nn_hls)>975 .or. mig(ji,nn_hls)<25 .or. mig(ji,nn_hls)>975) THEN
v_ice(ji,jj) = zinvw*(ztauy_ai(ji,jj) + zCorV(ji,jj) + zspgV(ji,jj) + ztauy_oi(ji,jj))
END IF
END_2D
@@ -978,7 +978,7 @@ CONTAINS
zresm = 0._wp
DO_2D( 0, 0, 0, 0 )
! cut of the boundary of the box (forced velocities)
- IF (mjg0(jj)>30 .AND. mjg0(jj)<=970 .AND. mig0(ji)>30 .AND. mig0(ji)<=970) THEN
+ IF (mjg(jj,0)>30 .AND. mjg(jj,0)<=970 .AND. mig(ji,0)>30 .AND. mig(ji,0)<=970) THEN
zresm = MAX( zresm, MAX( ABS( pu(ji,jj) - pub(ji,jj) ) * umask(ji,jj,1), &
& ABS( pv(ji,jj) - pvb(ji,jj) ) * vmask(ji,jj,1) ) * pmsk15(ji,jj) )
ENDIF
diff --git a/tests/ICE_RHEO/MY_SRC/usrdef_hgr.F90 b/tests/ICE_RHEO/MY_SRC/usrdef_hgr.F90
index e585820e8d60519aa219f35a333b81a1669cf7b4..679c2153369de41d2e31b05ebed04b9c2a1dc1b0 100644
--- a/tests/ICE_RHEO/MY_SRC/usrdef_hgr.F90
+++ b/tests/ICE_RHEO/MY_SRC/usrdef_hgr.F90
@@ -98,17 +98,17 @@ CONTAINS
!! ==> EITHER 1) variable scale factors
!! clem: This can be used with a 1proc simulation but I think it breaks repro when >1procs are used
!! DO_2D( 1, 1, 1, 1 )
-!! !!pe1t(ji,jj) = rn_dx * EXP( -0.8/REAL(jpiglo**2) * (mi0(ji)-REAL(jpiglo+1)*0.5)**2 ) ! gaussian shape
-!! !!pe2t(ji,jj) = rn_dy * EXP( -0.8/REAL(jpjglo**2) * (mj0(jj)-REAL(jpjglo+1)*0.5)**2 ) ! gaussian shape
-!! pe1t(ji,jj) = rn_dx * ( 1. -0.1 * ABS(REAL(mi0(ji))-REAL(jpiglo+1)*0.5) / (1.-REAL(jpiglo+1)*0.5) ) ! linear shape
-!! pe2t(ji,jj) = rn_dy * ( 1. -0.1 * ABS(REAL(mj0(jj))-REAL(jpjglo+1)*0.5) / (1.-REAL(jpjglo+1)*0.5) ) ! linear shape
+!! !!pe1t(ji,jj) = rn_dx * EXP( -0.8/REAL(jpiglo**2) * (mi0(ji,nn_hls)-REAL(jpiglo+1)*0.5)**2 ) ! gaussian shape
+!! !!pe2t(ji,jj) = rn_dy * EXP( -0.8/REAL(jpjglo**2) * (mj0(jj,nn_hls)-REAL(jpjglo+1)*0.5)**2 ) ! gaussian shape
+!! pe1t(ji,jj) = rn_dx * ( 1. -0.1 * ABS(REAL(mi0(ji,nn_hls))-REAL(jpiglo+1)*0.5) / (1.-REAL(jpiglo+1)*0.5) ) ! linear shape
+!! pe2t(ji,jj) = rn_dy * ( 1. -0.1 * ABS(REAL(mj0(jj,nn_hls))-REAL(jpjglo+1)*0.5) / (1.-REAL(jpjglo+1)*0.5) ) ! linear shape
!! END_2D
!!#if defined key_agrif
!! IF( .NOT. Agrif_Root() ) THEN ! only works if the zoom is positioned at the center of the parent grid
!! DO_2D( 1, 1, 1, 1 )
-!! pe1t(ji,jj) = rn_dx * ( 1. -0.1 * ABS(REAL(mi0(ji))-REAL(jpiglo+1)*0.5) / (1.-REAL(jpiglo+1)*0.5) &
+!! pe1t(ji,jj) = rn_dx * ( 1. -0.1 * ABS(REAL(mi0(ji,nn_hls))-REAL(jpiglo+1)*0.5) / (1.-REAL(jpiglo+1)*0.5) &
!! & * REAL(jpiglo) / REAL(Agrif_Parent(jpiglo) * Agrif_Rhox()) ) ! factor to match parent grid
-!! pe2t(ji,jj) = rn_dy * ( 1. -0.1 * ABS(REAL(mj0(jj))-REAL(jpjglo+1)*0.5) / (1.-REAL(jpjglo+1)*0.5) &
+!! pe2t(ji,jj) = rn_dy * ( 1. -0.1 * ABS(REAL(mj0(jj,nn_hls))-REAL(jpjglo+1)*0.5) / (1.-REAL(jpjglo+1)*0.5) &
!! & * REAL(jpjglo) / REAL(Agrif_Parent(jpjglo) * Agrif_Rhoy()) ) ! factor to match parent grid
!! END_2D
!! ENDIF
diff --git a/tests/ICE_RHEO/MY_SRC/usrdef_nam.F90 b/tests/ICE_RHEO/MY_SRC/usrdef_nam.F90
index 0f92fbee59790456df45d03d39da5357845781f8..df8898d9206e0f7401db9490c0c22554ca252fc7 100644
--- a/tests/ICE_RHEO/MY_SRC/usrdef_nam.F90
+++ b/tests/ICE_RHEO/MY_SRC/usrdef_nam.F90
@@ -13,7 +13,6 @@ MODULE usrdef_nam
!! usr_def_nam : read user defined namelist and set global domain size
!! usr_def_hgr : initialize the horizontal mesh
!!----------------------------------------------------------------------
- USE dom_oce , ONLY: nimpp , njmpp , Agrif_Root ! i- & j-indices of the local domain
USE par_oce ! ocean space and time domain
USE phycst ! physical constants
!
diff --git a/tests/ICE_RHEO/MY_SRC/usrdef_sbc.F90 b/tests/ICE_RHEO/MY_SRC/usrdef_sbc.F90
index 8d5fe4eb615de8df2477cec3d0c65b87c3c64b02..0b4f020abb72d3849d89ea5be6bac204539047c2 100644
--- a/tests/ICE_RHEO/MY_SRC/usrdef_sbc.F90
+++ b/tests/ICE_RHEO/MY_SRC/usrdef_sbc.F90
@@ -71,8 +71,8 @@ CONTAINS
!ij0 = 1 ; ij1 = 25 ! set boundary condition
!ii0 = 975 ; ii1 = 1000
- !DO jj = mj0(ij0), mj1(ij1)
- ! DO ji = mi0(ii0), mi1(ii1)
+ !DO jj = mj0(ij0,nn_hls), mj1(ij1,nn_hls)
+ ! DO ji = mi0(ii0,nn_hls), mi1(ii1,nn_hls)
! utau(ji,jj) = -utau_ice(ji,jj)
! vtau(ji,jj) = -vtau_ice(ji,jj)
! END DO
@@ -108,7 +108,7 @@ CONTAINS
REAL(wp) :: zwndi_f , zwndj_f, zwnorm_f ! relative wind module and components at F-point
REAL(wp) :: zwndi_t , zwndj_t ! relative wind components at T-point
- REAL(wp), DIMENSION(jpi,jpj) :: windu, windv ! wind components (idealised forcing)
+ REAL(wp), DIMENSION(A2D(0)) :: windu, windv ! wind components (idealised forcing)
REAL(wp), PARAMETER :: r_vfac = 1._wp ! relative velocity (make 0 for absolute velocity)
REAL(wp), PARAMETER :: Rwind = -0.8_wp ! ratio of wind components
REAL(wp), PARAMETER :: Umax = 15._wp ! maximum wind speed (m/s)
@@ -122,40 +122,26 @@ CONTAINS
DO_2D( 0, 0, 0, 0 )
! wind spins up over 6 hours, factor 1000 to balance the units
- windu(ji,jj) = Umax/sqrt(d*1000)*(d-2*mig(ji)*res)/((d-2*mig(ji)*res)**2+(d-2*mjg(jj)*res)**2*Rwind**2)**(1/4)*min(kt*30./21600,1.)
- windv(ji,jj) = Umax/sqrt(d*1000)*(d-2*mjg(jj)*res)/((d-2*mig(ji)*res)**2+(d-2*mjg(jj)*res)**2*Rwind**2)**(1/4)*Rwind*min(kt*30./21600,1.)
+ windu(ji,jj) = Umax/SQRT(d*1000)*(d-2*mig(ji,nn_hls)*res) / &
+ & ((d-2*mig(ji,nn_hls)*res)**2+(d-2*mjg(jj,nn_hls)*res)**2*Rwind**2)**(1/4)*MIN(kt*30./21600,1.)
+ windv(ji,jj) = Umax/SQRT(d*1000)*(d-2*mjg(jj,nn_hls)*res) / &
+ & ((d-2*mig(ji,nn_hls)*res)**2+(d-2*mjg(jj,nn_hls)*res)**2*Rwind**2)**(1/4)*Rwind*MIN(kt*30./21600,1.)
END_2D
- CALL lbc_lnk( 'usrdef_sbc', windu, 'U', -1., windv, 'V', -1. )
-
- wndm_ice(:,:) = 0._wp !!gm brutal....
! ------------------------------------------------------------ !
- ! Wind module relative to the moving ice ( U10m - U_ice ) !
+ ! Wind module and stress relative to the moving ice ( U10m - U_ice ) !
! ------------------------------------------------------------ !
- ! C-grid ice dynamics : U & V-points (same as ocean)
DO_2D( 0, 0, 0, 0 )
- zwndi_t = ( windu(ji,jj) - r_vfac * 0.5 * ( u_ice(ji-1,jj ) + u_ice(ji,jj) ) )
+ zwndi_t = ( windu(ji,jj) - r_vfac * 0.5 * ( u_ice(ji-1,jj) + u_ice(ji,jj) ) )
zwndj_t = ( windv(ji,jj) - r_vfac * 0.5 * ( v_ice(ji,jj-1) + v_ice(ji,jj) ) )
+ !
wndm_ice(ji,jj) = SQRT( zwndi_t * zwndi_t + zwndj_t * zwndj_t ) * tmask(ji,jj,1)
+ !
+ utau_ice(ji,jj) = zrhoa * Cd_atm * wndm_ice(ji,jj) * zwndi_t
+ vtau_ice(ji,jj) = zrhoa * Cd_atm * wndm_ice(ji,jj) * zwndj_t
END_2D
- CALL lbc_lnk( 'usrdef_sbc', wndm_ice, 'T', 1. )
-
- !!gm brutal....
- utau_ice (:,:) = 0._wp
- vtau_ice (:,:) = 0._wp
- !!gm end
+ CALL lbc_lnk( 'usrdef_sbc', utau_ice, 'T', -1., vtau_ice, 'T', -1., ldfull = .TRUE. )
- ! ------------------------------------------------------------ !
- ! Wind stress relative to the moving ice ( U10m - U_ice ) !
- ! ------------------------------------------------------------ !
- ! C-grid ice dynamics : U & V-points (same as ocean)
- DO_2D( 0, 0, 0, 0 )
- utau_ice(ji,jj) = 0.5 * zrhoa * Cd_atm * ( wndm_ice(ji+1,jj ) + wndm_ice(ji,jj) ) &
- & * ( 0.5 * (windu(ji+1,jj) + windu(ji,jj) ) - r_vfac * u_ice(ji,jj) )
- vtau_ice(ji,jj) = 0.5 * zrhoa * Cd_atm * ( wndm_ice(ji,jj+1 ) + wndm_ice(ji,jj) ) &
- & * ( 0.5 * (windv(ji,jj+1) + windv(ji,jj) ) - r_vfac * v_ice(ji,jj) )
- END_2D
- CALL lbc_lnk( 'usrdef_sbc', utau_ice, 'U', -1., vtau_ice, 'V', -1. )
!
END SUBROUTINE usrdef_sbc_ice_tau
@@ -170,7 +156,7 @@ CONTAINS
REAL(wp), DIMENSION(:,:,:), INTENT(in) :: phi ! ice thickness
!!
REAL(wp) :: zfr1, zfr2 ! local variables
- REAL(wp), DIMENSION(jpi,jpj) :: zsnw ! snw distribution after wind blowing
+ REAL(wp), DIMENSION(A2D(0)) :: zsnw ! snw distribution after wind blowing
!!---------------------------------------------------------------------
!
IF( kt==nit000 .AND. lwp) WRITE(numout,*)' usrdef_sbc_ice : ICE_RHEO case: NO flux forcing'
@@ -194,9 +180,9 @@ CONTAINS
emp_ice (:,:) = SUM( a_i_b(:,:,:) * evap_ice(:,:,:), dim=3 ) - sprecip(:,:) * zsnw(:,:)
emp_oce (:,:) = emp_oce(:,:) - sprecip(:,:) * (1._wp - zsnw(:,:) )
qevap_ice(:,:,:) = 0._wp
- qprec_ice(:,:) = rhos * ( sst_m(:,:) * rcpi - rLfus ) * tmask(:,:,1) ! in J/m3
- qemp_oce (:,:) = - emp_oce(:,:) * sst_m(:,:) * rcp
- qemp_ice (:,:) = sprecip(:,:) * zsnw * ( sst_m(:,:) * rcpi - rLfus ) * tmask(:,:,1) ! solid precip (only)
+ qprec_ice(:,:) = rhos * ( sst_m(A2D(0)) * rcpi - rLfus ) * smask0(:,:) ! in J/m3
+ qemp_oce (:,:) = - emp_oce(:,:) * sst_m(A2D(0)) * rcp
+ qemp_ice (:,:) = sprecip(:,:) * zsnw * ( sst_m(A2D(0)) * rcpi - rLfus ) * smask0(:,:) ! solid precip (only)
! total fluxes
emp_tot (:,:) = emp_ice + emp_oce
@@ -207,11 +193,11 @@ CONTAINS
zfr1 = ( 0.18 * ( 1.0 - pp_cldf ) + 0.35 * pp_cldf ) ! transmission when hi>10cm
zfr2 = ( 0.82 * ( 1.0 - pp_cldf ) + 0.65 * pp_cldf ) ! zfr2 such that zfr1 + zfr2 to equal 1
!
- WHERE ( phs(:,:,:) <= 0._wp .AND. phi(:,:,:) < 0.1_wp ) ! linear decrease from hi=0 to 10cm
- qtr_ice_top(:,:,:) = qsr_ice(:,:,:) * ( zfr1 + zfr2 * ( 1._wp - phi(:,:,:) * 10._wp ) )
- ELSEWHERE( phs(:,:,:) <= 0._wp .AND. phi(:,:,:) >= 0.1_wp ) ! constant (zfr1) when hi>10cm
+ WHERE ( phs(A2D(0),:) <= 0._wp .AND. phi(A2D(0),:) < 0.1_wp ) ! linear decrease from hi=0 to 10cm
+ qtr_ice_top(:,:,:) = qsr_ice(:,:,:) * ( zfr1 + zfr2 * ( 1._wp - phi(A2D(0),:) * 10._wp ) )
+ ELSEWHERE( phs(A2D(0),:) <= 0._wp .AND. phi(A2D(0),:) >= 0.1_wp ) ! constant (zfr1) when hi>10cm
qtr_ice_top(:,:,:) = qsr_ice(:,:,:) * zfr1
- ELSEWHERE ! zero when hs>0
+ ELSEWHERE ! zero when hs>0
qtr_ice_top(:,:,:) = 0._wp
END WHERE
diff --git a/tests/ISOMIP+/EXPREF/namelist_cfg b/tests/ISOMIP+/EXPREF/namelist_cfg
index 0b8ae4c942cae45c37a6d6af06a6289e343a890b..4f520bed6b9bf846c87b0c5a80efbbaee91e7d37 100644
--- a/tests/ISOMIP+/EXPREF/namelist_cfg
+++ b/tests/ISOMIP+/EXPREF/namelist_cfg
@@ -310,14 +310,19 @@ rn_Dt = 720.
!-----------------------------------------------------------------------
&nameos ! ocean Equation Of Seawater (default: NO selection)
!-----------------------------------------------------------------------
- ln_leos = .true. ! = Use L-EOS (linear Eq.)
- !
+ ln_seos = .true. ! = Use S-EOS (simplified Eq.)
! ! S-EOS coefficients (ln_seos=T):
! ! rd(T,S,Z)*rho0 = -a0*(1+.5*lambda*dT+mu*Z+nu*dS)*dT+b0*dS
- ! ! L-EOS coefficients (ln_seos=T):
- ! ! rd(T,S,Z)*rho0 = rho0*(-a0*dT+b0*dS)
+ ! ! dT = T-rn_T0 ; dS = S-rn_S0
+ rn_T0 = -1. ! reference temperature
+ rn_S0 = 34.2 ! reference salinity
rn_a0 = 3.7330e-5 ! thermal expension coefficient
rn_b0 = 7.8430e-4 ! saline expension coefficient
+ rn_lambda1 = 0. ! cabbeling coeff in T^2 (=0 for linear eos)
+ rn_lambda2 = 0. ! cabbeling coeff in S^2 (=0 for linear eos)
+ rn_mu1 = 0. ! thermobaric coeff. in T (=0 for linear eos)
+ rn_mu2 = 0. ! thermobaric coeff. in S (=0 for linear eos)
+ rn_nu = 0. ! cabbeling coeff in T*S (=0 for linear eos)
/
!-----------------------------------------------------------------------
&namtra_adv ! advection scheme for tracer (default: NO selection)
diff --git a/tests/ISOMIP+/MY_SRC/dtatsd.F90 b/tests/ISOMIP+/MY_SRC/dtatsd.F90
index cdee4ac5f65296fbbcdeb83ba0235006dd208c4c..27e99a3d7d7a8357cdcb71afd8b251181f00d2e9 100644
--- a/tests/ISOMIP+/MY_SRC/dtatsd.F90
+++ b/tests/ISOMIP+/MY_SRC/dtatsd.F90
@@ -33,11 +33,12 @@ MODULE dtatsd
LOGICAL , PUBLIC :: ln_tsd_init !: T & S data flag
LOGICAL , PUBLIC :: ln_tsd_dmp !: internal damping toward input data flag
+ TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_tsd ! structure of input SST (file informations, fields read)
TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_tsdini ! structure of input SST (file informations, fields read)
- TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_tsddmp ! structure of input SST (file informations, fields read)
!! * Substitutions
# include "do_loop_substitute.h90"
+# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
!! $Id: dtatsd.F90 10213 2018-10-23 14:40:09Z aumont $
@@ -121,16 +122,16 @@ CONTAINS
IF( ln_tsd_dmp ) THEN
!
- ALLOCATE( sf_tsddmp(jpts), STAT=ierr0 )
+ ALLOCATE( sf_tsd(jpts), STAT=ierr0 )
IF( ierr0 > 0 ) THEN
- CALL ctl_stop( 'dta_tsd_init: unable to allocate sf_tsddmp structure' ) ; RETURN
+ CALL ctl_stop( 'dta_tsd_init: unable to allocate sf_tsd structure' ) ; RETURN
ENDIF
!
! dmp file
- ALLOCATE( sf_tsddmp(jp_tem)%fnow(jpi,jpj,jpk) , STAT=ierr0 )
- IF( sn_dmpt%ln_tint ) ALLOCATE( sf_tsddmp(jp_tem)%fdta(jpi,jpj,jpk,2) , STAT=ierr1 )
- ALLOCATE( sf_tsddmp(jp_sal)%fnow(jpi,jpj,jpk) , STAT=ierr2 )
- IF( sn_dmps%ln_tint ) ALLOCATE( sf_tsddmp(jp_sal)%fdta(jpi,jpj,jpk,2) , STAT=ierr3 )
+ ALLOCATE( sf_tsd(jp_tem)%fnow(jpi,jpj,jpk) , STAT=ierr0 )
+ IF( sn_dmpt%ln_tint ) ALLOCATE( sf_tsd(jp_tem)%fdta(jpi,jpj,jpk,2) , STAT=ierr1 )
+ ALLOCATE( sf_tsd(jp_sal)%fnow(jpi,jpj,jpk) , STAT=ierr2 )
+ IF( sn_dmps%ln_tint ) ALLOCATE( sf_tsd(jp_sal)%fdta(jpi,jpj,jpk,2) , STAT=ierr3 )
!
IF( ierr0 + ierr1 + ierr2 + ierr3 > 0 ) THEN
CALL ctl_stop( 'dta_tsd : unable to allocate T & S dmp data arrays' ) ; RETURN
@@ -138,14 +139,14 @@ CONTAINS
!
! ! fill sf_tsd with sn_tem & sn_sal and control print
slf_i(jp_tem) = sn_dmpt ; slf_i(jp_sal) = sn_dmps
- CALL fld_fill( sf_tsddmp, slf_i, cn_dir, 'dta_tsd', 'Temperature & Salinity dmp data', 'namtsd', no_print )
+ CALL fld_fill( sf_tsd, slf_i, cn_dir, 'dta_tsd', 'Temperature & Salinity dmp data', 'namtsd', no_print )
!
ENDIF
!
END SUBROUTINE dta_tsd_init
- SUBROUTINE dta_tsd( kt, cddta, ptsd )
+ SUBROUTINE dta_tsd( kt, ptsd, cddta )
!!----------------------------------------------------------------------
!! *** ROUTINE dta_tsd ***
!!
@@ -159,47 +160,45 @@ CONTAINS
!!
!! ** Action : ptsd T-S data on medl mesh and interpolated at time-step kt
!!----------------------------------------------------------------------
- INTEGER , INTENT(in ) :: kt ! ocean time-step
- CHARACTER(LEN=3) , INTENT(in ) :: cddta ! dmp or ini
- REAL(wp), DIMENSION(A2D(nn_hls),jpk,jpts), INTENT( out) :: ptsd ! T & S data
+ INTEGER , INTENT(in ) :: kt ! ocean time-step
+ REAL(wp), DIMENSION(T2D(nn_hls),jpk,jpts), INTENT( out) :: ptsd ! T & S data
+ CHARACTER(len=*), OPTIONAL , INTENT(in ) :: cddta ! force the initialization when tradmp is used
!
INTEGER :: ji, jj, jk, jl, jkk ! dummy loop indicies
INTEGER :: ik, il0, il1, ii0, ii1, ij0, ij1 ! local integers
REAL(wp):: zl, zi ! local scalars
+ LOGICAL :: ll_tsdini
REAL(wp), DIMENSION(jpk) :: ztp, zsp ! 1D workspace
!!----------------------------------------------------------------------
!
+ ll_tsdini = .FALSE.
+ IF( PRESENT(cddta) ) ll_tsdini = .TRUE.
+
IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only for the full domain
IF( ln_tile ) CALL dom_tile_stop( ldhold=.TRUE. ) ! Use full domain
- SELECT CASE(cddta)
- CASE('ini')
+ IF( ll_tsdini ) THEN
CALL fld_read( kt, 1, sf_tsdini ) !== read T & S data at kt time step ==!
- CASE('dmp')
- CALL fld_read( kt, 1, sf_tsddmp ) !== read T & S data at kt time step ==!
- CASE DEFAULT
- CALL ctl_stop('STOP', 'dta_tsd: cddta case unknown')
- END SELECT
+ ELSE
+ CALL fld_read( kt, 1, sf_tsd ) !== read T & S data at kt time step ==!
+ ENDIF
IF( ln_tile ) CALL dom_tile_start( ldhold=.TRUE. ) ! Revert to tile domain
ENDIF
!
- SELECT CASE(cddta)
- CASE('ini')
+ IF( ll_tsdini ) THEN
DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpk )
ptsd(ji,jj,jk,jp_tem) = sf_tsdini(jp_tem)%fnow(ji,jj,jk) ! NO mask
ptsd(ji,jj,jk,jp_sal) = sf_tsdini(jp_sal)%fnow(ji,jj,jk)
END_3D
- CASE('dmp')
+ ELSE
DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpk )
- ptsd(ji,jj,jk,jp_tem) = sf_tsddmp(jp_tem)%fnow(ji,jj,jk) ! NO mask
- ptsd(ji,jj,jk,jp_sal) = sf_tsddmp(jp_sal)%fnow(ji,jj,jk)
+ ptsd(ji,jj,jk,jp_tem) = sf_tsd(jp_tem)%fnow(ji,jj,jk) ! NO mask
+ ptsd(ji,jj,jk,jp_sal) = sf_tsd(jp_sal)%fnow(ji,jj,jk)
END_3D
- CASE DEFAULT
- CALL ctl_stop('STOP', 'dta_tsd: cddta case unknown')
- END SELECT
+ ENDIF
!
- IF( ln_sco ) THEN !== s- or mixed s-zps-coordinate ==!
+ IF( l_sco ) THEN !== s- or mixed s-zps-coordinate ==!
!
IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile
IF( kt == nit000 .AND. lwp )THEN
@@ -218,7 +217,7 @@ CONTAINS
ztp(jk) = ptsd(ji,jj,jpkm1,jp_tem)
zsp(jk) = ptsd(ji,jj,jpkm1,jp_sal)
ELSE ! inbetween : vertical interpolation between jkk & jkk+1
- DO jkk = 1, jpkm1 ! when gdept(jkk) < zl < gdept(jkk+1)
+ DO jkk = 1, jpkm1 ! when gdept_jkk < zl < gdept_jkk+1
IF( (zl-gdept_1d(jkk)) * (zl-gdept_1d(jkk+1)) <= 0._wp ) THEN
zi = ( zl - gdept_1d(jkk) ) / (gdept_1d(jkk+1)-gdept_1d(jkk))
ztp(jk) = ptsd(ji,jj,jkk,jp_tem) + ( ptsd(ji,jj,jkk+1,jp_tem) - ptsd(ji,jj,jkk,jp_tem) ) * zi
@@ -242,27 +241,9 @@ CONTAINS
ptsd(ji,jj,jk,jp_sal) = ptsd(ji,jj,jk,jp_sal) * tmask(ji,jj,jk)
END_3D
!
- IF( ln_zps ) THEN ! zps-coordinate (partial steps) interpolation at the last ocean level
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
- ik = mbkt(ji,jj)
- IF( ik > 1 ) THEN
- zl = ( gdept_1d(ik) - gdept_0(ji,jj,ik) ) / ( gdept_1d(ik) - gdept_1d(ik-1) )
- ptsd(ji,jj,ik,jp_tem) = (1.-zl) * ptsd(ji,jj,ik,jp_tem) + zl * ptsd(ji,jj,ik-1,jp_tem)
- ptsd(ji,jj,ik,jp_sal) = (1.-zl) * ptsd(ji,jj,ik,jp_sal) + zl * ptsd(ji,jj,ik-1,jp_sal)
- ENDIF
- ik = mikt(ji,jj)
- IF( ik > 1 ) THEN
- zl = ( gdept_0(ji,jj,ik) - gdept_1d(ik) ) / ( gdept_1d(ik+1) - gdept_1d(ik) )
- ptsd(ji,jj,ik,jp_tem) = (1.-zl) * ptsd(ji,jj,ik,jp_tem) + zl * ptsd(ji,jj,ik+1,jp_tem)
- ptsd(ji,jj,ik,jp_sal) = (1.-zl) * ptsd(ji,jj,ik,jp_sal) + zl * ptsd(ji,jj,ik+1,jp_sal)
- END IF
- END_2D
- ENDIF
- !
ENDIF
!
- SELECT CASE(cddta)
- CASE('ini')
+ IF( ll_tsdini ) THEN
! !== deallocate T & S structure ==!
! (data used only for initialisation)
IF(lwp) WRITE(numout,*) 'dta_tsd: deallocte T & S arrays as they are only use to initialize the run'
@@ -272,7 +253,7 @@ CONTAINS
IF( sf_tsdini(jp_sal)%ln_tint ) DEALLOCATE( sf_tsdini(jp_sal)%fdta )
DEALLOCATE( sf_tsdini ) ! the structure itself
!
- END SELECT
+ ENDIF
!
END SUBROUTINE dta_tsd
diff --git a/tests/ISOMIP+/MY_SRC/eosbn2.F90 b/tests/ISOMIP+/MY_SRC/eosbn2.F90
deleted file mode 100644
index d2da8cfd5976e46e78df5a71aad6279ac86fe21b..0000000000000000000000000000000000000000
--- a/tests/ISOMIP+/MY_SRC/eosbn2.F90
+++ /dev/null
@@ -1,2078 +0,0 @@
-MODULE eosbn2
- !!==============================================================================
- !! *** MODULE eosbn2 ***
- !! Equation Of Seawater : in situ density - Brunt-Vaisala frequency
- !!==============================================================================
- !! History : OPA ! 1989-03 (O. Marti) Original code
- !! 6.0 ! 1994-07 (G. Madec, M. Imbard) add bn2
- !! 6.0 ! 1994-08 (G. Madec) Add Jackett & McDougall eos
- !! 7.0 ! 1996-01 (G. Madec) statement function for e3
- !! 8.1 ! 1997-07 (G. Madec) density instead of volumic mass
- !! - ! 1999-02 (G. Madec, N. Grima) semi-implicit pressure gradient
- !! 8.2 ! 2001-09 (M. Ben Jelloul) bugfix on linear eos
- !! NEMO 1.0 ! 2002-10 (G. Madec) add eos_init
- !! - ! 2002-11 (G. Madec, A. Bozec) partial step, eos_insitu_2d
- !! - ! 2003-08 (G. Madec) F90, free form
- !! 3.0 ! 2006-08 (G. Madec) add tfreez function (now eos_fzp function)
- !! 3.3 ! 2010-05 (C. Ethe, G. Madec) merge TRC-TRA
- !! - ! 2010-10 (G. Nurser, G. Madec) add alpha/beta used in ldfslp
- !! 3.7 ! 2012-03 (F. Roquet, G. Madec) add primitive of alpha and beta used in PE computation
- !! - ! 2012-05 (F. Roquet) add Vallis and original JM95 equation of state
- !! - ! 2013-04 (F. Roquet, G. Madec) add eos_rab, change bn2 computation and reorganize the module
- !! - ! 2014-09 (F. Roquet) add TEOS-10, S-EOS, and modify EOS-80
- !! - ! 2015-06 (P.A. Bouttier) eos_fzp functions changed to subroutines for AGRIF
- !!----------------------------------------------------------------------
-
- !!----------------------------------------------------------------------
- !! eos : generic interface of the equation of state
- !! eos_insitu : Compute the in situ density
- !! eos_insitu_pot: Compute the insitu and surface referenced potential volumic mass
- !! eos_insitu_2d : Compute the in situ density for 2d fields
- !! bn2 : compute the Brunt-Vaisala frequency
- !! eos_pt_from_ct: compute the potential temperature from the Conservative Temperature
- !! eos_rab : generic interface of in situ thermal/haline expansion ratio
- !! eos_rab_3d : compute in situ thermal/haline expansion ratio
- !! eos_rab_2d : compute in situ thermal/haline expansion ratio for 2d fields
- !! eos_fzp_2d : freezing temperature for 2d fields
- !! eos_fzp_0d : freezing temperature for scalar
- !! eos_init : set eos parameters (namelist)
- !!----------------------------------------------------------------------
- USE dom_oce ! ocean space and time domain
- USE domutl, ONLY : is_tile
- USE phycst ! physical constants
- USE stopar ! Stochastic T/S fluctuations
- USE stopts ! Stochastic T/S fluctuations
- !
- USE in_out_manager ! I/O manager
- USE lib_mpp ! MPP library
- USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined)
- USE prtctl ! Print control
- USE lbclnk ! ocean lateral boundary conditions
- USE timing ! Timing
-
- IMPLICIT NONE
- PRIVATE
-
- ! !! * Interface
- INTERFACE eos
- MODULE PROCEDURE eos_insitu_New, eos_insitu, eos_insitu_pot, eos_insitu_2d, eos_insitu_pot_2d
- END INTERFACE
- !
- INTERFACE eos_rab
- MODULE PROCEDURE rab_3d, rab_2d, rab_0d
- END INTERFACE
- !
- INTERFACE eos_fzp
- MODULE PROCEDURE eos_fzp_2d, eos_fzp_0d
- END INTERFACE
- !
- PUBLIC eos ! called by step, istate, tranpc and zpsgrd modules
- PUBLIC bn2 ! called by step module
- PUBLIC eos_rab ! called by ldfslp, zdfddm, trabbl
- PUBLIC eos_pt_from_ct ! called by sbcssm
- PUBLIC eos_fzp ! called by traadv_cen2 and sbcice_... modules
- PUBLIC eos_pen ! used for pe diagnostics in trdpen module
- PUBLIC eos_init ! called by istate module
-
- ! !!** Namelist nameos **
- LOGICAL , PUBLIC :: ln_TEOS10
- LOGICAL , PUBLIC :: ln_EOS80
- LOGICAL , PUBLIC :: ln_SEOS
- LOGICAL , PUBLIC :: ln_LEOS ! determine if linear eos is used
-
- ! Parameters
- LOGICAL , PUBLIC :: l_useCT ! =T in ln_TEOS10=T (i.e. use eos_pt_from_ct to compute sst_m), =F otherwise
- INTEGER , PUBLIC :: neos ! Identifier for equation of state used
-
- INTEGER , PARAMETER :: np_teos10 = -1 ! parameter for using TEOS10
- INTEGER , PARAMETER :: np_eos80 = 0 ! parameter for using EOS80
- INTEGER , PARAMETER :: np_seos = 1 ! parameter for using Simplified Equation of state
- INTEGER , PARAMETER :: np_leos = 2 ! parameter for using linear equation of state (ISOMIP+)
-
- ! !!! simplified eos coefficients (default value: Vallis 2006)
- REAL(wp), PUBLIC :: rn_a0 = 1.6550e-1_wp ! thermal expansion coeff.
- REAL(wp), PUBLIC :: rn_b0 = 7.6554e-1_wp ! saline expansion coeff.
- REAL(wp) :: rn_lambda1 = 5.9520e-2_wp ! cabbeling coeff. in T^2
- REAL(wp) :: rn_lambda2 = 5.4914e-4_wp ! cabbeling coeff. in S^2
- REAL(wp) :: rn_mu1 = 1.4970e-4_wp ! thermobaric coeff. in T
- REAL(wp) :: rn_mu2 = 1.1090e-5_wp ! thermobaric coeff. in S
- REAL(wp) :: rn_nu = 2.4341e-3_wp ! cabbeling coeff. in theta*salt
-
- ! TEOS10/EOS80 parameters
- REAL(wp) :: r1_S0, r1_T0, r1_Z0, rdeltaS
-
- ! EOS parameters
- REAL(wp) :: EOS000 , EOS100 , EOS200 , EOS300 , EOS400 , EOS500 , EOS600
- REAL(wp) :: EOS010 , EOS110 , EOS210 , EOS310 , EOS410 , EOS510
- REAL(wp) :: EOS020 , EOS120 , EOS220 , EOS320 , EOS420
- REAL(wp) :: EOS030 , EOS130 , EOS230 , EOS330
- REAL(wp) :: EOS040 , EOS140 , EOS240
- REAL(wp) :: EOS050 , EOS150
- REAL(wp) :: EOS060
- REAL(wp) :: EOS001 , EOS101 , EOS201 , EOS301 , EOS401
- REAL(wp) :: EOS011 , EOS111 , EOS211 , EOS311
- REAL(wp) :: EOS021 , EOS121 , EOS221
- REAL(wp) :: EOS031 , EOS131
- REAL(wp) :: EOS041
- REAL(wp) :: EOS002 , EOS102 , EOS202
- REAL(wp) :: EOS012 , EOS112
- REAL(wp) :: EOS022
- REAL(wp) :: EOS003 , EOS103
- REAL(wp) :: EOS013
-
- ! ALPHA parameters
- REAL(wp) :: ALP000 , ALP100 , ALP200 , ALP300 , ALP400 , ALP500
- REAL(wp) :: ALP010 , ALP110 , ALP210 , ALP310 , ALP410
- REAL(wp) :: ALP020 , ALP120 , ALP220 , ALP320
- REAL(wp) :: ALP030 , ALP130 , ALP230
- REAL(wp) :: ALP040 , ALP140
- REAL(wp) :: ALP050
- REAL(wp) :: ALP001 , ALP101 , ALP201 , ALP301
- REAL(wp) :: ALP011 , ALP111 , ALP211
- REAL(wp) :: ALP021 , ALP121
- REAL(wp) :: ALP031
- REAL(wp) :: ALP002 , ALP102
- REAL(wp) :: ALP012
- REAL(wp) :: ALP003
-
- ! BETA parameters
- REAL(wp) :: BET000 , BET100 , BET200 , BET300 , BET400 , BET500
- REAL(wp) :: BET010 , BET110 , BET210 , BET310 , BET410
- REAL(wp) :: BET020 , BET120 , BET220 , BET320
- REAL(wp) :: BET030 , BET130 , BET230
- REAL(wp) :: BET040 , BET140
- REAL(wp) :: BET050
- REAL(wp) :: BET001 , BET101 , BET201 , BET301
- REAL(wp) :: BET011 , BET111 , BET211
- REAL(wp) :: BET021 , BET121
- REAL(wp) :: BET031
- REAL(wp) :: BET002 , BET102
- REAL(wp) :: BET012
- REAL(wp) :: BET003
-
- ! PEN parameters
- REAL(wp) :: PEN000 , PEN100 , PEN200 , PEN300 , PEN400
- REAL(wp) :: PEN010 , PEN110 , PEN210 , PEN310
- REAL(wp) :: PEN020 , PEN120 , PEN220
- REAL(wp) :: PEN030 , PEN130
- REAL(wp) :: PEN040
- REAL(wp) :: PEN001 , PEN101 , PEN201
- REAL(wp) :: PEN011 , PEN111
- REAL(wp) :: PEN021
- REAL(wp) :: PEN002 , PEN102
- REAL(wp) :: PEN012
-
- ! ALPHA_PEN parameters
- REAL(wp) :: APE000 , APE100 , APE200 , APE300
- REAL(wp) :: APE010 , APE110 , APE210
- REAL(wp) :: APE020 , APE120
- REAL(wp) :: APE030
- REAL(wp) :: APE001 , APE101
- REAL(wp) :: APE011
- REAL(wp) :: APE002
-
- ! BETA_PEN parameters
- REAL(wp) :: BPE000 , BPE100 , BPE200 , BPE300
- REAL(wp) :: BPE010 , BPE110 , BPE210
- REAL(wp) :: BPE020 , BPE120
- REAL(wp) :: BPE030
- REAL(wp) :: BPE001 , BPE101
- REAL(wp) :: BPE011
- REAL(wp) :: BPE002
-
- !! * Substitutions
-# include "do_loop_substitute.h90"
-# include "domzgr_substitute.h90"
- !!----------------------------------------------------------------------
- !! NEMO/OCE 4.0 , NEMO Consortium (2018)
- !! $Id: eosbn2.F90 10425 2018-12-19 21:54:16Z smasson $
- !! Software governed by the CeCILL license (see ./LICENSE)
- !!----------------------------------------------------------------------
-CONTAINS
-
- SUBROUTINE eos_insitu_New( pts, Knn, prd )
- !!----------------------------------------------------------------------
- !! *** ROUTINE eos_insitu_New ***
- !!
- !! ** Purpose : Compute the in situ density (ratio rho/rho0) from
- !! potential temperature and salinity using an equation of state
- !! selected in the nameos namelist
- !!
- !! ** Method : prd(t,s,z) = ( rho(t,s,z) - rho0 ) / rho0
- !! with prd in situ density anomaly no units
- !! t TEOS10: CT or EOS80: PT Celsius
- !! s TEOS10: SA or EOS80: SP TEOS10: g/kg or EOS80: psu
- !! z depth meters
- !! rho in situ density kg/m^3
- !! rho0 reference density kg/m^3
- !!
- !! ln_teos10 : polynomial TEOS-10 equation of state is used for rho(t,s,z).
- !! Check value: rho = 1028.21993233072 kg/m^3 for z=3000 dbar, ct=3 Celsius, sa=35.5 g/kg
- !!
- !! ln_eos80 : polynomial EOS-80 equation of state is used for rho(t,s,z).
- !! Check value: rho = 1028.35011066567 kg/m^3 for z=3000 dbar, pt=3 Celsius, sp=35.5 psu
- !!
- !! ln_seos : simplified equation of state
- !! prd(t,s,z) = ( -a0*(1+lambda/2*(T-T0)+mu*z+nu*(S-S0))*(T-T0) + b0*(S-S0) ) / rho0
- !! linear case function of T only: rn_alpha<>0, other coefficients = 0
- !! linear eos function of T and S: rn_alpha and rn_beta<>0, other coefficients=0
- !! Vallis like equation: use default values of coefficients
- !!
- !! ln_leos : linear ISOMIP equation of state
- !! prd(t,s,z) = ( -a0*(T-T0) + b0*(S-S0) ) / rho0
- !! setup for ISOMIP linear eos
- !!
- !! ** Action : compute prd , the in situ density (no units)
- !!
- !! References : Roquet et al, Ocean Modelling, in preparation (2014)
- !! Vallis, Atmospheric and Oceanic Fluid Dynamics, 2006
- !! TEOS-10 Manual, 2010
- !!----------------------------------------------------------------------
- REAL(wp), DIMENSION(:,:,:,:,:), INTENT(in ) :: pts ! T-S
- INTEGER , INTENT(in ) :: Knn ! time-level
- REAL(wp), DIMENSION(:,:,: ), INTENT( out) :: prd ! in situ density
- !
- INTEGER :: ji, jj, jk ! dummy loop indices
- REAL(wp) :: zt , zh , zs , ztm ! local scalars
- REAL(wp) :: zn , zn0, zn1, zn2, zn3 ! - -
- !!----------------------------------------------------------------------
- !
- IF( ln_timing ) CALL timing_start('eos-insitu')
- !
- SELECT CASE( neos )
- !
- CASE( np_teos10, np_eos80 ) !== polynomial TEOS-10 / EOS-80 ==!
- !
- DO_3D(nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 )
- !
- zh = gdept(ji,jj,jk,Knn) * r1_Z0 ! depth
- zt = pts (ji,jj,jk,jp_tem,Knn) * r1_T0 ! temperature
- zs = SQRT( ABS( pts(ji,jj,jk,jp_sal,Knn) + rdeltaS ) * r1_S0 ) ! square root salinity
- ztm = tmask(ji,jj,jk) ! tmask
- !
- zn3 = EOS013*zt &
- & + EOS103*zs+EOS003
- !
- zn2 = (EOS022*zt &
- & + EOS112*zs+EOS012)*zt &
- & + (EOS202*zs+EOS102)*zs+EOS002
- !
- zn1 = (((EOS041*zt &
- & + EOS131*zs+EOS031)*zt &
- & + (EOS221*zs+EOS121)*zs+EOS021)*zt &
- & + ((EOS311*zs+EOS211)*zs+EOS111)*zs+EOS011)*zt &
- & + (((EOS401*zs+EOS301)*zs+EOS201)*zs+EOS101)*zs+EOS001
- !
- zn0 = (((((EOS060*zt &
- & + EOS150*zs+EOS050)*zt &
- & + (EOS240*zs+EOS140)*zs+EOS040)*zt &
- & + ((EOS330*zs+EOS230)*zs+EOS130)*zs+EOS030)*zt &
- & + (((EOS420*zs+EOS320)*zs+EOS220)*zs+EOS120)*zs+EOS020)*zt &
- & + ((((EOS510*zs+EOS410)*zs+EOS310)*zs+EOS210)*zs+EOS110)*zs+EOS010)*zt &
- & + (((((EOS600*zs+EOS500)*zs+EOS400)*zs+EOS300)*zs+EOS200)*zs+EOS100)*zs+EOS000
- !
- zn = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0
- !
- prd(ji,jj,jk) = ( zn * r1_rho0 - 1._wp ) * ztm ! density anomaly (masked)
- !
- END_3D
- !
- CASE( np_seos ) !== simplified EOS ==!
- !
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 )
- zt = pts (ji,jj,jk,jp_tem,Knn) - 10._wp
- zs = pts (ji,jj,jk,jp_sal,Knn) - 35._wp
- zh = gdept(ji,jj,jk,Knn)
- ztm = tmask(ji,jj,jk)
- !
- zn = - rn_a0 * ( 1._wp + 0.5_wp*rn_lambda1*zt + rn_mu1*zh ) * zt &
- & + rn_b0 * ( 1._wp - 0.5_wp*rn_lambda2*zs - rn_mu2*zh ) * zs &
- & - rn_nu * zt * zs
- !
- prd(ji,jj,jk) = zn * r1_rho0 * ztm ! density anomaly (masked)
- END_3D
- !
- CASE( np_leos ) !== linear ISOMIP EOS ==!
- !
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 )
- zt = pts (ji,jj,jk,jp_tem,Knn) - (-1._wp)
- zs = pts (ji,jj,jk,jp_sal,Knn) - 34.2_wp
- zh = gdept(ji,jj,jk, Knn)
- ztm = tmask(ji,jj,jk)
- !
- zn = rho0 * ( - rn_a0 * zt + rn_b0 * zs )
- !
- prd(ji,jj,jk) = zn * r1_rho0 * ztm ! density anomaly (masked)
- END_3D
- !
- END SELECT
- !
- IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=prd, clinfo1=' eos-insitu : ', kdim=jpk )
- !
- IF( ln_timing ) CALL timing_stop('eos-insitu')
- !
- END SUBROUTINE eos_insitu_New
-
-
- SUBROUTINE eos_insitu( pts, prd, pdep )
- !!
- REAL(wp), DIMENSION(:,:,:,:), INTENT(in ) :: pts ! 1 : potential temperature [Celsius]
- ! ! 2 : salinity [psu]
- REAL(wp), DIMENSION(:,:,:) , INTENT( out) :: prd ! in situ density [-]
- REAL(wp), DIMENSION(:,:,:) , INTENT(in ) :: pdep ! depth [m]
- !!
- CALL eos_insitu_t( pts, is_tile(pts), prd, is_tile(prd), pdep, is_tile(pdep) )
- END SUBROUTINE eos_insitu
-
- SUBROUTINE eos_insitu_t( pts, ktts, prd, ktrd, pdep, ktdep )
- !!----------------------------------------------------------------------
- !! *** ROUTINE eos_insitu ***
- !!
- !! ** Purpose : Compute the in situ density (ratio rho/rho0) from
- !! potential temperature and salinity using an equation of state
- !! selected in the nameos namelist
- !!
- !! ** Method : prd(t,s,z) = ( rho(t,s,z) - rho0 ) / rho0
- !! with prd in situ density anomaly no units
- !! t TEOS10: CT or EOS80: PT Celsius
- !! s TEOS10: SA or EOS80: SP TEOS10: g/kg or EOS80: psu
- !! z depth meters
- !! rho in situ density kg/m^3
- !! rho0 reference density kg/m^3
- !!
- !! ln_teos10 : polynomial TEOS-10 equation of state is used for rho(t,s,z).
- !! Check value: rho = 1028.21993233072 kg/m^3 for z=3000 dbar, ct=3 Celsius, sa=35.5 g/kg
- !!
- !! ln_eos80 : polynomial EOS-80 equation of state is used for rho(t,s,z).
- !! Check value: rho = 1028.35011066567 kg/m^3 for z=3000 dbar, pt=3 Celsius, sp=35.5 psu
- !!
- !! ln_seos : simplified equation of state
- !! prd(t,s,z) = ( -a0*(1+lambda/2*(T-T0)+mu*z+nu*(S-S0))*(T-T0) + b0*(S-S0) ) / rho0
- !! linear case function of T only: rn_alpha<>0, other coefficients = 0
- !! linear eos function of T and S: rn_alpha and rn_beta<>0, other coefficients=0
- !! Vallis like equation: use default values of coefficients
- !!
- !! ln_leos : linear ISOMIP equation of state
- !! prd(t,s,z) = ( -a0*(T-T0) + b0*(S-S0) ) / rho0
- !! setup for ISOMIP linear eos
- !!
- !! ** Action : compute prd , the in situ density (no units)
- !!
- !! References : Roquet et al, Ocean Modelling, in preparation (2014)
- !! Vallis, Atmospheric and Oceanic Fluid Dynamics, 2006
- !! TEOS-10 Manual, 2010
- !!----------------------------------------------------------------------
- INTEGER , INTENT(in ) :: ktts, ktrd, ktdep
- REAL(wp), DIMENSION(A2D_T(ktts) ,JPK,JPTS), INTENT(in ) :: pts ! 1 : potential temperature [Celsius]
- ! ! 2 : salinity [psu]
- REAL(wp), DIMENSION(A2D_T(ktrd) ,JPK ), INTENT( out) :: prd ! in situ density [-]
- REAL(wp), DIMENSION(A2D_T(ktdep),JPK ), INTENT(in ) :: pdep ! depth [m]
- !
- INTEGER :: ji, jj, jk ! dummy loop indices
- REAL(wp) :: zt , zh , zs , ztm ! local scalars
- REAL(wp) :: zn , zn0, zn1, zn2, zn3 ! - -
- !!----------------------------------------------------------------------
- !
- IF( ln_timing ) CALL timing_start('eos-insitu')
- !
- SELECT CASE( neos )
- !
- CASE( np_teos10, np_eos80 ) !== polynomial TEOS-10 / EOS-80 ==!
- !
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 )
- !
- zh = pdep(ji,jj,jk) * r1_Z0 ! depth
- zt = pts (ji,jj,jk,jp_tem) * r1_T0 ! temperature
- zs = SQRT( ABS( pts(ji,jj,jk,jp_sal) + rdeltaS ) * r1_S0 ) ! square root salinity
- ztm = tmask(ji,jj,jk) ! tmask
- !
- zn3 = EOS013*zt &
- & + EOS103*zs+EOS003
- !
- zn2 = (EOS022*zt &
- & + EOS112*zs+EOS012)*zt &
- & + (EOS202*zs+EOS102)*zs+EOS002
- !
- zn1 = (((EOS041*zt &
- & + EOS131*zs+EOS031)*zt &
- & + (EOS221*zs+EOS121)*zs+EOS021)*zt &
- & + ((EOS311*zs+EOS211)*zs+EOS111)*zs+EOS011)*zt &
- & + (((EOS401*zs+EOS301)*zs+EOS201)*zs+EOS101)*zs+EOS001
- !
- zn0 = (((((EOS060*zt &
- & + EOS150*zs+EOS050)*zt &
- & + (EOS240*zs+EOS140)*zs+EOS040)*zt &
- & + ((EOS330*zs+EOS230)*zs+EOS130)*zs+EOS030)*zt &
- & + (((EOS420*zs+EOS320)*zs+EOS220)*zs+EOS120)*zs+EOS020)*zt &
- & + ((((EOS510*zs+EOS410)*zs+EOS310)*zs+EOS210)*zs+EOS110)*zs+EOS010)*zt &
- & + (((((EOS600*zs+EOS500)*zs+EOS400)*zs+EOS300)*zs+EOS200)*zs+EOS100)*zs+EOS000
- !
- zn = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0
- !
- prd(ji,jj,jk) = ( zn * r1_rho0 - 1._wp ) * ztm ! density anomaly (masked)
- !
- END_3D
- !
- CASE( np_seos ) !== simplified EOS ==!
- !
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 )
- zt = pts (ji,jj,jk,jp_tem) - 10._wp
- zs = pts (ji,jj,jk,jp_sal) - 35._wp
- zh = pdep (ji,jj,jk)
- ztm = tmask(ji,jj,jk)
- !
- zn = - rn_a0 * ( 1._wp + 0.5_wp*rn_lambda1*zt + rn_mu1*zh ) * zt &
- & + rn_b0 * ( 1._wp - 0.5_wp*rn_lambda2*zs - rn_mu2*zh ) * zs &
- & - rn_nu * zt * zs
- !
- prd(ji,jj,jk) = zn * r1_rho0 * ztm ! density anomaly (masked)
- END_3D
- !
- CASE( np_leos ) !== linear ISOMIP EOS ==!
- !
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 )
- zt = pts (ji,jj,jk,jp_tem) - (-1._wp)
- zs = pts (ji,jj,jk,jp_sal) - 34.2_wp
- zh = pdep (ji,jj,jk)
- ztm = tmask(ji,jj,jk)
- !
- zn = rho0 * ( - rn_a0 * zt + rn_b0 * zs )
- !
- prd(ji,jj,jk) = zn * r1_rho0 * ztm ! density anomaly (masked)
- END_3D
- !
- END SELECT
- !
- IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=prd, clinfo1=' eos-insitu : ', kdim=jpk )
- !
- IF( ln_timing ) CALL timing_stop('eos-insitu')
- !
- END SUBROUTINE eos_insitu_t
-
-
- SUBROUTINE eos_insitu_pot( pts, prd, prhop, pdep )
- !!
- REAL(wp), DIMENSION(:,:,:,:), INTENT(in ) :: pts ! 1 : potential temperature [Celsius]
- ! ! 2 : salinity [psu]
- REAL(wp), DIMENSION(:,:,:) , INTENT( out) :: prd ! in situ density [-]
- REAL(wp), DIMENSION(:,:,:) , INTENT( out) :: prhop ! potential density (surface referenced)
- REAL(wp), DIMENSION(:,:,:) , INTENT(in ) :: pdep ! depth [m]
- !!
- CALL eos_insitu_pot_t( pts, is_tile(pts), prd, is_tile(prd), prhop, is_tile(prhop), pdep, is_tile(pdep) )
- END SUBROUTINE eos_insitu_pot
-
-
- SUBROUTINE eos_insitu_pot_t( pts, ktts, prd, ktrd, prhop, ktrhop, pdep, ktdep )
- !!----------------------------------------------------------------------
- !! *** ROUTINE eos_insitu_pot ***
- !!
- !! ** Purpose : Compute the in situ density (ratio rho/rho0) and the
- !! potential volumic mass (Kg/m3) from potential temperature and
- !! salinity fields using an equation of state selected in the
- !! namelist.
- !!
- !! ** Action : - prd , the in situ density (no units)
- !! - prhop, the potential volumic mass (Kg/m3)
- !!
- !!----------------------------------------------------------------------
- INTEGER , INTENT(in ) :: ktts, ktrd, ktrhop, ktdep
- REAL(wp), DIMENSION(A2D_T(ktts) ,JPK,JPTS), INTENT(in ) :: pts ! 1 : potential temperature [Celsius]
- ! ! 2 : salinity [psu]
- REAL(wp), DIMENSION(A2D_T(ktrd) ,JPK ), INTENT( out) :: prd ! in situ density [-]
- REAL(wp), DIMENSION(A2D_T(ktrhop),JPK ), INTENT( out) :: prhop ! potential density (surface referenced)
- REAL(wp), DIMENSION(A2D_T(ktdep) ,JPK ), INTENT(in ) :: pdep ! depth [m]
- !
- INTEGER :: ji, jj, jk, jsmp ! dummy loop indices
- INTEGER :: jdof
- REAL(wp) :: zt , zh , zstemp, zs , ztm ! local scalars
- REAL(wp) :: zn , zn0, zn1, zn2, zn3 ! - -
- REAL(wp), DIMENSION(:), ALLOCATABLE :: zn0_sto, zn_sto, zsign ! local vectors
- !!----------------------------------------------------------------------
- !
- IF( ln_timing ) CALL timing_start('eos-pot')
- !
- SELECT CASE ( neos )
- !
- CASE( np_teos10, np_eos80 ) !== polynomial TEOS-10 / EOS-80 ==!
- !
- ! Stochastic equation of state
- IF ( ln_sto_eos ) THEN
- ALLOCATE(zn0_sto(1:2*nn_sto_eos))
- ALLOCATE(zn_sto(1:2*nn_sto_eos))
- ALLOCATE(zsign(1:2*nn_sto_eos))
- DO jsmp = 1, 2*nn_sto_eos, 2
- zsign(jsmp) = 1._wp
- zsign(jsmp+1) = -1._wp
- END DO
- !
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 )
- !
- ! compute density (2*nn_sto_eos) times:
- ! (1) for t+dt, s+ds (with the random TS fluctutation computed in sto_pts)
- ! (2) for t-dt, s-ds (with the opposite fluctuation)
- DO jsmp = 1, nn_sto_eos*2
- jdof = (jsmp + 1) / 2
- zh = pdep(ji,jj,jk) * r1_Z0 ! depth
- zt = (pts (ji,jj,jk,jp_tem) + pts_ran(ji,jj,jk,jp_tem,jdof) * zsign(jsmp)) * r1_T0 ! temperature
- zstemp = pts (ji,jj,jk,jp_sal) + pts_ran(ji,jj,jk,jp_sal,jdof) * zsign(jsmp)
- zs = SQRT( ABS( zstemp + rdeltaS ) * r1_S0 ) ! square root salinity
- ztm = tmask(ji,jj,jk) ! tmask
- !
- zn3 = EOS013*zt &
- & + EOS103*zs+EOS003
- !
- zn2 = (EOS022*zt &
- & + EOS112*zs+EOS012)*zt &
- & + (EOS202*zs+EOS102)*zs+EOS002
- !
- zn1 = (((EOS041*zt &
- & + EOS131*zs+EOS031)*zt &
- & + (EOS221*zs+EOS121)*zs+EOS021)*zt &
- & + ((EOS311*zs+EOS211)*zs+EOS111)*zs+EOS011)*zt &
- & + (((EOS401*zs+EOS301)*zs+EOS201)*zs+EOS101)*zs+EOS001
- !
- zn0_sto(jsmp) = (((((EOS060*zt &
- & + EOS150*zs+EOS050)*zt &
- & + (EOS240*zs+EOS140)*zs+EOS040)*zt &
- & + ((EOS330*zs+EOS230)*zs+EOS130)*zs+EOS030)*zt &
- & + (((EOS420*zs+EOS320)*zs+EOS220)*zs+EOS120)*zs+EOS020)*zt &
- & + ((((EOS510*zs+EOS410)*zs+EOS310)*zs+EOS210)*zs+EOS110)*zs+EOS010)*zt &
- & + (((((EOS600*zs+EOS500)*zs+EOS400)*zs+EOS300)*zs+EOS200)*zs+EOS100)*zs+EOS000
- !
- zn_sto(jsmp) = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0_sto(jsmp)
- END DO
- !
- ! compute stochastic density as the mean of the (2*nn_sto_eos) densities
- prhop(ji,jj,jk) = 0._wp ; prd(ji,jj,jk) = 0._wp
- DO jsmp = 1, nn_sto_eos*2
- prhop(ji,jj,jk) = prhop(ji,jj,jk) + zn0_sto(jsmp) ! potential density referenced at the surface
- !
- prd(ji,jj,jk) = prd(ji,jj,jk) + ( zn_sto(jsmp) * r1_rho0 - 1._wp ) ! density anomaly (masked)
- END DO
- prhop(ji,jj,jk) = 0.5_wp * prhop(ji,jj,jk) * ztm / nn_sto_eos
- prd (ji,jj,jk) = 0.5_wp * prd (ji,jj,jk) * ztm / nn_sto_eos
- END_3D
- DEALLOCATE(zn0_sto,zn_sto,zsign)
- ! Non-stochastic equation of state
- ELSE
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 )
- !
- zh = pdep(ji,jj,jk) * r1_Z0 ! depth
- zt = pts (ji,jj,jk,jp_tem) * r1_T0 ! temperature
- zs = SQRT( ABS( pts(ji,jj,jk,jp_sal) + rdeltaS ) * r1_S0 ) ! square root salinity
- ztm = tmask(ji,jj,jk) ! tmask
- !
- zn3 = EOS013*zt &
- & + EOS103*zs+EOS003
- !
- zn2 = (EOS022*zt &
- & + EOS112*zs+EOS012)*zt &
- & + (EOS202*zs+EOS102)*zs+EOS002
- !
- zn1 = (((EOS041*zt &
- & + EOS131*zs+EOS031)*zt &
- & + (EOS221*zs+EOS121)*zs+EOS021)*zt &
- & + ((EOS311*zs+EOS211)*zs+EOS111)*zs+EOS011)*zt &
- & + (((EOS401*zs+EOS301)*zs+EOS201)*zs+EOS101)*zs+EOS001
- !
- zn0 = (((((EOS060*zt &
- & + EOS150*zs+EOS050)*zt &
- & + (EOS240*zs+EOS140)*zs+EOS040)*zt &
- & + ((EOS330*zs+EOS230)*zs+EOS130)*zs+EOS030)*zt &
- & + (((EOS420*zs+EOS320)*zs+EOS220)*zs+EOS120)*zs+EOS020)*zt &
- & + ((((EOS510*zs+EOS410)*zs+EOS310)*zs+EOS210)*zs+EOS110)*zs+EOS010)*zt &
- & + (((((EOS600*zs+EOS500)*zs+EOS400)*zs+EOS300)*zs+EOS200)*zs+EOS100)*zs+EOS000
- !
- zn = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0
- !
- prhop(ji,jj,jk) = zn0 * ztm ! potential density referenced at the surface
- !
- prd(ji,jj,jk) = ( zn * r1_rho0 - 1._wp ) * ztm ! density anomaly (masked)
- END_3D
- ENDIF
-
- CASE( np_seos ) !== simplified EOS ==!
- !
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 )
- zt = pts (ji,jj,jk,jp_tem) - 10._wp
- zs = pts (ji,jj,jk,jp_sal) - 35._wp
- zh = pdep (ji,jj,jk)
- ztm = tmask(ji,jj,jk)
- ! ! potential density referenced at the surface
- zn = - rn_a0 * ( 1._wp + 0.5_wp*rn_lambda1*zt ) * zt &
- & + rn_b0 * ( 1._wp - 0.5_wp*rn_lambda2*zs ) * zs &
- & - rn_nu * zt * zs
- prhop(ji,jj,jk) = ( rho0 + zn ) * ztm
- ! ! density anomaly (masked)
- zn = zn - ( rn_a0 * rn_mu1 * zt + rn_b0 * rn_mu2 * zs ) * zh
- prd(ji,jj,jk) = zn * r1_rho0 * ztm
- !
- END_3D
- !
- CASE( np_leos ) !== linear ISOMIP EOS ==!
- !
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 )
- zt = pts (ji,jj,jk,jp_tem) - (-1._wp)
- zs = pts (ji,jj,jk,jp_sal) - 34.2_wp
- zh = pdep (ji,jj,jk)
- ztm = tmask(ji,jj,jk)
- ! ! potential density referenced at the surface
- zn = rho0 * ( - rn_a0 * zt + rn_b0 * zs )
- prhop(ji,jj,jk) = ( rho0 + zn ) * ztm
- ! ! density anomaly (masked)
- prd(ji,jj,jk) = zn * r1_rho0 * ztm
- !
- END_3D
- !
- END SELECT
- !
- IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=prd, clinfo1=' eos-pot: ', &
- & tab3d_2=prhop, clinfo2=' pot : ', kdim=jpk )
- !
- IF( ln_timing ) CALL timing_stop('eos-pot')
- !
- END SUBROUTINE eos_insitu_pot_t
-
-
- SUBROUTINE eos_insitu_2d( pts, pdep, prd )
- !!
- REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: pts ! 1 : potential temperature [Celsius]
- ! ! 2 : salinity [psu]
- REAL(wp), DIMENSION(:,:) , INTENT(in ) :: pdep ! depth [m]
- REAL(wp), DIMENSION(:,:) , INTENT( out) :: prd ! in situ density
- !!
- CALL eos_insitu_2d_t( pts, is_tile(pts), pdep, is_tile(pdep), prd, is_tile(prd) )
- END SUBROUTINE eos_insitu_2d
-
-
- SUBROUTINE eos_insitu_2d_t( pts, ktts, pdep, ktdep, prd, ktrd )
- !!----------------------------------------------------------------------
- !! *** ROUTINE eos_insitu_2d ***
- !!
- !! ** Purpose : Compute the in situ density (ratio rho/rho0) from
- !! potential temperature and salinity using an equation of state
- !! selected in the nameos namelist. * 2D field case
- !!
- !! ** Action : - prd , the in situ density (no units) (unmasked)
- !!
- !!----------------------------------------------------------------------
- INTEGER , INTENT(in ) :: ktts, ktdep, ktrd
- REAL(wp), DIMENSION(A2D_T(ktts),JPTS), INTENT(in ) :: pts ! 1 : potential temperature [Celsius]
- ! ! 2 : salinity [psu]
- REAL(wp), DIMENSION(A2D_T(ktdep) ), INTENT(in ) :: pdep ! depth [m]
- REAL(wp), DIMENSION(A2D_T(ktrd) ), INTENT( out) :: prd ! in situ density
- !
- INTEGER :: ji, jj, jk ! dummy loop indices
- REAL(wp) :: zt , zh , zs ! local scalars
- REAL(wp) :: zn , zn0, zn1, zn2, zn3 ! - -
- !!----------------------------------------------------------------------
- !
- IF( ln_timing ) CALL timing_start('eos2d')
- !
- prd(:,:) = 0._wp
- !
- SELECT CASE( neos )
- !
- CASE( np_teos10, np_eos80 ) !== polynomial TEOS-10 / EOS-80 ==!
- !
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
- !
- zh = pdep(ji,jj) * r1_Z0 ! depth
- zt = pts (ji,jj,jp_tem) * r1_T0 ! temperature
- zs = SQRT( ABS( pts(ji,jj,jp_sal) + rdeltaS ) * r1_S0 ) ! square root salinity
- !
- zn3 = EOS013*zt &
- & + EOS103*zs+EOS003
- !
- zn2 = (EOS022*zt &
- & + EOS112*zs+EOS012)*zt &
- & + (EOS202*zs+EOS102)*zs+EOS002
- !
- zn1 = (((EOS041*zt &
- & + EOS131*zs+EOS031)*zt &
- & + (EOS221*zs+EOS121)*zs+EOS021)*zt &
- & + ((EOS311*zs+EOS211)*zs+EOS111)*zs+EOS011)*zt &
- & + (((EOS401*zs+EOS301)*zs+EOS201)*zs+EOS101)*zs+EOS001
- !
- zn0 = (((((EOS060*zt &
- & + EOS150*zs+EOS050)*zt &
- & + (EOS240*zs+EOS140)*zs+EOS040)*zt &
- & + ((EOS330*zs+EOS230)*zs+EOS130)*zs+EOS030)*zt &
- & + (((EOS420*zs+EOS320)*zs+EOS220)*zs+EOS120)*zs+EOS020)*zt &
- & + ((((EOS510*zs+EOS410)*zs+EOS310)*zs+EOS210)*zs+EOS110)*zs+EOS010)*zt &
- & + (((((EOS600*zs+EOS500)*zs+EOS400)*zs+EOS300)*zs+EOS200)*zs+EOS100)*zs+EOS000
- !
- zn = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0
- !
- prd(ji,jj) = zn * r1_rho0 - 1._wp ! unmasked in situ density anomaly
- !
- END_2D
- !
- CASE( np_seos ) !== simplified EOS ==!
- !
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
- !
- zt = pts (ji,jj,jp_tem) - 10._wp
- zs = pts (ji,jj,jp_sal) - 35._wp
- zh = pdep (ji,jj) ! depth at the partial step level
- !
- zn = - rn_a0 * ( 1._wp + 0.5_wp*rn_lambda1*zt + rn_mu1*zh ) * zt &
- & + rn_b0 * ( 1._wp - 0.5_wp*rn_lambda2*zs - rn_mu2*zh ) * zs &
- & - rn_nu * zt * zs
- !
- prd(ji,jj) = zn * r1_rho0 ! unmasked in situ density anomaly
- !
- END_2D
- !
- CASE( np_leos ) !== ISOMIP EOS ==!
- !
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
- !
- zt = pts (ji,jj,jp_tem) - (-1._wp)
- zs = pts (ji,jj,jp_sal) - 34.2_wp
- zh = pdep (ji,jj) ! depth at the partial step level
- !
- zn = rho0 * ( - rn_a0 * zt + rn_b0 * zs )
- !
- prd(ji,jj) = zn * r1_rho0 ! unmasked in situ density anomaly
- !
- END_2D
- !
- !
- END SELECT
- !
- IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab2d_1=prd, clinfo1=' eos2d: ' )
- !
- IF( ln_timing ) CALL timing_stop('eos2d')
- !
- END SUBROUTINE eos_insitu_2d_t
-
-
- SUBROUTINE eos_insitu_pot_2d( pts, prhop )
- !!
- REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: pts ! 1 : potential temperature [Celsius]
- ! ! 2 : salinity [psu]
- REAL(wp), DIMENSION(:,:) , INTENT( out) :: prhop ! potential density (surface referenced)
- !!
- CALL eos_insitu_pot_2d_t( pts, is_tile(pts), prhop, is_tile(prhop) )
- END SUBROUTINE eos_insitu_pot_2d
-
-
- SUBROUTINE eos_insitu_pot_2d_t( pts, ktts, prhop, ktrhop )
- !!----------------------------------------------------------------------
- !! *** ROUTINE eos_insitu_pot ***
- !!
- !! ** Purpose : Compute the in situ density (ratio rho/rho0) and the
- !! potential volumic mass (Kg/m3) from potential temperature and
- !! salinity fields using an equation of state selected in the
- !! namelist.
- !!
- !! ** Action :
- !! - prhop, the potential volumic mass (Kg/m3)
- !!
- !!----------------------------------------------------------------------
- INTEGER , INTENT(in ) :: ktts, ktrhop
- REAL(wp), DIMENSION(A2D_T(ktts),JPTS), INTENT(in ) :: pts ! 1 : potential temperature [Celsius]
- ! ! 2 : salinity [psu]
- REAL(wp), DIMENSION(A2D_T(ktrhop) ), INTENT( out) :: prhop ! potential density (surface referenced)
- !
- INTEGER :: ji, jj, jk, jsmp ! dummy loop indices
- INTEGER :: jdof
- REAL(wp) :: zt , zh , zstemp, zs , ztm ! local scalars
- REAL(wp) :: zn , zn0, zn1, zn2, zn3 ! - -
- REAL(wp), DIMENSION(:), ALLOCATABLE :: zn0_sto, zn_sto, zsign ! local vectors
- !!----------------------------------------------------------------------
- !
- IF( ln_timing ) CALL timing_start('eos-pot')
- !
- SELECT CASE ( neos )
- !
- CASE( np_teos10, np_eos80 ) !== polynomial TEOS-10 / EOS-80 ==!
- !
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
- !
- zt = pts (ji,jj,jp_tem) * r1_T0 ! temperature
- zs = SQRT( ABS( pts(ji,jj,jp_sal) + rdeltaS ) * r1_S0 ) ! square root salinity
- ztm = tmask(ji,jj,1) ! tmask
- !
- zn0 = (((((EOS060*zt &
- & + EOS150*zs+EOS050)*zt &
- & + (EOS240*zs+EOS140)*zs+EOS040)*zt &
- & + ((EOS330*zs+EOS230)*zs+EOS130)*zs+EOS030)*zt &
- & + (((EOS420*zs+EOS320)*zs+EOS220)*zs+EOS120)*zs+EOS020)*zt &
- & + ((((EOS510*zs+EOS410)*zs+EOS310)*zs+EOS210)*zs+EOS110)*zs+EOS010)*zt &
- & + (((((EOS600*zs+EOS500)*zs+EOS400)*zs+EOS300)*zs+EOS200)*zs+EOS100)*zs+EOS000
- !
- !
- prhop(ji,jj) = zn0 * ztm ! potential density referenced at the surface
- !
- END_2D
-
- CASE( np_seos ) !== simplified EOS ==!
- !
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
- zt = pts (ji,jj,jp_tem) - 10._wp
- zs = pts (ji,jj,jp_sal) - 35._wp
- ztm = tmask(ji,jj,1)
- ! ! potential density referenced at the surface
- zn = - rn_a0 * ( 1._wp + 0.5_wp*rn_lambda1*zt ) * zt &
- & + rn_b0 * ( 1._wp - 0.5_wp*rn_lambda2*zs ) * zs &
- & - rn_nu * zt * zs
- prhop(ji,jj) = ( rho0 + zn ) * ztm
- !
- END_2D
- !
- CASE( np_leos ) !== ISOMIP EOS ==!
- !
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
- !
- zt = pts (ji,jj,jp_tem) - (-1._wp)
- zs = pts (ji,jj,jp_sal) - 34.2_wp
- !zh = pdep (ji,jj) ! depth at the partial step level
- !
- zn = rho0 * ( - rn_a0 * zt + rn_b0 * zs )
- !
- prhop(ji,jj) = zn * r1_rho0 ! unmasked in situ density anomaly
- !
- END_2D
- !
- END SELECT
- IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab2d_1=prhop, clinfo1=' pot: ', kdim=1 )
- !
- IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab2d_1=prhop, clinfo1=' eos-pot: ' )
- !
- IF( ln_timing ) CALL timing_stop('eos-pot')
- !
- END SUBROUTINE eos_insitu_pot_2d_t
-
-
- SUBROUTINE rab_3d( pts, pab, Kmm )
- !!
- INTEGER , INTENT(in ) :: Kmm ! time level index
- REAL(wp), DIMENSION(:,:,:,:), INTENT(in ) :: pts ! pot. temperature & salinity
- REAL(wp), DIMENSION(:,:,:,:), INTENT( out) :: pab ! thermal/haline expansion ratio
- !!
- CALL rab_3d_t( pts, is_tile(pts), pab, is_tile(pab), Kmm )
- END SUBROUTINE rab_3d
-
-
- SUBROUTINE rab_3d_t( pts, ktts, pab, ktab, Kmm )
- !!----------------------------------------------------------------------
- !! *** ROUTINE rab_3d ***
- !!
- !! ** Purpose : Calculates thermal/haline expansion ratio at T-points
- !!
- !! ** Method : calculates alpha / beta at T-points
- !!
- !! ** Action : - pab : thermal/haline expansion ratio at T-points
- !!----------------------------------------------------------------------
- INTEGER , INTENT(in ) :: Kmm ! time level index
- INTEGER , INTENT(in ) :: ktts, ktab
- REAL(wp), DIMENSION(A2D_T(ktts),JPK,JPTS), INTENT(in ) :: pts ! pot. temperature & salinity
- REAL(wp), DIMENSION(A2D_T(ktab),JPK,JPTS), INTENT( out) :: pab ! thermal/haline expansion ratio
- !
- INTEGER :: ji, jj, jk ! dummy loop indices
- REAL(wp) :: zt , zh , zs , ztm ! local scalars
- REAL(wp) :: zn , zn0, zn1, zn2, zn3 ! - -
- !!----------------------------------------------------------------------
- !
- IF( ln_timing ) CALL timing_start('rab_3d')
- !
- SELECT CASE ( neos )
- !
- CASE( np_teos10, np_eos80 ) !== polynomial TEOS-10 / EOS-80 ==!
- !
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 )
- !
- zh = gdept(ji,jj,jk,Kmm) * r1_Z0 ! depth
- zt = pts (ji,jj,jk,jp_tem) * r1_T0 ! temperature
- zs = SQRT( ABS( pts(ji,jj,jk,jp_sal) + rdeltaS ) * r1_S0 ) ! square root salinity
- ztm = tmask(ji,jj,jk) ! tmask
- !
- ! alpha
- zn3 = ALP003
- !
- zn2 = ALP012*zt + ALP102*zs+ALP002
- !
- zn1 = ((ALP031*zt &
- & + ALP121*zs+ALP021)*zt &
- & + (ALP211*zs+ALP111)*zs+ALP011)*zt &
- & + ((ALP301*zs+ALP201)*zs+ALP101)*zs+ALP001
- !
- zn0 = ((((ALP050*zt &
- & + ALP140*zs+ALP040)*zt &
- & + (ALP230*zs+ALP130)*zs+ALP030)*zt &
- & + ((ALP320*zs+ALP220)*zs+ALP120)*zs+ALP020)*zt &
- & + (((ALP410*zs+ALP310)*zs+ALP210)*zs+ALP110)*zs+ALP010)*zt &
- & + ((((ALP500*zs+ALP400)*zs+ALP300)*zs+ALP200)*zs+ALP100)*zs+ALP000
- !
- zn = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0
- !
- pab(ji,jj,jk,jp_tem) = zn * r1_rho0 * ztm
- !
- ! beta
- zn3 = BET003
- !
- zn2 = BET012*zt + BET102*zs+BET002
- !
- zn1 = ((BET031*zt &
- & + BET121*zs+BET021)*zt &
- & + (BET211*zs+BET111)*zs+BET011)*zt &
- & + ((BET301*zs+BET201)*zs+BET101)*zs+BET001
- !
- zn0 = ((((BET050*zt &
- & + BET140*zs+BET040)*zt &
- & + (BET230*zs+BET130)*zs+BET030)*zt &
- & + ((BET320*zs+BET220)*zs+BET120)*zs+BET020)*zt &
- & + (((BET410*zs+BET310)*zs+BET210)*zs+BET110)*zs+BET010)*zt &
- & + ((((BET500*zs+BET400)*zs+BET300)*zs+BET200)*zs+BET100)*zs+BET000
- !
- zn = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0
- !
- pab(ji,jj,jk,jp_sal) = zn / zs * r1_rho0 * ztm
- !
- END_3D
- !
- CASE( np_seos ) !== simplified EOS ==!
- !
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 )
- zt = pts (ji,jj,jk,jp_tem) - 10._wp ! pot. temperature anomaly (t-T0)
- zs = pts (ji,jj,jk,jp_sal) - 35._wp ! abs. salinity anomaly (s-S0)
- zh = gdept(ji,jj,jk,Kmm) ! depth in meters at t-point
- ztm = tmask(ji,jj,jk) ! land/sea bottom mask = surf. mask
- !
- zn = rn_a0 * ( 1._wp + rn_lambda1*zt + rn_mu1*zh ) + rn_nu*zs
- pab(ji,jj,jk,jp_tem) = zn * r1_rho0 * ztm ! alpha
- !
- zn = rn_b0 * ( 1._wp - rn_lambda2*zs - rn_mu2*zh ) - rn_nu*zt
- pab(ji,jj,jk,jp_sal) = zn * r1_rho0 * ztm ! beta
- !
- END_3D
- !
- CASE( np_leos ) !== linear ISOMIP EOS ==!
- !
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 )
- zt = pts (ji,jj,jk,jp_tem) - (-1._wp)
- zs = pts (ji,jj,jk,jp_sal) - 34.2_wp ! abs. salinity anomaly (s-S0)
- zh = gdept(ji,jj,jk,Kmm) ! depth in meters at t-point
- ztm = tmask(ji,jj,jk) ! land/sea bottom mask = surf. mask
- !
- zn = rn_a0 * rho0
- pab(ji,jj,jk,jp_tem) = zn * r1_rho0 * ztm ! alpha
- !
- zn = rn_b0 * rho0
- pab(ji,jj,jk,jp_sal) = zn * r1_rho0 * ztm ! beta
- !
- END_3D
- !
- CASE DEFAULT
- WRITE(ctmp1,*) ' bad flag value for neos = ', neos
- CALL ctl_stop( 'rab_3d:', ctmp1 )
- !
- END SELECT
- !
- IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=pab(:,:,:,jp_tem), clinfo1=' rab_3d_t: ', &
- & tab3d_2=pab(:,:,:,jp_sal), clinfo2=' rab_3d_s : ', kdim=jpk )
- !
- IF( ln_timing ) CALL timing_stop('rab_3d')
- !
- END SUBROUTINE rab_3d_t
-
-
- SUBROUTINE rab_2d( pts, pdep, pab, Kmm )
- !!
- INTEGER , INTENT(in ) :: Kmm ! time level index
- REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: pts ! pot. temperature & salinity
- REAL(wp), DIMENSION(:,:) , INTENT(in ) :: pdep ! depth [m]
- REAL(wp), DIMENSION(:,:,:), INTENT( out) :: pab ! thermal/haline expansion ratio
- !!
- CALL rab_2d_t(pts, is_tile(pts), pdep, is_tile(pdep), pab, is_tile(pab), Kmm)
- END SUBROUTINE rab_2d
-
-
- SUBROUTINE rab_2d_t( pts, ktts, pdep, ktdep, pab, ktab, Kmm )
- !!----------------------------------------------------------------------
- !! *** ROUTINE rab_2d ***
- !!
- !! ** Purpose : Calculates thermal/haline expansion ratio for a 2d field (unmasked)
- !!
- !! ** Action : - pab : thermal/haline expansion ratio at T-points
- !!----------------------------------------------------------------------
- INTEGER , INTENT(in ) :: Kmm ! time level index
- INTEGER , INTENT(in ) :: ktts, ktdep, ktab
- REAL(wp), DIMENSION(A2D_T(ktts),JPTS), INTENT(in ) :: pts ! pot. temperature & salinity
- REAL(wp), DIMENSION(A2D_T(ktdep) ), INTENT(in ) :: pdep ! depth [m]
- REAL(wp), DIMENSION(A2D_T(ktab),JPTS), INTENT( out) :: pab ! thermal/haline expansion ratio
- !
- INTEGER :: ji, jj, jk ! dummy loop indices
- REAL(wp) :: zt , zh , zs ! local scalars
- REAL(wp) :: zn , zn0, zn1, zn2, zn3 ! - -
- !!----------------------------------------------------------------------
- !
- IF( ln_timing ) CALL timing_start('rab_2d')
- !
- pab(:,:,:) = 0._wp
- !
- SELECT CASE ( neos )
- !
- CASE( np_teos10, np_eos80 ) !== polynomial TEOS-10 / EOS-80 ==!
- !
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
- !
- zh = pdep(ji,jj) * r1_Z0 ! depth
- zt = pts (ji,jj,jp_tem) * r1_T0 ! temperature
- zs = SQRT( ABS( pts(ji,jj,jp_sal) + rdeltaS ) * r1_S0 ) ! square root salinity
- !
- ! alpha
- zn3 = ALP003
- !
- zn2 = ALP012*zt + ALP102*zs+ALP002
- !
- zn1 = ((ALP031*zt &
- & + ALP121*zs+ALP021)*zt &
- & + (ALP211*zs+ALP111)*zs+ALP011)*zt &
- & + ((ALP301*zs+ALP201)*zs+ALP101)*zs+ALP001
- !
- zn0 = ((((ALP050*zt &
- & + ALP140*zs+ALP040)*zt &
- & + (ALP230*zs+ALP130)*zs+ALP030)*zt &
- & + ((ALP320*zs+ALP220)*zs+ALP120)*zs+ALP020)*zt &
- & + (((ALP410*zs+ALP310)*zs+ALP210)*zs+ALP110)*zs+ALP010)*zt &
- & + ((((ALP500*zs+ALP400)*zs+ALP300)*zs+ALP200)*zs+ALP100)*zs+ALP000
- !
- zn = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0
- !
- pab(ji,jj,jp_tem) = zn * r1_rho0
- !
- ! beta
- zn3 = BET003
- !
- zn2 = BET012*zt + BET102*zs+BET002
- !
- zn1 = ((BET031*zt &
- & + BET121*zs+BET021)*zt &
- & + (BET211*zs+BET111)*zs+BET011)*zt &
- & + ((BET301*zs+BET201)*zs+BET101)*zs+BET001
- !
- zn0 = ((((BET050*zt &
- & + BET140*zs+BET040)*zt &
- & + (BET230*zs+BET130)*zs+BET030)*zt &
- & + ((BET320*zs+BET220)*zs+BET120)*zs+BET020)*zt &
- & + (((BET410*zs+BET310)*zs+BET210)*zs+BET110)*zs+BET010)*zt &
- & + ((((BET500*zs+BET400)*zs+BET300)*zs+BET200)*zs+BET100)*zs+BET000
- !
- zn = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0
- !
- pab(ji,jj,jp_sal) = zn / zs * r1_rho0
- !
- !
- END_2D
- !
- CASE( np_seos ) !== simplified EOS ==!
- !
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
- !
- zt = pts (ji,jj,jp_tem) - 10._wp ! pot. temperature anomaly (t-T0)
- zs = pts (ji,jj,jp_sal) - 35._wp ! abs. salinity anomaly (s-S0)
- zh = pdep (ji,jj) ! depth at the partial step level
- !
- zn = rn_a0 * ( 1._wp + rn_lambda1*zt + rn_mu1*zh ) + rn_nu*zs
- pab(ji,jj,jp_tem) = zn * r1_rho0 ! alpha
- !
- zn = rn_b0 * ( 1._wp - rn_lambda2*zs - rn_mu2*zh ) - rn_nu*zt
- pab(ji,jj,jp_sal) = zn * r1_rho0 ! beta
- !
- END_2D
- !
- CASE( np_leos ) !== linear ISOMIP EOS ==!
- !
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
- !
- zt = pts (ji,jj,jp_tem) - (-1._wp) ! pot. temperature anomaly (t-T0)
- zs = pts (ji,jj,jp_sal) - 34.2_wp ! abs. salinity anomaly (s-S0)
- zh = pdep (ji,jj) ! depth at the partial step level
- !
- zn = rn_a0 * rho0
- pab(ji,jj,jp_tem) = zn * r1_rho0 ! alpha
- !
- zn = rn_b0 * rho0
- pab(ji,jj,jp_sal) = zn * r1_rho0 ! beta
- !
- END_2D
- !
- CASE DEFAULT
- WRITE(ctmp1,*) ' bad flag value for neos = ', neos
- CALL ctl_stop( 'rab_2d:', ctmp1 )
- !
- END SELECT
- !
- IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab2d_1=pab(:,:,jp_tem), clinfo1=' rab_2d_t: ', &
- & tab2d_2=pab(:,:,jp_sal), clinfo2=' rab_2d_s : ' )
- !
- IF( ln_timing ) CALL timing_stop('rab_2d')
- !
- END SUBROUTINE rab_2d_t
-
-
- SUBROUTINE rab_0d( pts, pdep, pab, Kmm )
- !!----------------------------------------------------------------------
- !! *** ROUTINE rab_0d ***
- !!
- !! ** Purpose : Calculates thermal/haline expansion ratio for a 2d field (unmasked)
- !!
- !! ** Action : - pab : thermal/haline expansion ratio at T-points
- !!----------------------------------------------------------------------
- INTEGER , INTENT(in ) :: Kmm ! time level index
- REAL(wp), DIMENSION(jpts) , INTENT(in ) :: pts ! pot. temperature & salinity
- REAL(wp), INTENT(in ) :: pdep ! depth [m]
- REAL(wp), DIMENSION(jpts) , INTENT( out) :: pab ! thermal/haline expansion ratio
- !
- REAL(wp) :: zt , zh , zs ! local scalars
- REAL(wp) :: zn , zn0, zn1, zn2, zn3 ! - -
- !!----------------------------------------------------------------------
- !
- IF( ln_timing ) CALL timing_start('rab_0d')
- !
- pab(:) = 0._wp
- !
- SELECT CASE ( neos )
- !
- CASE( np_teos10, np_eos80 ) !== polynomial TEOS-10 / EOS-80 ==!
- !
- !
- zh = pdep * r1_Z0 ! depth
- zt = pts (jp_tem) * r1_T0 ! temperature
- zs = SQRT( ABS( pts(jp_sal) + rdeltaS ) * r1_S0 ) ! square root salinity
- !
- ! alpha
- zn3 = ALP003
- !
- zn2 = ALP012*zt + ALP102*zs+ALP002
- !
- zn1 = ((ALP031*zt &
- & + ALP121*zs+ALP021)*zt &
- & + (ALP211*zs+ALP111)*zs+ALP011)*zt &
- & + ((ALP301*zs+ALP201)*zs+ALP101)*zs+ALP001
- !
- zn0 = ((((ALP050*zt &
- & + ALP140*zs+ALP040)*zt &
- & + (ALP230*zs+ALP130)*zs+ALP030)*zt &
- & + ((ALP320*zs+ALP220)*zs+ALP120)*zs+ALP020)*zt &
- & + (((ALP410*zs+ALP310)*zs+ALP210)*zs+ALP110)*zs+ALP010)*zt &
- & + ((((ALP500*zs+ALP400)*zs+ALP300)*zs+ALP200)*zs+ALP100)*zs+ALP000
- !
- zn = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0
- !
- pab(jp_tem) = zn * r1_rho0
- !
- ! beta
- zn3 = BET003
- !
- zn2 = BET012*zt + BET102*zs+BET002
- !
- zn1 = ((BET031*zt &
- & + BET121*zs+BET021)*zt &
- & + (BET211*zs+BET111)*zs+BET011)*zt &
- & + ((BET301*zs+BET201)*zs+BET101)*zs+BET001
- !
- zn0 = ((((BET050*zt &
- & + BET140*zs+BET040)*zt &
- & + (BET230*zs+BET130)*zs+BET030)*zt &
- & + ((BET320*zs+BET220)*zs+BET120)*zs+BET020)*zt &
- & + (((BET410*zs+BET310)*zs+BET210)*zs+BET110)*zs+BET010)*zt &
- & + ((((BET500*zs+BET400)*zs+BET300)*zs+BET200)*zs+BET100)*zs+BET000
- !
- zn = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0
- !
- pab(jp_sal) = zn / zs * r1_rho0
- !
- !
- !
- CASE( np_seos ) !== simplified EOS ==!
- !
- zt = pts(jp_tem) - 10._wp ! pot. temperature anomaly (t-T0)
- zs = pts(jp_sal) - 35._wp ! abs. salinity anomaly (s-S0)
- zh = pdep ! depth at the partial step level
- !
- zn = rn_a0 * ( 1._wp + rn_lambda1*zt + rn_mu1*zh ) + rn_nu*zs
- pab(jp_tem) = zn * r1_rho0 ! alpha
- !
- zn = rn_b0 * ( 1._wp - rn_lambda2*zs - rn_mu2*zh ) - rn_nu*zt
- pab(jp_sal) = zn * r1_rho0 ! beta
- !
- CASE( np_leos ) !== linear ISOMIP EOS ==!
- !
- zt = pts(jp_tem) - (-1._wp) ! pot. temperature anomaly (t-T0)
- zs = pts(jp_sal) - 34.2_wp ! abs. salinity anomaly (s-S0)
- zh = pdep ! depth at the partial step level
- !
- zn = rn_a0 * rho0
- pab(jp_tem) = zn * r1_rho0 ! alpha
- !
- zn = rn_b0 * rho0
- pab(jp_sal) = zn * r1_rho0 ! beta
- !
- CASE DEFAULT
- WRITE(ctmp1,*) ' bad flag value for neos = ', neos
- CALL ctl_stop( 'rab_0d:', ctmp1 )
- !
- END SELECT
- !
- IF( ln_timing ) CALL timing_stop('rab_0d')
- !
- END SUBROUTINE rab_0d
-
-
- SUBROUTINE bn2( pts, pab, pn2, Kmm )
- !!
- INTEGER , INTENT(in ) :: Kmm ! time level index
- REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in ) :: pts ! pot. temperature and salinity [Celsius,psu]
- REAL(wp), DIMENSION(:,:,:,:) , INTENT(in ) :: pab ! thermal/haline expansion coef. [Celsius-1,psu-1]
- REAL(wp), DIMENSION(:,:,:) , INTENT( out) :: pn2 ! Brunt-Vaisala frequency squared [1/s^2]
- !!
- CALL bn2_t( pts, pab, is_tile(pab), pn2, is_tile(pn2), Kmm )
- END SUBROUTINE bn2
-
-
- SUBROUTINE bn2_t( pts, pab, ktab, pn2, ktn2, Kmm )
- !!----------------------------------------------------------------------
- !! *** ROUTINE bn2 ***
- !!
- !! ** Purpose : Compute the local Brunt-Vaisala frequency at the
- !! time-step of the input arguments
- !!
- !! ** Method : pn2 = grav * (alpha dk[T] + beta dk[S] ) / e3w
- !! where alpha and beta are given in pab, and computed on T-points.
- !! N.B. N^2 is set one for all to zero at jk=1 in istate module.
- !!
- !! ** Action : pn2 : square of the brunt-vaisala frequency at w-point
- !!
- !!----------------------------------------------------------------------
- INTEGER , INTENT(in ) :: Kmm ! time level index
- INTEGER , INTENT(in ) :: ktab, ktn2
- REAL(wp), DIMENSION(jpi,jpj, jpk,jpts), INTENT(in ) :: pts ! pot. temperature and salinity [Celsius,psu]
- REAL(wp), DIMENSION(A2D_T(ktab),JPK,JPTS), INTENT(in ) :: pab ! thermal/haline expansion coef. [Celsius-1,psu-1]
- REAL(wp), DIMENSION(A2D_T(ktn2),JPK ), INTENT( out) :: pn2 ! Brunt-Vaisala frequency squared [1/s^2]
- !
- INTEGER :: ji, jj, jk ! dummy loop indices
- REAL(wp) :: zaw, zbw, zrw ! local scalars
- !!----------------------------------------------------------------------
- !
- IF( ln_timing ) CALL timing_start('bn2')
- !
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 2, jpkm1 ) ! interior points only (2=< jk =< jpkm1 ); surface and bottom value set to zero one for all in istate.F90
- zrw = ( gdepw(ji,jj,jk ,Kmm) - gdept(ji,jj,jk,Kmm) ) &
- & / ( gdept(ji,jj,jk-1,Kmm) - gdept(ji,jj,jk,Kmm) )
- !
- zaw = pab(ji,jj,jk,jp_tem) * (1. - zrw) + pab(ji,jj,jk-1,jp_tem) * zrw
- zbw = pab(ji,jj,jk,jp_sal) * (1. - zrw) + pab(ji,jj,jk-1,jp_sal) * zrw
- !
- pn2(ji,jj,jk) = grav * ( zaw * ( pts(ji,jj,jk-1,jp_tem) - pts(ji,jj,jk,jp_tem) ) &
- & - zbw * ( pts(ji,jj,jk-1,jp_sal) - pts(ji,jj,jk,jp_sal) ) ) &
- & / e3w(ji,jj,jk,Kmm) * wmask(ji,jj,jk)
- END_3D
- !
- IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=pn2, clinfo1=' bn2 : ', kdim=jpk )
- !
- IF( ln_timing ) CALL timing_stop('bn2')
- !
- END SUBROUTINE bn2_t
-
-
- FUNCTION eos_pt_from_ct( ctmp, psal ) RESULT( ptmp )
- !!----------------------------------------------------------------------
- !! *** ROUTINE eos_pt_from_ct ***
- !!
- !! ** Purpose : Compute pot.temp. from cons. temp. [Celsius]
- !!
- !! ** Method : rational approximation (5/3th order) of TEOS-10 algorithm
- !! checkvalue: pt=20.02391895 Celsius for sa=35.7g/kg, ct=20degC
- !!
- !! Reference : TEOS-10, UNESCO
- !! Rational approximation to TEOS10 algorithm (rms error on WOA13 values: 4.0e-5 degC)
- !!----------------------------------------------------------------------
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: ctmp ! Cons. Temp [Celsius]
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: psal ! salinity [psu]
- ! Leave result array automatic rather than making explicitly allocated
- REAL(wp), DIMENSION(jpi,jpj) :: ptmp ! potential temperature [Celsius]
- !
- INTEGER :: ji, jj ! dummy loop indices
- REAL(wp) :: zt , zs , ztm ! local scalars
- REAL(wp) :: zn , zd ! local scalars
- REAL(wp) :: zdeltaS , z1_S0 , z1_T0
- !!----------------------------------------------------------------------
- !
- IF( ln_timing ) CALL timing_start('eos_pt_from_ct')
- !
- zdeltaS = 5._wp
- z1_S0 = 0.875_wp/35.16504_wp
- z1_T0 = 1._wp/40._wp
- !
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
- !
- zt = ctmp (ji,jj) * z1_T0
- zs = SQRT( ABS( psal(ji,jj) + zdeltaS ) * z1_S0 )
- ztm = tmask(ji,jj,1)
- !
- zn = ((((-2.1385727895e-01_wp*zt &
- & - 2.7674419971e-01_wp*zs+1.0728094330_wp)*zt &
- & + (2.6366564313_wp*zs+3.3546960647_wp)*zs-7.8012209473_wp)*zt &
- & + ((1.8835586562_wp*zs+7.3949191679_wp)*zs-3.3937395875_wp)*zs-5.6414948432_wp)*zt &
- & + (((3.5737370589_wp*zs-1.5512427389e+01_wp)*zs+2.4625741105e+01_wp)*zs &
- & +1.9912291000e+01_wp)*zs-3.2191146312e+01_wp)*zt &
- & + ((((5.7153204649e-01_wp*zs-3.0943149543_wp)*zs+9.3052495181_wp)*zs &
- & -9.4528934807_wp)*zs+3.1066408996_wp)*zs-4.3504021262e-01_wp
- !
- zd = (2.0035003456_wp*zt &
- & -3.4570358592e-01_wp*zs+5.6471810638_wp)*zt &
- & + (1.5393993508_wp*zs-6.9394762624_wp)*zs+1.2750522650e+01_wp
- !
- ptmp(ji,jj) = ( zt / z1_T0 + zn / zd ) * ztm
- !
- END_2D
- !
- IF( ln_timing ) CALL timing_stop('eos_pt_from_ct')
- !
- END FUNCTION eos_pt_from_ct
-
-
- SUBROUTINE eos_fzp_2d( psal, ptf, pdep )
- !!
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: psal ! salinity [psu]
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in ), OPTIONAL :: pdep ! depth [m]
- REAL(wp), DIMENSION(:,:) , INTENT(out ) :: ptf ! freezing temperature [Celsius]
- !!
- CALL eos_fzp_2d_t( psal, ptf, is_tile(ptf), pdep )
- END SUBROUTINE eos_fzp_2d
-
-
- SUBROUTINE eos_fzp_2d_t( psal, ptf, kttf, pdep )
- !!----------------------------------------------------------------------
- !! *** ROUTINE eos_fzp ***
- !!
- !! ** Purpose : Compute the freezing point temperature [Celsius]
- !!
- !! ** Method : UNESCO freezing point (ptf) in Celsius is given by
- !! ptf(t,z) = (-.0575+1.710523e-3*sqrt(abs(s))-2.154996e-4*s)*s - 7.53e-4*z
- !! checkvalue: tf=-2.588567 Celsius for s=40psu, z=500m
- !!
- !! Reference : UNESCO tech. papers in the marine science no. 28. 1978
- !!----------------------------------------------------------------------
- INTEGER , INTENT(in ) :: kttf
- REAL(wp), DIMENSION(jpi,jpj) , INTENT(in ) :: psal ! salinity [psu]
- REAL(wp), DIMENSION(jpi,jpj) , INTENT(in ), OPTIONAL :: pdep ! depth [m]
- REAL(wp), DIMENSION(A2D_T(kttf)), INTENT(out ) :: ptf ! freezing temperature [Celsius]
- !
- INTEGER :: ji, jj ! dummy loop indices
- REAL(wp) :: zt, zs, z1_S0 ! local scalars
- !!----------------------------------------------------------------------
- !
- SELECT CASE ( neos )
- !
- CASE ( np_teos10, np_seos ) !== CT,SA (TEOS-10 and S-EOS formulations) ==!
- !
- z1_S0 = 1._wp / 35.16504_wp
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
- zs= SQRT( ABS( psal(ji,jj) ) * z1_S0 ) ! square root salinity
- ptf(ji,jj) = ((((1.46873e-03_wp*zs-9.64972e-03_wp)*zs+2.28348e-02_wp)*zs &
- & - 3.12775e-02_wp)*zs+2.07679e-02_wp)*zs-5.87701e-02_wp
- END_2D
- ptf(:,:) = ptf(:,:) * psal(:,:)
- !
- IF( PRESENT( pdep ) ) ptf(:,:) = ptf(:,:) - 7.53e-4 * pdep(:,:)
- !
- CASE ( np_eos80 ) !== PT,SP (UNESCO formulation) ==!
- !
- ptf(:,:) = ( - 0.0575_wp + 1.710523e-3_wp * SQRT( psal(:,:) ) &
- & - 2.154996e-4_wp * psal(:,:) ) * psal(:,:)
- !
- IF( PRESENT( pdep ) ) ptf(:,:) = ptf(:,:) - 7.53e-4 * pdep(:,:)
- !
- CASE DEFAULT
- WRITE(ctmp1,*) ' bad flag value for neos = ', neos
- CALL ctl_stop( 'eos_fzp_2d:', ctmp1 )
- !
- END SELECT
- !
- END SUBROUTINE eos_fzp_2d_t
-
-
- SUBROUTINE eos_fzp_0d( psal, ptf, pdep )
- !!----------------------------------------------------------------------
- !! *** ROUTINE eos_fzp ***
- !!
- !! ** Purpose : Compute the freezing point temperature [Celsius]
- !!
- !! ** Method : UNESCO freezing point (ptf) in Celsius is given by
- !! ptf(t,z) = (-.0575+1.710523e-3*sqrt(abs(s))-2.154996e-4*s)*s - 7.53e-4*z
- !! checkvalue: tf=-2.588567 Celsius for s=40psu, z=500m
- !!
- !! Reference : UNESCO tech. papers in the marine science no. 28. 1978
- !!----------------------------------------------------------------------
- REAL(wp), INTENT(in ) :: psal ! salinity [psu]
- REAL(wp), INTENT(in ), OPTIONAL :: pdep ! depth [m]
- REAL(wp), INTENT(out) :: ptf ! freezing temperature [Celsius]
- !
- REAL(wp) :: zs ! local scalars
- !!----------------------------------------------------------------------
- !
- SELECT CASE ( neos )
- !
- CASE ( np_teos10, np_seos ) !== CT,SA (TEOS-10 and S-EOS formulations) ==!
- !
- zs = SQRT( ABS( psal ) / 35.16504_wp ) ! square root salinity
- ptf = ((((1.46873e-03_wp*zs-9.64972e-03_wp)*zs+2.28348e-02_wp)*zs &
- & - 3.12775e-02_wp)*zs+2.07679e-02_wp)*zs-5.87701e-02_wp
- ptf = ptf * psal
- !
- IF( PRESENT( pdep ) ) ptf = ptf - 7.53e-4 * pdep
- !
- CASE ( np_eos80 ) !== PT,SP (UNESCO formulation) ==!
- !
- ptf = ( - 0.0575_wp + 1.710523e-3_wp * SQRT( psal ) &
- & - 2.154996e-4_wp * psal ) * psal
- !
- IF( PRESENT( pdep ) ) ptf = ptf - 7.53e-4 * pdep
- !
- CASE DEFAULT
- WRITE(ctmp1,*) ' bad flag value for neos = ', neos
- CALL ctl_stop( 'eos_fzp_0d:', ctmp1 )
- !
- END SELECT
- !
- END SUBROUTINE eos_fzp_0d
-
-
- SUBROUTINE eos_pen( pts, pab_pe, ppen, Kmm )
- !!----------------------------------------------------------------------
- !! *** ROUTINE eos_pen ***
- !!
- !! ** Purpose : Calculates nonlinear anomalies of alpha_PE, beta_PE and PE at T-points
- !!
- !! ** Method : PE is defined analytically as the vertical
- !! primitive of EOS times -g integrated between 0 and z>0.
- !! pen is the nonlinear bsq-PE anomaly: pen = ( PE - rho0 gz ) / rho0 gz - rd
- !! = 1/z * /int_0^z rd dz - rd
- !! where rd is the density anomaly (see eos_rhd function)
- !! ab_pe are partial derivatives of PE anomaly with respect to T and S:
- !! ab_pe(1) = - 1/(rho0 gz) * dPE/dT + drd/dT = - d(pen)/dT
- !! ab_pe(2) = 1/(rho0 gz) * dPE/dS + drd/dS = d(pen)/dS
- !!
- !! ** Action : - pen : PE anomaly given at T-points
- !! : - pab_pe : given at T-points
- !! pab_pe(:,:,:,jp_tem) is alpha_pe
- !! pab_pe(:,:,:,jp_sal) is beta_pe
- !!----------------------------------------------------------------------
- INTEGER , INTENT(in ) :: Kmm ! time level index
- REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in ) :: pts ! pot. temperature & salinity
- REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT( out) :: pab_pe ! alpha_pe and beta_pe
- REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT( out) :: ppen ! potential energy anomaly
- !
- INTEGER :: ji, jj, jk ! dummy loop indices
- REAL(wp) :: zt , zh , zs , ztm ! local scalars
- REAL(wp) :: zn , zn0, zn1, zn2 ! - -
- !!----------------------------------------------------------------------
- !
- IF( ln_timing ) CALL timing_start('eos_pen')
- !
- SELECT CASE ( neos )
- !
- CASE( np_teos10, np_eos80 ) !== polynomial TEOS-10 / EOS-80 ==!
- !
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 )
- !
- zh = gdept(ji,jj,jk,Kmm) * r1_Z0 ! depth
- zt = pts (ji,jj,jk,jp_tem) * r1_T0 ! temperature
- zs = SQRT( ABS( pts(ji,jj,jk,jp_sal) + rdeltaS ) * r1_S0 ) ! square root salinity
- ztm = tmask(ji,jj,jk) ! tmask
- !
- ! potential energy non-linear anomaly
- zn2 = (PEN012)*zt &
- & + PEN102*zs+PEN002
- !
- zn1 = ((PEN021)*zt &
- & + PEN111*zs+PEN011)*zt &
- & + (PEN201*zs+PEN101)*zs+PEN001
- !
- zn0 = ((((PEN040)*zt &
- & + PEN130*zs+PEN030)*zt &
- & + (PEN220*zs+PEN120)*zs+PEN020)*zt &
- & + ((PEN310*zs+PEN210)*zs+PEN110)*zs+PEN010)*zt &
- & + (((PEN400*zs+PEN300)*zs+PEN200)*zs+PEN100)*zs+PEN000
- !
- zn = ( zn2 * zh + zn1 ) * zh + zn0
- !
- ppen(ji,jj,jk) = zn * zh * r1_rho0 * ztm
- !
- ! alphaPE non-linear anomaly
- zn2 = APE002
- !
- zn1 = (APE011)*zt &
- & + APE101*zs+APE001
- !
- zn0 = (((APE030)*zt &
- & + APE120*zs+APE020)*zt &
- & + (APE210*zs+APE110)*zs+APE010)*zt &
- & + ((APE300*zs+APE200)*zs+APE100)*zs+APE000
- !
- zn = ( zn2 * zh + zn1 ) * zh + zn0
- !
- pab_pe(ji,jj,jk,jp_tem) = zn * zh * r1_rho0 * ztm
- !
- ! betaPE non-linear anomaly
- zn2 = BPE002
- !
- zn1 = (BPE011)*zt &
- & + BPE101*zs+BPE001
- !
- zn0 = (((BPE030)*zt &
- & + BPE120*zs+BPE020)*zt &
- & + (BPE210*zs+BPE110)*zs+BPE010)*zt &
- & + ((BPE300*zs+BPE200)*zs+BPE100)*zs+BPE000
- !
- zn = ( zn2 * zh + zn1 ) * zh + zn0
- !
- pab_pe(ji,jj,jk,jp_sal) = zn / zs * zh * r1_rho0 * ztm
- !
- END_3D
- !
- CASE( np_seos ) !== Vallis (2006) simplified EOS ==!
- !
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 )
- zt = pts(ji,jj,jk,jp_tem) - 10._wp ! temperature anomaly (t-T0)
- zs = pts (ji,jj,jk,jp_sal) - 35._wp ! abs. salinity anomaly (s-S0)
- zh = gdept(ji,jj,jk,Kmm) ! depth in meters at t-point
- ztm = tmask(ji,jj,jk) ! tmask
- zn = 0.5_wp * zh * r1_rho0 * ztm
- ! ! Potential Energy
- ppen(ji,jj,jk) = ( rn_a0 * rn_mu1 * zt + rn_b0 * rn_mu2 * zs ) * zn
- ! ! alphaPE
- pab_pe(ji,jj,jk,jp_tem) = - rn_a0 * rn_mu1 * zn
- pab_pe(ji,jj,jk,jp_sal) = rn_b0 * rn_mu2 * zn
- !
- END_3D
- !
- CASE( np_leos ) !== linear ISOMIP EOS ==!
- !
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 )
- zt = pts(ji,jj,jk,jp_tem) - (-1._wp) ! temperature anomaly (t-T0)
- zs = pts (ji,jj,jk,jp_sal) - 34.2_wp ! abs. salinity anomaly (s-S0)
- zh = gdept(ji,jj,jk,Kmm) ! depth in meters at t-point
- ztm = tmask(ji,jj,jk) ! tmask
- zn = 0.5_wp * zh * r1_rho0 * ztm
- ! ! Potential Energy
- ppen(ji,jj,jk) = 0.
- ! ! alphaPE
- pab_pe(ji,jj,jk,jp_tem) = 0.
- pab_pe(ji,jj,jk,jp_sal) = 0.
- !
- END_3D
- !
- CASE DEFAULT
- WRITE(ctmp1,*) ' bad flag value for neos = ', neos
- CALL ctl_stop( 'eos_pen:', ctmp1 )
- !
- END SELECT
- !
- IF( ln_timing ) CALL timing_stop('eos_pen')
- !
- END SUBROUTINE eos_pen
-
-
- SUBROUTINE eos_init
- !!----------------------------------------------------------------------
- !! *** ROUTINE eos_init ***
- !!
- !! ** Purpose : initializations for the equation of state
- !!
- !! ** Method : Read the namelist nameos and control the parameters
- !!----------------------------------------------------------------------
- INTEGER :: ios ! local integer
- INTEGER :: ioptio ! local integer
- !!
- NAMELIST/nameos/ ln_TEOS10, ln_EOS80, ln_SEOS, ln_LEOS, rn_a0, rn_b0, &
- & rn_lambda1, rn_mu1, rn_lambda2, rn_mu2, rn_nu
- !!----------------------------------------------------------------------
- !
- READ ( numnam_ref, nameos, IOSTAT = ios, ERR = 901 )
-901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nameos in reference namelist' )
- !
- READ ( numnam_cfg, nameos, IOSTAT = ios, ERR = 902 )
-902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nameos in configuration namelist' )
- IF(lwm) WRITE( numond, nameos )
- !
- rho0 = 1027.51_wp !: volumic mass of reference [kg/m3]
- rcp = 3974.00_wp !: heat capacity [J/K]
- !
- IF(lwp) THEN ! Control print
- WRITE(numout,*)
- WRITE(numout,*) 'eos_init : equation of state'
- WRITE(numout,*) '~~~~~~~~'
- WRITE(numout,*) ' Namelist nameos : Chosen the Equation Of Seawater (EOS)'
- WRITE(numout,*) ' TEOS-10 : rho=F(Conservative Temperature, Absolute Salinity, depth) ln_TEOS10 = ', ln_TEOS10
- WRITE(numout,*) ' EOS-80 : rho=F(Potential Temperature, Practical Salinity, depth) ln_EOS80 = ', ln_EOS80
- WRITE(numout,*) ' S-EOS : rho=F(Conservative Temperature, Absolute Salinity, depth) ln_SEOS = ', ln_SEOS
- WRITE(numout,*) ' L-EOS : rho=F(Potential Temperature, Practical Salinity, depth) ln_LEOS = ', ln_LEOS
- ENDIF
-
- ! Check options for equation of state & set neos based on logical flags
- ioptio = 0
- IF( ln_TEOS10 ) THEN ; ioptio = ioptio+1 ; neos = np_teos10 ; ENDIF
- IF( ln_EOS80 ) THEN ; ioptio = ioptio+1 ; neos = np_eos80 ; ENDIF
- IF( ln_SEOS ) THEN ; ioptio = ioptio+1 ; neos = np_seos ; ENDIF
- IF( ln_LEOS ) THEN ; ioptio = ioptio+1 ; neos = np_leos ; ENDIF
- IF( ioptio /= 1 ) CALL ctl_stop("Exactly one equation of state option must be selected")
- !
- SELECT CASE( neos ) ! check option
- !
- CASE( np_teos10 ) !== polynomial TEOS-10 ==!
- IF(lwp) WRITE(numout,*)
- IF(lwp) WRITE(numout,*) ' ==>>> use of TEOS-10 equation of state (cons. temp. and abs. salinity)'
- !
- l_useCT = .TRUE. ! model temperature is Conservative temperature
- !
- rdeltaS = 32._wp
- r1_S0 = 0.875_wp/35.16504_wp
- r1_T0 = 1._wp/40._wp
- r1_Z0 = 1.e-4_wp
- !
- EOS000 = 8.0189615746e+02_wp
- EOS100 = 8.6672408165e+02_wp
- EOS200 = -1.7864682637e+03_wp
- EOS300 = 2.0375295546e+03_wp
- EOS400 = -1.2849161071e+03_wp
- EOS500 = 4.3227585684e+02_wp
- EOS600 = -6.0579916612e+01_wp
- EOS010 = 2.6010145068e+01_wp
- EOS110 = -6.5281885265e+01_wp
- EOS210 = 8.1770425108e+01_wp
- EOS310 = -5.6888046321e+01_wp
- EOS410 = 1.7681814114e+01_wp
- EOS510 = -1.9193502195_wp
- EOS020 = -3.7074170417e+01_wp
- EOS120 = 6.1548258127e+01_wp
- EOS220 = -6.0362551501e+01_wp
- EOS320 = 2.9130021253e+01_wp
- EOS420 = -5.4723692739_wp
- EOS030 = 2.1661789529e+01_wp
- EOS130 = -3.3449108469e+01_wp
- EOS230 = 1.9717078466e+01_wp
- EOS330 = -3.1742946532_wp
- EOS040 = -8.3627885467_wp
- EOS140 = 1.1311538584e+01_wp
- EOS240 = -5.3563304045_wp
- EOS050 = 5.4048723791e-01_wp
- EOS150 = 4.8169980163e-01_wp
- EOS060 = -1.9083568888e-01_wp
- EOS001 = 1.9681925209e+01_wp
- EOS101 = -4.2549998214e+01_wp
- EOS201 = 5.0774768218e+01_wp
- EOS301 = -3.0938076334e+01_wp
- EOS401 = 6.6051753097_wp
- EOS011 = -1.3336301113e+01_wp
- EOS111 = -4.4870114575_wp
- EOS211 = 5.0042598061_wp
- EOS311 = -6.5399043664e-01_wp
- EOS021 = 6.7080479603_wp
- EOS121 = 3.5063081279_wp
- EOS221 = -1.8795372996_wp
- EOS031 = -2.4649669534_wp
- EOS131 = -5.5077101279e-01_wp
- EOS041 = 5.5927935970e-01_wp
- EOS002 = 2.0660924175_wp
- EOS102 = -4.9527603989_wp
- EOS202 = 2.5019633244_wp
- EOS012 = 2.0564311499_wp
- EOS112 = -2.1311365518e-01_wp
- EOS022 = -1.2419983026_wp
- EOS003 = -2.3342758797e-02_wp
- EOS103 = -1.8507636718e-02_wp
- EOS013 = 3.7969820455e-01_wp
- !
- ALP000 = -6.5025362670e-01_wp
- ALP100 = 1.6320471316_wp
- ALP200 = -2.0442606277_wp
- ALP300 = 1.4222011580_wp
- ALP400 = -4.4204535284e-01_wp
- ALP500 = 4.7983755487e-02_wp
- ALP010 = 1.8537085209_wp
- ALP110 = -3.0774129064_wp
- ALP210 = 3.0181275751_wp
- ALP310 = -1.4565010626_wp
- ALP410 = 2.7361846370e-01_wp
- ALP020 = -1.6246342147_wp
- ALP120 = 2.5086831352_wp
- ALP220 = -1.4787808849_wp
- ALP320 = 2.3807209899e-01_wp
- ALP030 = 8.3627885467e-01_wp
- ALP130 = -1.1311538584_wp
- ALP230 = 5.3563304045e-01_wp
- ALP040 = -6.7560904739e-02_wp
- ALP140 = -6.0212475204e-02_wp
- ALP050 = 2.8625353333e-02_wp
- ALP001 = 3.3340752782e-01_wp
- ALP101 = 1.1217528644e-01_wp
- ALP201 = -1.2510649515e-01_wp
- ALP301 = 1.6349760916e-02_wp
- ALP011 = -3.3540239802e-01_wp
- ALP111 = -1.7531540640e-01_wp
- ALP211 = 9.3976864981e-02_wp
- ALP021 = 1.8487252150e-01_wp
- ALP121 = 4.1307825959e-02_wp
- ALP031 = -5.5927935970e-02_wp
- ALP002 = -5.1410778748e-02_wp
- ALP102 = 5.3278413794e-03_wp
- ALP012 = 6.2099915132e-02_wp
- ALP003 = -9.4924551138e-03_wp
- !
- BET000 = 1.0783203594e+01_wp
- BET100 = -4.4452095908e+01_wp
- BET200 = 7.6048755820e+01_wp
- BET300 = -6.3944280668e+01_wp
- BET400 = 2.6890441098e+01_wp
- BET500 = -4.5221697773_wp
- BET010 = -8.1219372432e-01_wp
- BET110 = 2.0346663041_wp
- BET210 = -2.1232895170_wp
- BET310 = 8.7994140485e-01_wp
- BET410 = -1.1939638360e-01_wp
- BET020 = 7.6574242289e-01_wp
- BET120 = -1.5019813020_wp
- BET220 = 1.0872489522_wp
- BET320 = -2.7233429080e-01_wp
- BET030 = -4.1615152308e-01_wp
- BET130 = 4.9061350869e-01_wp
- BET230 = -1.1847737788e-01_wp
- BET040 = 1.4073062708e-01_wp
- BET140 = -1.3327978879e-01_wp
- BET050 = 5.9929880134e-03_wp
- BET001 = -5.2937873009e-01_wp
- BET101 = 1.2634116779_wp
- BET201 = -1.1547328025_wp
- BET301 = 3.2870876279e-01_wp
- BET011 = -5.5824407214e-02_wp
- BET111 = 1.2451933313e-01_wp
- BET211 = -2.4409539932e-02_wp
- BET021 = 4.3623149752e-02_wp
- BET121 = -4.6767901790e-02_wp
- BET031 = -6.8523260060e-03_wp
- BET002 = -6.1618945251e-02_wp
- BET102 = 6.2255521644e-02_wp
- BET012 = -2.6514181169e-03_wp
- BET003 = -2.3025968587e-04_wp
- !
- PEN000 = -9.8409626043_wp
- PEN100 = 2.1274999107e+01_wp
- PEN200 = -2.5387384109e+01_wp
- PEN300 = 1.5469038167e+01_wp
- PEN400 = -3.3025876549_wp
- PEN010 = 6.6681505563_wp
- PEN110 = 2.2435057288_wp
- PEN210 = -2.5021299030_wp
- PEN310 = 3.2699521832e-01_wp
- PEN020 = -3.3540239802_wp
- PEN120 = -1.7531540640_wp
- PEN220 = 9.3976864981e-01_wp
- PEN030 = 1.2324834767_wp
- PEN130 = 2.7538550639e-01_wp
- PEN040 = -2.7963967985e-01_wp
- PEN001 = -1.3773949450_wp
- PEN101 = 3.3018402659_wp
- PEN201 = -1.6679755496_wp
- PEN011 = -1.3709540999_wp
- PEN111 = 1.4207577012e-01_wp
- PEN021 = 8.2799886843e-01_wp
- PEN002 = 1.7507069098e-02_wp
- PEN102 = 1.3880727538e-02_wp
- PEN012 = -2.8477365341e-01_wp
- !
- APE000 = -1.6670376391e-01_wp
- APE100 = -5.6087643219e-02_wp
- APE200 = 6.2553247576e-02_wp
- APE300 = -8.1748804580e-03_wp
- APE010 = 1.6770119901e-01_wp
- APE110 = 8.7657703198e-02_wp
- APE210 = -4.6988432490e-02_wp
- APE020 = -9.2436260751e-02_wp
- APE120 = -2.0653912979e-02_wp
- APE030 = 2.7963967985e-02_wp
- APE001 = 3.4273852498e-02_wp
- APE101 = -3.5518942529e-03_wp
- APE011 = -4.1399943421e-02_wp
- APE002 = 7.1193413354e-03_wp
- !
- BPE000 = 2.6468936504e-01_wp
- BPE100 = -6.3170583896e-01_wp
- BPE200 = 5.7736640125e-01_wp
- BPE300 = -1.6435438140e-01_wp
- BPE010 = 2.7912203607e-02_wp
- BPE110 = -6.2259666565e-02_wp
- BPE210 = 1.2204769966e-02_wp
- BPE020 = -2.1811574876e-02_wp
- BPE120 = 2.3383950895e-02_wp
- BPE030 = 3.4261630030e-03_wp
- BPE001 = 4.1079296834e-02_wp
- BPE101 = -4.1503681096e-02_wp
- BPE011 = 1.7676120780e-03_wp
- BPE002 = 1.7269476440e-04_wp
- !
- CASE( np_eos80 ) !== polynomial EOS-80 formulation ==!
- !
- IF(lwp) WRITE(numout,*)
- IF(lwp) WRITE(numout,*) ' ==>>> use of EOS-80 equation of state (pot. temp. and pract. salinity)'
- !
- l_useCT = .FALSE. ! model temperature is Potential temperature
- rdeltaS = 20._wp
- r1_S0 = 1._wp/40._wp
- r1_T0 = 1._wp/40._wp
- r1_Z0 = 1.e-4_wp
- !
- EOS000 = 9.5356891948e+02_wp
- EOS100 = 1.7136499189e+02_wp
- EOS200 = -3.7501039454e+02_wp
- EOS300 = 5.1856810420e+02_wp
- EOS400 = -3.7264470465e+02_wp
- EOS500 = 1.4302533998e+02_wp
- EOS600 = -2.2856621162e+01_wp
- EOS010 = 1.0087518651e+01_wp
- EOS110 = -1.3647741861e+01_wp
- EOS210 = 8.8478359933_wp
- EOS310 = -7.2329388377_wp
- EOS410 = 1.4774410611_wp
- EOS510 = 2.0036720553e-01_wp
- EOS020 = -2.5579830599e+01_wp
- EOS120 = 2.4043512327e+01_wp
- EOS220 = -1.6807503990e+01_wp
- EOS320 = 8.3811577084_wp
- EOS420 = -1.9771060192_wp
- EOS030 = 1.6846451198e+01_wp
- EOS130 = -2.1482926901e+01_wp
- EOS230 = 1.0108954054e+01_wp
- EOS330 = -6.2675951440e-01_wp
- EOS040 = -8.0812310102_wp
- EOS140 = 1.0102374985e+01_wp
- EOS240 = -4.8340368631_wp
- EOS050 = 1.2079167803_wp
- EOS150 = 1.1515380987e-01_wp
- EOS060 = -2.4520288837e-01_wp
- EOS001 = 1.0748601068e+01_wp
- EOS101 = -1.7817043500e+01_wp
- EOS201 = 2.2181366768e+01_wp
- EOS301 = -1.6750916338e+01_wp
- EOS401 = 4.1202230403_wp
- EOS011 = -1.5852644587e+01_wp
- EOS111 = -7.6639383522e-01_wp
- EOS211 = 4.1144627302_wp
- EOS311 = -6.6955877448e-01_wp
- EOS021 = 9.9994861860_wp
- EOS121 = -1.9467067787e-01_wp
- EOS221 = -1.2177554330_wp
- EOS031 = -3.4866102017_wp
- EOS131 = 2.2229155620e-01_wp
- EOS041 = 5.9503008642e-01_wp
- EOS002 = 1.0375676547_wp
- EOS102 = -3.4249470629_wp
- EOS202 = 2.0542026429_wp
- EOS012 = 2.1836324814_wp
- EOS112 = -3.4453674320e-01_wp
- EOS022 = -1.2548163097_wp
- EOS003 = 1.8729078427e-02_wp
- EOS103 = -5.7238495240e-02_wp
- EOS013 = 3.8306136687e-01_wp
- !
- ALP000 = -2.5218796628e-01_wp
- ALP100 = 3.4119354654e-01_wp
- ALP200 = -2.2119589983e-01_wp
- ALP300 = 1.8082347094e-01_wp
- ALP400 = -3.6936026529e-02_wp
- ALP500 = -5.0091801383e-03_wp
- ALP010 = 1.2789915300_wp
- ALP110 = -1.2021756164_wp
- ALP210 = 8.4037519952e-01_wp
- ALP310 = -4.1905788542e-01_wp
- ALP410 = 9.8855300959e-02_wp
- ALP020 = -1.2634838399_wp
- ALP120 = 1.6112195176_wp
- ALP220 = -7.5817155402e-01_wp
- ALP320 = 4.7006963580e-02_wp
- ALP030 = 8.0812310102e-01_wp
- ALP130 = -1.0102374985_wp
- ALP230 = 4.8340368631e-01_wp
- ALP040 = -1.5098959754e-01_wp
- ALP140 = -1.4394226233e-02_wp
- ALP050 = 3.6780433255e-02_wp
- ALP001 = 3.9631611467e-01_wp
- ALP101 = 1.9159845880e-02_wp
- ALP201 = -1.0286156825e-01_wp
- ALP301 = 1.6738969362e-02_wp
- ALP011 = -4.9997430930e-01_wp
- ALP111 = 9.7335338937e-03_wp
- ALP211 = 6.0887771651e-02_wp
- ALP021 = 2.6149576513e-01_wp
- ALP121 = -1.6671866715e-02_wp
- ALP031 = -5.9503008642e-02_wp
- ALP002 = -5.4590812035e-02_wp
- ALP102 = 8.6134185799e-03_wp
- ALP012 = 6.2740815484e-02_wp
- ALP003 = -9.5765341718e-03_wp
- !
- BET000 = 2.1420623987_wp
- BET100 = -9.3752598635_wp
- BET200 = 1.9446303907e+01_wp
- BET300 = -1.8632235232e+01_wp
- BET400 = 8.9390837485_wp
- BET500 = -1.7142465871_wp
- BET010 = -1.7059677327e-01_wp
- BET110 = 2.2119589983e-01_wp
- BET210 = -2.7123520642e-01_wp
- BET310 = 7.3872053057e-02_wp
- BET410 = 1.2522950346e-02_wp
- BET020 = 3.0054390409e-01_wp
- BET120 = -4.2018759976e-01_wp
- BET220 = 3.1429341406e-01_wp
- BET320 = -9.8855300959e-02_wp
- BET030 = -2.6853658626e-01_wp
- BET130 = 2.5272385134e-01_wp
- BET230 = -2.3503481790e-02_wp
- BET040 = 1.2627968731e-01_wp
- BET140 = -1.2085092158e-01_wp
- BET050 = 1.4394226233e-03_wp
- BET001 = -2.2271304375e-01_wp
- BET101 = 5.5453416919e-01_wp
- BET201 = -6.2815936268e-01_wp
- BET301 = 2.0601115202e-01_wp
- BET011 = -9.5799229402e-03_wp
- BET111 = 1.0286156825e-01_wp
- BET211 = -2.5108454043e-02_wp
- BET021 = -2.4333834734e-03_wp
- BET121 = -3.0443885826e-02_wp
- BET031 = 2.7786444526e-03_wp
- BET002 = -4.2811838287e-02_wp
- BET102 = 5.1355066072e-02_wp
- BET012 = -4.3067092900e-03_wp
- BET003 = -7.1548119050e-04_wp
- !
- PEN000 = -5.3743005340_wp
- PEN100 = 8.9085217499_wp
- PEN200 = -1.1090683384e+01_wp
- PEN300 = 8.3754581690_wp
- PEN400 = -2.0601115202_wp
- PEN010 = 7.9263222935_wp
- PEN110 = 3.8319691761e-01_wp
- PEN210 = -2.0572313651_wp
- PEN310 = 3.3477938724e-01_wp
- PEN020 = -4.9997430930_wp
- PEN120 = 9.7335338937e-02_wp
- PEN220 = 6.0887771651e-01_wp
- PEN030 = 1.7433051009_wp
- PEN130 = -1.1114577810e-01_wp
- PEN040 = -2.9751504321e-01_wp
- PEN001 = -6.9171176978e-01_wp
- PEN101 = 2.2832980419_wp
- PEN201 = -1.3694684286_wp
- PEN011 = -1.4557549876_wp
- PEN111 = 2.2969116213e-01_wp
- PEN021 = 8.3654420645e-01_wp
- PEN002 = -1.4046808820e-02_wp
- PEN102 = 4.2928871430e-02_wp
- PEN012 = -2.8729602515e-01_wp
- !
- APE000 = -1.9815805734e-01_wp
- APE100 = -9.5799229402e-03_wp
- APE200 = 5.1430784127e-02_wp
- APE300 = -8.3694846809e-03_wp
- APE010 = 2.4998715465e-01_wp
- APE110 = -4.8667669469e-03_wp
- APE210 = -3.0443885826e-02_wp
- APE020 = -1.3074788257e-01_wp
- APE120 = 8.3359333577e-03_wp
- APE030 = 2.9751504321e-02_wp
- APE001 = 3.6393874690e-02_wp
- APE101 = -5.7422790533e-03_wp
- APE011 = -4.1827210323e-02_wp
- APE002 = 7.1824006288e-03_wp
- !
- BPE000 = 1.1135652187e-01_wp
- BPE100 = -2.7726708459e-01_wp
- BPE200 = 3.1407968134e-01_wp
- BPE300 = -1.0300557601e-01_wp
- BPE010 = 4.7899614701e-03_wp
- BPE110 = -5.1430784127e-02_wp
- BPE210 = 1.2554227021e-02_wp
- BPE020 = 1.2166917367e-03_wp
- BPE120 = 1.5221942913e-02_wp
- BPE030 = -1.3893222263e-03_wp
- BPE001 = 2.8541225524e-02_wp
- BPE101 = -3.4236710714e-02_wp
- BPE011 = 2.8711395266e-03_wp
- BPE002 = 5.3661089288e-04_wp
- !
- CASE( np_seos ) !== Simplified EOS ==!
-
- r1_S0 = 0.875_wp/35.16504_wp ! Used to convert CT in potential temperature when using bulk formulae (eos_pt_from_ct)
-
- IF(lwp) THEN
- WRITE(numout,*)
- WRITE(numout,*) ' ==>>> use of simplified eos: '
- WRITE(numout,*) ' rhd(dT=T-10,dS=S-35,Z) = [-a0*(1+lambda1/2*dT+mu1*Z)*dT '
- WRITE(numout,*) ' + b0*(1+lambda2/2*dT+mu2*Z)*dS - nu*dT*dS] / rho0'
- WRITE(numout,*) ' with the following coefficients :'
- WRITE(numout,*) ' thermal exp. coef. rn_a0 = ', rn_a0
- WRITE(numout,*) ' saline cont. coef. rn_b0 = ', rn_b0
- WRITE(numout,*) ' cabbeling coef. rn_lambda1 = ', rn_lambda1
- WRITE(numout,*) ' cabbeling coef. rn_lambda2 = ', rn_lambda2
- WRITE(numout,*) ' thermobar. coef. rn_mu1 = ', rn_mu1
- WRITE(numout,*) ' thermobar. coef. rn_mu2 = ', rn_mu2
- WRITE(numout,*) ' 2nd cabbel. coef. rn_nu = ', rn_nu
- WRITE(numout,*) ' Caution: rn_beta0=0 incompatible with ddm parameterization '
- ENDIF
- l_useCT = .TRUE. ! Use conservative temperature
- !
- CASE( np_leos ) !== Linear ISOMIP EOS ==!
-
- r1_S0 = 0.875_wp/35.16504_wp ! Used to convert CT in potential temperature when using bulk formulae (eos_pt_from_ct)
-
- IF(lwp) THEN
- WRITE(numout,*)
- WRITE(numout,*) ' use of linear ISOMIP eos: rhd(dT=T-(-1),dS=S-(34.2),Z) = '
- WRITE(numout,*) ' [ -a0*dT + b0*dS ]/rho0'
- WRITE(numout,*)
- WRITE(numout,*) ' thermal exp. coef. rn_a0 = ', rn_a0
- WRITE(numout,*) ' saline cont. coef. rn_b0 = ', rn_b0
- ENDIF
- l_useCT = .TRUE. ! Use conservative temperature
- !
- CASE DEFAULT !== ERROR in neos ==!
- WRITE(ctmp1,*) ' bad flag value for neos = ', neos, '. You should never see this error'
- CALL ctl_stop( ctmp1 )
- !
- END SELECT
- !
- rho0_rcp = rho0 * rcp
- r1_rho0 = 1._wp / rho0
- r1_rcp = 1._wp / rcp
- r1_rho0_rcp = 1._wp / rho0_rcp
- !
- IF(lwp) THEN
- IF( l_useCT ) THEN
- WRITE(numout,*)
- WRITE(numout,*) ' ==>>> model uses Conservative Temperature'
- WRITE(numout,*) ' Important: model must be initialized with CT and SA fields'
- ELSE
- WRITE(numout,*)
- WRITE(numout,*) ' ==>>> model does not use Conservative Temperature'
- ENDIF
- ENDIF
- !
- IF(lwp) WRITE(numout,*)
- IF(lwp) WRITE(numout,*) ' Associated physical constant'
- IF(lwp) WRITE(numout,*) ' volumic mass of reference rho0 = ', rho0 , ' kg/m^3'
- IF(lwp) WRITE(numout,*) ' 1. / rho0 r1_rho0 = ', r1_rho0, ' m^3/kg'
- IF(lwp) WRITE(numout,*) ' ocean specific heat rcp = ', rcp , ' J/Kelvin'
- IF(lwp) WRITE(numout,*) ' rho0 * rcp rho0_rcp = ', rho0_rcp
- IF(lwp) WRITE(numout,*) ' 1. / ( rho0 * rcp ) r1_rho0_rcp = ', r1_rho0_rcp
- !
- END SUBROUTINE eos_init
-
- !!======================================================================
-END MODULE eosbn2
diff --git a/tests/ISOMIP+/MY_SRC/isf_oce.F90 b/tests/ISOMIP+/MY_SRC/isf_oce.F90
index 3bf1b30da0cbf5af17e40e4d0de4d006dd4193d2..e013cddb91be27bd7cfdf09ba922aa41ce3af1e6 100644
--- a/tests/ISOMIP+/MY_SRC/isf_oce.F90
+++ b/tests/ISOMIP+/MY_SRC/isf_oce.F90
@@ -13,8 +13,7 @@ MODULE isf_oce
!! isf : define and allocate ice shelf variables
!!----------------------------------------------------------------------
- USE par_oce , ONLY: jpi, jpj, jpk
- USE in_out_manager, ONLY: wp, jpts ! I/O manager
+ USE par_oce
USE lib_mpp , ONLY: ctl_stop, mpp_sum ! MPP library
USE fldread ! read input fields
@@ -22,7 +21,7 @@ MODULE isf_oce
PRIVATE
- PUBLIC isf_alloc, isf_alloc_par, isf_alloc_cav, isf_alloc_cpl, isf_dealloc_cpl
+ PUBLIC isf_alloc, isf_alloc_par, isf_alloc_cav, isf_alloc_cpl
!
!-------------------------------------------------------
! 0 : namelist parameter
@@ -65,7 +64,7 @@ MODULE isf_oce
!
REAL(wp), PARAMETER, PUBLIC :: rLfusisf = 0.334e6_wp !: latent heat of fusion of ice shelf [J/kg]
REAL(wp), PARAMETER, PUBLIC :: rcpisf = 2000.0_wp !: specific heat of ice shelf [J/kg/K]
- REAL(wp), PARAMETER, PUBLIC :: rkappa = 0.0_wp !: ISOMIP+ no heat diffusivity through the ice-shelf [m2/s]
+ REAL(wp), PARAMETER, PUBLIC :: rkappa = 0._wp !: ISOMIP: no heat diffusivity through the ice-shelf [m2/s]
REAL(wp), PARAMETER, PUBLIC :: rhoisf = 920.0_wp !: volumic mass of ice shelf [kg/m3]
REAL(wp), PARAMETER, PUBLIC :: rtsurf = -20.0 !: surface temperature [C]
!
@@ -79,33 +78,35 @@ MODULE isf_oce
REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fwfisf_oasis
!
! 2.2 -------- ice shelf cavity melt namelist parameter -------------
- INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: mskisf_cav !:
- INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: misfkt_cav , misfkb_cav !:
- REAL(wp) , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: rhisf_tbl_cav, rfrac_tbl_cav !:
- REAL(wp) , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fwfisf_cav , fwfisf_cav_b !: before and now net fwf from the ice shelf [kg/m2/s]
- REAL(wp) , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: risf_cav_tsc , risf_cav_tsc_b !: before and now T & S isf contents [K.m/s & PSU.m/s]
- TYPE(FLD), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: sf_isfcav_fwf !:
+ INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: mskisf_cav !:
+ INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: misfkt_cav , misfkb_cav !: shallowest and deepest level of the ice shelf
+ REAL(wp) , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: rhisf_tbl_cav, rfrac_tbl_cav !: thickness and fraction of deepest cell affected by the ice shelf
+ REAL(wp) , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fwfisf_cav , fwfisf_cav_b !: before and now net fwf from the ice shelf [kg/m2/s]
+ REAL(wp) , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: risf_cav_tsc , risf_cav_tsc_b !: before and now T & S isf contents [K.m/s & PSU.m/s]
+ TYPE(FLD), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: sf_isfcav_fwf !:
!
- REAL(wp) , PUBLIC :: risf_lamb1, risf_lamb2, risf_lamb3 ! freezing point linearization coeficient
+ REAL(wp) , PUBLIC :: risf_lamb1, risf_lamb2, risf_lamb3 !: freezing point linearization coeficient
!
! 2.3 -------- ice shelf param. melt namelist parameter -------------
- INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: mskisf_par !:
- INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: misfkt_par , misfkb_par !:
- REAL(wp) , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: rhisf_tbl_par, rfrac_tbl_par !:
- REAL(wp) , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fwfisf_par , fwfisf_par_b !: before and now net fwf from the ice shelf [kg/m2/s]
- REAL(wp) , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: risf_par_tsc , risf_par_tsc_b !: before and now T & S isf contents [K.m/s & PSU.m/s]
- TYPE(FLD), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: sf_isfpar_fwf !:
+ INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: mskisf_par !:
+ INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: misfkt_par , misfkb_par !:
+ REAL(wp) , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: rhisf_tbl_par, rfrac_tbl_par !:
+ REAL(wp) , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fwfisf_par , fwfisf_par_b !: before and now net fwf from the ice shelf [kg/m2/s]
+ REAL(wp) , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: risf_par_tsc , risf_par_tsc_b !: before and now T & S isf contents [K.m/s & PSU.m/s]
+ TYPE(FLD), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: sf_isfpar_fwf !:
!
- REAL(wp) , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: rhisf0_tbl_par !: thickness of tbl (initial value) [m]
- REAL(wp) , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: risfLeff !:
+ REAL(wp) , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: rhisf0_tbl_par !: thickness of tbl (initial value) [m]
+ REAL(wp) , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: risfLeff !:
!
! 2.4 -------- coupling namelist parameter -------------
INTEGER , PUBLIC :: nstp_iscpl !:
REAL(wp), PUBLIC :: rdt_iscpl !:
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: risfcpl_ssh, risfcpl_cons_ssh, risfcpl_cons_ssh_b !:
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: risfcpl_vol, risfcpl_cons_vol, risfcpl_cons_vol_b !:
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: risfcpl_tsc, risfcpl_cons_tsc, risfcpl_cons_tsc_b !:
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: risfcpl_ssh, risfcpl_cons_ssh !:
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: risfcpl_vol, risfcpl_cons_vol !:
+ REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: risfcpl_tsc, risfcpl_cons_tsc !:
!
+ !! * Substitutions
+# include "do_loop_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
!! $Id: sbcisf.F90 10536 2019-01-16 19:21:09Z mathiot $
@@ -125,20 +126,12 @@ CONTAINS
INTEGER :: ierr, ialloc
!!----------------------------------------------------------------------
ierr = 0 ! set to zero if no array to be allocated
- !
- ALLOCATE(risfLeff(jpi,jpj), STAT=ialloc)
- ierr = ierr + ialloc
- !
- ALLOCATE(misfkt_par(jpi,jpj), misfkb_par(jpi,jpj), STAT=ialloc )
- ierr = ierr + ialloc
- !
- ALLOCATE( rfrac_tbl_par(jpi,jpj), STAT=ialloc)
- ierr = ierr + ialloc
- !
- ALLOCATE( rhisf_tbl_par(jpi,jpj), rhisf0_tbl_par(jpi,jpj), STAT=ialloc)
- ierr = ierr + ialloc
- !
- ALLOCATE( mskisf_par(jpi,jpj), STAT=ialloc)
+ ! -------------------- !
+ ! == REDUCED ARRAYS == !
+ ! -------------------- !
+ ALLOCATE( misfkt_par (A2D(0)) , misfkb_par (A2D(0)) , rfrac_tbl_par(A2D(0)) , &
+ & rhisf_tbl_par(A2D(0)) , rhisf0_tbl_par(A2D(0)) , &
+ & risfLeff (A2D(0)) , mskisf_par (A2D(0)) , STAT=ialloc )
ierr = ierr + ialloc
!
CALL mpp_sum ( 'isf', ierr )
@@ -159,14 +152,10 @@ CONTAINS
INTEGER :: ierr, ialloc
!!----------------------------------------------------------------------
ierr = 0 ! set to zero if no array to be allocated
- !
- ALLOCATE(misfkt_cav(jpi,jpj), misfkb_cav(jpi,jpj), STAT=ialloc )
- ierr = ierr + ialloc
- !
- ALLOCATE( rfrac_tbl_cav(jpi,jpj), STAT=ialloc)
- ierr = ierr + ialloc
- !
- ALLOCATE( rhisf_tbl_cav(jpi,jpj), STAT=ialloc)
+ ! -------------------- !
+ ! == REDUCED ARRAYS == !
+ ! -------------------- !
+ ALLOCATE( misfkt_cav(A2D(0)), misfkb_cav(A2D(0)), rfrac_tbl_cav(A2D(0)) , rhisf_tbl_cav(A2D(0)) , STAT=ialloc )
ierr = ierr + ialloc
!
CALL mpp_sum ( 'isf', ierr )
@@ -185,46 +174,25 @@ CONTAINS
INTEGER :: ierr, ialloc
!!----------------------------------------------------------------------
ierr = 0
- !
- ALLOCATE( risfcpl_ssh(jpi,jpj) , risfcpl_tsc(jpi,jpj,jpk,jpts) , risfcpl_vol(jpi,jpj,jpk) , STAT=ialloc )
+ ! ----------------- !
+ ! == FULL ARRAYS == !
+ ! ----------------- !
+ ALLOCATE( risfcpl_ssh (jpi,jpj) , risfcpl_vol (jpi,jpj,jpk) , &
+ & risfcpl_cons_ssh(jpi,jpj) , risfcpl_cons_vol(jpi,jpj,jpk) , STAT=ialloc )
+ ierr = ierr + ialloc
+ ! -------------------- !
+ ! == REDUCED ARRAYS == !
+ ! -------------------- !
+ ALLOCATE( risfcpl_tsc (A2D(0),jpk,jpts) , &
+ & risfcpl_cons_tsc(A2D(0),jpk,jpts) , STAT=ialloc )
ierr = ierr + ialloc
- !
- risfcpl_tsc(:,:,:,:) = 0._wp ; risfcpl_vol(:,:,:) = 0._wp ; risfcpl_ssh(:,:) = 0._wp
-
- IF ( ln_isfcpl_cons ) THEN
- ALLOCATE( risfcpl_cons_tsc(jpi,jpj,jpk,jpts) , risfcpl_cons_vol(jpi,jpj,jpk) , risfcpl_cons_ssh(jpi,jpj) , STAT=ialloc )
- ierr = ierr + ialloc
- !
- risfcpl_cons_tsc(:,:,:,:) = 0._wp ; risfcpl_cons_vol(:,:,:) = 0._wp ; risfcpl_cons_ssh(:,:) = 0._wp
- !
- END IF
!
CALL mpp_sum ( 'isf', ierr )
IF( ierr /= 0 ) CALL ctl_stop('STOP','isfcpl: failed to allocate arrays.')
!
END SUBROUTINE isf_alloc_cpl
-
- SUBROUTINE isf_dealloc_cpl()
- !!---------------------------------------------------------------------
- !! *** ROUTINE isf_dealloc_cpl ***
- !!
- !! ** Purpose : de-allocate useless public 3d array used for ice sheet coupling
- !!
- !!----------------------------------------------------------------------
- INTEGER :: ierr, ialloc
- !!----------------------------------------------------------------------
- ierr = 0
- !
- DEALLOCATE( risfcpl_ssh , risfcpl_tsc , risfcpl_vol , STAT=ialloc )
- ierr = ierr + ialloc
- !
- CALL mpp_sum ( 'isf', ierr )
- IF( ierr /= 0 ) CALL ctl_stop('STOP','isfcpl: failed to deallocate arrays.')
- !
- END SUBROUTINE isf_dealloc_cpl
-
-
+
SUBROUTINE isf_alloc()
!!---------------------------------------------------------------------
!! *** ROUTINE isf_alloc ***
@@ -237,34 +205,29 @@ CONTAINS
!
ierr = 0 ! set to zero if no array to be allocated
!
- ALLOCATE( fwfisf_par (jpi,jpj) , fwfisf_par_b(jpi,jpj) , &
- & fwfisf_cav (jpi,jpj) , fwfisf_cav_b(jpi,jpj) , &
- & fwfisf_oasis(jpi,jpj) , STAT=ialloc )
- ierr = ierr + ialloc
- !
- ALLOCATE( risf_par_tsc(jpi,jpj,jpts) , risf_par_tsc_b(jpi,jpj,jpts) , STAT=ialloc )
+ ! ----------------- !
+ ! == FULL ARRAYS == !
+ ! ----------------- !
+ ALLOCATE( fwfisf_par (jpi,jpj) , fwfisf_cav (jpi,jpj) , risfload(jpi,jpj) , &
+#if ! defined key_RK3
+ & fwfisf_par_b(jpi,jpj) , fwfisf_cav_b(jpi,jpj) , & ! MLF : need to allocate before arrays
+#endif
+ & STAT=ialloc )
ierr = ierr + ialloc
!
- ALLOCATE( risf_cav_tsc(jpi,jpj,jpts) , risf_cav_tsc_b(jpi,jpj,jpts) , STAT=ialloc )
- ierr = ierr + ialloc
- !
- ALLOCATE( risfload(jpi,jpj) , STAT=ialloc )
- ierr = ierr + ialloc
- !
- ALLOCATE( mskisf_cav(jpi,jpj) , STAT=ialloc )
+ ! -------------------- !
+ ! == REDUCED ARRAYS == !
+ ! -------------------- !
+ ALLOCATE( fwfisf_oasis(A2D(0)) , risf_par_tsc (A2D(0),jpts) , risf_cav_tsc (A2D(0),jpts) , mskisf_cav(A2D(0)) , &
+#if ! defined key_RK3
+ & risf_par_tsc_b(A2D(0),jpts) , risf_cav_tsc_b(A2D(0),jpts) , & ! MLF : need to allocate before arrays
+#endif
+ & STAT=ialloc )
ierr = ierr + ialloc
!
CALL mpp_sum ( 'isf', ierr )
IF( ierr /= 0 ) CALL ctl_stop( 'STOP', 'isf: failed to allocate arrays.' )
!
- ! initalisation of fwf and tsc array to 0
- risfload (:,:) = 0._wp
- fwfisf_oasis(:,:) = 0._wp
- fwfisf_par (:,:) = 0._wp ; fwfisf_par_b (:,:) = 0._wp
- fwfisf_cav (:,:) = 0._wp ; fwfisf_cav_b (:,:) = 0._wp
- risf_cav_tsc(:,:,:) = 0._wp ; risf_cav_tsc_b(:,:,:) = 0._wp
- risf_par_tsc(:,:,:) = 0._wp ; risf_par_tsc_b(:,:,:) = 0._wp
- !
END SUBROUTINE isf_alloc
!!======================================================================
diff --git a/tests/ISOMIP+/MY_SRC/isfcavgam.F90 b/tests/ISOMIP+/MY_SRC/isfcavgam.F90
deleted file mode 100644
index 6c0ac2a4d94db9b728d48603e65d1d2f31f548ef..0000000000000000000000000000000000000000
--- a/tests/ISOMIP+/MY_SRC/isfcavgam.F90
+++ /dev/null
@@ -1,253 +0,0 @@
-MODULE isfcavgam
- !!======================================================================
- !! *** MODULE isfgammats ***
- !! Ice shelf gamma module : compute exchange coeficient at the ice/ocean interface
- !!======================================================================
- !! History : 4.1 ! (P. Mathiot) original
- !!----------------------------------------------------------------------
-
- !!----------------------------------------------------------------------
- !! isfcav_gammats : compute exchange coeficient gamma
- !!----------------------------------------------------------------------
- USE isf_oce
- USE isfutils, ONLY: debug
- USE isftbl , ONLY: isf_tbl
-
- USE oce , ONLY: uu, vv ! ocean dynamics
- USE phycst , ONLY: grav, vkarmn ! physical constant
- USE eosbn2 , ONLY: eos_rab ! equation of state
- USE zdfdrg , ONLY: rCd0_top, r_ke0_top ! vertical physics: top/bottom drag coef.
- USE iom , ONLY: iom_put !
- USE lib_mpp , ONLY: ctl_stop
-
- USE dom_oce ! ocean space and time domain
- USE in_out_manager ! I/O manager
- !
- IMPLICIT NONE
- !
- PRIVATE
- !
- PUBLIC isfcav_gammats
-
- !! * Substitutions
-# include "do_loop_substitute.h90"
-# include "domzgr_substitute.h90"
- !!----------------------------------------------------------------------
- !! NEMO/OCE 4.0 , NEMO Consortium (2018)
- !! $Id: sbcisf.F90 10536 2019-01-16 19:21:09Z mathiot $
- !! Software governed by the CeCILL license (see ./LICENSE)
- !!----------------------------------------------------------------------
-CONTAINS
- !
- !!-----------------------------------------------------------------------------------------------------
- !! PUBLIC SUBROUTINES
- !!-----------------------------------------------------------------------------------------------------
- !
- SUBROUTINE isfcav_gammats( Kmm, pttbl, pstbl, pqoce, pqfwf, pRc, pgt, pgs )
- !!----------------------------------------------------------------------
- !! ** Purpose : compute the coefficient echange for heat and fwf flux
- !!
- !! ** Method : select the gamma formulation
- !! 3 method available (cst, vel and vel_stab)
- !!---------------------------------------------------------------------
- !!-------------------------- OUT -------------------------------------
- REAL(wp), DIMENSION(jpi,jpj), INTENT( out) :: pgt , pgs ! gamma t and gamma s
- !!-------------------------- IN -------------------------------------
- INTEGER :: Kmm ! ocean time level index
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pqoce, pqfwf ! isf heat and fwf
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pttbl, pstbl ! top boundary layer tracer
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pRc ! Richardson number
- !!---------------------------------------------------------------------
- REAL(wp), DIMENSION(jpi,jpj) :: zutbl, zvtbl ! top boundary layer velocity
- !!---------------------------------------------------------------------
- !
- !==========================================
- ! 1.: compute velocity in the tbl if needed
- !==========================================
- !
- SELECT CASE ( cn_gammablk )
- CASE ( 'spe' )
- ! gamma is constant (specified in namelist)
- ! nothing to do
- CASE ('vel', 'vel_stab')
- ! compute velocity in tbl
- CALL isf_tbl(Kmm, uu(:,:,:,Kmm) ,zutbl(:,:),'U', miku, rhisf_tbl_cav)
- CALL isf_tbl(Kmm, vv(:,:,:,Kmm) ,zvtbl(:,:),'V', mikv, rhisf_tbl_cav)
- !
- ! mask velocity in tbl with ice shelf mask
- zutbl(:,:) = zutbl(:,:) * mskisf_cav(:,:)
- zvtbl(:,:) = zvtbl(:,:) * mskisf_cav(:,:)
- !
- ! output
- CALL iom_put('utbl',zutbl(:,:))
- CALL iom_put('vtbl',zvtbl(:,:))
- CASE DEFAULT
- CALL ctl_stop('STOP','method to compute gamma (cn_gammablk) is unknown (should not see this)')
- END SELECT
- !
- !==========================================
- ! 2.: compute gamma
- !==========================================
- !
- SELECT CASE ( cn_gammablk )
- CASE ( 'spe' ) ! gamma is constant (specified in namelist)
- pgt(:,:) = rn_gammat0
- pgs(:,:) = rn_gammas0
- CASE ( 'vel' ) ! gamma is proportional to u*
- CALL gammats_vel ( zutbl, zvtbl, rCd0_top, r_ke0_top, pgt, pgs )
- CASE ( 'vel_stab' ) ! gamma depends of stability of boundary layer and u*
- CALL gammats_vel_stab (Kmm, pttbl, pstbl, zutbl, zvtbl, rCd0_top, r_ke0_top, pqoce, pqfwf, pRc, pgt, pgs )
- CASE DEFAULT
- CALL ctl_stop('STOP','method to compute gamma (cn_gammablk) is unknown (should not see this)')
- END SELECT
- !
- !==========================================
- ! 3.: output and debug
- !==========================================
- !
- CALL iom_put('isfgammat', pgt(:,:))
- CALL iom_put('isfgammas', pgs(:,:))
- !
- IF (ln_isfdebug) THEN
- CALL debug( 'isfcav_gam pgt:', pgt(:,:) )
- CALL debug( 'isfcav_gam pgs:', pgs(:,:) )
- END IF
- !
- END SUBROUTINE isfcav_gammats
- !
- !!-----------------------------------------------------------------------------------------------------
- !! PRIVATE SUBROUTINES
- !!-----------------------------------------------------------------------------------------------------
- !
- SUBROUTINE gammats_vel( putbl, pvtbl, pCd, pke2, & ! <<== in
- & pgt, pgs ) ! ==>> out gammats [m/s]
- !!----------------------------------------------------------------------
- !! ** Purpose : compute the coefficient echange coefficient
- !!
- !! ** Method : gamma is velocity dependent ( gt= gt0 * Ustar )
- !!
- !! ** Reference : Asay-Davis et al., Geosci. Model Dev., 9, 2471-2497, 2016
- !!---------------------------------------------------------------------
- !!-------------------------- OUT -------------------------------------
- REAL(wp), DIMENSION(jpi,jpj), INTENT( out) :: pgt, pgs ! gammat and gammas [m/s]
- !!-------------------------- IN -------------------------------------
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: putbl, pvtbl ! velocity in the losch top boundary layer
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pCd ! drag coefficient
- REAL(wp), INTENT(in ) :: pke2 ! background velocity
- !!---------------------------------------------------------------------
- INTEGER :: ji, jj ! loop index
- REAL(wp), DIMENSION(jpi,jpj) :: zustar
- !!---------------------------------------------------------------------
- !
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
- ! compute ustar (AD15 eq. 27)
- zustar(ji,jj) = SQRT( pCd(ji,jj) * ( putbl(ji,jj) * putbl(ji,jj) + pvtbl(ji,jj) * pvtbl(ji,jj) + pke2 ) ) * mskisf_cav(ji,jj)
- !
- ! Compute gammats
- pgt(ji,jj) = zustar(ji,jj) * rn_gammat0
- pgs(ji,jj) = zustar(ji,jj) * rn_gammas0
- END_2D
- !
- ! output ustar
- CALL iom_put('isfustar',zustar(:,:))
- !
- END SUBROUTINE gammats_vel
-
- SUBROUTINE gammats_vel_stab( Kmm, pttbl, pstbl, putbl, pvtbl, pCd, pke2, pqoce, pqfwf, pRc, & ! <<== in
- & pgt , pgs ) ! ==>> out gammats [m/s]
- !!----------------------------------------------------------------------
- !! ** Purpose : compute the coefficient echange coefficient
- !!
- !! ** Method : gamma is velocity dependent and stability dependent
- !!
- !! ** Reference : Holland and Jenkins, 1999, JPO, p1787-1800
- !!---------------------------------------------------------------------
- !!-------------------------- OUT -------------------------------------
- REAL(wp), DIMENSION(jpi,jpj), INTENT( out) :: pgt, pgs ! gammat and gammas
- !!-------------------------- IN -------------------------------------
- INTEGER :: Kmm ! ocean time level index
- REAL(wp), INTENT(in ) :: pke2 ! background velocity squared
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pqoce, pqfwf ! surface heat flux and fwf flux
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pCd ! drag coeficient
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: putbl, pvtbl ! velocity in the losch top boundary layer
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pttbl, pstbl ! tracer in the losch top boundary layer
- REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pRc ! Richardson number
- !!---------------------------------------------------------------------
- INTEGER :: ji, jj ! loop index
- INTEGER :: ikt ! local integer
- REAL(wp) :: zdku, zdkv ! U, V shear
- REAL(wp) :: zPr, zSc ! Prandtl and Scmidth number
- REAL(wp) :: zmob, zmols ! Monin Obukov length, coriolis factor at T point
- REAL(wp) :: zbuofdep, zhnu ! Bouyancy length scale, sublayer tickness
- REAL(wp) :: zhmax ! limitation of mol
- REAL(wp) :: zetastar ! stability parameter
- REAL(wp) :: zgmolet, zgmoles, zgturb ! contribution of modelecular sublayer and turbulence
- REAL(wp) :: zcoef ! temporary coef
- REAL(wp) :: zdep
- REAL(wp) :: zeps = 1.0e-20_wp
- REAL(wp), PARAMETER :: zxsiN = 0.052_wp ! dimensionless constant
- REAL(wp), PARAMETER :: znu = 1.95e-6_wp ! kinamatic viscosity of sea water (m2.s-1)
- REAL(wp), DIMENSION(2) :: zts, zab
- REAL(wp), DIMENSION(jpi,jpj) :: zustar ! friction velocity
- !!---------------------------------------------------------------------
- !
- ! compute Pr and Sc number (eq ??)
- zPr = 13.8_wp
- zSc = 2432.0_wp
- !
- ! compute gamma mole (eq ??)
- zgmolet = 12.5_wp * zPr ** (2.0/3.0) - 6.0_wp
- zgmoles = 12.5_wp * zSc ** (2.0/3.0) - 6.0_wp
- !
- ! compute gamma
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
-
- ikt = mikt(ji,jj)
-
- ! compute ustar
- zustar(ji,jj) = SQRT( pCd(ji,jj) * ( putbl(ji,jj) * putbl(ji,jj) + pvtbl(ji,jj) * pvtbl(ji,jj) + pke2 ) )
-
- IF( zustar(ji,jj) == 0._wp ) THEN ! only for kt = 1 I think
- pgt(ji,jj) = rn_gammat0
- pgs(ji,jj) = rn_gammas0
- ELSE
- ! compute bouyancy
- zts(jp_tem) = pttbl(ji,jj)
- zts(jp_sal) = pstbl(ji,jj)
- zdep = gdepw(ji,jj,ikt,Kmm)
- !
- CALL eos_rab( zts, zdep, zab, Kmm )
- !
- ! compute length scale (Eq ??)
- zbuofdep = grav * ( zab(jp_tem) * pqoce(ji,jj) - zab(jp_sal) * pqfwf(ji,jj) )
- !
- ! compute Monin Obukov Length
- ! Maximum boundary layer depth (Eq ??)
- zhmax = gdept(ji,jj,mbkt(ji,jj),Kmm) - gdepw(ji,jj,mikt(ji,jj),Kmm) -0.001_wp
- !
- ! Compute Monin obukhov length scale at the surface and Ekman depth: (Eq ??)
- zmob = zustar(ji,jj) ** 3 / (vkarmn * (zbuofdep + zeps))
- zmols = SIGN(1._wp, zmob) * MIN(ABS(zmob), zhmax) * tmask(ji,jj,ikt)
- !
- ! compute eta* (stability parameter) (Eq ??)
- zetastar = 1._wp / ( SQRT(1._wp + MAX( 0._wp, zxsiN * zustar(ji,jj) &
- & / MAX( 1.e-20, ABS(ff_t(ji,jj)) * zmols * pRc(ji,jj) ) )))
- !
- ! compute the sublayer thickness (Eq ??)
- zhnu = 5 * znu / MAX( 1.e-20, zustar(ji,jj) )
- !
- ! compute gamma turb (Eq ??)
- zgturb = 1._wp / vkarmn * LOG(zustar(ji,jj) * zxsiN * zetastar * zetastar / MAX( 1.e-10, ABS(ff_t(ji,jj)) * zhnu )) &
- & + 1._wp / ( 2 * zxsiN * zetastar ) - 1._wp / vkarmn
- !
- ! compute gammats
- pgt(ji,jj) = zustar(ji,jj) / (zgturb + zgmolet)
- pgs(ji,jj) = zustar(ji,jj) / (zgturb + zgmoles)
- END IF
- END_2D
- ! output ustar
- CALL iom_put('isfustar',zustar(:,:))
-
- END SUBROUTINE gammats_vel_stab
-
-END MODULE isfcavgam
diff --git a/tests/ISOMIP+/MY_SRC/isfstp.F90 b/tests/ISOMIP+/MY_SRC/isfstp.F90
deleted file mode 100644
index 2ab920844a3af8cf4afda88d68297208ce312358..0000000000000000000000000000000000000000
--- a/tests/ISOMIP+/MY_SRC/isfstp.F90
+++ /dev/null
@@ -1,322 +0,0 @@
-MODULE isfstp
- !!======================================================================
- !! *** MODULE isfstp ***
- !! Ice Shelves : compute iceshelf load, melt and heat flux
- !!======================================================================
- !! History : 3.2 ! 2011-02 (C.Harris ) Original code isf cav
- !! X.X ! 2006-02 (C. Wang ) Original code bg03
- !! 3.4 ! 2013-03 (P. Mathiot) Merging + parametrization
- !! 4.1 ! 2019-09 (P. Mathiot) Split param/explicit ice shelf and re-organisation
- !!----------------------------------------------------------------------
-
- !!----------------------------------------------------------------------
- !! isfstp : compute iceshelf melt and heat flux
- !!----------------------------------------------------------------------
- USE isf_oce ! isf variables
- USE isfload, ONLY: isf_load ! ice shelf load
- USE isftbl , ONLY: isf_tbl_lvl ! ice shelf boundary layer
- USE isfpar , ONLY: isf_par, isf_par_init ! ice shelf parametrisation
- USE isfcav , ONLY: isf_cav, isf_cav_init ! ice shelf cavity
- USE isfcpl , ONLY: isfcpl_rst_write, isfcpl_init ! isf variables
-
- USE dom_oce ! ocean space and time domain
- USE oce , ONLY: ssh ! sea surface height
- USE domvvl, ONLY: ln_vvl_zstar ! zstar logical
- USE zdfdrg, ONLY: r_Cdmin_top, r_ke0_top ! vertical physics: top/bottom drag coef.
- !
- USE lib_mpp, ONLY: ctl_stop, ctl_nam
- USE fldread, ONLY: FLD, FLD_N
- USE in_out_manager ! I/O manager
- USE timing
-
- IMPLICIT NONE
- PRIVATE
-
- PUBLIC isf_stp, isf_init, isf_nam ! routine called in sbcmod and divhor
-
- !! * Substitutions
-# include "domzgr_substitute.h90"
- !!----------------------------------------------------------------------
- !! NEMO/OCE 4.0 , NEMO Consortium (2018)
- !! $Id: isfstp.F90 15574 2021-12-03 19:32:50Z techene $
- !! Software governed by the CeCILL license (see ./LICENSE)
- !!----------------------------------------------------------------------
-CONTAINS
-
- SUBROUTINE isf_stp( kt, Kmm )
- !!---------------------------------------------------------------------
- !! *** ROUTINE isf_stp ***
- !!
- !! ** Purpose : compute total heat flux and total fwf due to ice shelf melt
- !!
- !! ** Method : For each case (parametrisation or explicity cavity) :
- !! - define the before fields
- !! - compute top boundary layer properties
- !! (in case of parametrisation, this is the
- !! depth range model array used to compute mean far fields properties)
- !! - compute fluxes
- !! - write restart variables
- !!----------------------------------------------------------------------
- INTEGER, INTENT(in) :: kt ! ocean time step
- INTEGER, INTENT(in) :: Kmm ! ocean time level index
- !
- INTEGER :: jk ! loop index
-#if defined key_qco
- REAL(wp), DIMENSION(jpi,jpj,jpk) :: ze3t ! 3D workspace
-#endif
- !!---------------------------------------------------------------------
- !
- IF( ln_timing ) CALL timing_start('isf')
- !
- !=======================================================================
- ! 1.: compute melt and associated heat fluxes in the ice shelf cavities
- !=======================================================================
- !
- IF ( ln_isfcav_mlt ) THEN
- !
- ! 1.1: before time step
- IF ( kt /= nit000 ) THEN
- risf_cav_tsc_b (:,:,:) = risf_cav_tsc (:,:,:)
- fwfisf_cav_b(:,:) = fwfisf_cav(:,:)
- END IF
- !
- ! 1.2: compute misfkb, rhisf_tbl, rfrac (deepest level, thickness, fraction of deepest cell affected by tbl)
- rhisf_tbl_cav(:,:) = rn_htbl * mskisf_cav(:,:)
-#if defined key_qco
- DO jk = 1, jpk
- ze3t(:,:,jk) = e3t(:,:,jk,Kmm)
- END DO
- CALL isf_tbl_lvl( ht(:,:), ze3t , misfkt_cav, misfkb_cav, rhisf_tbl_cav, rfrac_tbl_cav )
-#else
- CALL isf_tbl_lvl( ht(:,:), e3t(:,:,:,Kmm), misfkt_cav, misfkb_cav, rhisf_tbl_cav, rfrac_tbl_cav )
-#endif
- !
- ! 1.3: compute ice shelf melt
- CALL isf_cav( kt, Kmm, risf_cav_tsc, fwfisf_cav )
- !
- END IF
- !
- !=================================================================================
- ! 2.: compute melt and associated heat fluxes for not resolved ice shelf cavities
- !=================================================================================
- !
- IF ( ln_isfpar_mlt ) THEN
- !
- ! 2.1: before time step
- IF ( kt /= nit000 ) THEN
- risf_par_tsc_b(:,:,:) = risf_par_tsc(:,:,:)
- fwfisf_par_b (:,:) = fwfisf_par (:,:)
- END IF
- !
- ! 2.2: compute misfkb, rhisf_tbl, rfrac (deepest level, thickness, fraction of deepest cell affected by tbl)
- ! by simplicity, we assume the top level where param applied do not change with time (done in init part)
- rhisf_tbl_par(:,:) = rhisf0_tbl_par(:,:)
-#if defined key_qco
- DO jk = 1, jpk
- ze3t(:,:,jk) = e3t(:,:,jk,Kmm)
- END DO
- CALL isf_tbl_lvl( ht(:,:), ze3t , misfkt_par, misfkb_par, rhisf_tbl_par, rfrac_tbl_par )
-#else
- CALL isf_tbl_lvl( ht(:,:), e3t(:,:,:,Kmm), misfkt_par, misfkb_par, rhisf_tbl_par, rfrac_tbl_par )
-#endif
- !
- ! 2.3: compute ice shelf melt
- CALL isf_par( kt, Kmm, risf_par_tsc, fwfisf_par )
- !
- END IF
- !
- !==================================================================================
- ! 3.: output specific restart variable in case of coupling with an ice sheet model
- !==================================================================================
- !
- IF ( ln_isfcpl .AND. lrst_oce ) CALL isfcpl_rst_write(kt, Kmm)
- !
- IF( ln_timing ) CALL timing_stop('isf')
- !
- END SUBROUTINE isf_stp
-
-
- SUBROUTINE isf_init( Kbb, Kmm, Kaa )
- !!---------------------------------------------------------------------
- !! *** ROUTINE isfstp_init ***
- !!
- !! ** Purpose : Initialisation of the ice shelf public variables
- !!
- !! ** Method : Read the namisf namelist, check option compatibility and set derived parameters
- !!
- !! ** Action : - read namisf parameters
- !! - allocate memory
- !! - output print
- !! - ckeck option compatibility
- !! - call cav/param/isfcpl init routine
- !!----------------------------------------------------------------------
- INTEGER, INTENT(in) :: Kbb, Kmm, Kaa ! ocean time level indices
- !!----------------------------------------------------------------------
- !
- ! constrain: l_isfoasis need to be known
- !
- CALL isf_nam() ! Read namelist
- !
- CALL isf_alloc() ! Allocate public array
- !
- CALL isf_ctl() ! check option compatibility
- !
- IF( ln_isfcav ) CALL isf_load( Kmm, risfload ) ! compute ice shelf load
- !
- ! terminate routine now if no ice shelf melt formulation specify
- IF( ln_isf ) THEN
- !
- IF( ln_isfcav_mlt ) CALL isf_cav_init() ! initialisation melt in the cavity
- !
- IF( ln_isfpar_mlt ) CALL isf_par_init() ! initialisation parametrised melt
- !
- IF( ln_isfcpl ) CALL isfcpl_init( Kbb, Kmm, Kaa ) ! initialisation ice sheet coupling
- !
- END IF
-
- END SUBROUTINE isf_init
-
-
- SUBROUTINE isf_ctl()
- !!---------------------------------------------------------------------
- !! *** ROUTINE isf_ctl ***
- !!
- !! ** Purpose : output print and option compatibility check
- !!
- !!----------------------------------------------------------------------
- IF (lwp) THEN
- WRITE(numout,*)
- WRITE(numout,*) 'isf_init : ice shelf initialisation'
- WRITE(numout,*) '~~~~~~~~~~~~'
- WRITE(numout,*) ' Namelist namisf :'
- !
- WRITE(numout,*) ' ice shelf cavity (open or parametrised) ln_isf = ', ln_isf
- WRITE(numout,*)
- !
- IF ( ln_isf ) THEN
-#if key_qco
-# if ! defined key_isf
- CALL ctl_stop( 'STOP', 'isf_ctl: ice shelf requires both ln_isf=T AND key_isf activated' )
-# endif
-#endif
- WRITE(numout,*) ' Add debug print in isf module ln_isfdebug = ', ln_isfdebug
- WRITE(numout,*)
- WRITE(numout,*) ' melt inside the cavity ln_isfcav_mlt = ', ln_isfcav_mlt
- IF ( ln_isfcav_mlt) THEN
- WRITE(numout,*) ' melt formulation cn_isfcav_mlt= ', TRIM(cn_isfcav_mlt)
- WRITE(numout,*) ' thickness of the top boundary layer rn_htbl = ', rn_htbl
- WRITE(numout,*) ' gamma formulation cn_gammablk = ', TRIM(cn_gammablk)
- IF ( TRIM(cn_gammablk) .NE. 'spe' ) THEN
- WRITE(numout,*) ' gammat coefficient rn_gammat0 = ', rn_gammat0
- WRITE(numout,*) ' gammas coefficient rn_gammas0 = ', rn_gammas0
- WRITE(numout,*) ' top background ke used (from namdrg_top) rn_ke0 = ', r_ke0_top
- WRITE(numout,*) ' top drag coef. used (from namdrg_top) rn_Cd0 = ', r_Cdmin_top
- END IF
- END IF
- WRITE(numout,*) ''
- !
- WRITE(numout,*) ' ice shelf melt parametrisation ln_isfpar_mlt = ', ln_isfpar_mlt
- IF ( ln_isfpar_mlt ) THEN
- WRITE(numout,*) ' isf parametrisation formulation cn_isfpar_mlt = ', TRIM(cn_isfpar_mlt)
- END IF
- WRITE(numout,*) ''
- !
- WRITE(numout,*) ' Coupling to an ice sheet model ln_isfcpl = ', ln_isfcpl
- IF ( ln_isfcpl ) THEN
- WRITE(numout,*) ' conservation activated ln_isfcpl_cons = ', ln_isfcpl_cons
- WRITE(numout,*) ' number of call of the extrapolation loop = ', nn_drown
- ENDIF
- WRITE(numout,*) ''
- !
- ELSE
- !
- IF ( ln_isfcav ) THEN
- WRITE(numout,*) ''
- WRITE(numout,*) ' W A R N I N G: ice shelf cavities are open BUT no melt will be computed or read from file !'
- WRITE(numout,*) ''
- END IF
- !
- END IF
-
- IF (ln_isfcav) THEN
- WRITE(numout,*) ' Ice shelf load method cn_isfload = ', TRIM(cn_isfload)
- WRITE(numout,*) ' Temperature used to compute the ice shelf load = ', rn_isfload_T
- WRITE(numout,*) ' Salinity used to compute the ice shelf load = ', rn_isfload_S
- END IF
- WRITE(numout,*) ''
- FLUSH(numout)
-
- END IF
- !
-
- !---------------------------------------------------------------------------------------------------------------------
- ! sanity check ! issue ln_isfcav not yet known as well as l_isfoasis => move this call in isf_stp ?
- ! melt in the cavity without cavity
- IF ( ln_isfcav_mlt .AND. (.NOT. ln_isfcav) ) &
- & CALL ctl_stop('ice shelf melt in the cavity activated (ln_isfcav_mlt) but no cavity detected in domcfg (ln_isfcav), STOP' )
- !
- ! ice sheet coupling without cavity
- IF ( ln_isfcpl .AND. (.NOT. ln_isfcav) ) &
- & CALL ctl_stop('coupling with an ice sheet model detected (ln_isfcpl) but no cavity detected in domcfg (ln_isfcav), STOP' )
- !
- IF ( ln_isfcpl .AND. ln_isfcpl_cons .AND. ln_linssh ) &
- & CALL ctl_stop( 'The coupling between NEMO and an ice sheet model with the conservation option does not work with the linssh option' )
- !
- IF ( l_isfoasis .AND. .NOT. ln_isf ) CALL ctl_stop( ' OASIS send ice shelf fluxes to NEMO but NEMO does not have the isf module activated' )
- !
- IF ( l_isfoasis .AND. ln_isf ) THEN
- !
- CALL ctl_stop( 'namelist combination ln_cpl and ln_isf not tested' )
- !
- ! NEMO coupled to ATMO model with isf cavity need oasis method for melt computation
- IF ( ln_isfcav_mlt .AND. TRIM(cn_isfcav_mlt) /= 'oasis' ) CALL ctl_stop( 'cn_isfcav_mlt = oasis is the only option availble if fwf send by oasis' )
- IF ( ln_isfpar_mlt .AND. TRIM(cn_isfpar_mlt) /= 'oasis' ) CALL ctl_stop( 'cn_isfpar_mlt = oasis is the only option availble if fwf send by oasis' )
- !
- ! oasis melt computation not tested (coded but not tested)
- IF ( ln_isfcav_mlt .OR. ln_isfpar_mlt ) THEN
- IF ( TRIM(cn_isfcav_mlt) == 'oasis' ) CALL ctl_stop( 'cn_isfcav_mlt = oasis not tested' )
- IF ( TRIM(cn_isfpar_mlt) == 'oasis' ) CALL ctl_stop( 'cn_isfpar_mlt = oasis not tested' )
- END IF
- !
- ! oasis melt computation with cavity open and cavity parametrised (not coded)
- IF ( ln_isfcav_mlt .AND. ln_isfpar_mlt ) THEN
- IF ( TRIM(cn_isfpar_mlt) == 'oasis' .AND. TRIM(cn_isfcav_mlt) == 'oasis' ) CALL ctl_stop( 'cn_isfpar_mlt = oasis and cn_isfcav_mlt = oasis not coded' )
- END IF
- !
- ! compatibility ice shelf and vvl
- IF( .NOT. ln_vvl_zstar .AND. ln_isf ) CALL ctl_stop( 'Only vvl_zstar has been tested with ice shelf cavity' )
- !
- END IF
- END SUBROUTINE isf_ctl
-
-
- SUBROUTINE isf_nam
- !!---------------------------------------------------------------------
- !! *** ROUTINE isf_nam ***
- !!
- !! ** Purpose : Read ice shelf namelist cfg and ref
- !!
- !!----------------------------------------------------------------------
- INTEGER :: ios ! Local integer output status for namelist read
- !!----------------------------------------------------------------------
- NAMELIST/namisf/ ln_isf , &
- & cn_gammablk , rn_gammat0 , rn_gammas0 , rn_htbl, sn_isfcav_fwf, &
- & ln_isfcav_mlt , cn_isfcav_mlt , sn_isfcav_fwf , &
- & ln_isfpar_mlt , cn_isfpar_mlt , sn_isfpar_fwf , &
- & sn_isfpar_zmin, sn_isfpar_zmax, sn_isfpar_Leff, &
- & ln_isfcpl , nn_drown , ln_isfcpl_cons, ln_isfdebug, &
- & cn_isfload , rn_isfload_T , rn_isfload_S , cn_isfdir , &
- & rn_isfpar_bg03_gt0
- !!----------------------------------------------------------------------
- !
- READ ( numnam_ref, namisf, IOSTAT = ios, ERR = 901)
-901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namisf in reference namelist' )
- !
- READ ( numnam_cfg, namisf, IOSTAT = ios, ERR = 902 )
-902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namisf in configuration namelist' )
- IF(lwm) WRITE ( numond, namisf )
-
- END SUBROUTINE isf_nam
- !!
- !!======================================================================
-END MODULE isfstp
diff --git a/tests/ISOMIP+/MY_SRC/istate.F90 b/tests/ISOMIP+/MY_SRC/istate.F90
index 0f32b25a96257355ffeb7d9dd22781306a3a860a..b85ac87deb9c11ec8c3694ae42e0b03138552ca6 100644
--- a/tests/ISOMIP+/MY_SRC/istate.F90
+++ b/tests/ISOMIP+/MY_SRC/istate.F90
@@ -25,7 +25,6 @@ MODULE istate
USE daymod ! calendar
USE dtatsd ! data temperature and salinity (dta_tsd routine)
USE dtauvd ! data: U & V current (dta_uvd routine)
- USE domvvl ! varying vertical mesh
USE wet_dry ! wetting and drying (needed for wad_istate)
USE usrdef_istate ! User defined initial state
!
@@ -50,7 +49,7 @@ MODULE istate
# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
- !! $Id: istate.F90 15581 2021-12-07 13:08:22Z techene $
+ !! $Id: istate.F90 14991 2021-06-14 19:52:31Z techene $
!! Software governed by the CeCILL license (see ./LICENSE)
!!----------------------------------------------------------------------
CONTAINS
@@ -79,10 +78,12 @@ CONTAINS
CALL dta_tsd_init ! Initialisation of T & S input data
IF( ln_c1d) CALL dta_uvd_init ! Initialisation of U & V input data (c1d only)
- rhd (:,:,: ) = 0._wp ; rhop (:,:,: ) = 0._wp ! set one for all to 0 at level jpk
- rn2b (:,:,: ) = 0._wp ; rn2 (:,:,: ) = 0._wp ! set one for all to 0 at levels 1 and jpk
- ts (:,:,:,:,Kaa) = 0._wp ! set one for all to 0 at level jpk
- rab_b(:,:,:,: ) = 0._wp ; rab_n(:,:,:,:) = 0._wp ! set one for all to 0 at level jpk
+ ts (:,:,:,:,Kaa) = 0._wp ; rn2 (:,:,: ) = 0._wp ! set one for all to 0 at levels 1 and jpk
+ IF ( ALLOCATED( rhd ) ) THEN ! SWE, for example, will not have allocated these
+ rhd (:,:,: ) = 0._wp ; rhop (:,:,: ) = 0._wp ! set one for all to 0 at level jpk
+ rn2b (:,:,: ) = 0._wp ! set one for all to 0 at level jpk
+ rab_b(:,:,:,: ) = 0._wp ; rab_n(:,:,:,:) = 0._wp ! set one for all to 0 at level jpk
+ ENDIF
#if defined key_agrif
uu (:,:,: ,Kaa) = 0._wp ! used in agrif_oce_sponge at initialization
vv (:,:,: ,Kaa) = 0._wp ! used in agrif_oce_sponge at initialization
@@ -113,7 +114,7 @@ CONTAINS
! ! Initialization of ocean to zero
!
IF( ln_tsd_init ) THEN
- CALL dta_tsd( nit000, 'ini', ts(:,:,:,:,Kbb) ) ! read 3D T and S data at nit000
+ CALL dta_tsd( nit000, ts(:,:,:,:,Kbb), 'ini' ) ! read 3D T and S data at nit000
ENDIF
!
IF( ln_uvd_init .AND. ln_c1d ) THEN
@@ -141,20 +142,6 @@ CONTAINS
ENDIF
#endif
!
- ! Initialize "now" barotropic velocities:
- ! Do it whatever the free surface method, these arrays being used eventually
- !
-!!gm the use of umask & vmask is not necessary below as uu(:,:,:,Kmm), vv(:,:,:,Kmm), uu(:,:,:,Kbb), vv(:,:,:,Kbb) are always masked
-#if ! defined key_RK3
- uu_b(:,:,Kmm) = 0._wp ; vv_b(:,:,Kmm) = 0._wp
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 )
- uu_b(ji,jj,Kmm) = uu_b(ji,jj,Kmm) + e3u(ji,jj,jk,Kmm) * uu(ji,jj,jk,Kmm) * umask(ji,jj,jk)
- vv_b(ji,jj,Kmm) = vv_b(ji,jj,Kmm) + e3v(ji,jj,jk,Kmm) * vv(ji,jj,jk,Kmm) * vmask(ji,jj,jk)
- END_3D
- uu_b(:,:,Kmm) = uu_b(:,:,Kmm) * r1_hu(:,:,Kmm)
- vv_b(:,:,Kmm) = vv_b(:,:,Kmm) * r1_hv(:,:,Kmm)
-#endif
- !
#if defined key_RK3
IF( .NOT. ln_rstart ) THEN
#endif
@@ -171,6 +158,25 @@ CONTAINS
!
#if defined key_RK3
ENDIF
+#endif
+ !
+ ! Initialize "now" barotropic velocities:
+ ! Do it whatever the free surface method, these arrays being used eventually
+ !
+#if defined key_RK3
+ IF( .NOT. ln_rstart ) THEN
+ uu_b(:,:,Kmm) = uu_b(:,:,Kbb) ! Kmm value set to Kbb for initialisation in Agrif_Regrid in namo_gcm
+ vv_b(:,:,Kmm) = vv_b(:,:,Kbb)
+ ENDIF
+#else
+!!gm the use of umask & vmask is not necessary below as uu(:,:,:,Kmm), vv(:,:,:,Kmm), uu(:,:,:,Kbb), vv(:,:,:,Kbb) are always masked
+ uu_b(:,:,Kmm) = 0._wp ; vv_b(:,:,Kmm) = 0._wp
+ DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 )
+ uu_b(ji,jj,Kmm) = uu_b(ji,jj,Kmm) + e3u(ji,jj,jk,Kmm) * uu(ji,jj,jk,Kmm) * umask(ji,jj,jk)
+ vv_b(ji,jj,Kmm) = vv_b(ji,jj,Kmm) + e3v(ji,jj,jk,Kmm) * vv(ji,jj,jk,Kmm) * vmask(ji,jj,jk)
+ END_3D
+ uu_b(:,:,Kmm) = uu_b(:,:,Kmm) * r1_hu(:,:,Kmm)
+ vv_b(:,:,Kmm) = vv_b(:,:,Kmm) * r1_hv(:,:,Kmm)
#endif
!
END SUBROUTINE istate_init
diff --git a/tests/ISOMIP+/MY_SRC/sbcfwb.F90 b/tests/ISOMIP+/MY_SRC/sbcfwb.F90
deleted file mode 100644
index 0102aa12740247e044537fa78f63c58149b73414..0000000000000000000000000000000000000000
--- a/tests/ISOMIP+/MY_SRC/sbcfwb.F90
+++ /dev/null
@@ -1,277 +0,0 @@
-MODULE sbcfwb
- !!======================================================================
- !! *** MODULE sbcfwb ***
- !! Ocean fluxes : domain averaged freshwater budget
- !!======================================================================
- !! History : OPA ! 2001-02 (E. Durand) Original code
- !! NEMO 1.0 ! 2002-06 (G. Madec) F90: Free form and module
- !! 3.0 ! 2006-08 (G. Madec) Surface module
- !! 3.2 ! 2009-07 (C. Talandier) emp mean s spread over erp area
- !! 3.6 ! 2014-11 (P. Mathiot ) add ice shelf melting
- !!----------------------------------------------------------------------
-
- !!----------------------------------------------------------------------
- !! sbc_fwb : freshwater budget for global ocean configurations (free surface & forced mode)
- !!----------------------------------------------------------------------
- USE oce ! ocean dynamics and tracers
- USE dom_oce ! ocean space and time domain
- USE sbc_oce ! surface ocean boundary condition
- USE isf_oce , ONLY : fwfisf_cav, fwfisf_par, ln_isfcpl, ln_isfcpl_cons, risfcpl_cons_ssh ! ice shelf melting contribution
- USE sbc_ice , ONLY : snwice_mass, snwice_mass_b, snwice_fmass
- USE phycst ! physical constants
- USE sbcrnf ! ocean runoffs
- USE sbcssr ! Sea-Surface damping terms
- !
- USE in_out_manager ! I/O manager
- USE iom ! IOM
- USE lib_mpp ! distribued memory computing library
- USE timing ! Timing
- USE lbclnk ! ocean lateral boundary conditions
- USE lib_fortran !
-
- IMPLICIT NONE
- PRIVATE
-
- PUBLIC sbc_fwb ! routine called by step
-
- REAL(wp) :: rn_fwb0 ! initial freshwater adjustment flux [kg/m2/s] (nn_fwb = 2 only)
- REAL(wp) :: a_fwb ! annual domain averaged freshwater budget from the previous year
- REAL(wp) :: a_fwb_b ! annual domain averaged freshwater budget from the year before or at initial state
- REAL(wp) :: a_fwb_ini ! initial domain averaged freshwater budget
- REAL(wp) :: area ! global mean ocean surface (interior domain)
-
- !!----------------------------------------------------------------------
- !! NEMO/OCE 4.0 , NEMO Consortium (2018)
- !! $Id: sbcfwb.F90 11395 2019-08-02 14:19:00Z mathiot $
- !! Software governed by the CeCILL license (see ./LICENSE)
- !!----------------------------------------------------------------------
-CONTAINS
-
- SUBROUTINE sbc_fwb( kt, kn_fwb, kn_fsbc, Kmm )
- !!---------------------------------------------------------------------
- !! *** ROUTINE sbc_fwb ***
- !!
- !! ** Purpose : Control the mean sea surface drift
- !!
- !! ** Method : several ways depending on kn_fwb
- !! =0 no control
- !! =1 global mean of emp set to zero at each nn_fsbc time step
- !! =2 annual global mean corrected from previous year
- !! =3 global mean of emp set to zero at each nn_fsbc time step
- !! & spread out over erp area depending its sign
- !! Note: if sea ice is embedded it is taken into account when computing the budget
- !!----------------------------------------------------------------------
- INTEGER, INTENT( in ) :: kt ! ocean time-step index
- INTEGER, INTENT( in ) :: kn_fsbc !
- INTEGER, INTENT( in ) :: kn_fwb ! ocean time-step index
- INTEGER, INTENT( in ) :: Kmm ! ocean time level index
- !
- INTEGER :: ios, inum, ikty ! local integers
- REAL(wp) :: z_fwf, z_fwf_nsrf, zsum_fwf, zsum_erp ! local scalars
- REAL(wp) :: zsurf_neg, zsurf_pos, zsurf_tospread, zcoef ! - -
- REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: ztmsk_neg, ztmsk_pos, z_wgt ! 2D workspaces
- REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: ztmsk_tospread, zerp_cor ! - -
- REAL(wp) ,DIMENSION(1) :: z_fwfprv
- COMPLEX(dp),DIMENSION(1) :: y_fwfnow
- !
- NAMELIST/namsbc_fwb/rn_fwb0
- !!----------------------------------------------------------------------
- !
- IF( kt == nit000 ) THEN
- READ( numnam_ref, namsbc_fwb, IOSTAT = ios, ERR = 901 )
-901 IF( ios /= 0 ) CALL ctl_nam( ios, 'namsbc_fwb in reference namelist' )
- READ( numnam_cfg, namsbc_fwb, IOSTAT = ios, ERR = 902 )
-902 IF( ios > 0 ) CALL ctl_nam( ios, 'namsbc_fwb in configuration namelist' )
- IF(lwm) WRITE( numond, namsbc_fwb )
- IF(lwp) THEN
- WRITE(numout,*)
- WRITE(numout,*) 'sbc_fwb : FreshWater Budget correction'
- WRITE(numout,*) '~~~~~~~'
- IF( kn_fwb == 1 ) WRITE(numout,*) ' instantaneously set to zero'
- IF( kn_fwb == 4 ) WRITE(numout,*) ' instantaneously set to zero with heat and salt flux correction (ISOMIP+)'
- IF( kn_fwb == 3 ) WRITE(numout,*) ' fwf set to zero and spread out over erp area'
- IF( kn_fwb == 2 ) THEN
- WRITE(numout,*) ' adjusted from previous year budget'
- WRITE(numout,*)
- WRITE(numout,*) ' Namelist namsbc_fwb'
- WRITE(numout,*) ' Initial freshwater adjustment flux [kg/m2/s] = ', rn_fwb0
- END IF
- ENDIF
- !
- IF( kn_fwb == 3 .AND. nn_sssr /= 2 ) CALL ctl_stop( 'sbc_fwb: nn_fwb = 3 requires nn_sssr = 2, we stop ' )
- IF( kn_fwb == 3 .AND. ln_isfcav ) CALL ctl_stop( 'sbc_fwb: nn_fwb = 3 with ln_isfcav = .TRUE. not working, we stop ' )
- !
- area = glob_sum( 'sbcfwb', e1e2t(:,:) * tmask(:,:,1)) ! interior global domain surface
- ! isf cavities are excluded because it can feedback to the melting with generation of inhibition of plumes
- ! and in case of no melt, it can generate HSSW.
- !
-#if ! defined key_si3 && ! defined key_cice
- snwice_mass_b(:,:) = 0.e0 ! no sea-ice model is being used : no snow+ice mass
- snwice_mass (:,:) = 0.e0
- snwice_fmass (:,:) = 0.e0
-#endif
- !
- ENDIF
-
- SELECT CASE ( kn_fwb )
- !
- CASE ( 1 ) !== global mean fwf set to zero ==!
- !
- IF( MOD( kt-1, kn_fsbc ) == 0 ) THEN
- y_fwfnow(1) = local_sum( e1e2t(:,:) * ( emp(:,:) - rnf(:,:) - fwfisf_cav(:,:) - fwfisf_par(:,:) - snwice_fmass(:,:) ) )
- CALL mpp_delay_sum( 'sbcfwb', 'fwb', y_fwfnow(:), z_fwfprv(:), kt == nitend - nn_fsbc + 1 )
- z_fwfprv(1) = z_fwfprv(1) / area
- zcoef = z_fwfprv(1) * rcp
- emp(:,:) = emp(:,:) - z_fwfprv(1) * tmask(:,:,1)
- qns(:,:) = qns(:,:) + zcoef * sst_m(:,:) * tmask(:,:,1) ! account for change to the heat budget due to fw correction
- ! outputs
- IF( iom_use('hflx_fwb_cea') ) CALL iom_put( 'hflx_fwb_cea', zcoef * sst_m(:,:) * tmask(:,:,1) )
- IF( iom_use('vflx_fwb_cea') ) CALL iom_put( 'vflx_fwb_cea', z_fwfprv(1) * tmask(:,:,1) )
- ENDIF
- !
- CASE ( 2 ) !== fw adjustment based on fw budget at the end of the previous year ==!
- ! simulation is supposed to start 1st of January
- IF( kt == nit000 ) THEN ! initialisation
- ! ! set the fw adjustment (a_fwb)
- IF ( ln_rstart .AND. iom_varid( numror, 'a_fwb_b', ldstop = .FALSE. ) > 0 & ! as read from restart file
- & .AND. iom_varid( numror, 'a_fwb', ldstop = .FALSE. ) > 0 ) THEN
- IF(lwp) WRITE(numout,*) 'sbc_fwb : reading freshwater-budget from restart file'
- CALL iom_get( numror, 'a_fwb_b', a_fwb_b )
- CALL iom_get( numror, 'a_fwb' , a_fwb )
- !
- a_fwb_ini = a_fwb_b
- ELSE ! as specified in namelist
- IF(lwp) WRITE(numout,*) 'sbc_fwb : setting freshwater-budget from namelist rn_fwb0'
- a_fwb = rn_fwb0
- a_fwb_b = 0._wp ! used only the first year then it is replaced by a_fwb_ini
- !
- a_fwb_ini = glob_sum( 'sbcfwb', e1e2t(:,:) * ( ssh(:,:,Kmm) + snwice_mass(:,:) * r1_rho0 ) ) &
- & * rho0 / ( area * rday * REAL(nyear_len(1), wp) )
- END IF
- !
- IF(lwp) WRITE(numout,*)
- IF(lwp) WRITE(numout,*)'sbc_fwb : freshwater-budget at the end of previous year = ', a_fwb , 'kg/m2/s'
- IF(lwp) WRITE(numout,*)' freshwater-budget at initial state = ', a_fwb_ini, 'kg/m2/s'
- !
- ELSE
- ! at the end of year n:
- ikty = nyear_len(1) * 86400 / NINT(rn_Dt)
- IF( MOD( kt, ikty ) == 0 ) THEN ! Update a_fwb at the last time step of a year
- ! It should be the first time step of a year MOD(kt-1,ikty) but then the restart would be wrong
- ! Hence, we make a small error here but the code is restartable
- a_fwb_b = a_fwb_ini
- ! mean sea level taking into account ice+snow
- a_fwb = glob_sum( 'sbcfwb', e1e2t(:,:) * ( ssh(:,:,Kmm) + snwice_mass(:,:) * r1_rho0 ) )
- a_fwb = a_fwb * rho0 / ( area * rday * REAL(nyear_len(1), wp) ) ! convert in kg/m2/s
- ENDIF
- !
- ENDIF
- !
- IF( MOD( kt-1, kn_fsbc ) == 0 ) THEN ! correct the freshwater fluxes using previous year budget minus initial state
- zcoef = ( a_fwb - a_fwb_b )
- emp(:,:) = emp(:,:) + zcoef * tmask(:,:,1)
- qns(:,:) = qns(:,:) - zcoef * rcp * sst_m(:,:) * tmask(:,:,1) ! account for change to the heat budget due to fw correction
- ! outputs
- IF( iom_use('hflx_fwb_cea') ) CALL iom_put( 'hflx_fwb_cea', -zcoef * rcp * sst_m(:,:) * tmask(:,:,1) )
- IF( iom_use('vflx_fwb_cea') ) CALL iom_put( 'vflx_fwb_cea', -zcoef * tmask(:,:,1) )
- ENDIF
- ! Output restart information
- IF( lrst_oce ) THEN
- IF(lwp) WRITE(numout,*)
- IF(lwp) WRITE(numout,*) 'sbc_fwb : writing FW-budget adjustment to ocean restart file at it = ', kt
- IF(lwp) WRITE(numout,*) '~~~~'
- CALL iom_rstput( kt, nitrst, numrow, 'a_fwb_b', a_fwb_b )
- CALL iom_rstput( kt, nitrst, numrow, 'a_fwb', a_fwb )
- END IF
- !
- IF( kt == nitend .AND. lwp ) THEN
- WRITE(numout,*) 'sbc_fwb : freshwater-budget at the end of simulation (year now) = ', a_fwb , 'kg/m2/s'
- WRITE(numout,*) ' freshwater-budget at initial state = ', a_fwb_b, 'kg/m2/s'
- ENDIF
- !
- CASE ( 3 ) !== global fwf set to zero and spread out over erp area ==!
- !
- ALLOCATE( ztmsk_neg(jpi,jpj) , ztmsk_pos(jpi,jpj) , ztmsk_tospread(jpi,jpj) , z_wgt(jpi,jpj) , zerp_cor(jpi,jpj) )
- !
- IF( MOD( kt-1, kn_fsbc ) == 0 ) THEN
- ztmsk_pos(:,:) = tmask_i(:,:) ! Select <0 and >0 area of erp
- WHERE( erp < 0._wp ) ztmsk_pos = 0._wp
- ztmsk_neg(:,:) = tmask_i(:,:) - ztmsk_pos(:,:)
- ! ! fwf global mean (excluding ocean to ice/snow exchanges)
- z_fwf = glob_sum( 'sbcfwb', e1e2t(:,:) * ( emp(:,:) - rnf(:,:) - fwfisf_cav(:,:) - fwfisf_par(:,:) - snwice_fmass(:,:) ) ) / area
- !
- IF( z_fwf < 0._wp ) THEN ! spread out over >0 erp area to increase evaporation
- zsurf_pos = glob_sum( 'sbcfwb', e1e2t(:,:)*ztmsk_pos(:,:) )
- zsurf_tospread = zsurf_pos
- ztmsk_tospread(:,:) = ztmsk_pos(:,:)
- ELSE ! spread out over <0 erp area to increase precipitation
- zsurf_neg = glob_sum( 'sbcfwb', e1e2t(:,:)*ztmsk_neg(:,:) ) ! Area filled by <0 and >0 erp
- zsurf_tospread = zsurf_neg
- ztmsk_tospread(:,:) = ztmsk_neg(:,:)
- ENDIF
- !
- zsum_fwf = glob_sum( 'sbcfwb', e1e2t(:,:) * z_fwf ) ! fwf global mean over <0 or >0 erp area
-!!gm : zsum_fwf = z_fwf * area ??? it is right? I think so....
- z_fwf_nsrf = zsum_fwf / ( zsurf_tospread + rsmall )
- ! ! weight to respect erp field 2D structure
- zsum_erp = glob_sum( 'sbcfwb', ztmsk_tospread(:,:) * erp(:,:) * e1e2t(:,:) )
- z_wgt(:,:) = ztmsk_tospread(:,:) * erp(:,:) / ( zsum_erp + rsmall )
- ! ! final correction term to apply
- zerp_cor(:,:) = -1. * z_fwf_nsrf * zsurf_tospread * z_wgt(:,:)
- !
-!!gm ===>>>> lbc_lnk should be useless as all the computation is done over the whole domain !
- CALL lbc_lnk( 'sbcfwb', zerp_cor, 'T', 1.0_wp )
- !
- emp(:,:) = emp(:,:) + zerp_cor(:,:)
- qns(:,:) = qns(:,:) - zerp_cor(:,:) * rcp * sst_m(:,:) ! account for change to the heat budget due to fw correction
- erp(:,:) = erp(:,:) + zerp_cor(:,:)
- ! outputs
- IF( iom_use('hflx_fwb_cea') ) CALL iom_put( 'hflx_fwb_cea', -zerp_cor(:,:) * rcp * sst_m(:,:) )
- IF( iom_use('vflx_fwb_cea') ) CALL iom_put( 'vflx_fwb_cea', -zerp_cor(:,:) )
- !
- IF( lwp ) THEN ! control print
- IF( z_fwf < 0._wp ) THEN
- WRITE(numout,*)' z_fwf < 0'
- WRITE(numout,*)' SUM(erp+) = ', SUM( ztmsk_tospread(:,:)*erp(:,:)*e1e2t(:,:) )*1.e-9,' Sv'
- ELSE
- WRITE(numout,*)' z_fwf >= 0'
- WRITE(numout,*)' SUM(erp-) = ', SUM( ztmsk_tospread(:,:)*erp(:,:)*e1e2t(:,:) )*1.e-9,' Sv'
- ENDIF
- WRITE(numout,*)' SUM(empG) = ', SUM( z_fwf*e1e2t(:,:) )*1.e-9,' Sv'
- WRITE(numout,*)' z_fwf = ', z_fwf ,' Kg/m2/s'
- WRITE(numout,*)' z_fwf_nsrf = ', z_fwf_nsrf ,' Kg/m2/s'
- WRITE(numout,*)' MIN(zerp_cor) = ', MINVAL(zerp_cor)
- WRITE(numout,*)' MAX(zerp_cor) = ', MAXVAL(zerp_cor)
- ENDIF
- ENDIF
- DEALLOCATE( ztmsk_neg , ztmsk_pos , ztmsk_tospread , z_wgt , zerp_cor )
- !
- CASE ( 4 ) !== global mean fwf set to zero (ISOMIP case) ==!
- !
- IF( MOD( kt-1, kn_fsbc ) == 0 ) THEN
- z_fwf = glob_sum( 'sbcfwb', e1e2t(:,:) * ( emp(:,:) - rnf(:,:) - fwfisf_cav(:,:) - fwfisf_par(:,:) - snwice_fmass(:,:) ) )
- !
- ! correction for ice sheet coupling testing (ie remove the excess through the surface)
- ! test impact on the melt as conservation correction made in depth
- ! test conservation level as sbcfwb is conserving
- ! avoid the model to blow up for large ssh drop (isomip OCEAN3 with melt switch off and uniform T/S)
- IF (ln_isfcpl .AND. ln_isfcpl_cons) THEN
- z_fwf = z_fwf + glob_sum( 'sbcfwb', e1e2t(:,:) * risfcpl_cons_ssh(:,:) * rho0 )
- END IF
- !
- z_fwf = z_fwf / area
- zcoef = z_fwf * rcp
- emp(:,:) = emp(:,:) - z_fwf * tmask(:,:,1) ! (Eq. 34 AD2015)
- qns(:,:) = qns(:,:) + zcoef * sst_m(:,:) * tmask(:,:,1) ! (Eq. 35 AD2015) ! use sst_m to avoid generation of any bouyancy fluxes
- sfx(:,:) = sfx(:,:) + z_fwf * sss_m(:,:) * tmask(:,:,1) ! (Eq. 36 AD2015) ! use sss_m to avoid generation of any bouyancy fluxes
- ENDIF
- !
- CASE DEFAULT !== you should never be there ==!
- CALL ctl_stop( 'sbc_fwb : wrong nn_fwb value for the FreshWater Budget correction, choose either 1, 2 or 3' )
- !
- END SELECT
- !
- END SUBROUTINE sbc_fwb
-
- !!======================================================================
-END MODULE sbcfwb
diff --git a/tests/ISOMIP+/MY_SRC/tradmp.F90 b/tests/ISOMIP+/MY_SRC/tradmp.F90
deleted file mode 100644
index 05ed5b09aa1bbdcabb8968ffc18dfd51e11f2acb..0000000000000000000000000000000000000000
--- a/tests/ISOMIP+/MY_SRC/tradmp.F90
+++ /dev/null
@@ -1,243 +0,0 @@
-MODULE tradmp
- !!======================================================================
- !! *** MODULE tradmp ***
- !! Ocean physics: internal restoring trend on active tracers (T and S)
- !!======================================================================
- !! History : OPA ! 1991-03 (O. Marti, G. Madec) Original code
- !! ! 1992-06 (M. Imbard) doctor norme
- !! ! 1998-07 (M. Imbard, G. Madec) ORCA version
- !! 7.0 ! 2001-02 (M. Imbard) add distance to coast, Original code
- !! 8.1 ! 2001-02 (G. Madec, E. Durand) cleaning
- !! NEMO 1.0 ! 2002-08 (G. Madec, E. Durand) free form + modules
- !! 3.2 ! 2009-08 (G. Madec, C. Talandier) DOCTOR norm for namelist parameter
- !! 3.3 ! 2010-06 (C. Ethe, G. Madec) merge TRA-TRC
- !! 3.4 ! 2011-04 (G. Madec, C. Ethe) Merge of dtatem and dtasal + suppression of CPP keys
- !! 3.6 ! 2015-06 (T. Graham) read restoring coefficient in a file
- !! 3.7 ! 2015-10 (G. Madec) remove useless trends arrays
- !!----------------------------------------------------------------------
-
- !!----------------------------------------------------------------------
- !! tra_dmp_alloc : allocate tradmp arrays
- !! tra_dmp : update the tracer trend with the internal damping
- !! tra_dmp_init : initialization, namlist read, parameters control
- !!----------------------------------------------------------------------
- USE oce ! ocean: variables
- USE dom_oce ! ocean: domain variables
- USE trd_oce ! trends: ocean variables
- USE trdtra ! trends manager: tracers
- USE zdf_oce ! ocean: vertical physics
- USE phycst ! physical constants
- USE dtatsd ! data: temperature & salinity
- USE zdfmxl ! vertical physics: mixed layer depth
- !
- USE in_out_manager ! I/O manager
- USE iom ! XIOS
- USE lib_mpp ! MPP library
- USE prtctl ! Print control
- USE timing ! Timing
-
- IMPLICIT NONE
- PRIVATE
-
- PUBLIC tra_dmp ! called by step.F90
- PUBLIC tra_dmp_init ! called by nemogcm.F90
-
- ! !!* Namelist namtra_dmp : T & S newtonian damping *
- LOGICAL , PUBLIC :: ln_tradmp !: internal damping flag
- INTEGER , PUBLIC :: nn_zdmp !: = 0/1/2 flag for damping in the mixed layer
- CHARACTER(LEN=200) , PUBLIC :: cn_resto !: name of netcdf file containing restoration coefficient field
- !
- REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: resto !: restoring coeff. on T and S (s-1)
-
- !! * Substitutions
-# include "do_loop_substitute.h90"
-# include "domzgr_substitute.h90"
- !!----------------------------------------------------------------------
- !! NEMO/OCE 4.0 , NEMO Consortium (2018)
- !! $Id: tradmp.F90 15574 2021-12-03 19:32:50Z techene $
- !! Software governed by the CeCILL license (see ./LICENSE)
- !!----------------------------------------------------------------------
-CONTAINS
-
- INTEGER FUNCTION tra_dmp_alloc()
- !!----------------------------------------------------------------------
- !! *** FUNCTION tra_dmp_alloc ***
- !!----------------------------------------------------------------------
- ALLOCATE( resto(jpi,jpj,jpk), STAT= tra_dmp_alloc )
- !
- CALL mpp_sum ( 'tradmp', tra_dmp_alloc )
- IF( tra_dmp_alloc > 0 ) CALL ctl_warn('tra_dmp_alloc: allocation of arrays failed')
- !
- END FUNCTION tra_dmp_alloc
-
-
- SUBROUTINE tra_dmp( kt, Kbb, Kmm, pts, Krhs )
- !!----------------------------------------------------------------------
- !! *** ROUTINE tra_dmp ***
- !!
- !! ** Purpose : Compute the tracer trend due to a newtonian damping
- !! of the tracer field towards given data field and add it to the
- !! general tracer trends.
- !!
- !! ** Method : Newtonian damping towards t_dta and s_dta computed
- !! and add to the general tracer trends:
- !! ta = ta + resto * (t_dta - tb)
- !! sa = sa + resto * (s_dta - sb)
- !! The trend is computed either throughout the water column
- !! (nlmdmp=0) or in area of weak vertical mixing (nlmdmp=1) or
- !! below the well mixed layer (nlmdmp=2)
- !!
- !! ** Action : - tsa: tracer trends updated with the damping trend
- !!----------------------------------------------------------------------
- INTEGER, INTENT(in ) :: kt ! ocean time-step index
- INTEGER, INTENT(in ) :: Kbb, Kmm, Krhs ! time level indices
- REAL(wp), DIMENSION(jpi,jpj,jpk,jpts,jpt), INTENT(inout) :: pts ! active tracers and RHS of tracer equation
- !
- INTEGER :: ji, jj, jk, jn ! dummy loop indices
- REAL(wp), DIMENSION(A2D(nn_hls),jpk,jpts) :: zts_dta
- REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE :: zwrk
- REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: ztrdts
- !!----------------------------------------------------------------------
- !
- IF( ln_timing ) CALL timing_start('tra_dmp')
- !
- IF( l_trdtra .OR. iom_use('hflx_dmp_cea') .OR. iom_use('sflx_dmp_cea') ) THEN !* Save ta and sa trends
- ALLOCATE( ztrdts(A2D(nn_hls),jpk,jpts) )
- DO jn = 1, jpts
- DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpk )
- ztrdts(ji,jj,jk,jn) = pts(ji,jj,jk,jn,Krhs)
- END_3D
- END DO
- ENDIF
- ! !== input T-S data at kt ==!
- CALL dta_tsd( kt, 'dmp', zts_dta ) ! read and interpolates T-S data at kt
- !
- SELECT CASE ( nn_zdmp ) !== type of damping ==!
- !
- CASE( 0 ) !* newtonian damping throughout the water column *!
- DO jn = 1, jpts
- DO_3D( 0, 0, 0, 0, 1, jpkm1 )
- pts(ji,jj,jk,jn,Krhs) = pts(ji,jj,jk,jn,Krhs) &
- & + resto(ji,jj,jk) * ( zts_dta(ji,jj,jk,jn) - pts(ji,jj,jk,jn,Kbb) )
- END_3D
- END DO
- !
- CASE ( 1 ) !* no damping in the turbocline (avt > 5 cm2/s) *!
- DO_3D( 0, 0, 0, 0, 1, jpkm1 )
- IF( avt(ji,jj,jk) <= avt_c ) THEN
- pts(ji,jj,jk,jp_tem,Krhs) = pts(ji,jj,jk,jp_tem,Krhs) &
- & + resto(ji,jj,jk) * ( zts_dta(ji,jj,jk,jp_tem) - pts(ji,jj,jk,jp_tem,Kbb) )
- pts(ji,jj,jk,jp_sal,Krhs) = pts(ji,jj,jk,jp_sal,Krhs) &
- & + resto(ji,jj,jk) * ( zts_dta(ji,jj,jk,jp_sal) - pts(ji,jj,jk,jp_sal,Kbb) )
- ENDIF
- END_3D
- !
- CASE ( 2 ) !* no damping in the mixed layer *!
- DO_3D( 0, 0, 0, 0, 1, jpkm1 )
- IF( gdept(ji,jj,jk,Kmm) >= hmlp (ji,jj) ) THEN
- pts(ji,jj,jk,jp_tem,Krhs) = pts(ji,jj,jk,jp_tem,Krhs) &
- & + resto(ji,jj,jk) * ( zts_dta(ji,jj,jk,jp_tem) - pts(ji,jj,jk,jp_tem,Kbb) )
- pts(ji,jj,jk,jp_sal,Krhs) = pts(ji,jj,jk,jp_sal,Krhs) &
- & + resto(ji,jj,jk) * ( zts_dta(ji,jj,jk,jp_sal) - pts(ji,jj,jk,jp_sal,Kbb) )
- ENDIF
- END_3D
- !
- END SELECT
- !
- ! outputs (clem trunk)
- IF( iom_use('hflx_dmp_cea') .OR. iom_use('sflx_dmp_cea') ) THEN
- ALLOCATE( zwrk(A2D(nn_hls),jpk) ) ! Needed to handle expressions containing e3t when using key_qco or key_linssh
- zwrk(:,:,:) = 0._wp
-
- IF( iom_use('hflx_dmp_cea') ) THEN
- DO_3D( 0, 0, 0, 0, 1, jpk )
- zwrk(ji,jj,jk) = ( pts(ji,jj,jk,jp_tem,Krhs) - ztrdts(ji,jj,jk,jp_tem) ) * e3t(ji,jj,jk,Kmm)
- END_3D
- CALL iom_put('hflx_dmp_cea', SUM( zwrk(:,:,:), dim=3 ) * rcp * rho0 ) ! W/m2
- ENDIF
- IF( iom_use('sflx_dmp_cea') ) THEN
- DO_3D( 0, 0, 0, 0, 1, jpk )
- zwrk(ji,jj,jk) = ( pts(ji,jj,jk,jp_sal,Krhs) - ztrdts(ji,jj,jk,jp_sal) ) * e3t(ji,jj,jk,Kmm)
- END_3D
- CALL iom_put('sflx_dmp_cea', SUM( zwrk(:,:,:), dim=3 ) * rho0 ) ! g/m2/s
- ENDIF
-
- DEALLOCATE( zwrk )
- ENDIF
- !
- IF( l_trdtra ) THEN ! trend diagnostic
- ztrdts(:,:,:,:) = pts(:,:,:,:,Krhs) - ztrdts(:,:,:,:)
- CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_tem, jptra_dmp, ztrdts(:,:,:,jp_tem) )
- CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_sal, jptra_dmp, ztrdts(:,:,:,jp_sal) )
- DEALLOCATE( ztrdts )
- ENDIF
- ! ! Control print
- IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=pts(:,:,:,jp_tem,Krhs), clinfo1=' dmp - Ta: ', mask1=tmask, &
- & tab3d_2=pts(:,:,:,jp_sal,Krhs), clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' )
- !
- IF( ln_timing ) CALL timing_stop('tra_dmp')
- !
- END SUBROUTINE tra_dmp
-
-
- SUBROUTINE tra_dmp_init
- !!----------------------------------------------------------------------
- !! *** ROUTINE tra_dmp_init ***
- !!
- !! ** Purpose : Initialization for the newtonian damping
- !!
- !! ** Method : read the namtra_dmp namelist and check the parameters
- !!----------------------------------------------------------------------
- INTEGER :: ios, imask ! local integers
- !
- NAMELIST/namtra_dmp/ ln_tradmp, nn_zdmp, cn_resto
- !!----------------------------------------------------------------------
- !
- READ ( numnam_ref, namtra_dmp, IOSTAT = ios, ERR = 901)
-901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtra_dmp in reference namelist' )
- !
- READ ( numnam_cfg, namtra_dmp, IOSTAT = ios, ERR = 902 )
-902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namtra_dmp in configuration namelist' )
- IF(lwm) WRITE ( numond, namtra_dmp )
- !
- IF(lwp) THEN ! Namelist print
- WRITE(numout,*)
- WRITE(numout,*) 'tra_dmp_init : T and S newtonian relaxation'
- WRITE(numout,*) '~~~~~~~~~~~~'
- WRITE(numout,*) ' Namelist namtra_dmp : set relaxation parameters'
- WRITE(numout,*) ' Apply relaxation or not ln_tradmp = ', ln_tradmp
- WRITE(numout,*) ' mixed layer damping option nn_zdmp = ', nn_zdmp
- WRITE(numout,*) ' Damping file name cn_resto = ', cn_resto
- WRITE(numout,*)
- ENDIF
- !
- IF( ln_tradmp ) THEN
- ! ! Allocate arrays
- IF( tra_dmp_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'tra_dmp_init: unable to allocate arrays' )
- !
- SELECT CASE (nn_zdmp) ! Check values of nn_zdmp
- CASE ( 0 ) ; IF(lwp) WRITE(numout,*) ' tracer damping as specified by mask'
- CASE ( 1 ) ; IF(lwp) WRITE(numout,*) ' no tracer damping in the mixing layer (kz > 5 cm2/s)'
- CASE ( 2 ) ; IF(lwp) WRITE(numout,*) ' no tracer damping in the mixed layer'
- CASE DEFAULT
- CALL ctl_stop('tra_dmp_init : wrong value of nn_zdmp')
- END SELECT
- !
- !!TG: Initialisation of dtatsd - Would it be better to have dmpdta routine
- ! so can damp to something other than intitial conditions files?
- !!gm: In principle yes. Nevertheless, we can't anticipate demands that have never been formulated.
- IF( .NOT.ln_tsd_dmp ) THEN
- IF(lwp) WRITE(numout,*)
- IF(lwp) WRITE(numout, *) ' read T-S data not initialized, we force ln_tsd_dmp=T'
- CALL dta_tsd_init( ld_tradmp=ln_tradmp ) ! forces the initialisation of T-S data
- ENDIF
- ! ! Read in mask from file
- CALL iom_open ( cn_resto, imask)
- CALL iom_get ( imask, jpdom_auto, 'resto', resto )
- CALL iom_close( imask )
- ENDIF
- !
- END SUBROUTINE tra_dmp_init
-
- !!======================================================================
-END MODULE tradmp
diff --git a/tests/ISOMIP+/cpp_ISOMIP+.fcm b/tests/ISOMIP+/cpp_ISOMIP+.fcm
index abd9e036dfbded542269b75c6145c26ae10d87a4..e2ce910a38c73d422f72d322746ebcddc3c8ad42 100644
--- a/tests/ISOMIP+/cpp_ISOMIP+.fcm
+++ b/tests/ISOMIP+/cpp_ISOMIP+.fcm
@@ -1 +1 @@
- bld::tool::fppkeys key_xios key_qco key_isf
+ bld::tool::fppkeys key_xios key_qco key_vco_1d key_isf
diff --git a/tests/ISOMIP/EXPREF/ISOMIP_mlt.png b/tests/ISOMIP/EXPREF/ISOMIP_mlt.png
deleted file mode 100644
index 5435a75b3ce83568f9458cd51df0209e9b108b83..0000000000000000000000000000000000000000
Binary files a/tests/ISOMIP/EXPREF/ISOMIP_mlt.png and /dev/null differ
diff --git a/tests/ISOMIP/EXPREF/ISOMIP_moc.png b/tests/ISOMIP/EXPREF/ISOMIP_moc.png
deleted file mode 100644
index 5afdfbd5c5f22d809056dbdb913beef70447b0bd..0000000000000000000000000000000000000000
Binary files a/tests/ISOMIP/EXPREF/ISOMIP_moc.png and /dev/null differ
diff --git a/tests/ISOMIP/EXPREF/ISOMIP_psi.png b/tests/ISOMIP/EXPREF/ISOMIP_psi.png
deleted file mode 100644
index 5c46d728c3b6dc012e6ffb669f52687b2abb58cc..0000000000000000000000000000000000000000
Binary files a/tests/ISOMIP/EXPREF/ISOMIP_psi.png and /dev/null differ
diff --git a/tests/ISOMIP/EXPREF/README b/tests/ISOMIP/EXPREF/README
deleted file mode 100644
index 06dd530372dc213f637492d698ed8b044d1c6bc1..0000000000000000000000000000000000000000
--- a/tests/ISOMIP/EXPREF/README
+++ /dev/null
@@ -1,25 +0,0 @@
-# ISOMIP is a simple TEST_CASE to test the iceshelves in NEMO.
-# no input files are needed (all is prescribed in MY_SRC/usr_def routines
-# for a reference documentation on the ISOMIP test case, see experiement 1 on http://efdl.cims.nyu.edu/project_oisi/isomip/experiments/phase_I/idealized_numerical_models_5.pdf
-
-# default namelist is setup for a 30y run on 32 processors with the minimum output using XIOS in attached mode with single file output
-
-# How to build moc.nc and psi.nc
- - Download or clone the CDFTOOLS (see https://github.com/meom-group/CDFTOOLS)
- - Compile all the tools (or at least cdfpsi and cdfmoc) on your cluster (see https://github.com/meom-group/CDFTOOLS#using-cdftools)
- - if mesh_mask.nc is splitted, you need to rebuild them using the rebuild NEMO tools (see in NEMOGCM/TOOLS) or run 1 (or more) time step on a single processor (nn_itend variable in the namelist).
- - set the correct link: ln -s mesh_mask.nc mask.nc ; ln -s mesh_mask.nc mesh_hgr.nc ; ln -s mesh_mask.nc mesh_zgr.nc
- - run the cdftools :
- - cdfmoc ISOMIP_1m_00010101_00301231_grid_V.nc => moc.nc
- - cdfpsi ISOMIP_1m_00010101_00301231_grid_U.nc ISOMIP_1m_00010101_00301231_grid_V.nc => psi.nc
-
-# How to plt moc/psi and melt (python with netcdf and matplotlib library requiried):
- - psi.png => python2.7 plot_psi.py -f psi.nc -v sobarstf
- - moc.png => python2.7 plot_moc.py -f moc.nc -v zomsfglo
- - mlt.png => python2.7 plot_mlt.py -f ISOMIP_1m_00010101_00301231_grid_T.nc -v sowflisf
-by default the last time frame is plotted.
-
-# location the expected circulation and melt plot after 30y of run:
- - ISOMIP/EXP00/ISOMIP_psi.png
- - ISOMIP/EXP00/ISOMIP_moc.png
- - ISOMIP/EXP00/ISOMIP_mlt.png
diff --git a/tests/ISOMIP/EXPREF/axis_def_nemo.xml b/tests/ISOMIP/EXPREF/axis_def_nemo.xml
deleted file mode 120000
index 6117f35baf7f6be7afa129d96a3ec521cbbc06e6..0000000000000000000000000000000000000000
--- a/tests/ISOMIP/EXPREF/axis_def_nemo.xml
+++ /dev/null
@@ -1 +0,0 @@
-../../../cfgs/SHARED/axis_def_nemo.xml
\ No newline at end of file
diff --git a/tests/ISOMIP/EXPREF/context_nemo.xml b/tests/ISOMIP/EXPREF/context_nemo.xml
deleted file mode 100644
index c7598d4234111d516ea10527ec9e960f89f46bdd..0000000000000000000000000000000000000000
--- a/tests/ISOMIP/EXPREF/context_nemo.xml
+++ /dev/null
@@ -1,37 +0,0 @@
-<!--
- ==============================================================================================
- NEMO context
-==============================================================================================
--->
-<context id="nemo">
- <!-- $id$ -->
- <variable_definition>
- <!-- Year/Month/Day of time origin for NetCDF files; defaults to 1800-01-01 -->
- <variable id="ref_year" type="int"> 1900 </variable>
- <variable id="ref_month" type="int"> 01 </variable>
- <variable id="ref_day" type="int"> 01 </variable>
- <variable id="rho0" type="float" > 1026.0 </variable>
- <variable id="cpocean" type="float" > 3991.86795711963 </variable>
- <variable id="convSpsu" type="float" > 0.99530670233846 </variable>
- <variable id="rhoic" type="float" > 917.0 </variable>
- <variable id="rhosn" type="float" > 330.0 </variable>
- <variable id="missval" type="float" > 1.e20 </variable>
- </variable_definition>
-
-<!-- Fields definition -->
- <field_definition src="./field_def_nemo-oce.xml"/> <!-- NEMO ocean dynamics -->
-
-<!-- Files definition -->
- <file_definition src="./file_def_nemo-oce.xml"/> <!-- NEMO ocean dynamics -->
-
-<!-- Axis definition -->
- <axis_definition src="./axis_def_nemo.xml"/>
-
-<!-- Domain definition -->
- <domain_definition src="./domain_def_nemo.xml"/>
-
-<!-- Grids definition -->
- <grid_definition src="./grid_def_nemo.xml"/>
-
-
-</context>
diff --git a/tests/ISOMIP/EXPREF/domain_def_nemo.xml b/tests/ISOMIP/EXPREF/domain_def_nemo.xml
deleted file mode 120000
index f344125aff82ec6ef4f63f7516c3db1a6b3ea7e7..0000000000000000000000000000000000000000
--- a/tests/ISOMIP/EXPREF/domain_def_nemo.xml
+++ /dev/null
@@ -1 +0,0 @@
-../../../cfgs/SHARED/domain_def_nemo.xml
\ No newline at end of file
diff --git a/tests/ISOMIP/EXPREF/field_def_nemo-oce.xml b/tests/ISOMIP/EXPREF/field_def_nemo-oce.xml
deleted file mode 120000
index ff97068135ca98cec33e26d72ad41a072faf64b8..0000000000000000000000000000000000000000
--- a/tests/ISOMIP/EXPREF/field_def_nemo-oce.xml
+++ /dev/null
@@ -1 +0,0 @@
-../../../cfgs/SHARED/field_def_nemo-oce.xml
\ No newline at end of file
diff --git a/tests/ISOMIP/EXPREF/file_def_nemo-oce.xml b/tests/ISOMIP/EXPREF/file_def_nemo-oce.xml
deleted file mode 100644
index 77300b426d4928837c16150ea0c7c0f6c971adbc..0000000000000000000000000000000000000000
--- a/tests/ISOMIP/EXPREF/file_def_nemo-oce.xml
+++ /dev/null
@@ -1,50 +0,0 @@
-<?xml version="1.0"?>
- <!--
-============================================================================================================
-= output files definition =
-= Define your own files =
-= put the variables you want... =
-============================================================================================================
- -->
-
- <file_definition type="one_file" name="@expname@_@freq@_@startdate@_@enddate@" sync_freq="1d" min_digits="4">
-
- <file_group id="1ts" output_freq="1ts" output_level="10" enabled=".TRUE."/> <!-- 1 time step files -->
- <file_group id="1h" output_freq="1h" output_level="10" enabled=".TRUE."/> <!-- 1h files -->
- <file_group id="2h" output_freq="2h" output_level="10" enabled=".TRUE."/> <!-- 2h files -->
- <file_group id="3h" output_freq="3h" output_level="10" enabled=".TRUE."/> <!-- 3h files -->
- <file_group id="4h" output_freq="4h" output_level="10" enabled=".TRUE."/> <!-- 4h files -->
- <file_group id="6h" output_freq="6h" output_level="10" enabled=".TRUE."/> <!-- 6h files -->
-
- <file_group id="1d" output_freq="1d" output_level="10" enabled=".TRUE."/> <!-- 1d files -->
- <file_group id="3d" output_freq="3d" output_level="10" enabled=".TRUE."/> <!-- 3d files -->
- <file_group id="5d" output_freq="5d" output_level="10" enabled=".TRUE."> <!-- 5d files -->
-
- <file_group id="1m" output_freq="1mo" output_level="10" enabled=".TRUE."/> <!-- real monthly files -->
- <file id="file1" output_freq="1mo" name_suffix="_grid_T" description="ocean T grid variables" >
- <field field_ref="toce" name="votemper" />
- <field field_ref="soce" name="vosaline" />
- <field field_ref="ssh" name="sossheig" />
- <!-- variable for ice shelf -->
- <field field_ref="fwfisf_cav" name="sowflisf" />
- <field field_ref="isfgammat" name="sogammat" />
- <field field_ref="isfgammas" name="sogammas" />
- </file>
- <file id="file2" output_freq="1mo" name_suffix="_grid_U" description="ocean U grid variables" >
- <field field_ref="uoce" name="vozocrtx" />
- </file>
- <file id="file3" output_freq="1mo" name_suffix="_grid_V" description="ocean V grid variables" >
- <field field_ref="voce" name="vomecrty" />
- </file>
- </file_group>
- <file_group id="2m" output_freq="2mo" output_level="10" enabled=".TRUE."/> <!-- real 2m files -->
- <file_group id="3m" output_freq="3mo" output_level="10" enabled=".TRUE."/> <!-- real 3m files -->
- <file_group id="4m" output_freq="4mo" output_level="10" enabled=".TRUE."/> <!-- real 4m files -->
- <file_group id="6m" output_freq="6mo" output_level="10" enabled=".TRUE."/> <!-- real 6m files -->
- <file_group id="1y" output_freq="1y" output_level="10" enabled=".TRUE."/> <!-- real yearly files -->
- <file_group id="2y" output_freq="2y" output_level="10" enabled=".TRUE."/> <!-- real 2y files -->
- <file_group id="5y" output_freq="5y" output_level="10" enabled=".TRUE."/> <!-- real 5y files -->
- <file_group id="10y" output_freq="10y" output_level="10" enabled=".TRUE."/> <!-- real 10y files -->
-
- </file_definition>
-
diff --git a/tests/ISOMIP/EXPREF/grid_def_nemo.xml b/tests/ISOMIP/EXPREF/grid_def_nemo.xml
deleted file mode 120000
index 1be74edf6d85af6063315421809ef3994216004f..0000000000000000000000000000000000000000
--- a/tests/ISOMIP/EXPREF/grid_def_nemo.xml
+++ /dev/null
@@ -1 +0,0 @@
-../../../cfgs/SHARED/grid_def_nemo.xml
\ No newline at end of file
diff --git a/tests/ISOMIP/EXPREF/iodef.xml b/tests/ISOMIP/EXPREF/iodef.xml
deleted file mode 100644
index d4be5c1bd4104bfd3e1a69db33d6647804565cf9..0000000000000000000000000000000000000000
--- a/tests/ISOMIP/EXPREF/iodef.xml
+++ /dev/null
@@ -1,26 +0,0 @@
-<?xml version="1.0"?>
-<simulation>
-
-<!-- ============================================================================================ -->
-<!-- XIOS context -->
-<!-- ============================================================================================ -->
-
- <context id="xios" >
-
- <variable_definition>
-
- <variable id="info_level" type="int">10</variable>
- <variable id="using_server" type="bool">false</variable>
- <variable id="using_oasis" type="bool">false</variable>
- <variable id="oasis_codes_id" type="string" >oceanx</variable>
-
- </variable_definition>
- </context>
-
-<!-- ============================================================================================ -->
-<!-- NEMO CONTEXT add and suppress the components you need -->
-<!-- ============================================================================================ -->
-
- <context id="nemo" src="./context_nemo.xml"/> <!-- NEMO -->
-
-</simulation>
diff --git a/tests/ISOMIP/EXPREF/namelist_cfg b/tests/ISOMIP/EXPREF/namelist_cfg
deleted file mode 100644
index 2358fa203d75ff6a3ed552933d4a5972aa99273e..0000000000000000000000000000000000000000
--- a/tests/ISOMIP/EXPREF/namelist_cfg
+++ /dev/null
@@ -1,510 +0,0 @@
-!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
-!! NEMO/OCE Configuration namelist : overwrite default values defined in SHARED/namelist_ref
-!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
-!! ISOMIP configuration !!
-!!======================================================================
-!! *** Domain & Run management namelists *** !!
-!! !!
-!! namrun parameters of the run
-!! namdom space and time domain
-!! namcfg parameters of the configuration (default: user defined GYRE)
-!! namwad Wetting and drying (default: OFF)
-!! namtsd data: temperature & salinity (default: OFF)
-!! namcrs coarsened grid (for outputs and/or TOP) (ln_crs =T)
-!! namc1d 1D configuration options (ln_c1d =T)
-!! namc1d_dyndmp 1D newtonian damping applied on currents (ln_c1d =T)
-!! namc1d_uvd 1D data (currents) (ln_c1d =T)
-!!======================================================================
-!
-!-----------------------------------------------------------------------
-&namrun ! parameters of the run
-!-----------------------------------------------------------------------
- cn_exp = "ISOMIP" ! experience name
- nn_it000 = 1 ! first time step
- nn_itend = 525600 ! last time step
- nn_leapy = 0 ! Leap year calendar (1) or not (0)
- ln_clobber = .true. ! clobber (overwrite) an existing file
- nn_istate = 0 ! output the initial state (1) or not (0)
- nn_stock = 99999999 ! frequency of creation of a restart file (modulo referenced to 1)
- nn_write = 48 ! frequency of write in the output file (modulo referenced to nn_it000)
- nn_istate = 0 ! output the initial state (1) or not (0)
-/
-!-----------------------------------------------------------------------
-&namusr_def ! ISOMIP user defined namelist
-!-----------------------------------------------------------------------
- ln_zps = .true. ! z-partial-step coordinate
- ln_zco = .false. ! z-full-step coordinate
- ln_sco = .false. ! s-coordinate
- rn_e1deg = 0.3 ! zonal grid-spacing (degrees)
- rn_e2deg = 0.1 ! meridional grid-spacing (degrees)
- rn_e3 = 30. ! vertical resolution
-/
-!-----------------------------------------------------------------------
-&namdom ! time and space domain
-!-----------------------------------------------------------------------
- ln_linssh = .false. ! =T linear free surface ==>> model level are fixed in time
- rn_Dt = 1800. ! time step for the dynamics (and tracer if nn_acc=0)
-/
-!-----------------------------------------------------------------------
-&namcfg ! parameters of the configuration (default: use namusr_def in namelist_cfg)
-!-----------------------------------------------------------------------
-/
-!-----------------------------------------------------------------------
-&namtile ! parameters of the tiling
-!-----------------------------------------------------------------------
-/
-!-----------------------------------------------------------------------
-&namtsd ! Temperature & Salinity Data (init/dmp) (default: OFF)
-!-----------------------------------------------------------------------
-
-/
-!-----------------------------------------------------------------------
-&namwad ! Wetting and Drying (WaD) (default: OFF)
-!-----------------------------------------------------------------------
-/
-!-----------------------------------------------------------------------
-&namcrs ! coarsened grid (for outputs and/or TOP) (ln_crs =T)
-!-----------------------------------------------------------------------
-/
-!-----------------------------------------------------------------------
-&namc1d ! 1D configuration options (ln_c1d =T default: PAPA station)
-!-----------------------------------------------------------------------
-/
-!-----------------------------------------------------------------------
-&namc1d_dyndmp ! U & V newtonian damping (ln_c1d =T default: OFF)
-!-----------------------------------------------------------------------
-/
-!-----------------------------------------------------------------------
-&namc1d_uvd ! data: U & V currents (ln_c1d =T default: OFF)
-!-----------------------------------------------------------------------
-
-/
-
-!!======================================================================
-!! *** Surface Boundary Condition namelists *** !!
-!! !!
-!! namsbc surface boundary condition manager (default: NO selection)
-!! namsbc_flx flux formulation (ln_flx =T)
-!! namsbc_blk Bulk formulae formulation (ln_blk =T)
-!! namsbc_cpl CouPLed formulation ("key_oasis3" )
-!! namsbc_sas Stand-Alone Surface module (SAS_SRC only)
-!! namsbc_iif Ice-IF: use observed ice cover (nn_ice = 1 )
-!! namtra_qsr penetrative solar radiation (ln_traqsr =T)
-!! namsbc_ssr sea surface restoring term (for T and/or S) (ln_ssr =T)
-!! namsbc_rnf river runoffs (ln_rnf =T)
-!! namsbc_apr Atmospheric Pressure (ln_apr_dyn =T)
-!! namsbc_wave external fields from wave model (ln_wave =T)
-!! namberg iceberg floats (ln_icebergs=T)
-!!======================================================================
-!
-!-----------------------------------------------------------------------
-&namsbc ! Surface Boundary Condition manager (default: NO selection)
-!-----------------------------------------------------------------------
- nn_fsbc = 1 ! frequency of SBC module call
- ! ! (control sea-ice & iceberg model call)
- ln_usr = .true. ! user defined formulation (T => check usrdef_sbc)
-/
-!-----------------------------------------------------------------------
-&namsbc_flx ! surface boundary condition : flux formulation (ln_flx =T)
-!-----------------------------------------------------------------------
-/
-!-----------------------------------------------------------------------
-&namsbc_blk ! namsbc_blk generic Bulk formula (ln_blk =T)
-!-----------------------------------------------------------------------
-
-/
-!-----------------------------------------------------------------------
-&namsbc_cpl ! coupled ocean/atmosphere model ("key_oasis3")
-!-----------------------------------------------------------------------
-
-/
-!-----------------------------------------------------------------------
-&namsbc_sas ! Stand-Alone Surface module: ocean data (SAS_SRC only)
-!-----------------------------------------------------------------------
-
-/
-!-----------------------------------------------------------------------
-&namsbc_iif ! Ice-IF : use observed ice cover (nn_ice = 1)
-!-----------------------------------------------------------------------
-/
-!-----------------------------------------------------------------------
-&namtra_qsr ! penetrative solar radiation (ln_traqsr =T)
-!-----------------------------------------------------------------------
-
-/
-!-----------------------------------------------------------------------
-&namsbc_ssr ! surface boundary condition : sea surface restoring (ln_ssr =T)
-!-----------------------------------------------------------------------
-
-/
-!-----------------------------------------------------------------------
-&namsbc_rnf ! runoffs (ln_rnf =T)
-!-----------------------------------------------------------------------
-
-/
-!-----------------------------------------------------------------------
-&namsbc_apr ! Atmospheric pressure used as ocean forcing (ln_apr_dyn =T)
-!-----------------------------------------------------------------------
-
-/
-!-----------------------------------------------------------------------
-&namisf ! Top boundary layer (ISF) (default: OFF)
-!-----------------------------------------------------------------------
- !
- ! ---------------- ice shelf load -------------------------------
- !
- !
- ! ---------------- ice shelf melt formulation -------------------------------
- !
- ln_isf = .true. ! activate ice shelf module
- cn_isfdir = './' ! directory for all ice shelf input file
- !
- ! ---------------- cavities opened -------------------------------
- !
- ln_isfcav_mlt = .true. ! ice shelf melting into the cavity (need ln_isfcav = .true. in domain_cfg.nc)
- cn_isfcav_mlt = '2eq' ! ice shelf melting formulation (spe/2eq/3eq/oasis)
- ! ! spe = fwfisf is read from a forcing field
- ! ! 2eq = ISOMIP like: 2 equations formulation (Hunter et al., 2006)
- ! ! 3eq = ISOMIP+ like: 3 equations formulation (Asay-Davis et al., 2015)
- ! ! oasis = fwfisf is given by oasis and pattern by file sn_isfcav_fwf
- ! ! cn_isfcav_mlt = 2eq or 3eq cases:
- cn_gammablk = 'spe' ! scheme to compute gammat/s (spe,ad15,hj99)
- ! ! ad15 = velocity dependend Gamma (u* * gammat/s) (Jenkins et al. 2010)
- ! ! hj99 = velocity and stability dependent Gamma (Holland et al. 1999)
- rn_gammat0 = 1.e-4 ! gammat coefficient used in blk formula
- rn_gammas0 = 1.e-4 ! gammas coefficient used in blk formula
- !
- rn_htbl = 30. ! thickness of the top boundary layer (Losh et al. 2008)
- ! ! 0 => thickness of the tbl = thickness of the first wet cell
- !
-/
-!-----------------------------------------------------------------------
-&namsbc_wave ! External fields from wave model (ln_wave=T)
-!-----------------------------------------------------------------------
-/
-!-----------------------------------------------------------------------
-&namberg ! iceberg parameters (default: OFF)
-!-----------------------------------------------------------------------
-
-/
-
-!!======================================================================
-!! *** Lateral boundary condition *** !!
-!! !!
-!! namlbc lateral momentum boundary condition (default: NO selection)
-!! namagrif agrif nested grid (read by child model only) ("key_agrif")
-!! nam_tide Tidal forcing (default: OFF)
-!! nambdy Unstructured open boundaries (default: OFF)
-!! nambdy_dta Unstructured open boundaries - external data (see nambdy)
-!! nambdy_tide tidal forcing at open boundaries (default: OFF)
-!!======================================================================
-!
-!-----------------------------------------------------------------------
-&namlbc ! lateral momentum boundary condition (default: NO selection)
-!-----------------------------------------------------------------------
- rn_shlat = 0. ! free slip
-/
-!-----------------------------------------------------------------------
-&namagrif ! AGRIF zoom ("key_agrif")
-!-----------------------------------------------------------------------
-/
-!-----------------------------------------------------------------------
-&nam_tide ! tide parameters (default: OFF)
-!-----------------------------------------------------------------------
-/
-!-----------------------------------------------------------------------
-&nambdy ! unstructured open boundaries (default: OFF)
-!-----------------------------------------------------------------------
-/
-!-----------------------------------------------------------------------
-&nambdy_dta ! open boundaries - external data (see nam_bdy)
-!-----------------------------------------------------------------------
-
-/
-!-----------------------------------------------------------------------
-&nambdy_tide ! tidal forcing at open boundaries (default: OFF)
-!-----------------------------------------------------------------------
-/
-
-!!======================================================================
-!! *** Top/Bottom boundary condition *** !!
-!! !!
-!! namdrg top/bottom drag coefficient (default: NO selection)
-!! namdrg_top top friction (ln_drg_OFF=F & ln_isfcav=T)
-!! namdrg_bot bottom friction (ln_drg_OFF=F)
-!! nambbc bottom temperature boundary condition (default: OFF)
-!! nambbl bottom boundary layer scheme (default: OFF)
-!!======================================================================
-!
-!-----------------------------------------------------------------------
-&namdrg ! top/bottom drag coefficient (default: NO selection)
-!-----------------------------------------------------------------------
- ln_drg_OFF = .false. ! free-slip : Cd = 0 (F => fill namdrg_bot
- ln_lin = .false. ! linear drag: Cd = Cd0 Uc0 & namdrg_top)
- ln_non_lin = .true. ! non-linear drag: Cd = Cd0 |U|
- ln_loglayer = .false. ! logarithmic drag: Cd = vkarmn/log(z/z0) |U|
- !
- ln_drgimp = .false. ! implicit top/bottom friction flag
-/
-!-----------------------------------------------------------------------
-&namdrg_top ! TOP friction (ln_drg_OFF =F & ln_isfcav=T)
-!-----------------------------------------------------------------------
- rn_Cd0 = 2.5e-3 ! drag coefficient [-]
- rn_Uc0 = 0.16 ! ref. velocity [m/s] (linear drag=Cd0*Uc0)
- rn_Cdmax = 0.1 ! drag value maximum [-] (logarithmic drag)
- rn_ke0 = 0.0e-0 ! background kinetic energy [m2/s2] (non-linear cases)
- rn_z0 = 3.0e-3 ! roughness [m] (ln_loglayer=T)
- ln_boost = .false. ! =T regional boost of Cd0 ; =F constant
- rn_boost = 50. ! local boost factor [-]
-/
-!-----------------------------------------------------------------------
-&namdrg_bot ! BOTTOM friction (ln_drg_OFF =F)
-!-----------------------------------------------------------------------
- rn_Cd0 = 1.e-3 ! drag coefficient [-]
- rn_Uc0 = 0.4 ! ref. velocity [m/s] (linear drag=Cd0*Uc0)
- rn_Cdmax = 0.1 ! drag value maximum [-] (logarithmic drag)
- rn_ke0 = 2.5e-3 ! background kinetic energy [m2/s2] (non-linear cases)
- rn_z0 = 3.e-3 ! roughness [m] (ln_loglayer=T)
- ln_boost = .false. ! =T regional boost of Cd0 ; =F constant
- rn_boost = 50. ! local boost factor [-]
-/
-!-----------------------------------------------------------------------
-&nambbc ! bottom temperature boundary condition (default: OFF)
-!-----------------------------------------------------------------------
-
-/
-!-----------------------------------------------------------------------
-&nambbl ! bottom boundary layer scheme (default: OFF)
-!-----------------------------------------------------------------------
-/
-
-!!======================================================================
-!! Tracer (T-S) namelists !!
-!! !!
-!! nameos equation of state (default: NO selection)
-!! namtra_adv advection scheme (default: NO selection)
-!! namtra_ldf lateral diffusion scheme (default: NO selection)
-!! namtra_mle mixed layer eddy param. (Fox-Kemper param.) (default: OFF)
-!! namtra_eiv eddy induced velocity param. (default: OFF)
-!! namtra_dmp T & S newtonian damping (default: OFF)
-!!======================================================================
-!
-!-----------------------------------------------------------------------
-&nameos ! ocean Equation Of Seawater (default: NO selection)
-!-----------------------------------------------------------------------
- ln_eos80 = .true. ! = Use EOS80 equation of state
-/
-!-----------------------------------------------------------------------
-&namtra_adv ! advection scheme for tracer (default: NO selection)
-!-----------------------------------------------------------------------
- ln_traadv_fct = .true. ! FCT scheme
- nn_fct_h = 2 ! =2/4, horizontal 2nd / 4th order
- nn_fct_v = 2 ! =2/4, vertical 2nd / COMPACT 4th order
-/
-!-----------------------------------------------------------------------
-&namtra_ldf ! lateral diffusion scheme for tracers (default: NO selection)
-!-----------------------------------------------------------------------
- ln_traldf_lap = .true. ! laplacian operator
- ln_traldf_hor = .true. ! horizontal (geopotential)
- ! ! Coefficients:
- nn_aht_ijk_t = 0 ! = 0 constant = 1/2 Ud*Ld (lap case)
- rn_Ud = 0.02 ! lateral diffusive velocity [m/s]
- rn_Ld = 10.e+3 ! lateral diffusive length [m]
-/
-!-----------------------------------------------------------------------
-&namtra_mle ! mixed layer eddy parametrisation (Fox-Kemper) (default: OFF)
-!-----------------------------------------------------------------------
-/
-!-----------------------------------------------------------------------
-&namtra_eiv ! eddy induced velocity param. (default: OFF)
-!-----------------------------------------------------------------------
-/
-!-----------------------------------------------------------------------
-&namtra_dmp ! tracer: T & S newtonian damping (default: OFF)
-!-----------------------------------------------------------------------
-/
-
-!!======================================================================
-!! *** Dynamics namelists *** !!
-!! !!
-!! nam_vvl vertical coordinate options (default: z-star)
-!! namdyn_adv formulation of the momentum advection (default: NO selection)
-!! namdyn_vor advection scheme (default: NO selection)
-!! namdyn_hpg hydrostatic pressure gradient (default: NO selection)
-!! namdyn_spg surface pressure gradient (default: NO selection)
-!! namdyn_ldf lateral diffusion scheme (default: NO selection)
-!! namdta_dyn offline TOP: dynamics read in files (OFF_SRC only)
-!!======================================================================
-!
-!-----------------------------------------------------------------------
-&nam_vvl ! vertical coordinate options (default: z-star)
-!-----------------------------------------------------------------------
-/
-!-----------------------------------------------------------------------
-&namdyn_adv ! formulation of the momentum advection (default: NO selection)
-!-----------------------------------------------------------------------
- ln_dynadv_vec = .true. ! vector form (T) or flux form (F)
- nn_dynkeg = 0 ! scheme for grad(KE): =0 C2 ; =1 Hollingsworth correction
-/
-!-----------------------------------------------------------------------
-&namdyn_vor ! Vorticity / Coriolis scheme (default: NO selection)
-!-----------------------------------------------------------------------
- ln_dynvor_ene = .true. ! energy conserving scheme
-/
-!-----------------------------------------------------------------------
-&namdyn_hpg ! Hydrostatic pressure gradient option (default: NO selection)
-!-----------------------------------------------------------------------
- ln_hpg_isf = .true. ! s-coordinate adapted for isf (standard jacobian formulation)
-/
-!-----------------------------------------------------------------------
-&namdyn_spg ! surface pressure gradient (default: NO selection)
-!-----------------------------------------------------------------------
- ln_dynspg_ts = .true. ! split-explicit free surface
-/
-!-----------------------------------------------------------------------
-&namdyn_ldf ! lateral diffusion on momentum (default: NO selection)
-!-----------------------------------------------------------------------
- ln_dynldf_lap = .true. ! laplacian operator
- ln_dynldf_lev = .true. ! iso-level
- nn_ahm_ijk_t = 0 ! = 0 constant = 1/2 Uv*Lv (lap case)
- rn_Uv = 0.12 ! lateral viscous velocity [m/s]
- rn_Lv = 10.e+3 ! lateral viscous length [m]
-/
-!-----------------------------------------------------------------------
-&namdta_dyn ! offline ocean input files (OFF_SRC only)
-!-----------------------------------------------------------------------
-
-/
-
-!!======================================================================
-!! vertical physics namelists !!
-!! !!
-!! namzdf vertical physics manager (default: NO selection)
-!! namzdf_ric richardson number vertical mixing (ln_zdfric=T)
-!! namzdf_tke TKE vertical mixing (ln_zdftke=T)
-!! namzdf_gls GLS vertical mixing (ln_zdfgls=T)
-!! namzdf_osm OSM vertical diffusion (ln_zdfosm=T)
-!! namzdf_iwm tidal mixing parameterization (ln_zdfiwm=T)
-!!======================================================================
-!
-!-----------------------------------------------------------------------
-&namzdf ! vertical physics manager (default: NO selection)
-!-----------------------------------------------------------------------
- ! ! type of vertical closure (required)
- ln_zdfcst = .true. ! constant mixing
- !
- ! ! convection
- ln_zdfevd = .true. ! enhanced vertical diffusion
- rn_evd = 0.1 ! mixing coefficient [m2/s]
- !
- ! ! coefficients
- rn_avm0 = 1.e-3 ! vertical eddy viscosity [m2/s] (background Kz if ln_zdfcst)
- rn_avt0 = 5.e-5 ! vertical eddy diffusivity [m2/s] (background Kz if ln_zdfcst)
-/
-!-----------------------------------------------------------------------
-&namzdf_ric ! richardson number dependent vertical diffusion (ln_zdfric =T)
-!-----------------------------------------------------------------------
-/
-!-----------------------------------------------------------------------
-&namzdf_tke ! turbulent eddy kinetic dependent vertical diffusion (ln_zdftke =T)
-!-----------------------------------------------------------------------
-/
-!-----------------------------------------------------------------------
-&namzdf_gls ! GLS vertical diffusion (ln_zdfgls =T)
-!-----------------------------------------------------------------------
-/
-!-----------------------------------------------------------------------
-&namzdf_osm ! OSM vertical diffusion (ln_zdfosm =T)
-!-----------------------------------------------------------------------
-/
-!-----------------------------------------------------------------------
-&namzdf_iwm ! internal wave-driven mixing parameterization (ln_zdfiwm =T)
-!-----------------------------------------------------------------------
-/
-
-!!======================================================================
-!! *** Diagnostics namelists *** !!
-!! !!
-!! namtrd dynamics and/or tracer trends (default: OFF)
-!! namhsb Heat and salt budgets (default: OFF)
-!! namdiu Cool skin and warm layer models (default: OFF)
-!! namdiu Cool skin and warm layer models (default: OFF)
-!! namflo float parameters (default: OFF)
-!! nam_diadct transports through some sections (default: OFF)
-!! nam_dia25h 25h Mean Output (default: OFF)
-!! namnc4 netcdf4 chunking and compression settings ("key_netcdf4")
-!!======================================================================
-!
-!-----------------------------------------------------------------------
-&namtrd ! trend diagnostics (default: OFF)
-!-----------------------------------------------------------------------
-/
-!-----------------------------------------------------------------------
-&namhsb ! Heat and salt budgets (default: OFF)
-!-----------------------------------------------------------------------
-/
-!-----------------------------------------------------------------------
-&namdiu ! Cool skin and warm layer models (default: OFF)
-!-----------------------------------------------------------------------
-/
-!-----------------------------------------------------------------------
-&namflo ! float parameters ("key_float")
-!-----------------------------------------------------------------------
-/
-!-----------------------------------------------------------------------
-&nam_diaharm ! Harmonic analysis of tidal constituents ("key_diaharm")
-!-----------------------------------------------------------------------
-/
-!-----------------------------------------------------------------------
-&namdct ! transports through some sections ("key_diadct")
-!-----------------------------------------------------------------------
-/
-!-----------------------------------------------------------------------
-&nam_diatmb ! Top Middle Bottom Output (default: OFF)
-!-----------------------------------------------------------------------
-/
-!-----------------------------------------------------------------------
-&nam_dia25h ! 25h Mean Output (default: OFF)
-!-----------------------------------------------------------------------
-/
-!-----------------------------------------------------------------------
-&namnc4 ! netcdf4 chunking and compression settings ("key_netcdf4")
-!-----------------------------------------------------------------------
-/
-
-!!======================================================================
-!! *** Observation & Assimilation *** !!
-!! !!
-!! namobs observation and model comparison (default: OFF)
-!! nam_asminc assimilation increments ('key_asminc')
-!!======================================================================
-!
-!-----------------------------------------------------------------------
-&namobs ! observation usage switch (default: OFF)
-!-----------------------------------------------------------------------
-/
-!-----------------------------------------------------------------------
-&nam_asminc ! assimilation increments ('key_asminc')
-!-----------------------------------------------------------------------
-/
-
-!!======================================================================
-!! *** Miscellaneous namelists *** !!
-!! !!
-!! nammpp Massively Parallel Processing
-!! namctl Control prints (default: OFF)
-!! namsto Stochastic parametrization of EOS (default: OFF)
-!!======================================================================
-!
-!-----------------------------------------------------------------------
-&nammpp ! Massively Parallel Processing
-!-----------------------------------------------------------------------
-/
-!-----------------------------------------------------------------------
-&namctl ! Control prints (default: OFF)
-!-----------------------------------------------------------------------
-/
-!-----------------------------------------------------------------------
-&namsto ! Stochastic parametrization of EOS (default: OFF)
-!-----------------------------------------------------------------------
-/
diff --git a/tests/ISOMIP/EXPREF/namelist_ref b/tests/ISOMIP/EXPREF/namelist_ref
deleted file mode 120000
index 97682863712c9d973a2d1aa35a12452a3e8b4f96..0000000000000000000000000000000000000000
--- a/tests/ISOMIP/EXPREF/namelist_ref
+++ /dev/null
@@ -1 +0,0 @@
-../../../cfgs/SHARED/namelist_ref
\ No newline at end of file
diff --git a/tests/ISOMIP/EXPREF/plot_mlt.py b/tests/ISOMIP/EXPREF/plot_mlt.py
deleted file mode 100644
index edb9e04afe6a73d309ca73ecf5922344e4c0c060..0000000000000000000000000000000000000000
--- a/tests/ISOMIP/EXPREF/plot_mlt.py
+++ /dev/null
@@ -1,47 +0,0 @@
-from netCDF4 import Dataset
-import numpy as np
-from numpy import ma
-import argparse
-import matplotlib.pyplot as plt
-import matplotlib
-
-parser = argparse.ArgumentParser()
-parser.add_argument("-f" , metavar='file_name' , help="names of input files" , type=str , nargs="+", required=True )
-parser.add_argument("-v" , metavar='var_name' , help="variable list" , type=str , nargs=1 , required=True )
-args = parser.parse_args()
-
-# read mesh_mask
-ncid = Dataset('mesh_mask.nc')
-lat2d = ncid.variables['gphit' ][ :,:].squeeze()
-lon2d = ncid.variables['glamt' ][ :,:].squeeze()
-msk = ncid.variables['tmaskutil'][0,:,:].squeeze()
-ncid.close()
-
-plt.figure(figsize=np.array([210,210]) / 25.4)
-
-# read psi.nc
-ncid = Dataset(args.f[0])
-var2d = ncid.variables[args.v[0]][-1,:,:].squeeze()
-var2dm = ma.masked_where(msk==0.0,var2d)
-# convert in m/y
-var2dm = var2dm * 86400 * 365 / 1e3
-ncid.close()
-
-# define colorbar
-vlevel=np.arange(-1.6,1.8,0.2)
-pcol = plt.contourf(lon2d,lat2d,var2dm,levels=vlevel,extend='both')
-vlevel=np.arange(-1.6,1.8,0.4)
-matplotlib.rcParams['contour.negative_linestyle'] = 'solid'
-plt.contour(lon2d,lat2d,var2dm,levels=vlevel,colors='k')
-plt.grid()
-plt.title('melt rate ISOMIP (m/y)')
-plt.ylabel('Latitude',fontsize=14)
-plt.xlabel('Longitude',fontsize=14)
-cbar = plt.colorbar(pcol, ticks=vlevel)
-cbar.ax.tick_params(labelsize=14)
-
-# save figure
-plt.savefig('mlt.png', format='png', dpi=300)
-
-plt.show()
-
diff --git a/tests/ISOMIP/EXPREF/plot_moc.py b/tests/ISOMIP/EXPREF/plot_moc.py
deleted file mode 100644
index f8fc48e811b92f6c2d44cb70942afe119d228242..0000000000000000000000000000000000000000
--- a/tests/ISOMIP/EXPREF/plot_moc.py
+++ /dev/null
@@ -1,60 +0,0 @@
-from netCDF4 import Dataset
-import numpy as np
-import argparse
-import matplotlib.pyplot as plt
-
-# read argument
-parser = argparse.ArgumentParser()
-parser.add_argument("-f" , metavar='file_name' , help="names of input files" , type=str , nargs=1 , required=True )
-parser.add_argument("-v" , metavar='var_name' , help="variable list" , type=str , nargs=1 , required=True )
-args = parser.parse_args()
-
-# read mesh mask
-ncid = Dataset('mesh_mask.nc')
-vx2d = ncid.variables['gphit' ][0,:,0].squeeze()
-vx2dv = ncid.variables['gphiv' ][0,:,0].squeeze()
-y2d = ncid.variables['gdepw_0'][0,:,:,1].squeeze()*-1
-y2dt = ncid.variables['gdept_0'][0,:,:,1].squeeze()*-1
-msk = ncid.variables['tmask' ][0,:,:,1].squeeze()
-ncid.close()
-
-# build x 2d array
-x2d=y2d*0.0
-x2dv=y2d*0.0
-for jk in range(0,y2d.shape[0]):
- x2d[jk,:]=vx2d[:]
- x2dv[jk,:]=vx2d[:]
-
-plt.figure(figsize=np.array([210,210]) / 25.4)
-
-# read data and mask it
-ncid = Dataset(args.f[0])
-var2d = ncid.variables[args.v[0]][-1,:,:,:].squeeze()
-var2dm = var2d[:,:]
-var2dm[msk==0] = -1
-ncid.close()
-
-# define colorbar
-vlevel=np.arange(0,0.13,0.01)
-pcol = plt.contourf(x2d,y2d,var2dm,levels=vlevel)
-plt.clf()
-
-# plot contour
-ax = plt.subplot(1, 1, 1)
-ax.contour(x2dv,y2dt,var2dm,levels=vlevel)
-ax.grid()
-ax.set_title('MOC ISOMIP (Sv)')
-ax.set_ylabel('Depth (m)',fontsize=14)
-ax.set_xlabel('Latitude',fontsize=14)
-
-# plot colorbar
-plt.subplots_adjust(left=0.1,right=0.89, bottom=0.1, top=0.89, wspace=0.1, hspace=0.1)
-cax = plt.axes([0.91, 0.1, 0.02, 0.79])
-cbar= plt.colorbar(pcol, ticks=vlevel, cax=cax)
-cbar.ax.tick_params(labelsize=14)
-
-# save figure
-plt.savefig('moc.png', format='png', dpi=300)
-
-plt.show()
-
diff --git a/tests/ISOMIP/EXPREF/plot_psi.py b/tests/ISOMIP/EXPREF/plot_psi.py
deleted file mode 100644
index 16b615fdad922cd8f0cd41591e937a7e9f5d909d..0000000000000000000000000000000000000000
--- a/tests/ISOMIP/EXPREF/plot_psi.py
+++ /dev/null
@@ -1,52 +0,0 @@
-from netCDF4 import Dataset
-import numpy as np
-from numpy import ma
-import argparse
-import matplotlib.pyplot as plt
-
-parser = argparse.ArgumentParser()
-parser.add_argument("-f" , metavar='file_name' , help="names of input files" , type=str , nargs="+", required=True )
-parser.add_argument("-v" , metavar='var_name' , help="variable list" , type=str , nargs=1 , required=True )
-args = parser.parse_args()
-
-# read mesh_mask
-ncid = Dataset('mesh_mask.nc')
-lat2d = ncid.variables['gphit' ][ :,:].squeeze()
-lon2d = ncid.variables['glamt' ][ :,:].squeeze()
-msk = ncid.variables['tmaskutil'][0,:,:].squeeze()
-ncid.close()
-
-plt.figure(figsize=np.array([210,210]) / 25.4)
-
-# read psi.nc
-ncid = Dataset(args.f[0])
-var2d = ncid.variables[args.v[0]][-1,:,:].squeeze()
-var2dm = ma.masked_where(msk==0.0,var2d)
-# convert in Sv
-var2dm = var2dm / 1e6
-ncid.close()
-
-# define colorbar
-vlevel=np.arange(0.00,0.36,0.02)
-pcol = plt.contourf(lon2d,lat2d,var2dm,levels=vlevel)
-plt.clf()
-
-# plot contour
-ax = plt.subplot(1, 1, 1)
-ax.contour(lon2d,lat2d,var2dm,levels=vlevel)
-ax.grid()
-ax.set_title('PSI ISOMIP (Sv)')
-ax.set_ylabel('Latitude',fontsize=14)
-ax.set_xlabel('Longitude',fontsize=14)
-
-# plot colorbar
-plt.subplots_adjust(left=0.1,right=0.89, bottom=0.1, top=0.89, wspace=0.1, hspace=0.1)
-cax = plt.axes([0.91, 0.1, 0.02, 0.79])
-cbar= plt.colorbar(pcol, ticks=vlevel, cax=cax)
-cbar.ax.tick_params(labelsize=14)
-
-# save figure
-plt.savefig('psi.png', format='png', dpi=300)
-
-plt.show()
-
diff --git a/tests/ISOMIP/MY_SRC/usrdef_hgr.F90 b/tests/ISOMIP/MY_SRC/usrdef_hgr.F90
deleted file mode 100644
index 95bdd75af7e866caf87798a50f9f8f13f258449a..0000000000000000000000000000000000000000
--- a/tests/ISOMIP/MY_SRC/usrdef_hgr.F90
+++ /dev/null
@@ -1,119 +0,0 @@
-MODULE usrdef_hgr
- !!======================================================================
- !! *** MODULE usrdef_hgr ***
- !!
- !! === LOCK_EXCHANGE configuration ===
- !!
- !! User defined : mesh and Coriolis parameter of a user configuration
- !!======================================================================
- !! History : NEMO ! 2016-08 (S. Flavoni, G. Madec) Original code
- !! ! 2017-02 (P. Mathiot, S. Flavoni) Adapt code to ISOMIP case
- !!----------------------------------------------------------------------
-
- !!----------------------------------------------------------------------
- !! usr_def_hgr : initialize the horizontal mesh for ISOMIP configuration
- !!----------------------------------------------------------------------
- USE dom_oce
- USE par_oce ! ocean space and time domain
- USE phycst ! physical constants
- USE usrdef_nam, ONLY: rn_e1deg, rn_e2deg ! horizontal resolution in meters
- !
- USE in_out_manager ! I/O manager
- USE lib_mpp ! MPP library
-
- IMPLICIT NONE
- PRIVATE
-
- PUBLIC usr_def_hgr ! called by domhgr.F90
-
- !! * Substitutions
-# include "do_loop_substitute.h90"
- !!----------------------------------------------------------------------
- !! NEMO/OCE 4.0 , NEMO Consortium (2018)
- !! $Id: usrdef_hgr.F90 14223 2020-12-19 10:22:45Z smasson $
- !! Software governed by the CeCILL license (see ./LICENSE)
- !!----------------------------------------------------------------------
-CONTAINS
-
- SUBROUTINE usr_def_hgr( plamt , plamu , plamv , plamf , & ! geographic position (required)
- & pphit , pphiu , pphiv , pphif , & !
- & kff , pff_f , pff_t , & ! Coriolis parameter (if domain not on the sphere)
- & pe1t , pe1u , pe1v , pe1f , & ! scale factors (required)
- & pe2t , pe2u , pe2v , pe2f , & !
- & ke1e2u_v , pe1e2u , pe1e2v ) ! u- & v-surfaces (if gridsize reduction is used in strait(s))
- !!----------------------------------------------------------------------
- !! *** ROUTINE usr_def_hgr ***
- !!
- !! ** Purpose : user defined mesh and Coriolis parameter
- !!
- !! ** Method : set all intent(out) argument to a proper value
- !! ISOMIP configuration
- !!
- !! ** Action : - define longitude & latitude of t-, u-, v- and f-points (in degrees)
- !! - define i- & j-scale factors at t-, u-, v- and f-points (in meters)
- !! - define u- & v-surfaces (in m2)
- !!----------------------------------------------------------------------
- REAL(wp), DIMENSION(:,:), INTENT(out) :: plamt, plamu, plamv, plamf ! longitude outputs [degrees]
- REAL(wp), DIMENSION(:,:), INTENT(out) :: pphit, pphiu, pphiv, pphif ! latitude outputs [degrees]
- INTEGER , INTENT(out) :: kff ! =1 Coriolis parameter computed here, =0 otherwise
- REAL(wp), DIMENSION(:,:), INTENT(out) :: pff_f, pff_t ! Coriolis factor at f-point [1/s]
- REAL(wp), DIMENSION(:,:), INTENT(out) :: pe1t, pe1u, pe1v, pe1f ! i-scale factors [m]
- REAL(wp), DIMENSION(:,:), INTENT(out) :: pe2t, pe2u, pe2v, pe2f ! j-scale factors [m]
- INTEGER , INTENT(out) :: ke1e2u_v ! =1 u- & v-surfaces computed here, =0 otherwise
- REAL(wp), DIMENSION(:,:), INTENT(out) :: pe1e2u, pe1e2v ! u- & v-surfaces (if reduction in strait) [m2]
- !
- INTEGER :: ji, jj ! dummy loop indices
- REAL(wp) :: zfact, zti, zui, zvi, zfi, ztj, zuj, zvj, zfj ! local scalars
- !!-------------------------------------------------------------------------------
- !
- IF(lwp) THEN
- WRITE(numout,*)
- WRITE(numout,*) 'usr_def_hgr : ISOMIP configuration'
- WRITE(numout,*) '~~~~~~~~~~~'
- WRITE(numout,*)
- WRITE(numout,*) ' ===>> geographical mesh on the sphere with regular grid-spacing'
- WRITE(numout,*) ' given by rn_e1deg and rn_e2deg'
- ENDIF
- !
- ! !== grid point position ==! (in degrees)
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
- ! ! longitude (west coast at lon=0°)
- plamt(ji,jj) = rn_e1deg * ( - 0.5 + REAL( mig0(ji)-1 , wp ) )
- plamu(ji,jj) = rn_e1deg * ( REAL( mig0(ji)-1 , wp ) )
- plamv(ji,jj) = plamt(ji,jj)
- plamf(ji,jj) = plamu(ji,jj)
- ! ! latitude (south coast at lat=-80°)
- pphit(ji,jj) = rn_e2deg * ( - 0.5 + REAL( mjg0(jj)-1 , wp ) ) - 80._wp
- pphiu(ji,jj) = pphit(ji,jj)
- pphiv(ji,jj) = rn_e2deg * ( REAL( mjg0(jj)-1 , wp ) ) - 80._wp
- pphif(ji,jj) = pphiv(ji,jj)
- END_2D
- !
- ! !== Horizontal scale factors ==! (in meters)
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
- ! ! e1 (zonal)
- pe1t(ji,jj) = ra * rad * COS( rad * pphit(ji,jj) ) * rn_e1deg
- pe1u(ji,jj) = ra * rad * COS( rad * pphiu(ji,jj) ) * rn_e1deg
- pe1v(ji,jj) = ra * rad * COS( rad * pphiv(ji,jj) ) * rn_e1deg
- pe1f(ji,jj) = ra * rad * COS( rad * pphif(ji,jj) ) * rn_e1deg
- ! ! e2 (meridional)
- pe2t(ji,jj) = ra * rad * rn_e2deg
- pe2u(ji,jj) = ra * rad * rn_e2deg
- pe2v(ji,jj) = ra * rad * rn_e2deg
- pe2f(ji,jj) = ra * rad * rn_e2deg
- END_2D
- ! ! NO reduction of grid size in some straits
- ke1e2u_v = 0 ! ==>> u_ & v_surfaces will be computed in dom_ghr routine
- pe1e2u(:,:) = 0._wp ! CAUTION: set to zero to avoid error with some compilers that
- pe1e2v(:,:) = 0._wp ! require an initialization of INTENT(out) arguments
- !
- !
- ! !== Coriolis parameter ==!
- kff = 0 ! Coriolis parameter calculated on the sphere
- pff_f(:,:) = 0._wp ! CAUTION: set to zero to avoid error with some compilers that
- pff_t(:,:) = 0._wp ! require an initialization of INTENT(out) arguments
- !
- END SUBROUTINE usr_def_hgr
-
- !!======================================================================
-END MODULE usrdef_hgr
diff --git a/tests/ISOMIP/MY_SRC/usrdef_istate.F90 b/tests/ISOMIP/MY_SRC/usrdef_istate.F90
deleted file mode 100644
index 42cf30fd2d67ddbb8fa411873beec23c58de5c9c..0000000000000000000000000000000000000000
--- a/tests/ISOMIP/MY_SRC/usrdef_istate.F90
+++ /dev/null
@@ -1,87 +0,0 @@
-MODULE usrdef_istate
- !!======================================================================
- !! *** MODULE usrdef_istate ***
- !!
- !! === ISOMIP configuration ===
- !!
- !! User defined : set the initial state of a user configuration
- !!======================================================================
- !! History : NEMO ! 2016-11 (S. Flavoni) Original code
- !! ! 2017-02 (P. Mathiot, S. Flavoni) Adapt code to ISOMIP case
- !! ! 2020-11 (S. Techene, G. Madec) separate tsuv from ssh
- !!----------------------------------------------------------------------
-
- !!----------------------------------------------------------------------
- !! usr_def_istate : initial state in Temperature and salinity
- !!----------------------------------------------------------------------
- USE par_oce ! ocean space and time domain
- USE dom_oce , ONLY : glamt
- USE phycst ! physical constants
- !
- USE in_out_manager ! I/O manager
- USE lib_mpp ! MPP library
-
- IMPLICIT NONE
- PRIVATE
-
- PUBLIC usr_def_istate ! called by istate.F90
- PUBLIC usr_def_istate_ssh ! called by domqco.F90
-
- !!----------------------------------------------------------------------
- !! NEMO/OCE 4.0 , NEMO Consortium (2018)
- !! $Id: usrdef_istate.F90 14053 2020-12-03 13:48:38Z techene $
- !! Software governed by the CeCILL license (see ./LICENSE)
- !!----------------------------------------------------------------------
-CONTAINS
-
- SUBROUTINE usr_def_istate( pdept, ptmask, pts, pu, pv )
- !!----------------------------------------------------------------------
- !! *** ROUTINE usr_def_istate ***
- !!
- !! ** Purpose : Initialization of the dynamics and tracers
- !! Here ISOMIP configuration
- !!
- !! ** Method : - set temperature field
- !! - set salinity field
- !!----------------------------------------------------------------------
- REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT(in ) :: pdept ! depth of t-point [m]
- REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT(in ) :: ptmask ! t-point ocean mask [m]
- REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT( out) :: pts ! T & S fields [Celsius ; g/kg]
- REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT( out) :: pu ! i-component of the velocity [m/s]
- REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT( out) :: pv ! j-component of the velocity [m/s]
- !!----------------------------------------------------------------------
- !
- IF(lwp) WRITE(numout,*)
- IF(lwp) WRITE(numout,*) 'usr_def_istate : ISOMIP configuration, analytical definition of initial state'
- IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~~ Ocean at rest, with a constant salinity and temperature. '
- pu (:,:,:) = 0._wp ! ocean at rest
- pv (:,:,:) = 0._wp
- ! ! T & S profiles
- pts(:,:,:,jp_tem) = - 1.9 * ptmask(:,:,:) ! ISOMIP configuration : start from constant T+S fields
- pts(:,:,:,jp_sal) = 34.4 * ptmask(:,:,:)
- !
- END SUBROUTINE usr_def_istate
-
-
- SUBROUTINE usr_def_istate_ssh( ptmask, pssh )
- !!----------------------------------------------------------------------
- !! *** ROUTINE usr_def_istate_ssh ***
- !!
- !! ** Purpose : Initialization of ssh
- !! Here ISOMIP configuration
- !!
- !! ** Method : set ssh to 0
- !!----------------------------------------------------------------------
- REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT(in ) :: ptmask ! t-point ocean mask [m]
- REAL(wp), DIMENSION(jpi,jpj) , INTENT( out) :: pssh ! sea-surface height [m]
- !!----------------------------------------------------------------------
- !
- IF(lwp) WRITE(numout,*)
- IF(lwp) WRITE(numout,*) 'usr_def_istate_ssh : ISOMIP configuration, analytical definition of initial state'
- !
- pssh(:,:) = 0._wp
- !
- END SUBROUTINE usr_def_istate_ssh
-
- !!======================================================================
-END MODULE usrdef_istate
diff --git a/tests/ISOMIP/MY_SRC/usrdef_nam.F90 b/tests/ISOMIP/MY_SRC/usrdef_nam.F90
deleted file mode 100644
index b10630838bb8cb52d6067d92a147d7686e169e36..0000000000000000000000000000000000000000
--- a/tests/ISOMIP/MY_SRC/usrdef_nam.F90
+++ /dev/null
@@ -1,108 +0,0 @@
-MODULE usrdef_nam
- !!======================================================================
- !! *** MODULE usrdef_nam ***
- !!
- !! === ISOMIP configuration ===
- !!
- !! User defined : set the domain characteristics of a user configuration
- !!======================================================================
- !! History : NEMO ! 2016-03 (S. Flavoni, G. Madec) Original code
- !! ! 2017-02 (P. Mathiot, S. Flavoni) Adapt code to ISOMIP case
- !!----------------------------------------------------------------------
-
- !!----------------------------------------------------------------------
- !! usr_def_nam : read user defined namelist and set global domain size
- !! usr_def_hgr : initialize the horizontal mesh
- !!----------------------------------------------------------------------
- USE dom_oce , ONLY: ln_zco, ln_zps, ln_sco ! flag of type of coordinate
- USE par_oce ! ocean space and time domain
- USE phycst ! physical constants
- !
- USE in_out_manager ! I/O manager
- USE lib_mpp ! MPP library
- USE timing ! Timing
-
- IMPLICIT NONE
- PRIVATE
-
- PUBLIC usr_def_nam ! called by nemogcm.F90
-
- ! !!* namusr_def namelist *!!
- REAL(wp), PUBLIC :: rn_e1deg, rn_e2deg !: horizontal resolution [degrees]
- REAL(wp), PUBLIC :: rn_e3 !: vertical resolution [m]
-
- REAL(wp), PARAMETER, PUBLIC :: rbathy = 900._wp !: depth of the seafloor [m]
-
- !!----------------------------------------------------------------------
- !! NEMO/OCE 4.0 , NEMO Consortium (2018)
- !! $Id: usrdef_nam.F90 14433 2021-02-11 08:06:49Z smasson $
- !! Software governed by the CeCILL license (see ./LICENSE)
- !!----------------------------------------------------------------------
-CONTAINS
-
- SUBROUTINE usr_def_nam( cd_cfg, kk_cfg, kpi, kpj, kpk, ldIperio, ldJperio, ldNFold, cdNFtype )
- !!----------------------------------------------------------------------
- !! *** ROUTINE dom_nam ***
- !!
- !! ** Purpose : read user defined namelist and define the domain size
- !!
- !! ** Method : read in namusr_def containing all the user specific namelist parameter
- !!
- !! Here ISOMIP configuration
- !!
- !! ** input : - namusr_def namelist found in namelist_cfg
- !!----------------------------------------------------------------------
- CHARACTER(len=*), INTENT(out) :: cd_cfg ! configuration name
- INTEGER , INTENT(out) :: kk_cfg ! configuration resolution
- INTEGER , INTENT(out) :: kpi, kpj, kpk ! global domain sizes
- LOGICAL , INTENT(out) :: ldIperio, ldJperio ! i- and j- periodicity
- LOGICAL , INTENT(out) :: ldNFold ! North pole folding
- CHARACTER(len=1), INTENT(out) :: cdNFtype ! Folding type: T or F
- !
- INTEGER :: ios ! Local integer
- !!
- NAMELIST/namusr_def/ ln_zco, ln_zps, ln_sco, rn_e1deg, rn_e2deg, rn_e3
- !!----------------------------------------------------------------------
- !
- READ ( numnam_cfg, namusr_def, IOSTAT = ios, ERR = 902 )
-902 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namusr_def in configuration namelist' )
- !
- IF(lwm) WRITE( numond, namusr_def )
- !
- cd_cfg = 'ISOMIP' ! name & resolution (not used)
- kk_cfg = INT( rn_e3 )
- !
- ! Global Domain size: ISOMIP domain is 15° x 10° x 900 m
- kpi = INT( 15.0 / rn_e1deg ) + 2 ! add 2 for t-point in the east & west coasts
- kpj = INT( 10.0 / rn_e2deg ) + 2 ! - - north & south -
- kpk = INT( rbathy / rn_e3 ) + 1 ! add 1 for t-point in the seafloor
- !
- ! ! Set the lateral boundary condition of the global domain
- ldIperio = .FALSE. ; ldJperio = .FALSE. ! ISOMIP configuration : closed domain
- ldNFold = .FALSE. ; cdNFtype = '-'
- !
- ! ! control print
- IF(lwp) THEN
- WRITE(numout,*) ' '
- WRITE(numout,*) 'usr_def_nam : read the user defined namelist (namusr_def) in namelist_cfg'
- WRITE(numout,*) '~~~~~~~~~~~ '
- WRITE(numout,*) ' Namelist namusr_def : ISOMIP test case'
- WRITE(numout,*) ' type of vertical coordinate : '
- WRITE(numout,*) ' z-coordinate flag ln_zco = ', ln_zco
- WRITE(numout,*) ' z-partial-step coordinate flag ln_zps = ', ln_zps
- WRITE(numout,*) ' s-coordinate flag ln_sco = ', ln_sco
- WRITE(numout,*) ' resolution'
- WRITE(numout,*) ' zonal resolution rn_e1deg = ', rn_e1deg, ' degrees'
- WRITE(numout,*) ' meridional resolution rn_e1deg = ', rn_e1deg, ' degrees'
- WRITE(numout,*) ' vertical resolution rn_e3 = ', rn_e3 , ' meters'
- WRITE(numout,*) ' ISOMIP domain = 15° x 10° x 900 m'
- WRITE(numout,*) ' resulting global domain size : Ni0glo = ', kpi
- WRITE(numout,*) ' Nj0glo = ', kpj
- WRITE(numout,*) ' jpkglo = ', kpk
- WRITE(numout,*) ' '
- ENDIF
- !
- END SUBROUTINE usr_def_nam
-
- !!======================================================================
-END MODULE usrdef_nam
diff --git a/tests/ISOMIP/MY_SRC/usrdef_sbc.F90 b/tests/ISOMIP/MY_SRC/usrdef_sbc.F90
deleted file mode 100644
index b3ff303a842d5898dd4f39d91aaa6ed5e0a65757..0000000000000000000000000000000000000000
--- a/tests/ISOMIP/MY_SRC/usrdef_sbc.F90
+++ /dev/null
@@ -1,90 +0,0 @@
-MODULE usrdef_sbc
- !!======================================================================
- !! *** MODULE usrdef_sbc ***
- !!
- !! === ISOMIP configuration ===
- !!
- !! User defined : surface forcing of a user configuration
- !!======================================================================
- !! History : 4.0 ! 2016-03 (S. Flavoni, G. Madec) user defined interface
- !! ! 2017-02 (P. Mathiot, S. Flavoni) adapt code to ISOMIP case
- !!----------------------------------------------------------------------
-
- !!----------------------------------------------------------------------
- !! usr_def_sbc : user defined surface bounday conditions in ISOMIP case
- !!----------------------------------------------------------------------
- USE oce ! ocean dynamics and tracers
- USE dom_oce ! ocean space and time domain
- USE sbc_oce ! Surface boundary condition: ocean fields
- USE sbc_ice ! Surface boundary condition: ice fields
- USE phycst ! physical constants
- !
- USE in_out_manager ! I/O manager
- USE lib_mpp ! distribued memory computing library
- USE lbclnk ! ocean lateral boundary conditions (or mpp link)
- USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined)
-
- IMPLICIT NONE
- PRIVATE
-
- PUBLIC usrdef_sbc_oce ! routine called in sbcmod module
- PUBLIC usrdef_sbc_ice_tau ! routine called by icestp.F90 for ice dynamics
- PUBLIC usrdef_sbc_ice_flx ! routine called by icestp.F90 for ice thermo
-
- !!----------------------------------------------------------------------
- !! NEMO/OCE 4.0 , NEMO Consortium (2018)
- !! $Id: usrdef_sbc.F90 12377 2020-02-12 14:39:06Z acc $
- !! Software governed by the CeCILL license (see ./LICENSE)
- !!----------------------------------------------------------------------
-CONTAINS
-
- SUBROUTINE usrdef_sbc_oce( kt, Kbb )
- !!---------------------------------------------------------------------
- !! *** ROUTINE usr_def_sbc ***
- !!
- !! ** Purpose : provide at each time-step the surface boundary
- !! condition, i.e. the momentum, heat and freshwater fluxes.
- !!
- !! ** Method : all 0 fields, for ISOMIP case
- !! CAUTION : never mask the surface stress field !
- !!
- !! ** Action : - set to ZERO all the ocean surface boundary condition, i.e.
- !! utau, vtau, taum, wndm, qns, qsr, emp, sfx
- !!
- !!----------------------------------------------------------------------
- INTEGER, INTENT(in) :: kt ! ocean time step
- INTEGER, INTENT(in) :: Kbb ! ocean time index
- !!---------------------------------------------------------------------
- !
- IF( kt == nit000 ) THEN
- !
- IF(lwp) WRITE(numout,*)' usr_sbc : ISOMIP case: NO surface forcing'
- IF(lwp) WRITE(numout,*)' ~~~~~~~~~~~ utau = vtau = taum = wndm = qns = qsr = emp = sfx = 0'
- !
- utau(:,:) = 0._wp
- vtau(:,:) = 0._wp
- taum(:,:) = 0._wp
- wndm(:,:) = 0._wp
- !
- emp (:,:) = 0._wp
- sfx (:,:) = 0._wp
- qns (:,:) = 0._wp
- qsr (:,:) = 0._wp
- !
- ENDIF
- !
- END SUBROUTINE usrdef_sbc_oce
-
- SUBROUTINE usrdef_sbc_ice_tau( kt )
- INTEGER, INTENT(in) :: kt ! ocean time step
- END SUBROUTINE usrdef_sbc_ice_tau
-
-
- SUBROUTINE usrdef_sbc_ice_flx( kt, phs, phi )
- INTEGER, INTENT(in) :: kt ! ocean time step
- REAL(wp), DIMENSION(:,:,:), INTENT(in) :: phs ! snow thickness
- REAL(wp), DIMENSION(:,:,:), INTENT(in) :: phi ! ice thickness
- END SUBROUTINE usrdef_sbc_ice_flx
-
- !!======================================================================
-END MODULE usrdef_sbc
diff --git a/tests/ISOMIP/MY_SRC/usrdef_zgr.F90 b/tests/ISOMIP/MY_SRC/usrdef_zgr.F90
deleted file mode 100644
index 225e1ca0f45a25490726832681b8e63650ec801b..0000000000000000000000000000000000000000
--- a/tests/ISOMIP/MY_SRC/usrdef_zgr.F90
+++ /dev/null
@@ -1,236 +0,0 @@
-MODULE usrdef_zgr
- !!======================================================================
- !! *** MODULE usrdef_zgr ***
- !!
- !! === ISOMIP case ===
- !!
- !! user defined : vertical coordinate system of a user configuration
- !!======================================================================
- !! History : 4.0 ! 2016-08 (G. Madec, S. Flavoni) Original code
- !! ! 2017-02 (P. Mathiot, S. Flavoni) Adapt code to ISOMIP case
- !!----------------------------------------------------------------------
-
- !!----------------------------------------------------------------------
- !! usr_def_zgr : user defined vertical coordinate system (required)
- !! zgr_z1d : reference 1D z-coordinate
- !!---------------------------------------------------------------------
- USE oce ! ocean variables
- USE dom_oce , ONLY: mj0 , mj1 ! ocean space and time domain
- USE dom_oce , ONLY: glamt , gphit ! ocean space and time domain
- USE usrdef_nam ! User defined : namelist variables
- !
- USE in_out_manager ! I/O manager
- USE lbclnk ! ocean lateral boundary conditions (or mpp link)
- USE lib_mpp ! distributed memory computing library
- USE timing ! Timing
-
- IMPLICIT NONE
- PRIVATE
-
- PUBLIC usr_def_zgr ! called by domzgr.F90
-
- !! * Substitutions
-# include "do_loop_substitute.h90"
- !!----------------------------------------------------------------------
- !! NEMO/OCE 4.0 , NEMO Consortium (2018)
- !! $Id: usrdef_zgr.F90 13295 2020-07-10 18:24:21Z acc $
- !! Software governed by the CeCILL license (see ./LICENSE)
- !!----------------------------------------------------------------------
-CONTAINS
-
- SUBROUTINE usr_def_zgr( ld_zco , ld_zps , ld_sco , ld_isfcav, & ! type of vertical coordinate
- & pdept_1d, pdepw_1d, pe3t_1d , pe3w_1d , & ! 1D reference vertical coordinate
- & pdept , pdepw , & ! 3D t & w-points depth
- & pe3t , pe3u , pe3v , pe3f , & ! vertical scale factors
- & pe3w , pe3uw , pe3vw, & ! - - -
- & k_top , k_bot ) ! top & bottom ocean level
- !!---------------------------------------------------------------------
- !! *** ROUTINE usr_def_zgr ***
- !!
- !! ** Purpose : User defined the vertical coordinates
- !!
- !!----------------------------------------------------------------------
- LOGICAL , INTENT(in ) :: ld_zco, ld_zps, ld_sco ! vertical coordinate flags ( read in namusr_def )
- LOGICAL , INTENT( out) :: ld_isfcav ! under iceshelf cavity flag
- REAL(wp), DIMENSION(:) , INTENT( out) :: pdept_1d, pdepw_1d ! 1D grid-point depth [m]
- REAL(wp), DIMENSION(:) , INTENT( out) :: pe3t_1d , pe3w_1d ! 1D grid-point depth [m]
- REAL(wp), DIMENSION(:,:,:), INTENT( out) :: pdept, pdepw ! grid-point depth [m]
- REAL(wp), DIMENSION(:,:,:), INTENT( out) :: pe3t , pe3u , pe3v , pe3f ! vertical scale factors [m]
- REAL(wp), DIMENSION(:,:,:), INTENT( out) :: pe3w , pe3uw, pe3vw ! i-scale factors
- INTEGER , DIMENSION(:,:) , INTENT( out) :: k_top, k_bot ! first & last ocean level
- !
- INTEGER :: ji , jj, jk ! dummy indices
- INTEGER :: ij0, ij1 ! dummy indices
- INTEGER :: ik ! local integers
- REAL(wp) :: zfact, z1_jpkm1 ! local scalar
- REAL(wp) :: ze3min, zdepth ! local scalar
- REAL(wp), DIMENSION(jpi,jpj) :: zht , zhu ! bottom depth
- REAL(wp), DIMENSION(jpi,jpj) :: zhisf, zhisfu ! top depth
- !!----------------------------------------------------------------------
- !
- IF(lwp) WRITE(numout,*)
- IF(lwp) WRITE(numout,*) 'usr_def_zgr : ISOMIP configuration (z(ps)- or s-coordinate closed box ocean without cavities)'
- IF(lwp) WRITE(numout,*) '~~~~~~~~~~~'
- !
- !
- ! type of vertical coordinate
- ! ---------------------------
- ! set in usrdef_nam.F90 by reading the namusr_def namelist except for ISF
- ld_isfcav = .TRUE. ! ISF Ice Shelves Flag
- !
- !
- ! Build the vertical coordinate system
- ! ------------------------------------
- !
- ! !== isfdraft ==!
- !
- zht (:,:) = rbathy
- zhisf(:,:) = 200._wp
- ij0 = 1 ; ij1 = 40+nn_hls
- DO jj = mj0(ij0), mj1(ij1)
- zhisf(:,jj)=700.0_wp-(gphit(:,jj)+80.0_wp)*125.0_wp
- END DO
- !
- CALL zgr_z1d( pdept_1d, pdepw_1d, pe3t_1d , pe3w_1d ) ! Reference z-coordinate system
- !
- ! !== top masked level bathymetry ==! (all coordinates)
- !
- IF ( ld_zps ) THEN !== zps-coordinate ==! (partial bottom-steps)
- !
- ze3min = 0.1_wp * rn_e3
- IF(lwp) WRITE(numout,*) ' minimum thickness of the partial cells = 10 % of e3 = ', ze3min
- !
- ! !* bottom ocean compute from the depth of grid-points
- k_bot(:,:) = jpkm1
- DO jk = jpkm1, 1, -1
- WHERE( zht(:,:) < pdepw_1d(jk) + ze3min ) k_bot(:,:) = jk-1
- END DO
- ! !* top ocean compute from the depth of grid-points
- k_top(:,:) = 1 !
- DO jk = 2, jpkm1
- zdepth = pdepw_1d(jk+1) - ze3min
- WHERE( zhisf(:,:) > 0.0 .AND. zhisf(:,:) >= zdepth ) k_top(:,:) = (jk + 1)
- END DO
- !
- ! !* vertical coordinate system
- DO jk = 1, jpk ! initialization to the reference z-coordinate
- pdept(:,:,jk) = pdept_1d(jk)
- pdepw(:,:,jk) = pdepw_1d(jk)
- pe3t (:,:,jk) = pe3t_1d (jk)
- pe3u (:,:,jk) = pe3t_1d (jk)
- pe3v (:,:,jk) = pe3t_1d (jk)
- pe3f (:,:,jk) = pe3t_1d (jk)
- pe3w (:,:,jk) = pe3w_1d (jk)
- pe3uw(:,:,jk) = pe3w_1d (jk)
- pe3vw(:,:,jk) = pe3w_1d (jk)
- END DO
- ! top scale factors and depth at T- and W-points
- DO_2D( 1, 1, 1, 1 )
- ik = k_top(ji,jj)
- IF ( ik > 2 ) THEN
- ! pdeptw at the interface
- pdepw(ji,jj,ik ) = MAX( zhisf(ji,jj) , pdepw(ji,jj,ik) )
- ! e3t in both side of the interface
- pe3t (ji,jj,ik ) = pdepw(ji,jj,ik+1) - pdepw(ji,jj,ik)
- ! pdept in both side of the interface (from previous e3t)
- pdept(ji,jj,ik ) = pdepw(ji,jj,ik ) + pe3t (ji,jj,ik ) * 0.5_wp
- pdept(ji,jj,ik-1) = pdepw(ji,jj,ik ) - pe3t (ji,jj,ik ) * 0.5_wp
- ! pe3w on both side of the interface
- pe3w (ji,jj,ik+1) = pdept(ji,jj,ik+1) - pdept(ji,jj,ik )
- pe3w (ji,jj,ik ) = pdept(ji,jj,ik ) - pdept(ji,jj,ik-1)
- ! e3t into the ice shelf
- pe3t (ji,jj,ik-1) = pdepw(ji,jj,ik ) - pdepw(ji,jj,ik-1)
- pe3w (ji,jj,ik-1) = pdept(ji,jj,ik-1) - pdept(ji,jj,ik-2)
- END IF
- END_2D
- ! bottom scale factors and depth at T- and W-points
- DO_2D( 1, 1, 1, 1 )
- ik = k_bot(ji,jj)
- pdepw(ji,jj,ik+1) = MIN( zht(ji,jj) , pdepw_1d(ik+1) )
- pe3t (ji,jj,ik ) = pdepw(ji,jj,ik+1) - pdepw(ji,jj,ik)
- pe3t (ji,jj,ik+1) = pe3t (ji,jj,ik )
- !
- pdept(ji,jj,ik ) = pdepw(ji,jj,ik ) + pe3t (ji,jj,ik ) * 0.5_wp
- pdept(ji,jj,ik+1) = pdepw(ji,jj,ik+1) + pe3t (ji,jj,ik+1) * 0.5_wp
- pe3w (ji,jj,ik+1) = pdept(ji,jj,ik+1) - pdept(ji,jj,ik)
- END_2D
- ! ! bottom scale factors and depth at U-, V-, UW and VW-points
- pe3u (:,:,:) = pe3t(:,:,:)
- pe3uw(:,:,:) = pe3w(:,:,:)
- DO_3D( 0, 0, 0, 0, 1, jpk )
- ! ! Computed as the minimum of neighbooring scale factors
- pe3v (ji,jj,jk) = MIN( pe3t(ji,jj,jk), pe3t(ji,jj+1,jk) )
- pe3vw(ji,jj,jk) = MIN( pe3w(ji,jj,jk), pe3w(ji,jj+1,jk) )
- pe3f (ji,jj,jk) = pe3v(ji,jj,jk)
- END_3D
- CALL lbc_lnk( 'usrdef_zgr', pe3v , 'V', 1._wp ) ; CALL lbc_lnk( 'usrdef_zgr', pe3vw, 'V', 1._wp )
- CALL lbc_lnk( 'usrdef_zgr', pe3f , 'F', 1._wp )
- DO jk = 1, jpk
- ! set to z-scale factor if zero (i.e. along closed boundaries) because of lbclnk
- WHERE( pe3u (:,:,jk) == 0._wp ) pe3u (:,:,jk) = pe3t_1d(jk)
- WHERE( pe3v (:,:,jk) == 0._wp ) pe3v (:,:,jk) = pe3t_1d(jk)
- WHERE( pe3f (:,:,jk) == 0._wp ) pe3f (:,:,jk) = pe3t_1d(jk)
- WHERE( pe3uw(:,:,jk) == 0._wp ) pe3uw(:,:,jk) = pe3w_1d(jk)
- WHERE( pe3vw(:,:,jk) == 0._wp ) pe3vw(:,:,jk) = pe3w_1d(jk)
- END DO
- !
- ENDIF
- !
- END SUBROUTINE usr_def_zgr
-
-
- SUBROUTINE zgr_z1d( pdept_1d, pdepw_1d, pe3t_1d , pe3w_1d ) ! 1D reference vertical coordinate
- !!----------------------------------------------------------------------
- !! *** ROUTINE zgr_z1d ***
- !!
- !! ** Purpose : set the depth of model levels and the resulting
- !! vertical scale factors.
- !!
- !! ** Method : 1D z-coordinate system (use in all type of coordinate)
- !! The depth of model levels is set from dep(k), an analytical function:
- !! w-level: depw_1d = dep(k)
- !! t-level: dept_1d = dep(k+0.5)
- !! The scale factors are the discrete derivative of the depth:
- !! e3w_1d(jk) = dk[ dept_1d ]
- !! e3t_1d(jk) = dk[ depw_1d ]
- !!
- !! === Here constant vertical resolution ===
- !!
- !! ** Action : - pdept_1d, pdepw_1d : depth of T- and W-point (m)
- !! - pe3t_1d , pe3w_1d : scale factors at T- and W-levels (m)
- !!----------------------------------------------------------------------
- REAL(wp), DIMENSION(:), INTENT(out) :: pdept_1d, pdepw_1d ! 1D grid-point depth [m]
- REAL(wp), DIMENSION(:), INTENT(out) :: pe3t_1d , pe3w_1d ! 1D vertical scale factors [m]
- !
- INTEGER :: jk ! dummy loop indices
- REAL(wp) :: zt, zw ! local scalar
- !!----------------------------------------------------------------------
- !
- IF(lwp) THEN ! Parameter print
- WRITE(numout,*)
- WRITE(numout,*) ' zgr_z1d : Reference vertical z-coordinates: uniform dz = ', rn_e3
- WRITE(numout,*) ' ~~~~~~~'
- ENDIF
- !
- ! Reference z-coordinate (depth - scale factor at T- and W-points) ! Madec & Imbard 1996 function
- ! ----------------------
- DO jk = 1, jpk
- zw = REAL( jk , wp )
- zt = REAL( jk , wp ) + 0.5_wp
- pdepw_1d(jk) = rn_e3 * REAL( jk-1 , wp )
- pdept_1d(jk) = rn_e3 * ( REAL( jk-1 , wp ) + 0.5_wp )
- pe3w_1d (jk) = rn_e3
- pe3t_1d (jk) = rn_e3
- END DO
- !
- IF(lwp) THEN ! control print
- WRITE(numout,*)
- WRITE(numout,*) ' Reference 1D z-coordinate depth and scale factors:'
- WRITE(numout, "(9x,' level gdept_1d gdepw_1d e3t_1d e3w_1d ')" )
- WRITE(numout, "(10x, i4, 4f9.2)" ) ( jk, pdept_1d(jk), pdepw_1d(jk), pe3t_1d(jk), pe3w_1d(jk), jk = 1, jpk )
- ENDIF
- !
- END SUBROUTINE zgr_z1d
-
- !!======================================================================
-END MODULE usrdef_zgr
diff --git a/tests/ISOMIP/cpp_ISOMIP.fcm b/tests/ISOMIP/cpp_ISOMIP.fcm
deleted file mode 100644
index 4055ae28435f2ceea81e07f39f5f06ecbb0e2103..0000000000000000000000000000000000000000
--- a/tests/ISOMIP/cpp_ISOMIP.fcm
+++ /dev/null
@@ -1 +0,0 @@
- bld::tool::fppkeys key_xios
diff --git a/tests/LOCK_EXCHANGE/MY_SRC/usrdef_hgr.F90 b/tests/LOCK_EXCHANGE/MY_SRC/usrdef_hgr.F90
index 62a161477baf829e5cdc9046f3aa4567270fed3c..b4cac5c173f0d2b1a08a778aa8411ce7a0c6e129 100644
--- a/tests/LOCK_EXCHANGE/MY_SRC/usrdef_hgr.F90
+++ b/tests/LOCK_EXCHANGE/MY_SRC/usrdef_hgr.F90
@@ -75,14 +75,14 @@ CONTAINS
zfact = rn_dx * 1.e-3 ! conversion in km
DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
! ! longitude (west coast at lon=0°)
- plamt(ji,jj) = zfact * ( - 0.5 + REAL( mig0(ji)-1 , wp ) )
- plamu(ji,jj) = zfact * ( REAL( mig0(ji)-1 , wp ) )
+ plamt(ji,jj) = zfact * ( - 0.5 + REAL( mig(ji,0)-1 , wp ) )
+ plamu(ji,jj) = zfact * ( REAL( mig(ji,0)-1 , wp ) )
plamv(ji,jj) = plamt(ji,jj)
plamf(ji,jj) = plamu(ji,jj)
! ! latitude (south coast at lat= 0°)
- pphit(ji,jj) = zfact * ( - 0.5 + REAL( mjg0(jj)-1 , wp ) )
+ pphit(ji,jj) = zfact * ( - 0.5 + REAL( mjg(jj,0)-1 , wp ) )
pphiu(ji,jj) = pphit(ji,jj)
- pphiv(ji,jj) = zfact * ( REAL( mjg0(jj)-1 , wp ) )
+ pphiv(ji,jj) = zfact * ( REAL( mjg(jj,0)-1 , wp ) )
pphif(ji,jj) = pphiv(ji,jj)
END_2D
!
diff --git a/tests/LOCK_EXCHANGE/MY_SRC/usrdef_zgr.F90 b/tests/LOCK_EXCHANGE/MY_SRC/usrdef_zgr.F90
index a6b980b7f512a4de82052b9700c96964f0b138dc..2c5879eba4bfe0e8a29626efe5258d9171da7b2b 100644
--- a/tests/LOCK_EXCHANGE/MY_SRC/usrdef_zgr.F90
+++ b/tests/LOCK_EXCHANGE/MY_SRC/usrdef_zgr.F90
@@ -14,6 +14,7 @@ MODULE usrdef_zgr
!! zgr_z1d : reference 1D z-coordinate
!!---------------------------------------------------------------------
USE oce ! ocean variables
+ USE dom_oce !
USE usrdef_nam ! User defined : namelist variables
!
USE in_out_manager ! I/O manager
@@ -31,14 +32,14 @@ MODULE usrdef_zgr
!! $Id: usrdef_zgr.F90 14433 2021-02-11 08:06:49Z smasson $
!! Software governed by the CeCILL license (see ./LICENSE)
!!----------------------------------------------------------------------
-CONTAINS
-
+CONTAINS
+
SUBROUTINE usr_def_zgr( ld_zco , ld_zps , ld_sco , ld_isfcav, & ! type of vertical coordinate
+ & k_top , k_bot , & ! top & bottom ocean level
& pdept_1d, pdepw_1d, pe3t_1d , pe3w_1d , & ! 1D reference vertical coordinate
+ & pe3t , pe3u , pe3v , pe3f , & ! vertical scale factors
& pdept , pdepw , & ! 3D t & w-points depth
- & pe3t , pe3u , pe3v , pe3f , & ! vertical scale factors
- & pe3w , pe3uw , pe3vw, & ! - - -
- & k_top , k_bot ) ! top & bottom ocean level
+ & pe3w , pe3uw , pe3vw ) ! vertical scale factors
!!---------------------------------------------------------------------
!! *** ROUTINE usr_def_zgr ***
!!
@@ -47,12 +48,12 @@ CONTAINS
!!----------------------------------------------------------------------
LOGICAL , INTENT(out) :: ld_zco, ld_zps, ld_sco ! vertical coordinate flags
LOGICAL , INTENT(out) :: ld_isfcav ! under iceshelf cavity flag
+ INTEGER , DIMENSION(:,:) , INTENT(out) :: k_top, k_bot ! first & last ocean level
REAL(wp), DIMENSION(:) , INTENT(out) :: pdept_1d, pdepw_1d ! 1D grid-point depth [m]
REAL(wp), DIMENSION(:) , INTENT(out) :: pe3t_1d , pe3w_1d ! 1D grid-point depth [m]
- REAL(wp), DIMENSION(:,:,:), INTENT(out) :: pdept, pdepw ! grid-point depth [m]
- REAL(wp), DIMENSION(:,:,:), INTENT(out) :: pe3t , pe3u , pe3v , pe3f ! vertical scale factors [m]
- REAL(wp), DIMENSION(:,:,:), INTENT(out) :: pe3w , pe3uw, pe3vw ! i-scale factors
- INTEGER , DIMENSION(:,:) , INTENT(out) :: k_top, k_bot ! first & last ocean level
+ REAL(wp), DIMENSION(:,:,:), OPTIONAL, INTENT(out) :: pdept, pdepw ! grid-point depth [m]
+ REAL(wp), DIMENSION(:,:,:), OPTIONAL, INTENT(out) :: pe3t , pe3u , pe3v , pe3f ! vertical scale factors [m]
+ REAL(wp), DIMENSION(:,:,:), OPTIONAL, INTENT(out) :: pe3w , pe3uw, pe3vw ! i-scale factors
!
INTEGER :: jk ! dummy indices
REAL(wp), DIMENSION(jpi,jpj) :: z2d ! 2D workspace
@@ -93,18 +94,19 @@ CONTAINS
!
! !* bottom ocean compute from the depth of grid-points
k_bot(:,:) = jpkm1 * k_top(:,:) ! here use k_top as a land mask
- ! !* horizontally uniform coordinate (reference z-co everywhere)
- DO jk = 1, jpk
- pdept(:,:,jk) = pdept_1d(jk)
- pdepw(:,:,jk) = pdepw_1d(jk)
- pe3t (:,:,jk) = pe3t_1d (jk)
- pe3u (:,:,jk) = pe3t_1d (jk)
- pe3v (:,:,jk) = pe3t_1d (jk)
- pe3f (:,:,jk) = pe3t_1d (jk)
- pe3w (:,:,jk) = pe3w_1d (jk)
- pe3uw(:,:,jk) = pe3w_1d (jk)
- pe3vw(:,:,jk) = pe3w_1d (jk)
- END DO
+ IF( lk_vco_3d ) THEN !* horizontally uniform coordinate (reference z-co everywhere)
+ DO jk = 1, jpk
+ pdept(:,:,jk) = pdept_1d(jk)
+ pdepw(:,:,jk) = pdepw_1d(jk)
+ pe3t (:,:,jk) = pe3t_1d (jk)
+ pe3u (:,:,jk) = pe3t_1d (jk)
+ pe3v (:,:,jk) = pe3t_1d (jk)
+ pe3f (:,:,jk) = pe3t_1d (jk)
+ pe3w (:,:,jk) = pe3w_1d (jk)
+ pe3uw(:,:,jk) = pe3w_1d (jk)
+ pe3vw(:,:,jk) = pe3w_1d (jk)
+ END DO
+ ENDIF
!
END SUBROUTINE usr_def_zgr
diff --git a/tests/LOCK_EXCHANGE/cpp_LOCK_EXCHANGE.fcm b/tests/LOCK_EXCHANGE/cpp_LOCK_EXCHANGE.fcm
index 8ca0747ce0d598316f412510ac879c3ea7d74c24..6dc86985276a8ec9602ade5c093a66dede0c0359 100644
--- a/tests/LOCK_EXCHANGE/cpp_LOCK_EXCHANGE.fcm
+++ b/tests/LOCK_EXCHANGE/cpp_LOCK_EXCHANGE.fcm
@@ -1 +1 @@
- bld::tool::fppkeys key_qco key_xios
+ bld::tool::fppkeys key_qco key_vco_1d key_xios
diff --git a/tests/OVERFLOW/EXPREF/namelist_sco_FCT2_flux_cen-ahm1000_cfg b/tests/OVERFLOW/EXPREF/namelist_sco_FCT2_flux_cen-ahm1000_cfg
index 2d3c479edef5fc08ca0a7f74e330113891ef9f85..0e68fd721932e435bf6b4eedb6599daa2abde055 100644
--- a/tests/OVERFLOW/EXPREF/namelist_sco_FCT2_flux_cen-ahm1000_cfg
+++ b/tests/OVERFLOW/EXPREF/namelist_sco_FCT2_flux_cen-ahm1000_cfg
@@ -6,9 +6,6 @@
&namusr_def ! User defined : OVERFLOW configuration
!-----------------------------------------------------------------------
! ! type of vertical coordinate
- ln_zco = .false. ! z-coordinate
- ln_zps = .false. ! z-partial-step coordinate
- ln_sco = .true. ! s-coordinate
rn_dx = 1000. ! horizontal resolution [meters]
rn_dz = 20. ! vertical resolution [meters]
/
diff --git a/tests/OVERFLOW/EXPREF/namelist_sco_FCT2_flux_ubs_cfg b/tests/OVERFLOW/EXPREF/namelist_sco_FCT2_flux_ubs_cfg
index 65a70db0e0aa266749644a67bb4c264e9ed713d9..406cfd5a4d65d954046c1ff947a69c1b9f1d660f 100644
--- a/tests/OVERFLOW/EXPREF/namelist_sco_FCT2_flux_ubs_cfg
+++ b/tests/OVERFLOW/EXPREF/namelist_sco_FCT2_flux_ubs_cfg
@@ -5,10 +5,6 @@
!-----------------------------------------------------------------------
&namusr_def ! User defined : OVERFLOW configuration
!-----------------------------------------------------------------------
- ! ! type of vertical coordinate
- ln_zco = .false. ! z-coordinate
- ln_zps = .false. ! z-partial-step coordinate
- ln_sco = .true. ! s-coordinate
rn_dx = 1000. ! horizontal resolution [meters]
rn_dz = 20. ! vertical resolution [meters]
/
diff --git a/tests/OVERFLOW/EXPREF/namelist_sco_FCT4_flux_cen-ahm1000_cfg b/tests/OVERFLOW/EXPREF/namelist_sco_FCT4_flux_cen-ahm1000_cfg
index 6921fdfa569471c4596a581de7c415bdee08f270..d28129a0c5d42f25c7fc7b04d859ed4694d0f3b2 100644
--- a/tests/OVERFLOW/EXPREF/namelist_sco_FCT4_flux_cen-ahm1000_cfg
+++ b/tests/OVERFLOW/EXPREF/namelist_sco_FCT4_flux_cen-ahm1000_cfg
@@ -5,10 +5,6 @@
!-----------------------------------------------------------------------
&namusr_def ! User defined : OVERFLOW configuration
!-----------------------------------------------------------------------
- ! ! type of vertical coordinate
- ln_zco = .false. ! z-coordinate
- ln_zps = .false. ! z-partial-step coordinate
- ln_sco = .true. ! s-coordinate
rn_dx = 1000. ! horizontal resolution [meters]
rn_dz = 20. ! vertical resolution [meters]
/
diff --git a/tests/OVERFLOW/EXPREF/namelist_sco_FCT4_flux_ubs_cfg b/tests/OVERFLOW/EXPREF/namelist_sco_FCT4_flux_ubs_cfg
index 91681d5ceddf5b27a412f4e4b4c50ce960bef2b9..080a0baee725751a05b646f57b9df5bdfd853a58 100644
--- a/tests/OVERFLOW/EXPREF/namelist_sco_FCT4_flux_ubs_cfg
+++ b/tests/OVERFLOW/EXPREF/namelist_sco_FCT4_flux_ubs_cfg
@@ -5,10 +5,6 @@
!-----------------------------------------------------------------------
&namusr_def ! User defined : OVERFLOW configuration
!-----------------------------------------------------------------------
- ! ! type of vertical coordinate
- ln_zco = .false. ! z-coordinate
- ln_zps = .false. ! z-partial-step coordinate
- ln_sco = .true. ! s-coordinate
rn_dx = 1000. ! horizontal resolution [meters]
rn_dz = 20. ! vertical resolution [meters]
/
diff --git a/tests/OVERFLOW/EXPREF/namelist_zps_FCT4_flux_ubs_cfg b/tests/OVERFLOW/EXPREF/namelist_zps_FCT4_flux_ubs_cfg
index ebc351fe4be1ad15d64d8a6358705bee276a434a..5e2dfe4659d419d465f7bb9b2d3965dcabdef87b 100644
--- a/tests/OVERFLOW/EXPREF/namelist_zps_FCT4_flux_ubs_cfg
+++ b/tests/OVERFLOW/EXPREF/namelist_zps_FCT4_flux_ubs_cfg
@@ -20,9 +20,6 @@
&namusr_def ! User defined : OVERFLOW configuration
!-----------------------------------------------------------------------
! ! type of vertical coordinate
- ln_zco = .false. ! z-coordinate
- ln_zps = .true. ! z-partial-step coordinate
- ln_sco = .false. ! s-coordinate
rn_dx = 1000. ! horizontal resolution [meters]
rn_dz = 20. ! vertical resolution [meters]
/
diff --git a/tests/OVERFLOW/MY_SRC/usrdef_hgr.F90 b/tests/OVERFLOW/MY_SRC/usrdef_hgr.F90
index 0abf8552b8b9fef6f4aef3463d80b948b4724ec8..55d8d2a6125dcc9a1a86f487308ef48c265ca12d 100644
--- a/tests/OVERFLOW/MY_SRC/usrdef_hgr.F90
+++ b/tests/OVERFLOW/MY_SRC/usrdef_hgr.F90
@@ -75,14 +75,14 @@ CONTAINS
zfact = rn_dx * 1.e-3 ! conversion in km
DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
! ! longitude (west coast at lon=0°)
- plamt(ji,jj) = zfact * ( - 0.5 + REAL( mig0(ji)-1 , wp ) )
- plamu(ji,jj) = zfact * ( REAL( mig0(ji)-1 , wp ) )
+ plamt(ji,jj) = zfact * ( - 0.5 + REAL( mig(ji,0)-1 , wp ) )
+ plamu(ji,jj) = zfact * ( REAL( mig(ji,0)-1 , wp ) )
plamv(ji,jj) = plamt(ji,jj)
plamf(ji,jj) = plamu(ji,jj)
! ! latitude (south coast at lat= 0°)
- pphit(ji,jj) = zfact * ( - 0.5 + REAL( mjg0(jj)-1 , wp ) )
+ pphit(ji,jj) = zfact * ( - 0.5 + REAL( mjg(jj,0)-1 , wp ) )
pphiu(ji,jj) = pphit(ji,jj)
- pphiv(ji,jj) = zfact * ( REAL( mjg0(jj)-1 , wp ) )
+ pphiv(ji,jj) = zfact * ( REAL( mjg(jj,0)-1 , wp ) )
pphif(ji,jj) = pphiv(ji,jj)
END_2D
!
diff --git a/tests/OVERFLOW/MY_SRC/usrdef_nam.F90 b/tests/OVERFLOW/MY_SRC/usrdef_nam.F90
index 3e75682aa6c8e6c01b29dca234d3cd0dd0b1ea5c..f430a6c60e4adbf541b24baa9fb5fa50e3927801 100644
--- a/tests/OVERFLOW/MY_SRC/usrdef_nam.F90
+++ b/tests/OVERFLOW/MY_SRC/usrdef_nam.F90
@@ -13,7 +13,6 @@ MODULE usrdef_nam
!! usr_def_nam : read user defined namelist and set global domain size
!! usr_def_hgr : initialize the horizontal mesh
!!----------------------------------------------------------------------
- USE dom_oce , ONLY: ln_zco, ln_zps, ln_sco ! flag of type of coordinate
USE par_oce ! ocean space and time domain
USE phycst ! physical constants
!
@@ -58,7 +57,7 @@ CONTAINS
!
INTEGER :: ios ! Local integer
!!
- NAMELIST/namusr_def/ ln_zco, ln_zps, ln_sco, rn_dx, rn_dz
+ NAMELIST/namusr_def/ rn_dx, rn_dz
!!----------------------------------------------------------------------
!
READ ( numnam_cfg, namusr_def, IOSTAT = ios, ERR = 902 )
@@ -79,10 +78,6 @@ CONTAINS
WRITE(numout,*) 'usr_def_nam : read the user defined namelist (namusr_def) in namelist_cfg'
WRITE(numout,*) '~~~~~~~~~~~ '
WRITE(numout,*) ' Namelist namusr_def : OVERFLOW test case'
- WRITE(numout,*) ' type of vertical coordinate : '
- WRITE(numout,*) ' z-coordinate flag ln_zco = ', ln_zco
- WRITE(numout,*) ' z-partial-step coordinate flag ln_zps = ', ln_zps
- WRITE(numout,*) ' s-coordinate flag ln_sco = ', ln_sco
WRITE(numout,*) ' horizontal resolution rn_dx = ', rn_dx, ' meters'
WRITE(numout,*) ' vertical resolution rn_dz = ', rn_dz, ' meters'
WRITE(numout,*) ' OVERFLOW domain = 200 km x 3 grid-points x 2000 m'
diff --git a/tests/OVERFLOW/MY_SRC/usrdef_zgr.F90 b/tests/OVERFLOW/MY_SRC/usrdef_zgr.F90
index b39e22ab155ee6eaf7ba10d463f3edfc0205a74d..9a88ea58e0a6678fe1e608294ecf1be735e7a47b 100644
--- a/tests/OVERFLOW/MY_SRC/usrdef_zgr.F90
+++ b/tests/OVERFLOW/MY_SRC/usrdef_zgr.F90
@@ -14,8 +14,7 @@ MODULE usrdef_zgr
!! zgr_z1d : reference 1D z-coordinate
!!---------------------------------------------------------------------
USE oce ! ocean variables
- USE dom_oce , ONLY: mi0, mi1 ! ocean space and time domain
- USE dom_oce , ONLY: glamt ! ocean space and time domain
+ USE dom_oce ! ocean space and time domain
USE usrdef_nam ! User defined : namelist variables
!
USE in_out_manager ! I/O manager
@@ -38,31 +37,32 @@ MODULE usrdef_zgr
CONTAINS
SUBROUTINE usr_def_zgr( ld_zco , ld_zps , ld_sco , ld_isfcav, & ! type of vertical coordinate
+ & k_top , k_bot , & ! top & bottom ocean level
& pdept_1d, pdepw_1d, pe3t_1d , pe3w_1d , & ! 1D reference vertical coordinate
+ & pe3t , pe3u , pe3v , pe3f , & ! vertical scale factors
& pdept , pdepw , & ! 3D t & w-points depth
- & pe3t , pe3u , pe3v , pe3f , & ! vertical scale factors
- & pe3w , pe3uw , pe3vw, & ! - - -
- & k_top , k_bot ) ! top & bottom ocean level
+ & pe3w , pe3uw , pe3vw ) ! vertical scale factors
!!---------------------------------------------------------------------
!! *** ROUTINE usr_def_zgr ***
!!
!! ** Purpose : User defined the vertical coordinates
!!
!!----------------------------------------------------------------------
- LOGICAL , INTENT(in ) :: ld_zco, ld_zps, ld_sco ! vertical coordinate flags ( read in namusr_def )
- LOGICAL , INTENT( out) :: ld_isfcav ! under iceshelf cavity flag
- REAL(wp), DIMENSION(:) , INTENT( out) :: pdept_1d, pdepw_1d ! 1D grid-point depth [m]
- REAL(wp), DIMENSION(:) , INTENT( out) :: pe3t_1d , pe3w_1d ! 1D grid-point depth [m]
- REAL(wp), DIMENSION(:,:,:), INTENT( out) :: pdept, pdepw ! grid-point depth [m]
- REAL(wp), DIMENSION(:,:,:), INTENT( out) :: pe3t , pe3u , pe3v , pe3f ! vertical scale factors [m]
- REAL(wp), DIMENSION(:,:,:), INTENT( out) :: pe3w , pe3uw, pe3vw ! i-scale factors
- INTEGER , DIMENSION(:,:) , INTENT( out) :: k_top, k_bot ! first & last ocean level
+ LOGICAL , INTENT(out) :: ld_zco, ld_zps, ld_sco ! vertical coordinate flags
+ LOGICAL , INTENT(out) :: ld_isfcav ! under iceshelf cavity flag
+ INTEGER , DIMENSION(:,:) , INTENT(out) :: k_top, k_bot ! first & last ocean level
+ REAL(wp), DIMENSION(:) , INTENT(out) :: pdept_1d, pdepw_1d ! 1D grid-point depth [m]
+ REAL(wp), DIMENSION(:) , INTENT(out) :: pe3t_1d , pe3w_1d ! 1D grid-point depth [m]
+ REAL(wp), DIMENSION(:,:,:), OPTIONAL, INTENT(out) :: pdept, pdepw ! grid-point depth [m]
+ REAL(wp), DIMENSION(:,:,:), OPTIONAL, INTENT(out) :: pe3t , pe3u , pe3v , pe3f ! vertical scale factors [m]
+ REAL(wp), DIMENSION(:,:,:), OPTIONAL, INTENT(out) :: pe3w , pe3uw, pe3vw ! i-scale factors
!
INTEGER :: ji, jj, jk ! dummy indices
INTEGER :: ik ! local integers
REAL(wp) :: zfact, z1_jpkm1 ! local scalar
REAL(wp) :: ze3min ! local scalar
REAL(wp), DIMENSION(jpi,jpj) :: zht, zhu, z2d ! 2D workspace
+ REAL(wp), DIMENSION(A2D(nn_hls), jpk) :: zdepw ! 3D workspace !!st a mettre en ALLOCATABLE
!!----------------------------------------------------------------------
!
IF(lwp) WRITE(numout,*)
@@ -74,7 +74,9 @@ CONTAINS
! ---------------------------
! already set in usrdef_nam.F90 by reading the namusr_def namelist except for ISF
ld_isfcav = .FALSE.
- !
+ ld_zco = .FALSE.
+ ld_zps = .FALSE.
+ ld_sco = .TRUE.
!
! Build the vertical coordinate system
! ------------------------------------
@@ -89,19 +91,11 @@ CONTAINS
zht(:,:) = + ( 500. + 0.5 * 1500. * ( 1.0 + tanh( (glamt(:,:) - 40.) / 7. ) ) )
!
! at u-point: averaging zht
- DO_2D( 0, 0, 0, 0 )
+ DO_2D( nn_hls, nn_hls-1, nn_hls, nn_hls )
zhu(ji,jj) = 0.5_wp * ( zht(ji,jj) + zht(ji+1,jj) )
END_2D
CALL lbc_lnk( 'usrdef_zgr', zhu, 'U', 1. ) ! boundary condition: this mask the surrouding grid-points
! ! ==>>> set by hand non-zero value on first/last columns & rows
- DO ji = mi0(1), mi1(1) ! first row of global domain only
- zhu(ji,2) = zht(ji,2)
- END DO
- DO ji = mi0(jpiglo), mi1(jpiglo) ! last row of global domain only
- zhu(ji,2) = zht(ji,2)
- END DO
- zhu(:,1) = zhu(:,2)
- zhu(:,3) = zhu(:,2)
!
CALL zgr_z1d( pdept_1d, pdepw_1d, pe3t_1d , pe3w_1d ) ! Reference z-coordinate system
!
@@ -116,50 +110,91 @@ CONTAINS
!
!
!
- IF ( ld_sco ) THEN !== s-coordinate ==! (terrain-following coordinate)
+ IF( lk_vco_3d ) THEN !== s-coordinate ==! (terrain-following coordinate)
!
- k_bot(:,:) = jpkm1 * k_top(:,:) !* bottom ocean = jpk-1 (here use k_top as a land mask)
- !
- ! !* terrain-following coordinate with e3.(k)=cst)
- ! ! OVERFLOW case : identical with j-index (T=V, U=F)
- z1_jpkm1 = 1._wp / REAL( jpkm1 , wp)
- DO jk = 1, jpk
- pdept(:,:,jk) = zht(:,:) * z1_jpkm1 * ( REAL( jk , wp ) - 0.5_wp )
- pdepw(:,:,jk) = zht(:,:) * z1_jpkm1 * ( REAL( jk-1 , wp ) )
- pe3t (:,:,jk) = zht(:,:) * z1_jpkm1
- pe3u (:,:,jk) = zhu(:,:) * z1_jpkm1
- pe3v (:,:,jk) = zht(:,:) * z1_jpkm1
- pe3f (:,:,jk) = zhu(:,:) * z1_jpkm1
- pe3w (:,:,jk) = zht(:,:) * z1_jpkm1
- pe3uw(:,:,jk) = zhu(:,:) * z1_jpkm1
- pe3vw(:,:,jk) = zht(:,:) * z1_jpkm1
- END DO
+ IF( ld_sco ) THEN
+ !
+ k_bot(:,:) = jpkm1 * k_top(:,:) !* bottom ocean = jpk-1 (here use k_top as a land mask)
+ !
+ ! !* terrain-following coordinate with e3.(k)=cst)
+ ! ! OVERFLOW case : identical with j-index (T=V, U=F)
+ z1_jpkm1 = 1._wp / REAL( jpkm1 , wp)
+ DO jk = 1, jpk
+ pdept(:,:,jk) = zht(:,:) * z1_jpkm1 * ( REAL( jk , wp ) - 0.5_wp )
+ pdepw(:,:,jk) = zht(:,:) * z1_jpkm1 * ( REAL( jk-1 , wp ) )
+ pe3t (:,:,jk) = zht(:,:) * z1_jpkm1
+ pe3u (:,:,jk) = zhu(:,:) * z1_jpkm1
+ pe3v (:,:,jk) = zht(:,:) * z1_jpkm1
+ pe3f (:,:,jk) = zhu(:,:) * z1_jpkm1
+ pe3w (:,:,jk) = zht(:,:) * z1_jpkm1
+ pe3uw(:,:,jk) = zhu(:,:) * z1_jpkm1
+ pe3vw(:,:,jk) = zht(:,:) * z1_jpkm1
+ END DO
+ !
+ ELSEIF( ld_zco ) THEN
+ k_bot(:,:) = jpkm1 * k_top(:,:) ! here use k_top as a land mask
+ DO jk = 1, jpkm1
+ WHERE( pdept_1d(jk) < zht(:,:) .AND. zht(:,:) <= pdept_1d(jk+1) ) k_bot(:,:) = jk * k_top(:,:)
+ END DO
+ ! !* horizontally uniform coordinate (reference z-co everywhere)
+ DO jk = 1, jpk
+ pdept(:,:,jk) = pdept_1d(jk)
+ pdepw(:,:,jk) = pdepw_1d(jk)
+ pe3t (:,:,jk) = pe3t_1d (jk)
+ pe3u (:,:,jk) = pe3t_1d (jk)
+ pe3v (:,:,jk) = pe3t_1d (jk)
+ pe3f (:,:,jk) = pe3t_1d (jk)
+ pe3w (:,:,jk) = pe3w_1d (jk)
+ pe3uw(:,:,jk) = pe3w_1d (jk)
+ pe3vw(:,:,jk) = pe3w_1d (jk)
+ END DO
+ ELSEIF( ld_zps ) THEN
+ k_bot(:,:) = jpkm1 * k_top(:,:) ! here use k_top as a land mask
+ DO jk = 1, jpkm1
+ WHERE( pdept_1d(jk) < zht(:,:) .AND. zht(:,:) <= pdept_1d(jk+1) ) k_bot(:,:) = jk * k_top(:,:)
+ END DO
+ ! !* horizontally uniform coordinate (reference z-co everywhere)
+ DO jk = 1, jpk
+ pdept(:,:,jk) = pdept_1d(jk)
+ pdepw(:,:,jk) = pdepw_1d(jk)
+ pe3w (:,:,jk) = pe3w_1d (jk)
+ pe3uw(:,:,jk) = pe3w_1d (jk)
+ pe3vw(:,:,jk) = pe3w_1d (jk)
+ END DO
+ !
+ DO jk = 1, jpk ! initialization to the reference z-coordinate
+ pe3t (:,:,jk) = pe3t_1d (jk)
+ pe3u (:,:,jk) = pe3t_1d (jk)
+ pe3v (:,:,jk) = pe3t_1d (jk)
+ pe3f (:,:,jk) = pe3t_1d (jk)
+ END DO
+ DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ ik = k_bot(ji,jj)
+ zdepw(ji,jj,ik+1) = MIN( zht(ji,jj) , pdepw_1d(ik+1) )
+ pe3t (ji,jj,ik ) = zdepw(ji,jj,ik+1) - zdepw(ji,jj,ik)
+ pe3t (ji,jj,ik+1) = pe3t (ji,jj,ik )
+ END_2D
+ ! ! bottom scale factors and depth at U-, V-, UW and VW-points
+ ! ! usually Computed as the minimum of neighbooring scale factors
+ pe3u (:,:,:) = pe3t(:,:,:) ! HERE OVERFLOW configuration :
+ pe3v (:,:,:) = pe3t(:,:,:) ! e3 increases with i-index and identical with j-index
+ pe3f (:,:,:) = pe3t(:,:,:) ! so e3 minimum of (i,i+1) points is (i) point in j-direction e3v=e3t and e3f=e3v
+ ! ! ==>> no need of lbc_lnk calls
+ ENDIF
ENDIF
!
!
- IF ( ld_zco ) THEN !== z-coordinate ==! (step-like topography)
+ IF( lk_vco_1d ) THEN !== z-coordinate ==! (step-like topography)
!
! !* bottom ocean compute from the depth of grid-points
k_bot(:,:) = jpkm1 * k_top(:,:) ! here use k_top as a land mask
DO jk = 1, jpkm1
WHERE( pdept_1d(jk) < zht(:,:) .AND. zht(:,:) <= pdept_1d(jk+1) ) k_bot(:,:) = jk * k_top(:,:)
END DO
- ! !* horizontally uniform coordinate (reference z-co everywhere)
- DO jk = 1, jpk
- pdept(:,:,jk) = pdept_1d(jk)
- pdepw(:,:,jk) = pdepw_1d(jk)
- pe3t (:,:,jk) = pe3t_1d (jk)
- pe3u (:,:,jk) = pe3t_1d (jk)
- pe3v (:,:,jk) = pe3t_1d (jk)
- pe3f (:,:,jk) = pe3t_1d (jk)
- pe3w (:,:,jk) = pe3w_1d (jk)
- pe3uw(:,:,jk) = pe3w_1d (jk)
- pe3vw(:,:,jk) = pe3w_1d (jk)
- END DO
ENDIF
!
!
- IF ( ld_zps ) THEN !== zps-coordinate ==! (partial bottom-steps)
+ IF( lk_vco_1d3d ) THEN !== zps-coordinate ==! (partial bottom-steps)
!
ze3min = 0.1_wp * rn_dz
IF(lwp) WRITE(numout,*) ' minimum thickness of the partial cells = 10 % of e3 = ', ze3min
@@ -171,37 +206,33 @@ CONTAINS
WHERE( zht(:,:) < pdepw_1d(jk) + ze3min ) k_bot(:,:) = jk-1
END DO
!
- ! !* vertical coordinate system
- DO jk = 1, jpk ! initialization to the reference z-coordinate
- pdept(:,:,jk) = pdept_1d(jk)
- pdepw(:,:,jk) = pdepw_1d(jk)
- pe3t (:,:,jk) = pe3t_1d (jk)
- pe3u (:,:,jk) = pe3t_1d (jk)
- pe3v (:,:,jk) = pe3t_1d (jk)
- pe3f (:,:,jk) = pe3t_1d (jk)
- pe3w (:,:,jk) = pe3w_1d (jk)
- pe3uw(:,:,jk) = pe3w_1d (jk)
- pe3vw(:,:,jk) = pe3w_1d (jk)
- END DO
- DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
- ik = k_bot(ji,jj)
- pdepw(ji,jj,ik+1) = MIN( zht(ji,jj) , pdepw_1d(ik+1) )
- pe3t (ji,jj,ik ) = pdepw(ji,jj,ik+1) - pdepw(ji,jj,ik)
- pe3t (ji,jj,ik+1) = pe3t (ji,jj,ik )
- !
- pdept(ji,jj,ik ) = pdepw(ji,jj,ik ) + pe3t (ji,jj,ik ) * 0.5_wp
- pdept(ji,jj,ik+1) = pdepw(ji,jj,ik+1) + pe3t (ji,jj,ik+1) * 0.5_wp
- pe3w (ji,jj,ik+1) = pdept(ji,jj,ik+1) - pdept(ji,jj,ik) ! = pe3t (ji,jj,ik )
- pe3w (ji,jj,ik ) = pdept(ji,jj,ik ) - pdept(ji,jj,ik-1) ! st caution ik > 1
- END_2D
- ! ! bottom scale factors and depth at U-, V-, UW and VW-points
- ! ! usually Computed as the minimum of neighbooring scale factors
- pe3u (:,:,:) = pe3t(:,:,:) ! HERE OVERFLOW configuration :
- pe3v (:,:,:) = pe3t(:,:,:) ! e3 increases with i-index and identical with j-index
- pe3f (:,:,:) = pe3t(:,:,:) ! so e3 minimum of (i,i+1) points is (i) point
- pe3uw(:,:,:) = pe3w(:,:,:) ! in j-direction e3v=e3t and e3f=e3v
- pe3vw(:,:,:) = pe3w(:,:,:) ! ==>> no need of lbc_lnk calls
- !
+ IF( ld_zps ) THEN !* vertical coordinate system
+ DO jk = 1, jpk ! initialization to the reference z-coordinate
+ pe3t (:,:,jk) = pe3t_1d (jk)
+ pe3u (:,:,jk) = pe3t_1d (jk)
+ pe3v (:,:,jk) = pe3t_1d (jk)
+ pe3f (:,:,jk) = pe3t_1d (jk)
+ END DO
+ DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
+ ik = k_bot(ji,jj)
+ zdepw(ji,jj,ik+1) = MIN( zht(ji,jj) , pdepw_1d(ik+1) )
+ pe3t (ji,jj,ik ) = zdepw(ji,jj,ik+1) - zdepw(ji,jj,ik)
+ pe3t (ji,jj,ik+1) = pe3t (ji,jj,ik )
+ END_2D
+ ! ! bottom scale factors and depth at U-, V-, UW and VW-points
+ ! ! usually Computed as the minimum of neighbooring scale factors
+ pe3u (:,:,:) = pe3t(:,:,:) ! HERE OVERFLOW configuration :
+ pe3v (:,:,:) = pe3t(:,:,:) ! e3 increases with i-index and identical with j-index
+ pe3f (:,:,:) = pe3t(:,:,:) ! so e3 minimum of (i,i+1) points is (i) point in j-direction e3v=e3t and e3f=e3v
+ ! ! ==>> no need of lbc_lnk calls
+ ELSEIF( ld_zco ) THEN
+ DO jk = 1, jpk ! initialization to the reference z-coordinate
+ pe3t (:,:,jk) = pe3t_1d (jk)
+ pe3u (:,:,jk) = pe3t_1d (jk)
+ pe3v (:,:,jk) = pe3t_1d (jk)
+ pe3f (:,:,jk) = pe3t_1d (jk)
+ END DO
+ ENDIF
ENDIF
!
END SUBROUTINE usr_def_zgr
@@ -262,3 +293,4 @@ CONTAINS
!!======================================================================
END MODULE usrdef_zgr
+
diff --git a/tests/OVERFLOW/cpp_OVERFLOW.fcm b/tests/OVERFLOW/cpp_OVERFLOW.fcm
index ef35582cf5e19734c05df69491e6e176774b17bc..9abfe31eacbc588c8ea145ffcb7e6c7bc1f0d5c1 100644
--- a/tests/OVERFLOW/cpp_OVERFLOW.fcm
+++ b/tests/OVERFLOW/cpp_OVERFLOW.fcm
@@ -1 +1 @@
-bld::tool::fppkeys key_qco key_xios
+bld::tool::fppkeys key_qco key_vco_3d key_xios
diff --git a/tests/STATION_ASF/MY_SRC/icesbc.F90 b/tests/STATION_ASF/MY_SRC/icesbc.F90
index 644ad0cfb5607f8dfd1f8c05e880e0650a8c5437..b6a19b82fa29a47ff688e5f14bdda3196292e3cf 100644
--- a/tests/STATION_ASF/MY_SRC/icesbc.F90
+++ b/tests/STATION_ASF/MY_SRC/icesbc.F90
@@ -75,10 +75,9 @@ CONTAINS
CALL usrdef_sbc_ice_tau( kt ) ! user defined formulation
!
CASE( jp_blk )
- CALL blk_ice_1( sf(jp_wndi)%fnow(:,:,1), sf(jp_wndj)%fnow(:,:,1), &
- & theta_air_zt(:,:), q_air_zt(:,:), & ! #LB: known from "sbc_oce" module...
- & sf(jp_slp )%fnow(:,:,1), u_ice, v_ice, tm_su , & ! inputs
- & putaui = utau_ice, pvtaui = vtau_ice ) ! outputs
+ CALL blk_ice_1( sf(jp_wndi)%fnow(:,:,1), sf(jp_wndj)%fnow(:,:,1), theta_air_zt(:,:), q_air_zt(:,:), & ! <<== in
+ & sf(jp_slp )%fnow(:,:,1), tm_su(:,:), & ! <<== in
+ & putaui=utau_ice(A2D(0)), pvtaui=vtau_ice(A2D(0)) ) ! ==>> out
! CASE( jp_abl ) utau_ice & vtau_ice are computed in ablmod
CASE( jp_purecpl )
CALL sbc_cpl_ice_tau( utau_ice , vtau_ice ) ! Coupled formulation
@@ -152,13 +151,13 @@ CONTAINS
& sf(jp_slp)%fnow(:,:,1), sf(jp_qlw)%fnow(:,:,1), &
& sf(jp_prec)%fnow(:,:,1), sf(jp_snow)%fnow(:,:,1) )
!
- IF( ln_mixcpl ) CALL sbc_cpl_ice_flx( picefr=at_i_b, palbi=alb_ice, psst=sst_m, pist=t_su, phs=h_s, phi=h_i )
+ IF( ln_mixcpl ) CALL sbc_cpl_ice_flx( kt, picefr=at_i_b, palbi=alb_ice, psst=sst_m, pist=t_su, phs=h_s, phi=h_i )
IF( nn_flxdist /= -1 ) CALL ice_flx_dist ( t_su, alb_ice, qns_ice, qsr_ice, dqns_ice, evap_ice, devap_ice, nn_flxdist )
! ! compute conduction flux and surface temperature (as in Jules surface module)
IF( ln_cndflx .AND. .NOT.ln_cndemulate ) &
& CALL blk_ice_qcn ( ln_virtual_itd, t_su, t_bo, h_s, h_i )
CASE ( jp_purecpl ) !--- coupled formulation
- CALL sbc_cpl_ice_flx( picefr=at_i_b, palbi=alb_ice, psst=sst_m, pist=t_su, phs=h_s, phi=h_i )
+ CALL sbc_cpl_ice_flx( kt, picefr=at_i_b, palbi=alb_ice, psst=sst_m, pist=t_su, phs=h_s, phi=h_i )
IF( nn_flxdist /= -1 ) CALL ice_flx_dist ( t_su, alb_ice, qns_ice, qsr_ice, dqns_ice, evap_ice, devap_ice, nn_flxdist )
END SELECT
diff --git a/tests/STATION_ASF/MY_SRC/icestp.F90 b/tests/STATION_ASF/MY_SRC/icestp.F90
index a6ef6521ed7556b217d4f38b673a582b6c07a323..b0cb0aa0f721a8917fc92671f62eb4d8b243d407 100644
--- a/tests/STATION_ASF/MY_SRC/icestp.F90
+++ b/tests/STATION_ASF/MY_SRC/icestp.F90
@@ -102,7 +102,7 @@ CONTAINS
INTEGER, INTENT(in) :: Kbb, Kmm ! ocean time level indices
INTEGER, INTENT(in) :: ksbc ! flux formulation (user defined, bulk, or Pure Coupled)
!
- INTEGER :: jl ! dummy loop index
+ INTEGER :: ji, jj, jl ! dummy loop index
!!----------------------------------------------------------------------
!
IF( ln_timing ) CALL timing_start('ice_stp')
@@ -116,8 +116,10 @@ CONTAINS
u_oce(:,:) = ssu_m(:,:) ! -- mean surface ocean current
v_oce(:,:) = ssv_m(:,:)
!
- CALL eos_fzp( sss_m(:,:) , t_bo(:,:) ) ! -- freezing temperature [Kelvin] (set to rt0 over land)
- t_bo(:,:) = ( t_bo(:,:) + rt0 ) * tmask(:,:,1) + rt0 * ( 1._wp - tmask(:,:,1) )
+ CALL eos_fzp( sss_m(:,:), t_bo(:,:), kbnd=0 ) ! -- freezing temperature [Kelvin] (set to rt0 over land)
+ DO_2D( 0, 0, 0, 0 )
+ t_bo(ji,jj) = ( t_bo(ji,jj) + rt0 ) * tmask(ji,jj,1) + rt0 * ( 1._wp - tmask(ji,jj,1) )
+ END_2D
!
!
!------------------------------------------------!
diff --git a/tests/STATION_ASF/MY_SRC/stpctl.F90 b/tests/STATION_ASF/MY_SRC/stpctl.F90
index c51b350411df9c704245f23b616ec899dc5af078..29ac3941b6775277701112561dafe1551e46989c 100644
--- a/tests/STATION_ASF/MY_SRC/stpctl.F90
+++ b/tests/STATION_ASF/MY_SRC/stpctl.F90
@@ -74,8 +74,8 @@ CONTAINS
IF( nstop > 0 .AND. ngrdstop > -1 ) RETURN ! stpctl was already called by a child grid
!
ll_wrtstp = ( MOD( kt-nit000, sn_cfctl%ptimincr ) == 0 ) .OR. ( kt == nitend )
- ll_colruns = ll_wrtstp .AND. sn_cfctl%l_runstat .AND. jpnij > 1
- ll_wrtruns = ( ll_colruns .OR. jpnij == 1 ) .AND. lwm
+ ll_colruns = sn_cfctl%l_runstat .AND. ll_wrtstp .AND. jpnij > 1
+ ll_wrtruns = sn_cfctl%l_runstat .AND. ll_wrtstp .AND. lwm
!
IF( kt == nit000 ) THEN
!
@@ -121,8 +121,8 @@ CONTAINS
!
ll_0oce = .NOT. ANY( llmsk(:,:) ) ! no ocean point in the inner domain?
!
- zmax(1) = MAXVAL( taum(:,:) , mask = llmsk ) ! max wind stress module
- zmax(2) = MAXVAL( ABS( qns(:,:) ), mask = llmsk ) ! max non-solar heat flux
+ zmax(1) = MAXVAL( taum(:,:) , mask = llmsk(A2D(0)) ) ! max wind stress module
+ zmax(2) = MAXVAL( ABS( qns(:,:) ), mask = llmsk(A2D(0)) ) ! max non-solar heat flux
zmax(3) = MAXVAL( ABS( emp(:,:) ), mask = llmsk ) ! max E-P
zmax(jpvar+1) = REAL( nstop, wp ) ! stop indicator
!
@@ -159,9 +159,9 @@ CONTAINS
! first: close the netcdf file, so we can read it
IF( lwm .AND. kt /= nitend ) istatus = NF90_CLOSE(nrunid)
! get global loc on the min/max
- CALL mpp_maxloc( 'stpctl', taum(:,:) , llmsk, zzz, iloc(1:2,1) ) ! mpp_maxloc ok if mask = F
- CALL mpp_maxloc( 'stpctl',ABS( qns(:,:) ), llmsk, zzz, iloc(1:2,2) )
- CALL mpp_minloc( 'stpctl',ABS( emp(:,:) ), llmsk, zzz, iloc(1:2,3) )
+ CALL mpp_maxloc( 'stpctl', taum(:,:) , llmsk(A2D(0)), zzz, iloc(1:2,1) ) ! mpp_maxloc ok if mask = F
+ CALL mpp_maxloc( 'stpctl',ABS( qns(:,:) ), llmsk(A2D(0)), zzz, iloc(1:2,2) )
+ CALL mpp_minloc( 'stpctl',ABS( emp(:,:) ), llmsk , zzz, iloc(1:2,3) )
! find which subdomain has the max.
iareamin(:) = jpnij+1 ; iareamax(:) = 0 ; iareasum(:) = 0
DO ji = 1, jptst
@@ -174,11 +174,11 @@ CONTAINS
CALL mpp_sum( "stpctl", iareasum ) ! sum over the global domain
ELSE ! find local min and max locations:
! if we are here, this means that the subdomain contains some oce points -> no need to test the mask used in maxloc
- iloc(1:2,1) = MAXLOC( taum(:,:) , mask = llmsk )
- iloc(1:2,2) = MAXLOC( ABS( qns(:,:) ), mask = llmsk )
- iloc(1:2,3) = MINLOC( ABS( emp(:,:) ), mask = llmsk )
+ iloc(1:2,1) = MAXLOC( taum(:,:) , mask = llmsk(A2D(0)) )
+ iloc(1:2,2) = MAXLOC( ABS( qns(:,:) ), mask = llmsk(A2D(0)) )
+ iloc(1:2,3) = MINLOC( ABS( emp(:,:) ), mask = llmsk )
DO ji = 1, jptst ! local domain indices ==> global domain indices, excluding halos
- iloc(1:2,ji) = (/ mig0(iloc(1,ji)), mjg0(iloc(2,ji)) /)
+ iloc(1:2,ji) = (/ mig(iloc(1,ji),0), mjg(iloc(2,ji),0) /)
END DO
iareamin(:) = narea ; iareamax(:) = narea ; iareasum(:) = 1 ! this is local information
ENDIF
@@ -196,11 +196,11 @@ CONTAINS
CALL dia_wri_state( Kmm, 'output.abort' ) ! create an output.abort file
!
IF( ll_colruns .OR. jpnij == 1 ) THEN ! all processes synchronized -> use lwp to print in opened ocean.output files
- IF(lwp) THEN ; CALL ctl_stop( ctmp1, ' ', ctmp2, ctmp3, ctmp4, ctmp5, ' ', ctmp6 )
+ IF(lwp) THEN ; CALL ctl_stop( ctmp1, ' ', ctmp2, ctmp3, ctmp4, ' ', ctmp6 )
ELSE ; nstop = MAX(1, nstop) ! make sure nstop > 0 (automatically done when calling ctl_stop)
ENDIF
ELSE ! only mpi subdomains with errors are here -> STOP now
- CALL ctl_stop( 'STOP', ctmp1, ' ', ctmp2, ctmp3, ctmp4, ctmp5, ' ', ctmp6 )
+ CALL ctl_stop( 'STOP', ctmp1, ' ', ctmp2, ctmp3, ctmp4, ' ', ctmp6 )
ENDIF
!
ENDIF
diff --git a/tests/STATION_ASF/MY_SRC/usrdef_hgr.F90 b/tests/STATION_ASF/MY_SRC/usrdef_hgr.F90
index 65d186a5be42264facc748ed403f1ab2cae91198..199dce11f323fa08fd2b5b3467d7a5ccf5952c67 100644
--- a/tests/STATION_ASF/MY_SRC/usrdef_hgr.F90
+++ b/tests/STATION_ASF/MY_SRC/usrdef_hgr.F90
@@ -13,7 +13,6 @@ MODULE usrdef_hgr
!!----------------------------------------------------------------------
!! usr_def_hgr : initialize the horizontal mesh
!!----------------------------------------------------------------------
- USE dom_oce , ONLY: nimpp, njmpp ! ocean space and time domain
USE c1d , ONLY: rn_lon1d, rn_lat1d ! ocean lon/lat define by namelist
USE par_oce ! ocean space and time domain
USE phycst ! physical constants
diff --git a/tests/STATION_ASF/MY_SRC/usrdef_nam.F90 b/tests/STATION_ASF/MY_SRC/usrdef_nam.F90
index fda9175c2fe7d013006c4dbf0400440518bde157..b16e928502e23c493acda8bb985d5b0a4dc3f57d 100644
--- a/tests/STATION_ASF/MY_SRC/usrdef_nam.F90
+++ b/tests/STATION_ASF/MY_SRC/usrdef_nam.F90
@@ -14,7 +14,6 @@ MODULE usrdef_nam
!! usr_def_nam : read user defined namelist and set global domain size
!! usr_def_hgr : initialize the horizontal mesh
!!----------------------------------------------------------------------
- USE dom_oce , ONLY: nimpp, njmpp ! ocean space and time domain
USE par_oce ! ocean space and time domain
USE phycst ! physical constants
!
diff --git a/tests/SWG/EXPREF/file_def_nemo-oce.xml b/tests/SWG/EXPREF/file_def_nemo-oce.xml
index fb16bbbd5abcd9873c2bbb7356a437604f2564bd..3b1c4d50b1da28e119c57f856dc623c5651651f5 100644
--- a/tests/SWG/EXPREF/file_def_nemo-oce.xml
+++ b/tests/SWG/EXPREF/file_def_nemo-oce.xml
@@ -27,6 +27,8 @@
<field field_ref="sKE" name="sKE" operation = "instant" />
<field field_ref="ssh" name="sossheig" operation = "instant" />
<field field_ref="wetdep" name="hswe_wd" operation = "instant" />
+ <field field_ref="utau" name="sozotaux" operation = "instant" />
+ <field field_ref="vtau" name="sometauy" operation = "instant" />
</file>
<file id="file2" name_suffix="_grid_U" description="ocean U grid variables" >
@@ -34,7 +36,6 @@
<field field_ref="e3u_0" name="e3u_0" operation = "instant" />
<field field_ref="hu" name="hu" operation = "instant" />
<field field_ref="ssu" name="ssu" operation = "instant" />
- <field field_ref="utau" name="sozotaux" operation = "instant" />
</file>
<file id="file3" name_suffix="_grid_V" description="ocean V grid variables" >
@@ -42,7 +43,6 @@
<field field_ref="e3v_0" name="e3v_0" operation = "instant" />
<field field_ref="hv" name="hv" operation = "instant" />
<field field_ref="ssv" name="ssv" operation = "instant" />
- <field field_ref="vtau" name="sometauy" operation = "instant" />
</file>
<file id="file5" name_suffix="_grid_F" description="ocean F grid variables" >
diff --git a/tests/SWG/MY_SRC/usrdef_fmask.F90 b/tests/SWG/MY_SRC/usrdef_fmask.F90
index 014180924d3278374617df69cf3ce38eee13e865..6ad45ee16aab6edb5d60c5558acdfaa390ccf764 100644
--- a/tests/SWG/MY_SRC/usrdef_fmask.F90
+++ b/tests/SWG/MY_SRC/usrdef_fmask.F90
@@ -68,22 +68,22 @@ CONTAINS
!
IF(lwp) WRITE(numout,*) ' Gibraltar '
ij0 = 101 ; ij1 = 101 ! Gibraltar strait : partial slip (pfmsk=0.5)
- ii0 = 139 ; ii1 = 140 ; pfmsk( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , 1:jpk ) = 0.5_wp
+ ii0 = 139 ; ii1 = 140 ; pfmsk( mi0(ii0,nn_hls):mi1(ii1,nn_hls) , mj0(ij0,nn_hls):mj1(ij1,nn_hls) , 1:jpk ) = 0.5_wp
ij0 = 102 ; ij1 = 102
- ii0 = 139 ; ii1 = 140 ; pfmsk( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , 1:jpk ) = 0.5_wp
+ ii0 = 139 ; ii1 = 140 ; pfmsk( mi0(ii0,nn_hls):mi1(ii1,nn_hls) , mj0(ij0,nn_hls):mj1(ij1,nn_hls) , 1:jpk ) = 0.5_wp
!
IF(lwp) WRITE(numout,*) ' Bab el Mandeb '
ij0 = 87 ; ij1 = 88 ! Bab el Mandeb : partial slip (pfmsk=1)
- ii0 = 160 ; ii1 = 160 ; pfmsk( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , 1:jpk ) = 1._wp
+ ii0 = 160 ; ii1 = 160 ; pfmsk( mi0(ii0,nn_hls):mi1(ii1,nn_hls) , mj0(ij0,nn_hls):mj1(ij1,nn_hls) , 1:jpk ) = 1._wp
ij0 = 88 ; ij1 = 88
- ii0 = 159 ; ii1 = 159 ; pfmsk( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , 1:jpk ) = 1._wp
+ ii0 = 159 ; ii1 = 159 ; pfmsk( mi0(ii0,nn_hls):mi1(ii1,nn_hls) , mj0(ij0,nn_hls):mj1(ij1,nn_hls) , 1:jpk ) = 1._wp
!
! We keep this as an example but it is instable in this case
!IF(lwp) WRITE(numout,*) ' Danish straits '
! ij0 = 115 ; ij1 = 115 ! Danish straits : strong slip (pfmsk > 2)
- ! ii0 = 145 ; ii1 = 146 ; pfmsk( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , 1:jpk ) = 4._wp
+ ! ii0 = 145 ; ii1 = 146 ; pfmsk( mi0(ii0,nn_hls):mi1(ii1,nn_hls) , mj0(ij0,nn_hls):mj1(ij1,nn_hls) , 1:jpk ) = 4._wp
! ij0 = 116 ; ij1 = 116
- ! ii0 = 145 ; ii1 = 146 ; pfmsk( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , 1:jpk ) = 4._wp
+ ! ii0 = 145 ; ii1 = 146 ; pfmsk( mi0(ii0,nn_hls):mi1(ii1,nn_hls) , mj0(ij0,nn_hls):mj1(ij1,nn_hls) , 1:jpk ) = 4._wp
!
CASE( 1 ) ! R1 case
IF(lwp) WRITE(numout,*)
@@ -99,35 +99,35 @@ CONTAINS
IF(lwp) WRITE(numout,*) ' orca_r1: increase friction near the following straits : '
IF(lwp) WRITE(numout,*) ' Gibraltar '
ii0 = 282 ; ii1 = 283 ! Gibraltar Strait
- ij0 = 241 - isrow ; ij1 = 241 - isrow ; pfmsk( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp
+ ij0 = 241 - isrow ; ij1 = 241 - isrow ; pfmsk( mi0(ii0,nn_hls):mi1(ii1,nn_hls),mj0(ij0,nn_hls):mj1(ij1,nn_hls),1:jpk ) = 2._wp
!
IF(lwp) WRITE(numout,*) ' Bhosporus '
ii0 = 314 ; ii1 = 315 ! Bhosporus Strait
- ij0 = 248 - isrow ; ij1 = 248 - isrow ; pfmsk( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp
+ ij0 = 248 - isrow ; ij1 = 248 - isrow ; pfmsk( mi0(ii0,nn_hls):mi1(ii1,nn_hls),mj0(ij0,nn_hls):mj1(ij1,nn_hls),1:jpk ) = 2._wp
!
IF(lwp) WRITE(numout,*) ' Makassar (Top) '
ii0 = 48 ; ii1 = 48 ! Makassar Strait (Top)
- ij0 = 189 - isrow ; ij1 = 190 - isrow ; pfmsk( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 3._wp
+ ij0 = 189 - isrow ; ij1 = 190 - isrow ; pfmsk( mi0(ii0,nn_hls):mi1(ii1,nn_hls),mj0(ij0,nn_hls):mj1(ij1,nn_hls),1:jpk ) = 3._wp
!
IF(lwp) WRITE(numout,*) ' Lombok '
ii0 = 44 ; ii1 = 44 ! Lombok Strait
- ij0 = 164 - isrow ; ij1 = 165 - isrow ; pfmsk( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp
+ ij0 = 164 - isrow ; ij1 = 165 - isrow ; pfmsk( mi0(ii0,nn_hls):mi1(ii1,nn_hls),mj0(ij0,nn_hls):mj1(ij1,nn_hls),1:jpk ) = 2._wp
!
IF(lwp) WRITE(numout,*) ' Ombai '
ii0 = 53 ; ii1 = 53 ! Ombai Strait
- ij0 = 164 - isrow ; ij1 = 165 - isrow ; pfmsk( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp
+ ij0 = 164 - isrow ; ij1 = 165 - isrow ; pfmsk( mi0(ii0,nn_hls):mi1(ii1,nn_hls),mj0(ij0,nn_hls):mj1(ij1,nn_hls),1:jpk ) = 2._wp
!
IF(lwp) WRITE(numout,*) ' Timor Passage '
ii0 = 56 ; ii1 = 56 ! Timor Passage
- ij0 = 164 - isrow ; ij1 = 165 - isrow ; pfmsk( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp
+ ij0 = 164 - isrow ; ij1 = 165 - isrow ; pfmsk( mi0(ii0,nn_hls):mi1(ii1,nn_hls),mj0(ij0,nn_hls):mj1(ij1,nn_hls),1:jpk ) = 2._wp
!
IF(lwp) WRITE(numout,*) ' West Halmahera '
ii0 = 58 ; ii1 = 58 ! West Halmahera Strait
- ij0 = 181 - isrow ; ij1 = 182 - isrow ; pfmsk( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 3._wp
+ ij0 = 181 - isrow ; ij1 = 182 - isrow ; pfmsk( mi0(ii0,nn_hls):mi1(ii1,nn_hls),mj0(ij0,nn_hls):mj1(ij1,nn_hls),1:jpk ) = 3._wp
!
IF(lwp) WRITE(numout,*) ' East Halmahera '
ii0 = 55 ; ii1 = 55 ! East Halmahera Strait
- ij0 = 181 - isrow ; ij1 = 182 - isrow ; pfmsk( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 3._wp
+ ij0 = 181 - isrow ; ij1 = 182 - isrow ; pfmsk( mi0(ii0,nn_hls):mi1(ii1,nn_hls),mj0(ij0,nn_hls):mj1(ij1,nn_hls),1:jpk ) = 3._wp
!
CASE DEFAULT
IF(lwp) WRITE(numout,*)
diff --git a/tests/SWG/MY_SRC/usrdef_nam.F90 b/tests/SWG/MY_SRC/usrdef_nam.F90
index 37742d7658c322b8a30b21be343e830a8db20e83..fb95a32ef02068a0972ecf257ddde41f12adce92 100644
--- a/tests/SWG/MY_SRC/usrdef_nam.F90
+++ b/tests/SWG/MY_SRC/usrdef_nam.F90
@@ -14,7 +14,6 @@ MODULE usrdef_nam
!! usr_def_nam : read user defined namelist and set global domain size
!! usr_def_hgr : initialize the horizontal mesh
!!----------------------------------------------------------------------
- USE dom_oce , ONLY: nimpp, njmpp ! ocean space and time domain
USE par_oce ! ocean space and time domain
USE phycst ! physical constants
!
diff --git a/tests/SWG/MY_SRC/usrdef_sbc.F90 b/tests/SWG/MY_SRC/usrdef_sbc.F90
index a3069954721d86aa464b7bb297e5d233f808c8b3..6283b4a579bbd5f9d238646aaf3ba6b8cd72e2fe 100644
--- a/tests/SWG/MY_SRC/usrdef_sbc.F90
+++ b/tests/SWG/MY_SRC/usrdef_sbc.F90
@@ -61,7 +61,7 @@ CONTAINS
REAL(wp) :: ztauu, ztauv ! wind intensity projeted
REAL(wp) :: zrhoa = 1.22 ! Air density kg/m3
REAL(wp) :: zcdrag = 1.5e-3 ! drag coefficient
- REAL(wp) :: ztx, zty, zmod, zcoef ! temporary variables
+ REAL(wp) :: zmod, zcoef ! temporary variables
!!---------------------------------------------------------------------
! ---------------------------- !
@@ -86,22 +86,19 @@ CONTAINS
ztauu = REAL( rn_tau, wp ) * COS( rn_theta * rad ) ! N.m-2
ztauv = - REAL( rn_tau, wp ) * SIN( rn_theta * rad ) ! N.m-2
+ zcoef = 1. / ( zrhoa * zcdrag )
DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
! length of the domain : 2000km x 2000km
- utau(ji,jj) = - ztauu * COS( rpi * gphiu(ji,jj) / 2000000._wp)
- vtau(ji,jj) = - ztauv * COS( rpi * gphiv(ji,jj) / 2000000._wp)
+ utau(ji,jj) = - ztauu * COS( rpi * gphit(ji,jj) / 2000000._wp)
+ vtau(ji,jj) = - ztauv * COS( rpi * gphit(ji,jj) / 2000000._wp)
END_2D
! module of wind stress and wind speed at T-point
- zcoef = 1. / ( zrhoa * zcdrag )
DO_2D( 0, 0, 0, 0 )
- ztx = utau(ji-1,jj ) + utau(ji,jj)
- zty = vtau(ji ,jj-1) + vtau(ji,jj)
- zmod = 0.5 * SQRT( ztx * ztx + zty * zty )
- taum(ji,jj) = zmod
+ zmod = SQRT( utau(ji,jj) * utau(ji,jj) + vtau(ji,jj) * vtau(ji,jj) )
+ taum(ji,jj) = zmod
wndm(ji,jj) = SQRT( zmod * zcoef )
END_2D
- CALL lbc_lnk( 'usrdef_sbc', taum(:,:), 'T', 1. , wndm(:,:), 'T', 1. )
!
END SUBROUTINE usrdef_sbc_oce
diff --git a/tests/SWG/MY_SRC/usrdef_zgr.F90 b/tests/SWG/MY_SRC/usrdef_zgr.F90
index acd295e3dd6197b329b8749b6cc37fe6b1d78a17..7da49f1f646f73fceb72a5d6b8e67917d523a537 100644
--- a/tests/SWG/MY_SRC/usrdef_zgr.F90
+++ b/tests/SWG/MY_SRC/usrdef_zgr.F90
@@ -37,14 +37,14 @@ MODULE usrdef_zgr
!! $Id: usrdef_zgr.F90 10425 2018-12-19 21:54:16Z smasson $
!! Software governed by the CeCILL license (see ./LICENSE)
!!----------------------------------------------------------------------
-CONTAINS
-
+CONTAINS
+
SUBROUTINE usr_def_zgr( ld_zco , ld_zps , ld_sco , ld_isfcav, & ! type of vertical coordinate
+ & k_top , k_bot , & ! top & bottom ocean level
& pdept_1d, pdepw_1d, pe3t_1d , pe3w_1d , & ! 1D reference vertical coordinate
+ & pe3t , pe3u , pe3v , pe3f , & ! vertical scale factors at t-level
& pdept , pdepw , & ! 3D t & w-points depth
- & pe3t , pe3u , pe3v , pe3f , & ! vertical scale factors
- & pe3w , pe3uw , pe3vw , & ! - - -
- & k_top , k_bot ) ! top & bottom ocean level
+ & pe3w , pe3uw , pe3vw ) ! vertical scale factors at w-level
!!---------------------------------------------------------------------
!! *** ROUTINE usr_def_zgr ***
!!
@@ -53,12 +53,12 @@ CONTAINS
!!----------------------------------------------------------------------
LOGICAL , INTENT(out) :: ld_zco, ld_zps, ld_sco ! vertical coordinate flags
LOGICAL , INTENT(out) :: ld_isfcav ! under iceshelf cavity flag
+ INTEGER , DIMENSION(:,:) , INTENT(out) :: k_top, k_bot ! first & last ocean level
REAL(wp), DIMENSION(:) , INTENT(out) :: pdept_1d, pdepw_1d ! 1D grid-point depth [m]
REAL(wp), DIMENSION(:) , INTENT(out) :: pe3t_1d , pe3w_1d ! 1D grid-point depth [m]
- REAL(wp), DIMENSION(:,:,:), INTENT(out) :: pdept, pdepw ! grid-point depth [m]
- REAL(wp), DIMENSION(:,:,:), INTENT(out) :: pe3t , pe3u , pe3v , pe3f ! vertical scale factors [m]
- REAL(wp), DIMENSION(:,:,:), INTENT(out) :: pe3w , pe3uw, pe3vw ! i-scale factors
- INTEGER , DIMENSION(:,:) , INTENT(out) :: k_top, k_bot ! first & last ocean level
+ REAL(wp), DIMENSION(:,:,:), OPTIONAL, INTENT(out) :: pdept, pdepw ! grid-point depth [m]
+ REAL(wp), DIMENSION(:,:,:), OPTIONAL, INTENT(out) :: pe3t , pe3u , pe3v , pe3f ! vertical scale factors [m]
+ REAL(wp), DIMENSION(:,:,:), OPTIONAL, INTENT(out) :: pe3w , pe3uw, pe3vw ! i-scale factors
!
INTEGER :: inum ! local logical unit
REAL(WP) :: z_zco, z_zps, z_sco, z_cav
diff --git a/tests/SWG/cpp_SWG.fcm b/tests/SWG/cpp_SWG.fcm
index 880c4685181a36eae3e1333ea1c2536ce7344dba..38af76f7b4bd4aca94d386dd9a4c8031943df93b 100644
--- a/tests/SWG/cpp_SWG.fcm
+++ b/tests/SWG/cpp_SWG.fcm
@@ -1 +1 @@
-bld::tool::fppkeys key_xios key_qco key_RK3
+bld::tool::fppkeys key_xios key_qco key_vco_3d key_RK3
diff --git a/tests/TSUNAMI/MY_SRC/usrdef_hgr.F90 b/tests/TSUNAMI/MY_SRC/usrdef_hgr.F90
index 5c9921e476aeb7ce0149f0a8ca0bfbbd0fd0343b..d8a5d6d84375f21df21d3056028b6d60d830122d 100644
--- a/tests/TSUNAMI/MY_SRC/usrdef_hgr.F90
+++ b/tests/TSUNAMI/MY_SRC/usrdef_hgr.F90
@@ -88,8 +88,8 @@ CONTAINS
#endif
DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
- zti = REAL( mig0(ji)-ii0, wp ) ! =0 at i=ii0 in the global grid without halos
- ztj = REAL( mjg0(jj)-ij0, wp ) ! =0 at i=ij0 in the global grid without halos
+ zti = REAL( mig(ji,0)-ii0, wp ) ! =0 at i=ii0 in the global grid without halos
+ ztj = REAL( mjg(jj,0)-ij0, wp ) ! =0 at i=ij0 in the global grid without halos
plamt(ji,jj) = rn_dx * zti
plamu(ji,jj) = rn_dx * ( zti + 0.5_wp )
diff --git a/tests/VORTEX/MY_SRC/usrdef_hgr.F90 b/tests/VORTEX/MY_SRC/usrdef_hgr.F90
index 7721821ba9be90850d0366fc2e5996a50e21be54..c6d0003e8d1ad92018c9dcd946dc0024fabf6767 100644
--- a/tests/VORTEX/MY_SRC/usrdef_hgr.F90
+++ b/tests/VORTEX/MY_SRC/usrdef_hgr.F90
@@ -93,8 +93,8 @@ CONTAINS
ENDIF
#endif
DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
- zti = REAL( mig0(ji)-1, wp ) ! start at i=0 in the global grid without halos
- ztj = REAL( mjg0(jj)-1, wp ) ! start at j=0 in the global grid without halos
+ zti = REAL( mig(ji,0)-1, wp ) ! start at i=0 in the global grid without halos
+ ztj = REAL( mjg(jj,0)-1, wp ) ! start at j=0 in the global grid without halos
plamt(ji,jj) = roffsetx + rn_dx * 1.e-3 * ( zti - 0.5_wp )
plamu(ji,jj) = roffsetx + rn_dx * 1.e-3 * zti
diff --git a/tests/VORTEX/MY_SRC/usrdef_zgr.F90 b/tests/VORTEX/MY_SRC/usrdef_zgr.F90
index 6b02fbcb9e6c72a41b1f35cd97a1f79e9a18c94f..06c739ed22a38ec08ce54d3f9f7ed80b18c289a0 100644
--- a/tests/VORTEX/MY_SRC/usrdef_zgr.F90
+++ b/tests/VORTEX/MY_SRC/usrdef_zgr.F90
@@ -36,11 +36,11 @@ MODULE usrdef_zgr
CONTAINS
SUBROUTINE usr_def_zgr( ld_zco , ld_zps , ld_sco , ld_isfcav, & ! type of vertical coordinate
+ & k_top , k_bot , & ! top & bottom ocean level
& pdept_1d, pdepw_1d, pe3t_1d , pe3w_1d , & ! 1D reference vertical coordinate
- & pdept , pdepw , & ! 3D t & w-points depth
& pe3t , pe3u , pe3v , pe3f , & ! vertical scale factors
- & pe3w , pe3uw , pe3vw , & ! - - -
- & k_top , k_bot ) ! top & bottom ocean level
+ & pdept , pdepw , & ! 3D t & w-points depth
+ & pe3w , pe3uw , pe3vw ) ! vertical scale factors
!!---------------------------------------------------------------------
!! *** ROUTINE usr_def_zgr ***
!!
@@ -49,16 +49,12 @@ CONTAINS
!!----------------------------------------------------------------------
LOGICAL , INTENT(out) :: ld_zco, ld_zps, ld_sco ! vertical coordinate flags
LOGICAL , INTENT(out) :: ld_isfcav ! under iceshelf cavity flag
+ INTEGER , DIMENSION(:,:) , INTENT(out) :: k_top, k_bot ! first & last ocean level
REAL(wp), DIMENSION(:) , INTENT(out) :: pdept_1d, pdepw_1d ! 1D grid-point depth [m]
REAL(wp), DIMENSION(:) , INTENT(out) :: pe3t_1d , pe3w_1d ! 1D grid-point depth [m]
- REAL(wp), DIMENSION(:,:,:), INTENT(out) :: pdept, pdepw ! grid-point depth [m]
- REAL(wp), DIMENSION(:,:,:), INTENT(out) :: pe3t , pe3u , pe3v , pe3f ! vertical scale factors [m]
- REAL(wp), DIMENSION(:,:,:), INTENT(out) :: pe3w , pe3uw, pe3vw ! i-scale factors
- INTEGER , DIMENSION(:,:) , INTENT(out) :: k_top, k_bot ! first & last ocean level
- !
- INTEGER :: inum ! local logical unit
- REAL(WP) :: z_zco, z_zps, z_sco, z_cav
- REAL(wp), DIMENSION(jpi,jpj) :: z2d ! 2D workspace
+ REAL(wp), DIMENSION(:,:,:), OPTIONAL, INTENT(out) :: pdept, pdepw ! grid-point depth [m]
+ REAL(wp), DIMENSION(:,:,:), OPTIONAL, INTENT(out) :: pe3t , pe3u , pe3v , pe3f ! vertical scale factors [m]
+ REAL(wp), DIMENSION(:,:,:), OPTIONAL, INTENT(out) :: pe3w , pe3uw, pe3vw ! i-scale factors
!!----------------------------------------------------------------------
!
IF(lwp) WRITE(numout,*)
@@ -80,11 +76,13 @@ CONTAINS
!
CALL zgr_msk_top_bot( k_top , k_bot ) ! masked top and bottom ocean t-level indices
!
- ! ! z-coordinate (3D arrays) from the 1D z-coord.
- CALL zgr_zco( pdept_1d, pdepw_1d, pe3t_1d, pe3w_1d, & ! in : 1D reference vertical coordinate
- & pdept , pdepw , & ! out : 3D t & w-points depth
- & pe3t , pe3u , pe3v , pe3f , & ! vertical scale factors
- & pe3w , pe3uw , pe3vw ) ! - - -
+ !
+ IF( PRESENT( pe3t ) ) THEN ! z-coordinate (3D arrays) from the 1D z-coord.
+ CALL zgr_zco( pdept_1d, pdepw_1d, pe3t_1d, pe3w_1d, & ! in : 1D reference vertical coordinate
+ & pdept , pdepw , & ! out : 3D t & w-points depth
+ & pe3t , pe3u , pe3v , pe3f , & ! vertical scale factors
+ & pe3w , pe3uw , pe3vw ) ! - - -
+ ENDIF
!
END SUBROUTINE usr_def_zgr
diff --git a/tests/VORTEX/cpp_VORTEX.fcm b/tests/VORTEX/cpp_VORTEX.fcm
index 66e62c9bc47e4b29bcfd25e40f41638be3cb85b3..c3349e81f32945b0151b8c2959c01bf46de223be 100644
--- a/tests/VORTEX/cpp_VORTEX.fcm
+++ b/tests/VORTEX/cpp_VORTEX.fcm
@@ -1 +1 @@
- bld::tool::fppkeys key_xios key_agrif key_qco
+ bld::tool::fppkeys key_xios key_agrif key_qco key_vco_1d
diff --git a/tests/WAD/EXPREF/file_def_nemo-oce.xml b/tests/WAD/EXPREF/file_def_nemo-oce.xml
index a9c10b7e0ec45084087a8614c64a3d13fc5392a0..90124a63601afba0a6d011cf701d31ec48cfa39d 100644
--- a/tests/WAD/EXPREF/file_def_nemo-oce.xml
+++ b/tests/WAD/EXPREF/file_def_nemo-oce.xml
@@ -69,16 +69,16 @@
<field field_ref="qt" name="sohefldo" />
<field field_ref="mldr10_1" name="somxl010" />
<field field_ref="mldkz5" name="somixhgt" />
+ <field field_ref="utau" name="sozotaux" />
+ <field field_ref="vtau" name="sometauy" />
</file>
<file id="file2" name_suffix="_grid_U" description="ocean U grid variables" >
<field field_ref="uoce" name="vozocrtx" />
- <field field_ref="utau" name="sozotaux" />
</file>
<file id="file3" name_suffix="_grid_V" description="ocean V grid variables" >
<field field_ref="voce" name="vomecrty" />
- <field field_ref="vtau" name="sometauy" />
</file>
<file id="file4" name_suffix="_grid_W" description="ocean W grid variables" >
diff --git a/tests/WAD/MY_SRC/usrdef_hgr.F90 b/tests/WAD/MY_SRC/usrdef_hgr.F90
index 38cec157e7b781e96bd2ca967faf0dd227091de6..459c26dc3f54ce0ae00738abb1548fc7bfe6eabc 100644
--- a/tests/WAD/MY_SRC/usrdef_hgr.F90
+++ b/tests/WAD/MY_SRC/usrdef_hgr.F90
@@ -75,14 +75,14 @@ CONTAINS
zfact = rn_dx * 1.e-3 ! conversion in km
DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )
! ! longitude (west coast at lon=0°)
- plamt(ji,jj) = zfact * ( - 0.5 + REAL( mig0(ji)-1 , wp ) )
- plamu(ji,jj) = zfact * ( REAL( mig0(ji)-1 , wp ) )
+ plamt(ji,jj) = zfact * ( - 0.5 + REAL( mig(ji,0)-1 , wp ) )
+ plamu(ji,jj) = zfact * ( REAL( mig(ji,0)-1 , wp ) )
plamv(ji,jj) = plamt(ji,jj)
plamf(ji,jj) = plamu(ji,jj)
! ! latitude (south coast at lat= 0°)
- pphit(ji,jj) = zfact * ( - 0.5 + REAL( mjg0(jj)-1 , wp ) )
+ pphit(ji,jj) = zfact * ( - 0.5 + REAL( mjg(jj,0)-1 , wp ) )
pphiu(ji,jj) = pphit(ji,jj)
- pphiv(ji,jj) = zfact * ( REAL( mjg0(jj)-1 , wp ) )
+ pphiv(ji,jj) = zfact * ( REAL( mjg(jj,0)-1 , wp ) )
pphif(ji,jj) = pphiv(ji,jj)
END_2D
!
diff --git a/tests/WAD/MY_SRC/usrdef_istate.F90 b/tests/WAD/MY_SRC/usrdef_istate.F90
index b34b77c77fbe69505b28bef4498976e054688eef..36896424d5c92494e0f2ecb14b9243711f3a4019 100644
--- a/tests/WAD/MY_SRC/usrdef_istate.F90
+++ b/tests/WAD/MY_SRC/usrdef_istate.F90
@@ -13,8 +13,7 @@ MODULE usrdef_istate
!!----------------------------------------------------------------------
!! usr_def_istate : initial state in Temperature and salinity
!!----------------------------------------------------------------------
- USE par_oce ! ocean space and time domain
- USE dom_oce , ONLY : mi0, mig, mjg, glamt, gphit, ht_0
+ USE dom_oce ! ocean space and time domain
USE phycst ! physical constants
USE wet_dry ! Wetting and drying
!
@@ -44,7 +43,7 @@ CONTAINS
!! ** Purpose : Initialization of the dynamics and tracers
!! Here WAD_TEST_CASES configuration
!!
-q !! ** Method : - set temprature field
+ !! ** Method : - set temprature field
!! - set salinity field
!!----------------------------------------------------------------------
REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT(in ) :: pdept ! depth of t-point [m]
@@ -116,7 +115,7 @@ q !! ** Method : - set temprature field
IF(lwp) WRITE(numout,*) 'usr_def_istate : WAD Parobolic EW channel with gaussian ridge'
IF(lwp) WRITE(numout,*) '~~~~~~~~~~'
!
- DO ji = mi0(jpiglo/2), mi0(jpiglo)
+ DO ji = mi0(jpiglo/2,nn_hls), mi1(jpiglo,nn_hls)
pts(ji,:,:,jp_sal) = 30._wp
END DO
!
@@ -230,7 +229,7 @@ q !! ** Method : - set temprature field
pssh(ji,:) = ( -2.5_wp + 5.5_wp*(50._wp-glamt(ji,1))/50._wp)*ptmask(ji,:,1)
END DO
!
- DO ji = mi0(jpiglo/2), mi0(jpiglo)
+ DO ji = mi0(jpiglo/2,nn_hls), mi1(jpiglo,nn_hls)
pssh(ji,:) = -0.1*ptmask(ji,:,1)
END DO
!
diff --git a/tests/WAD/MY_SRC/usrdef_zgr.F90 b/tests/WAD/MY_SRC/usrdef_zgr.F90
index eab2b9a325da1789b58db614c2e3bc6bc181996e..df9970a0b289ce811f436720e5ef95cf711b0a36 100644
--- a/tests/WAD/MY_SRC/usrdef_zgr.F90
+++ b/tests/WAD/MY_SRC/usrdef_zgr.F90
@@ -14,7 +14,7 @@ MODULE usrdef_zgr
!! zgr_z : reference 1D z-coordinate
!!---------------------------------------------------------------------
USE oce ! ocean variables
- USE dom_oce , ONLY: ht_0, mi0, mi1, mj0, mj1, glamt, gphit ! ocean space and time domain
+ USE dom_oce ! ocean space and time domain
USE usrdef_nam ! User defined : namelist variables
USE wet_dry , ONLY: rn_wdmin1, rn_wdmin2, rn_wdld ! Wetting and drying
!
@@ -101,10 +101,10 @@ CONTAINS
zi = MIN((glamt(ji,1) - 10.0)/40.0, 1.0 )
zht(ji,:) = MAX(zbathy*zi, -2.0)
END DO
- zht(mi0(1):mi1(1),:) = -4._wp
- zht(mi0(jpiglo):mi1(jpiglo),:) = -4._wp
- zht(:,mj0(1):mj1(1)) = -4._wp
- zht(:,mj0(jpjglo):mj1(jpjglo)) = -4._wp
+ zht(mi0( 1,nn_hls):mi1( 1,nn_hls),:) = -4._wp
+ zht(mi0(jpiglo,nn_hls):mi1(jpiglo,nn_hls),:) = -4._wp
+ zht(:,mj0( 1,nn_hls):mj1( 1,nn_hls)) = -4._wp
+ zht(:,mj0(jpjglo,nn_hls):mj1(jpjglo,nn_hls)) = -4._wp
! ! ====================
CASE ( 2, 3, 8 ) ! WAD 2 or 3 configuration
! ! ====================
@@ -117,11 +117,11 @@ CONTAINS
zi = MAX(1.0-((glamt(ji,1)-25.0)**2)/484.0, -0.3 )
zht(ji,:) = MAX(zbathy*zi, -2.0)
END DO
- zht(mi0(1):mi1(1),:) = -4._wp
- zht(mi0(jpiglo):mi1(jpiglo),:) = -4._wp
+ zht(mi0( 1,nn_hls):mi1( 1,nn_hls),:) = -4._wp
+ zht(mi0(jpiglo,nn_hls):mi1(jpiglo,nn_hls),:) = -4._wp
IF( nn_cfg /= 8 ) THEN
- zht(:,mj0(1):mj1(1)) = -4._wp
- zht(:,mj0(jpjglo):mj1(jpjglo)) = -4._wp
+ zht(:,mj0( 1,nn_hls):mj1( 1,nn_hls)) = -4._wp
+ zht(:,mj0(jpjglo,nn_hls):mj1(jpjglo,nn_hls)) = -4._wp
ENDIF
! ! ====================
CASE ( 4 ) ! WAD 4 configuration
@@ -138,10 +138,10 @@ CONTAINS
zht(ji,jj) = MAX(zbathy*zi*zj, -2.0)
END DO
END DO
- zht(mi0(1):mi1(1),:) = -4._wp
- zht(mi0(jpiglo):mi1(jpiglo),:) = -4._wp
- zht(:,mj0(1):mj1(1)) = -4._wp
- zht(:,mj0(jpjglo):mj1(jpjglo)) = -4._wp
+ zht(mi0(1 ,nn_hls):mi1( 1,nn_hls),:) = -4._wp
+ zht(mi0(jpiglo,nn_hls):mi1(jpiglo,nn_hls),:) = -4._wp
+ zht(:,mj0( 1,nn_hls):mj1( 1,nn_hls)) = -4._wp
+ zht(:,mj0(jpjglo,nn_hls):mj1(jpjglo,nn_hls)) = -4._wp
! ! ===========================
CASE ( 5 ) ! WAD 5 configuration
! ! ====================
@@ -168,10 +168,10 @@ CONTAINS
ENDIF
END DO
! ! ===========================
- zht(mi0(1):mi1(1),:) = -4._wp
- zht(mi0(jpiglo):mi1(jpiglo),:) = -4._wp
- zht(:,mj0(1):mj1(1)) = -4._wp
- zht(:,mj0(jpjglo):mj1(jpjglo)) = -4._wp
+ zht(mi0( 1,nn_hls):mi1( 1,nn_hls),:) = -4._wp
+ zht(mi0(jpiglo,nn_hls):mi1(jpiglo,nn_hls),:) = -4._wp
+ zht(:,mj0( 1,nn_hls):mj1( 1,nn_hls)) = -4._wp
+ zht(:,mj0(jpjglo,nn_hls):mj1(jpjglo,nn_hls)) = -4._wp
! ! ===========================
CASE ( 6 ) ! WAD 6 configuration
! ! ====================
@@ -185,10 +185,10 @@ CONTAINS
zj = 1.075*MAX(EXP(-1.0*((glamt(ji,1)-25.0)**2)/32.0) , 0.0 )
zht(ji,:) = MAX(zbathy*(zi-zj), -2.0)
END DO
- zht(mi0(1):mi1(1),:) = -4._wp
- zht(mi0(jpiglo):mi1(jpiglo),:) = -4._wp
- zht(:,mj0(1):mj1(1)) = -4._wp
- zht(:,mj0(jpjglo):mj1(jpjglo)) = -4._wp
+ zht(mi0( 1,nn_hls):mi1( 1,nn_hls),:) = -4._wp
+ zht(mi0(jpiglo,nn_hls):mi1(jpiglo,nn_hls),:) = -4._wp
+ zht(:,mj0( 1,nn_hls):mj1( 1,nn_hls)) = -4._wp
+ zht(:,mj0(jpjglo,nn_hls):mj1(jpjglo,nn_hls)) = -4._wp
! ! ===========================
CASE ( 7 ) ! WAD 7 configuration
! ! ====================
@@ -215,9 +215,9 @@ CONTAINS
ENDIF
END DO
! ! ===========================
- zht(mi0(1):mi1(1),:) = -4._wp
- zht(:,mj0(1):mj1(1)) = -4._wp
- zht(:,mj0(jpjglo):mj1(jpjglo)) = -4._wp
+ zht(mi0( 1,nn_hls):mi1( 1,nn_hls),:) = -4._wp
+ zht(:,mj0( 1,nn_hls):mj1( 1,nn_hls)) = -4._wp
+ zht(:,mj0(jpjglo,nn_hls):mj1(jpjglo,nn_hls)) = -4._wp
CASE DEFAULT
! ! ===========================
WRITE(ctmp1,*) 'WAD test with a ', nn_cfg,' option is not coded'
@@ -234,10 +234,10 @@ CONTAINS
END_2D
CALL lbc_lnk( 'usrdef_zgr', zhu, 'U', 1. ) ! boundary condition: this mask the surrounding grid-points
! ! ==>>> set by hand non-zero value on first/last columns & rows
- DO ji = mi0(1), mi1(1) ! first row of global domain only
+ DO ji = mi0( 1,nn_hls), mi1( 1,nn_hls) ! first row of global domain only
zhu(ji,:) = zht(1,:)
END DO
- DO ji = mi0(jpiglo), mi1(jpiglo) ! last row of global domain only
+ DO ji = mi0(jpiglo,nn_hls), mi1(jpiglo,nn_hls) ! last row of global domain only
zhu(ji,:) = zht(jpi,:)
END DO
! at v-point: averaging zht
@@ -246,10 +246,10 @@ CONTAINS
zhv(ji,jj) = 0.5_wp * ( zht(ji,jj) + zht(ji,jj+1) )
END_2D
CALL lbc_lnk( 'usrdef_zgr', zhv, 'V', 1. ) ! boundary condition: this mask the surrounding grid-points
- DO jj = mj0(1), mj1(1) ! first row of global domain only
+ DO jj = mj0( 1,nn_hls), mj1( 1,nn_hls) ! first row of global domain only
zhv(:,jj) = zht(:,jj)
END DO
- DO jj = mj0(jpjglo), mj1(jpjglo) ! last row of global domain only
+ DO jj = mj0(jpjglo,nn_hls), mj1(jpjglo,nn_hls) ! last row of global domain only
zhv(:,jj) = zht(:,jj)
END DO
!
@@ -261,10 +261,10 @@ CONTAINS
! no ocean cavities : top ocean level is ONE, except over land
! the ocean basin surrounnded by land (1+nn_hls grid-points) set through lbc_lnk call
z2d(:,:) = 1._wp ! surface ocean is the 1st level
- z2d(mi0(1):mi1(1),:) = 0._wp
- z2d(mi0(jpiglo):mi1(jpiglo),:) = 0._wp
- z2d(:,mj0(1):mj1(1)) = 0._wp
- z2d(:,mj0(jpjglo):mj1(jpjglo)) = 0._wp
+ z2d(mi0( 1,nn_hls):mi1( 1,nn_hls),:) = 0._wp
+ z2d(mi0(jpiglo,nn_hls):mi1(jpiglo,nn_hls),:) = 0._wp
+ z2d(:,mj0( 1,nn_hls):mj1( 1,nn_hls)) = 0._wp
+ z2d(:,mj0(jpjglo,nn_hls):mj1(jpjglo,nn_hls)) = 0._wp
CALL lbc_lnk( 'usrdef_zgr', z2d, 'T', 1. ) ! closed basin, see userdef_nam.F90
k_top(:,:) = NINT( z2d(:,:) )
diff --git a/tools/MISCELLANEOUS/chk_jijj_in_doloops.sh b/tools/MISCELLANEOUS/chk_jijj_in_doloops.sh
new file mode 100755
index 0000000000000000000000000000000000000000..2664643b2eb7ef59a8fc836a1b1e7390dc1bd016
--- /dev/null
+++ b/tools/MISCELLANEOUS/chk_jijj_in_doloops.sh
@@ -0,0 +1,55 @@
+#!/bin/bash
+#
+# check if a do loop, starting with DO_2D, DO_3D ou DO ji=, contains (:,:
+# that most probably should be (ji,jj
+#
+set -u
+
+for ff in $( find src -name "*90" ) */*/MY_SRC/*90
+do
+
+ for ll1 in $( grep -n DO_2D $ff | sed -s "s/:.*//" )
+ do
+ nb=$( sed -n ${ll1},/END_2D/p $ff | sed -e "s/\!.*//" | grep -c "( *: *, *:" )
+ if [ $nb -ne 0 ]
+ then
+ echo "----------------------------------------------"
+ echo
+ echo "error in DO_2D: $ff $nb"
+ sed -n ${ll1},/END_2D/p $ff
+ echo
+ fi
+ done
+
+ for ll1 in $( grep -n DO_3D $ff | sed -s "s/:.*//" )
+ do
+ nb=$( sed -n ${ll1},/END_3D/p $ff | sed -e "s/\!.*//" | grep -c "( *: *, *:" )
+ if [ $nb -ne 0 ]
+ then
+ echo "----------------------------------------------"
+ echo
+ echo "error in DO_3D: $ff $nb"
+ sed -n ${ll1},/END_3D/p $ff
+ echo
+ fi
+ done
+
+ for ll1 in $( grep -in "DO *ji *=" $ff | sed -s "s/:.*//" )
+ do
+ nb=$( sed -n ${ll1},/"[eE][nN][dD] *[dD][oO]"/p $ff | sed -e "s/\!.*//" | grep -c "( *: *, *:" )
+ if [ $nb -ne 0 ]
+ then
+ echo "----------------------------------------------"
+ echo
+ echo "error in END DO: $ff $nb"
+ sed -n ${ll1},/"[eE][nN][dD] *[dD][oO]"/p $ff
+ echo
+ fi
+ done
+
+done
+
+
+
+
+